C#ATIA

↑タイトル詐欺 主にFusion360API 偶にCATIA V5 VBA(絶賛ネタ切れ中)

形状セット要素の対称化マクロ

会社のデータサーバーが、暑さで壊れてしまい全く仕事になりませんでした。
暇だったので、形状セットと平面を指定し、形状セットの階層を維持しつつ
データム化させ対称形状を作成するマクロを作ってみました。
(スケッチは対象外です)

例としてこんな感じのデータです。
f:id:kandennti:20150731232207p:plain
マクロ実行し最初に「Hoge」形状セットを選択し、続いてYZ平面を指定します。

f:id:kandennti:20150731232220p:plain
Hoge_Symmetry」が新たに作成されます。画像では元のデータが
パラメトリックなアイテムになっていますが、データム化されたものでも大丈夫です。
当方ライセンスが無いためボリュームが扱えないのですが、対応できるように
作成したつもりです。

ソースコードはこちらです。

'vba 指定した形状セットを対称化しコピペ
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
    Part.Update
    MsgBox ("終了")
End Sub

'コピペした要素を削除
Private Sub DeleteItem()
    Dim Ref As Reference
    For Each Ref In DeleteItems
        Call HSFact.DeleteObjectForDatum(Ref)
    Next
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)
    Next
End Sub

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

'Symmetry
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

'Datum
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
        .Clear
        .Add HBody
        .Copy
        .Clear
        .Add Part
        .Paste
    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

'SelectElement用BrapName取得
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)
    Sel.Clear
    If Sel.SelectElement2(FilterType, Msg, False) = "Cancel" Then End
End Sub

"これが商売にならないかな?" と思う反面、全く責任を持つ気力も出てこない・・・。