会社のデータサーバーが、暑さで壊れてしまい全く仕事になりませんでした。
暇だったので、形状セットと平面を指定し、形状セットの階層を維持しつつ
データム化させ対称形状を作成するマクロを作ってみました。
(スケッチは対象外です)
例としてこんな感じのデータです。
マクロ実行し最初に「Hoge」形状セットを選択し、続いてYZ平面を指定します。
「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
"これが商売にならないかな?" と思う反面、全く責任を持つ気力も出てこない・・・。