↑タイトル詐欺 主にCATIA V5 の VBA(最近はPMillマクロとFusion360APIが多い)


形状セット要素の対称化マクロ - C#ATIA


'vba 指定した形状セットを対称化しコピペ2
Option Explicit

Dim PartDoc As PartDocument
Dim Part As Part
Dim sel 'As Selection
Dim HSFact As HybridShapeFactory
Dim BasePlane As Reference
Dim DeleteItems As New Collection

Sub CATMain()
    Set PartDoc = CATIA.ActiveDocument
    Set Part = PartDoc.Part
    Set sel = PartDoc.selection
    Dim BaseHBody As HybridBody
    Set BaseHBody = SelectHybridBody
    Set BasePlane = SelectPlanarFace
    Dim MirrerHBody As HybridBody
    Set MirrerHBody = CopyPasteHybridBody(BaseHBody)
    MirrerHBody.Name = BaseHBody.Name + "_Symmetry"
    Set HSFact = Part.HybridShapeFactory
    Call HBodyLoop(MirrerHBody)
    Call DeleteItem
    MsgBox ("終了")
End Sub

Private Sub DeleteItem()
    Dim Ref As Reference
    For Each Ref In DeleteItems
        Call HSFact.DeleteObjectForDatum(Ref)
End Sub

Private Sub HBodyLoop(HBody As HybridBody)
    Call SymmetryItem(HBody.HybridShapes)
    If HBody.HybridBodies.Count = 0 Then Exit Sub '下階層無し
    Dim HB As HybridBody
    For Each HB In HBody.HybridBodies
        Call HBodyLoop(HB)
End Sub

Private Sub SymmetryItem(HShapes As HybridShapes)
    Dim HShape As HybridShape
    Dim Ref As Reference
    Dim rgb As Variant
    Dim sym As HybridShape
    For Each HShape In HShapes
        Set Ref = Part.CreateReferenceFromObject(HShape)
        rgb = GetColor(HShape)
        If HSFact.GetGeometricalFeatureType(Ref) <> 0 Then
            Call DeleteItems.Add(Ref) '削除登録
            Set sym = CreateDatum(CreateSymmetry(Ref, BasePlane))
            Call setColor(sym, rgb)
            Call HShapes.Parent.AppendHybridShape(sym)
        End If
End Sub

Private Function GetColor( _
    ByVal shape As HybridShape) As Variant
    sel.Add shape
    Dim vis As VisPropertySet
    Set vis = sel.VisProperties
    Dim rgb(2) As Long
    vis.GetRealColor rgb(0), rgb(1), rgb(2)
    GetColor = rgb
End Function

Private Sub setColor( _
    ByVal shape As HybridShape, _
    ByVal rgb As Variant)
    sel.Add shape
    Dim vis As VisPropertySet
    Set vis = sel.VisProperties
    Call vis.SetRealColor(rgb(0), rgb(1), rgb(2), 1)
End Sub

Private Function CreateSymmetry(ItemRef As Reference, PlaneRef As Reference) As Reference
    Dim Symmetry As HybridShapeSymmetry
    Set Symmetry = HSFact.AddNewSymmetry(ItemRef, PlaneRef)
    Symmetry.VolumeResult = False
    Call Part.UpdateObject(Symmetry)
    Set CreateSymmetry = Part.CreateReferenceFromObject(Symmetry)
    Call DeleteItems.Add(CreateSymmetry) '削除登録
End Function

Private Function CreateDatum(Ref As Reference) As AnyObject
    Dim Datum As AnyObject
    Select Case HSFact.GetGeometricalFeatureType(Ref)
        Case 1 'Point
            Set Datum = HSFact.AddNewPointDatum(Ref)
        Case 2 'Curve
            Set Datum = HSFact.AddNewCurveDatum(Ref)
        Case 3 'Line
            Set Datum = HSFact.AddNewLineDatum(Ref)
        Case 4 'Circle
            Set Datum = HSFact.AddNewCircleDatum(Ref)
        Case 5 'Surface
            Set Datum = HSFact.AddNewSurfaceDatum(Ref)
        Case 6 'Plane
            Set Datum = HSFact.AddNewPlaneDatum(Ref)
        Case 7 'Volume
            Set Datum = HSFact.AddNewVolumeDatum(Ref)
    End Select
    Call Part.UpdateObject(Datum)
    Set CreateDatum = Datum
End Function

Private Function CopyPasteHybridBody(HBody As HybridBody) As HybridBody
    With sel
        .Add HBody
        .Add Part
    End With
    With Part.HybridBodies
        Set CopyPasteHybridBody = .Item(.Count)
    End With
End Function

Private Function SelectPlanarFace() As Reference
    Dim FilterType(0)  As Variant
    FilterType(0) = "PlanarFace"
    Call SelectItem(FilterType, "対称基準となる平面を選択して下さい / ESCキー キャンセル")
    Set SelectPlanarFace = Part.CreateReferenceFromBRepName( _
                    GetBrepName(sel.Item(1).Value.Name), sel.Item(1).Value.Parent)
End Function

Private Function GetBrepName(MyBRepName As String) As String
    MyBRepName = Replace(MyBRepName, "Selection_", "")
    MyBRepName = Left(MyBRepName, InStrRev(MyBRepName, "));"))
    MyBRepName = MyBRepName + ");WithPermanentBody;WithoutBuildError;WithSelectingFeatureSupport;MFBRepVersion_CXR15)"
    GetBrepName = MyBRepName
End Function

Private Function SelectHybridBody() As HybridBody
    Dim FilterType(0)  As Variant
    FilterType(0) = "HybridBody"
    Call SelectItem(FilterType, "元となる形状セットを選択して下さい / ESCキー キャンセル")
    Set SelectHybridBody = sel.Item(1).Value
End Function

Private Sub SelectItem(FilterType As Variant, Msg As String)
    If sel.SelectElement2(FilterType, Msg, False) = "Cancel" Then End
End Sub