问题[vba](coding)

我有一个可以创建 4 个点的宏，每个点的长度都链接到一个已设置的参数。但这只是第一次创建点。我希望有一个完整的链接，例如，如果参数值有任何更新，每个点的长度应该会相应更新。谢谢

更多细节：如果我双击通过此代码创建的点，我需要看到长度 = 值 = CATIA_V5R22_VENT-HOLES-DEFINITION-BACKREST_V01\HOLES_PARAMETERS\HOLE_RADIUS

不是这样的长度=值

    Private Function GetParameterValue(part As Object, categoryName As String, parameterName As String) As Double
    Dim parameters As Object
    Dim parameter As Object
    Set parameters = part.parameters
    On Error Resume Next
    Set parameter = parameters.Item(categoryName & "\" & parameterName)
    If Not parameter Is Nothing Then
        GetParameterValue = parameter.value
    Else
        GetParameterValue = 0  ' Default value if the parameter doesn't exist
    End If
    On Error GoTo 0
End Function


Sub points(hybridBody As Object)
    Dim partDocument As Object
    Set partDocument = CATIA.Documents.Item("CATIA_V5R22_VENT-HOLES-DEFINITION-BACKREST_V01.CATPart")
    Dim part1 As Object
    Set part1 = partDocument.part
    
    ' Retrieve the value of the hole radius
    Dim holeRadius As Double
    holeRadius = GetParameterValue(part1, "HOLES_PARAMETERS", "HOLE_RADIUS")
    
    Dim hybridShapes1 As Object
    Set hybridShapes1 = hybridBody.hybridShapes
    Dim hybridShapeLinePtDir1 As Object
    Set hybridShapeLinePtDir1 = hybridShapes1.Item("Horiz. Axis")
    
    Dim reference1 As Object
    Set reference1 = part1.CreateReferenceFromObject(hybridShapeLinePtDir1)
    
    Dim hybridShapeIntersection1 As Object
    Set hybridShapeIntersection1 = hybridShapes1.Item("Inter. Right")
    Dim reference2 As Object
    Set reference2 = part1.CreateReferenceFromObject(hybridShapeIntersection1)
    
    Dim hybridShapeFactory1 As Object
    Set hybridShapeFactory1 = part1.hybridShapeFactory
    Dim hybridShapePointOnCurve1 As Object
    Set hybridShapePointOnCurve1 = hybridShapeFactory1.AddNewPointOnCurveWithReferenceFromDistance(reference1, reference2, holeRadius, True)
    hybridShapePointOnCurve1.distanceType = 1
    hybridShapePointOnCurve1.Name = "Point.1"
    hybridBody.AppendHybridShape hybridShapePointOnCurve1
    part1.InWorkObject = hybridShapePointOnCurve1
    part1.Update

    part1.Update
End Sub

这些日期是根据 Trevor Eyre 的美国格式日历生成的，所以我已将其转换为英国格式供用户使用。不过，我猜这就是为什么我找不到日期差值的原因，因为它不再是数字。有什么办法吗？

Private Sub TextBox6_Enter()
'CALENDAR arrival date
    Dim dateVariable As Date
    dateVariable = CalendarForm.GetDate
    Dim sDate As String 'changes format from USA for UK users
    sDate = Format(dateVariable, "dd-mmm-yy")
    TextBox6.value = sDate
End Sub
Private Sub TextBox7_Enter()
'CALENDAR date leave
    Dim dateVariable As Date
    dateVariable = CalendarForm.GetDate
    Dim sDate As String
'changes format from USA to UK
    sDate = Format(dateVariable, "dd-mmm-yy")
    TextBox7.value = sDate
End Sub
  Private Sub TextBox20_change()
'Number of NIGHTS
     TextBox20.value = DateDiff("d", DateValue(TextBox6.value), TextBox7.value)
End Sub

几天后，我意识到 sDate 在 TextBox 6 和 TextBox 7 中重复了。77 的时候我的脑子都糊涂了。现在一切正常了。谢谢 `Private Sub TextBox6_Enter()' CALENDAR 到达日期

Dim dateVariable As Date
dateVariable = CalendarForm.GetDate
TextBox6.value = dateVariable

sDate = Format(dateVariable, "dd/mm/yyyy") '将格式从美国更改为英国 TextBox6.value = sDate '输入文本框 End Sub

Private Sub TextBox7_Enter() '日历日期休假

Dim dateVariable As Date
dateVariable = CalendarForm.GetDate
TextBox7.value = dateVariable

tDate = Format(dateVariable, "dd/mm/yyyy") '将格式从美国更改为英国 TextBox7.value = tDate

TextBox20.Text = DateDiff("d", TextBox6.value, TextBox7.value) End Sub```

亲爱的，我已经开始开发一个 VBA 代码，它应该：1- 要求用户从当前 CATPART 中的任何主体中选择一个面。2- 完成后，VBA 应该在几何集中提取该表面并在该表面的轮廓上创建 3 个点。3- 基于这些点，创建一个计划，最后将该表面轮廓投影到草图内。

在我的代码下面，它不起作用。它显示类型不匹配，但没有指定。

图片大致描述了我想要的内容。注意：catpart 可能包含复杂的形状，因此提取的曲面需要相切。

Sub ExtractSurfaceAndCreateSketch()
    Dim partDocument As Object
    Dim part1 As Object
    Dim selection1 As Object
    Dim face1 As Object
    Dim hybridShapeFactory As Object
    Dim hybridBody As Object
    Dim reference1 As Object
    Dim hybridShapeExtract As Object
    Dim hybridShapePoint As Object
    Dim sketch As Object
    Dim sketches As Object

    ' Initialize CATIA Document and Part
    Set partDocument = CATIA.activeDocument
    Set part1 = partDocument.part
    Set selection1 = partDocument.selection
    
    ' Clear previous selections
    selection1.Clear
    
    ' Prompt user to select a face
    MsgBox "Please select a face from a body."
    
    ' Select the face
    On Error Resume Next
    Dim result As Variant
    result = selection1.SelectElement2("Face", "Select a face", False)
    If Err.Number <> 0 Then
        MsgBox "Error during selection: " & Err.Description
        Err.Clear
        Exit Sub
    End If
    On Error GoTo 0
    
    ' Check the type of the result and compare accordingly
    If VarType(result) = vbString Then
        If result <> "Normal" Then
            MsgBox "No valid face selected. Exiting."
            Exit Sub
        End If
    Else
        MsgBox "Unexpected return type from SelectElement2. Exiting."
        Exit Sub
    End If
    
    ' Get the selected face
    If selection1.Count = 0 Then
        MsgBox "No face selected. Exiting."
        Exit Sub
    End If
    Set face1 = selection1.Item(1).Value
    
    ' Create a reference from the face
    On Error GoTo ErrorHandler
    Set reference1 = part1.CreateReferenceFromBRepName(face1.brepName)
    
    ' Create the Hybrid Shape Factory and Hybrid Body
    Set hybridShapeFactory = part1.hybridShapeFactory
    Set hybridBody = part1.hybridBodies.Add
    
    ' Extract the surface from the face
    Set hybridShapeExtract = hybridShapeFactory.AddNewExtract(reference1)
    hybridShapeExtract.Name = "ExtractedSurface"
    hybridBody.AppendHybridShape hybridShapeExtract
    
    ' Create points on the outline of the extracted surface
    Dim posX As Variant, posY As Variant
    Dim pointArray(2) As Object
    
    ' Define UV coordinates for point placement
    posX = Array(0.1, 0.5, 0.9) ' X coordinates
    posY = Array(0.1, 0.5, 0.9) ' Y coordinates
    
    Dim i As Integer
    For i = 0 To 2
        ' Create a point on the extracted surface using UV coordinates
        Set hybridShapePoint = hybridShapeFactory.AddNewPointOnSurface(reference1, posX(i), posY(i))
        hybridBody.AppendHybridShape hybridShapePoint
        Set pointArray(i) = hybridShapePoint ' Store the points for plane creation
    Next i
    
    ' Create a plane based on the three points
    Dim hybridShapePlane As Object
    Set hybridShapePlane = hybridShapeFactory.AddNewPlaneThroughPoints(pointArray(0), pointArray(1), pointArray(2))
    hybridBody.AppendHybridShape hybridShapePlane
    
    ' Create a sketch on the new plane
    Set sketches = part1.sketches
    Set sketch = sketches.Add(hybridShapePlane)
    
    ' Extract the projected profile of the extracted surface
    Dim projectedProfile As Object
    Set projectedProfile = hybridShapeFactory.AddNewProjection(hybridShapeExtract, hybridShapePlane)
    projectedProfile.Name = "ProjectedProfile"
    hybridBody.AppendHybridShape projectedProfile
    
    ' Set the sketch as editable
    Dim sketcherEditor As Object
    Set sketcherEditor = sketch.OpenEdition()
    
    ' Create lines based on the projected profile
    Dim iCurve As Integer
    Dim profile As Object

    ' Loop through all segments of the projected profile
    For iCurve = 1 To projectedProfile.Profiles.Count
        ' Get the profile curve
        Set profile = projectedProfile.Profiles.Item(iCurve)

        ' If it's a line, extract its start and end points
        If profile.Type = "Line" Then
            Dim startPoint As Object
            Dim endPoint As Object
            
            ' Retrieve the start and end points
            Set startPoint = profile.GetStartPoint()
            Set endPoint = profile.GetEndPoint()
            
            ' Create a line in the sketch using the Factory2D
            Dim factory2D As Object
            Set factory2D = sketcherEditor.factory2D
            
            ' Create the line in the sketch
            On Error Resume Next
            factory2D.CreateLine startPoint.X, startPoint.Y, endPoint.X, endPoint.Y
            If Err.Number <> 0 Then
                MsgBox "Error creating line: " & Err.Description
                Err.Clear
            End If
            On Error GoTo 0
        End If
    Next iCurve
    
    ' Close the sketch edition
    sketch.CloseEdition
    
    ' Update the part
    part1.Update
    
    MsgBox "Surface extracted, points created, plane established, and sketch projected successfully!"

    Exit Sub

ErrorHandler:
    MsgBox "Error: " & Err.Description
    Exit Sub
End Sub

下面的代码是完美的。

    Sub Macro1()
            
        Dim mySecond As Double
        mySecond = 75
            
        Dim myMinute As Double
        myMinute = mySecond / 86400
            
        'Output of the following code is 01:15 which is perfect.
        Debug.Print Format(myMinute, "nn:ss")
             
    End Sub

我想通过省略以下几行来缩短上述代码。

        Dim myMinute As Double
        myMinute = mySecond / 86400

是否可以？

我想在 PowerPoint 应用程序中制作一个 200 行的表格。

以下代码会引发此错误：运行时错误 424：需要对象

如何解决该错误？

    Public Sub Macro1()
    
    'Delete all slides
    For i = ActivePresentation.Slides.Count To 1 Step -1
        ActivePresentation.Slides(i).Delete
    Next i
    
    'Add a blank slide
    ActivePresentation.Slides.Add Index:=1, Layout:=ppLayoutBlank
    
    'Zoom out
    ActiveWindow.View.Zoom = 40
    
    'Add a Table
    With ActivePresentation.Slides(1).Shapes.AddTable(NumRows:=1, NumColumns:=1, Left:=5, Top:=5, Width:=900, Height:=500)
        .Name = "tbl"
    End With
    
    'Make 200 rows
    While ActivePresentation.Slides(1).Shapes("tbl").Table.Rows.Count < 200
        ActivePresentation.Slides(1).Shapes("tbl").Table.Rows.Add
    Wend
    
    'Change height for all rows
    For i = 1 To ActivePresentation.Slides(1).Shapes("tbl").Table.Rows.Count
        ActivePresentation.Slides(1).Shapes("tbl").Table.Rows(i).Height = 8
    Next i
    
    'Fill text to the 200 cells
    For i = 1 To 200
        ActivePresentation.Slides(1).Shapes("tbl").Table.Cell(i, 1).Shape.TextFrame.TextRange.Text = i
    Next i
    
    End Sub

以下行引发错误。

ActivePresentation.Slides(1).Shapes("tbl").Table.Cell(i, 1).Shape.TextFrame.TextRange.Text = i

我在表单的子表单1上有下面的代码。这指的是同一表单上不相关的子表单2（fzzzSubConditionalFormatCriteria）。

打开主窗体时，我收到“：窗体：<您输入的表达式对属性窗体/报告的引用无效。>：窗体”错误，但之后当我单击记录时，它工作正常。我该如何解决这个问题？或者，最坏的情况是，不要在打开窗体时运行此代码

基本上，需要一种方法来判断子表单何时加载并可以访问

  vrSQL = "SELECT zzAppObjectFields.AppObjectField, zzAppObjectFields.AppObjectFieldTypeID, zzAppObjectFields.AppObjectIDCmb " & _
                            "FROM zzAppObjectFields WHERE zzAppObjectFields.AppObjectFieldTypeID In (10,12) AND zzAppObjectFields.AppObjectID=" & Me.AppObjectID & " " & _
                            "ORDER BY zzAppObjectFields.AppObjectField;"
    
                Me.Parent.fzzzSubConditionalFormatCriteria.Form!uuulllAppObjectFieldIDCriteria.RowSource = vrSQL
                Me.Parent.fzzzSubConditionalFormatCriteria.Form!uuulllAppObjectFieldIDCriteria.Requery

我已经开发了一个宏，它可以在从另一个 Catpart 粘贴的实体上创建厚度操作。它可以工作，但我面临的问题是，此代码中的面 ID 有时与操作中的面 ID 不一致。有没有办法避免面 ID 并自动从粘贴的实体中捕获所有面并进行厚度操作。在下面的代码中，您可以看到许多面 ID，有时它可以工作，有时 Catia 会询问缺失的面。非常感谢

Sub ThicknessOP()
    Dim partDocument1 As Object
    Set partDocument1 = CATIA.activeDocument

    Dim part1 As Object
    Set part1 = partDocument1.part

    Dim bodies1 As Object
    Set bodies1 = part1.bodies

    ' Modify input body name and thickness name here
    Dim bodyName As String
    Dim thicknessName As String

    bodyName = "FOAM_HOLES" ' Change this to the desired body name
    thicknessName = "ThicknessOperation" ' Change this to the desired thickness name

    Dim body1 As Object
    Set body1 = bodies1.Item(bodyName)

    Dim shapes1 As Object
    Set shapes1 = body1.Shapes

    ' Try to retrieve the thickness shape
    Dim thickness1 As Object
    On Error Resume Next ' Enable error handling
    Set thickness1 = shapes1.Item(thicknessName)
    On Error GoTo 0 ' Disable error handling

    ' Check if the thickness has been retrieved
    If thickness1 Is Nothing Then
        MsgBox "Error: " & thicknessName & " not found in " & bodyName & ". Please verify the name.", vbExclamation
        Exit Sub
    End If

    Dim solid1 As Object
    Dim solidFound As Boolean
    solidFound = False

    ' Loop through all solids in the body to find the desired solid
    Dim i As Integer
    For i = 1 To shapes1.Count
        Set solid1 = shapes1.Item(i)
        If solid1.Name Like "Solid.*" Then
            solidFound = True
            Exit For
        End If
    Next i

    If Not solidFound Then
        MsgBox "Error: Solid not found in " & bodyName & ". Please verify the name.", vbExclamation
        Exit Sub
    End If

    Dim faceIds As Variant
    faceIds = Array(4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38) ' Face IDs from 4 to 38
    
    Dim successfullyAdded As Integer
    Dim failedIds As String
    successfullyAdded = 0
    failedIds = ""

    ' Try to add each face to the thickness operation
    For i = LBound(faceIds) To UBound(faceIds)
        Dim reference As Object
        On Error Resume Next ' Enable error handling
        Set reference = part1.CreateReferenceFromBRepName("RSur:(Face:(Brp:(" & solid1.Name & ";%" & faceIds(i) & ");None:();Cf11:());WithTemporaryBody;WithoutBuildError;WithSelectingFeatureSupport;MFBRepVersion_CXR15)", solid1)
        If Err.Number = 0 Then
            thickness1.AddFaceToThicken reference
            successfullyAdded = successfullyAdded + 1
        Else
            failedIds = failedIds & faceIds(i) & ", "
        End If
        On Error GoTo 0 ' Disable error handling
    Next i

    ' Update the thickening object
    part1.UpdateObject thickness1
    part1.Update

    ' Provide feedback on the operation
    If successfullyAdded > 0 Then
        MsgBox successfullyAdded & " face(s) added to the thickness operation." & vbCrLf & _
               "Failed face IDs: " & IIf(failedIds = "", "None", Left(failedIds, Len(failedIds) - 2)), vbInformation
    Else
        MsgBox "No faces were successfully added to the thickness operation." & vbCrLf & _
               "Failed face IDs: " & IIf(failedIds = "", "None", Left(failedIds, Len(failedIds) - 2)), vbExclamation
    End If

End Sub

宏是否有可能在移除操作后生成边缘圆角（仅适用于移除的孔）。我尝试了很多次使用 AI 编码，但没有得到任何解决方案。我唯一做的事情就是录制一个宏。（但这个宏使用特定的边缘和名称）它不适用于不同的部件或操作名称。

    Sub CATMain()

Dim partDocument1 As partDocument
Set partDocument1 = CATIA.activeDocument

Dim part1 As part
Set part1 = partDocument1.part

Dim shapeFactory1 As ShapeFactory
Set shapeFactory1 = part1.ShapeFactory

Dim reference1 As reference
Set reference1 = part1.CreateReferenceFromName("")

Dim constRadEdgeFillet1 As ConstRadEdgeFillet
Set constRadEdgeFillet1 = shapeFactory1.AddNewSolidEdgeFilletWithConstantRadius(reference1, catTangencyFilletEdgePropagation, 3#)

Dim bodies1 As bodies
Set bodies1 = part1.bodies

Dim body1 As body
Set body1 = bodies1.Item("PartBody")

Dim shapes1 As Shapes
Set shapes1 = body1.Shapes

Dim remove1 As Remove
Set remove1 = shapes1.Item("Remove.1")

Dim reference2 As reference
Set reference2 = part1.CreateReferenceFromBRepName("TgtIntersEdge:(GeneratedEdges;MfIE_R20SP4HFAA;TgtPropagationFillet;FirstOperands:(Remove.1);SecondOperands:();InitEdges:(REdge:(Edge:(Face:(Brp:(Solid.6;%21);None:();Cf11:());Face:(Brp:(Solid.5;%2);None:();Cf11:());None:(Limits1:();Limits2:());Cf11:());WithTemporaryBody;WithoutBuildError;WithSelectingFeatureSupport;MFBRepVersion_CXR15)))", remove1)

constRadEdgeFillet1.AddObjectToFillet reference2

constRadEdgeFillet1.EdgePropagation = catTangencyFilletEdgePropagation

Dim reference3 As reference
Set reference3 = part1.CreateReferenceFromBRepName("TgtIntersEdge:(GeneratedEdges;MfIE_R20SP4HFAA;TgtPropagationFillet;FirstOperands:(Remove.1);SecondOperands:();InitEdges:(REdge:(Edge:(Face:(Brp:(Solid.6;%18);None:();Cf11:());Face:(Brp:(Solid.5;%2);None:();Cf11:());None:(Limits1:();Limits2:());Cf11:());WithTemporaryBody;WithoutBuildError;WithSelectingFeatureSupport;MFBRepVersion_CXR15)))", remove1)

constRadEdgeFillet1.AddObjectToFillet reference3

constRadEdgeFillet1.EdgePropagation = catTangencyFilletEdgePropagation

Dim reference4 As reference
Set reference4 = part1.CreateReferenceFromBRepName("TgtIntersEdge:(GeneratedEdges;MfIE_R20SP4HFAA;TgtPropagationFillet;FirstOperands:(Remove.1);SecondOperands:();InitEdges:(REdge:(Edge:(Face:(Brp:(Solid.5;%3);None:();Cf11:());Face:(Brp:(Solid.6;%24);None:();Cf11:());None:(Limits1:();Limits2:());Cf11:());WithTemporaryBody;WithoutBuildError;WithSelectingFeatureSupport;MFBRepVersion_CXR15)))", remove1)

constRadEdgeFillet1.AddObjectToFillet reference4

constRadEdgeFillet1.EdgePropagation = catTangencyFilletEdgePropagation

Dim reference5 As reference
Set reference5 = part1.CreateReferenceFromBRepName("TgtIntersEdge:(GeneratedEdges;MfIE_R20SP4HFAA;TgtPropagationFillet;FirstOperands:(Remove.1);SecondOperands:();InitEdges:(REdge:(Edge:(Face:(Brp:(Solid.5;%3);None:();Cf11:());Face:(Brp:(Solid.6;%27);None:();Cf11:());None:(Limits1:();Limits2:());Cf11:());WithTemporaryBody;WithoutBuildError;WithSelectingFeatureSupport;MFBRepVersion_CXR15)))", remove1)

constRadEdgeFillet1.AddObjectToFillet reference5

constRadEdgeFillet1.EdgePropagation = catTangencyFilletEdgePropagation

part1.UpdateObject constRadEdgeFillet1

part1.Update

End Sub

在此处输入图片描述

我想在节页脚的中心插入以下格式的页码。1/10、2/10、... 10/10

我尝试了以下代码，它将 1/10 插入到页脚左侧。

    Set rngHeader = wdDoc.Sections(1).Footers(wdHeaderFooterPrimary).Range
    rngHeader.Delete
    With rngHeader
        '.InsertAfter Text:="Page "

        '.MoveEnd wdCharacter, 0
        .Fields.Add Range:=.Characters.Last, Type:=wdFieldEmpty, Text:="NUMPAGES", PreserveFormatting:=False

  
        .InsertAfter Text:="  / "
        .Collapse wdCollapseStart
        .Fields.Add Range:=.Characters.Last, Type:=wdFieldEmpty, Text:="PAGE", PreserveFormatting:=False
    End With

我无法控制特殊字段的插入。我是 Word VBA 的新手。

先谢谢各位专家了。

-- 苏布

我有此代码，用于使用映射表将输入文本中的每个字母转换为新文本

Attribute VB_Name = "Module1"
Option Compare Database

Function ReplaceLetters(inputText As String) As String
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim i As Integer
    Dim originalChar As String
    Dim mappedChar As String
    Dim newText As String
    
    ' Open the database and the lookup table
    Set db = CurrentDb
    Set rs = db.OpenRecordset("LetterMapping", dbOpenSnapshot) ' Lookup table name
    
    newText = inputText
    
    ' Loop through each letter in the text
    For i = 1 To Len(inputText)
        originalChar = Mid(inputText, i, 1) ' Get the character at position i
        
        ' Look up the replacement in the table
        rs.MoveFirst
        Do While Not rs.EOF
            If rs!OriginalLetter = originalChar Then
                mappedChar = rs!MappedLetter
                newText = Left(newText, i - 1) & mappedChar & Mid(newText, i + 1)
                Exit Do ' Stop searching once found
            End If
            rs.MoveNext
        Loop
    Next i
    
    ' Close the recordset
    rs.Close
    Set rs = Nothing
    Set db = Nothing
    
    ReplaceLetters = newText
End Function

这是映射表：

代码运行良好，但有些字母会改变一个字母，例如，如果我在输入文本“ÌÍΔ中有这些字母，则在映射字母中只给出一个字母，即第一个字母“ج”