Perguntas[vba](coding)

Tenho uma macro que pode criar 4 pontos. O comprimento de cada ponto está vinculado a um parâmetro já definido. Mas, apenas para criar o ponto pela primeira vez, gostaria de ter um link completo. Por exemplo, se o parâmetro tiver alguma atualização de valor, o comprimento de cada ponto deve ser atualizado de acordo. Obrigado.

mais detalhes: se eu clicar duas vezes no ponto criado por meio deste código, preciso ver Comprimento = valor = CATIA_V5R22_VENT-HOLES-DEFINITION-BACKREST_V01\HOLES_PARAMETERS\HOLE_RADIUS

não assim Comprimento = valor

    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

Essas datas são produzidas pelo calendário de Trevor Eyre no formato dos EUA, então converti para o Reino Unido para meus usuários. No entanto, acho que é por isso que não consigo encontrar a diferença de data, já que não é mais um número. Existe uma maneira?

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

Depois de vários dias, percebi que sDate estava repetido nas caixas de texto 6 e 7. Com 77, meu cérebro está confuso. Agora funciona perfeitamente. Obrigado `Private Sub TextBox6_Enter() ' CALENDAR data de chegada

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

sDate = Format(dateVariable, "dd/mm/aaaa") 'muda o formato dos EUA para o Reino Unido TextBox6.value = sDate 'entrada na caixa de texto End Sub

Private Sub TextBox7_Enter() 'Data de saída do CALENDÁRIO

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

tDate = Format(dateVariable, "dd/mm/aaaa") 'altera o formato dos EUA para o Reino Unido TextBox7.value = tDate

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

Prezados, comecei a desenvolver um código VBA que deve: 1- pedir para o usuário selecionar uma face de qualquer corpo no CATPART atual. 2- uma vez feito isso, o VBA deve extrair essa superfície em um conjunto geométrico e criar 3 pontos no contorno dessa superfície. 3- com base nesses pontos, criar um plano e, por fim, projetar o contorno da superfície dentro de um esboço.

abaixo do meu código, não funciona. Ele exibe incompatibilidade de tipo sem especificar onde.

A imagem descreve mais ou menos o que eu quero. NB: a parte do gato pode conter formas complexas, por isso a superfície extraída precisa estar em tangência

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

O código a seguir é perfeito.

    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

Quero encurtar o código acima omitindo as seguintes linhas.

        Dim myMinute As Double
        myMinute = mySecond / 86400

É possível?

Quero criar uma tabela de 200 linhas no aplicativo PowerPoint.

O código a seguir gera este erro: Erro de tempo de execução 424: Objeto requerido

Como resolver esse erro?

    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

A linha a seguir gera um erro.

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

Tenho o código abaixo no subformulário1 de um formulário. Isso se refere ao subformulário2 não relacionado (fzzzSubConditionalFormatCriteria) no mesmo formulário.

ao abrir o formulário principal, recebo o erro ": Form : <Você inseriu uma expressão que tem uma referência inválida à propriedade Form/Report.> : Form", mas depois disso funciona bem quando clico nos registros. Como faço para contornar isso? ou, no pior cenário, simplesmente não execute este código ao abrir o formulário

Basicamente, é preciso uma maneira de saber quando um subformulário foi carregado e pode ser acessado

  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

Eu desenvolvi uma macro que pode criar uma operação de espessura em um sólido colado de outro Catpart. Está funcionando, mas o problema que estou enfrentando é que os IDs de faces que tenho neste código às vezes não estão alinhados com o que tenho na operação. Existe uma maneira de evitar IDs de faces e capturar todas as faces automaticamente do sólido colado e fazer a operação de espessura. No código abaixo, você pode ver muitos IDs de faces, às vezes funciona, às vezes Catia pergunta sobre faces ausentes. Muito obrigado

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

existe alguma possibilidade de uma macro gerar filete de aresta após a operação de remoção (apenas para furos removidos)? Tentei muito usando codificação de IA, mas não obtive nenhuma solução. A única coisa que fiz foi gravar uma macro. (mas essa macro usa arestas e nomes específicos) que não funcionam para diferentes peças ou nomes de operação.

    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

insira a descrição da imagem aqui

Quero inserir o número da página no seguinte formato no centro do rodapé da minha seção. 1/10, 2/10,... 10/10

Tentei o seguinte código, que insere alinhamento 1/10 no lado esquerdo do rodapé.

    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

Não consigo controlar a inserção de campo especial. Sou novo no Word VBA.

Agradecemos antecipadamente aos especialistas.

-- Subbu

Eu tenho esse código para converter cada letra em um texto de entrada para o novo texto usando a tabela de mapeamento

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

esta é a tabela mapeada:

o código funciona bem, mas algumas letras mudam em uma letra, por exemplo, se eu tiver essas letras no texto de entrada "ÌÍÎ", dê apenas uma letra na letra mapeada, que é a primeira "ج"