C#ATIA

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

手抜きマクロ起動用メニュー1

CATIAのマクロを実行する際、こちらの前半に記載した方法で
ツールバーに登録して使っているのですが

マクロを高速に実行させる(非公式) - C#ATIA

正直な所、登録が面倒です。
(何処で見たか忘れましたが、全てのファイルを閉じた状態で
ツールバーを新規に作成すると、ワークベンチに依存しないツールバーが
作成可能なようです)

その為、フォームで自作のメニューを作り自作メニューだけをツールバーに
登録してマクロを起動して運用しています。
・・・が、非常に出来が悪く使い勝手もイマイチでした。

そこで重い腰を上げ、新たに作り直しました。こんな感じです。
f:id:kandennti:20171016183642p:plain
驚く程の手抜き感です。
態々ブログに載せるほどのものか? と、さえ思えます。


実は見た目以上に手抜きなのが、マクロの登録なんです。

最初にメニューを起動した際、"Part" タブにはボタンが1つしか
有りませんが、途中でVBエディタにモジュールをD&Dで追加し
再度メニューを起動すると、ボタンが追加されています。

これぐらい楽が出来るものが、前から欲しかったのですが
なかなか取り掛かれませんでした。

サンプルマクロを含めこちらにUpしております。

GrabCAD - CAD library

ちょっとだけ仕組みがあるため、それは次回に。

ProductTree の リオーダー2

こちらの続きです。
ProductTree の リオーダー - C#ATIA

サンプル用のマクロを用意していたのですが、Product用のマクロを持っていない為、
以前の物を修正し、インスタンス名でソートするマクロに変更しました。

'vba sample_ReOrder_Product ver0.0.1  using-'KCL0.0.12'  by Kantoku
'インスタンス名でのソート順にTreeを並び替えます

Option Explicit

Sub CATMain()
    'ドキュメントのチェック
    If Not CanExecute("ProductDocument") Then Exit Sub
    
    'Doc取得
    Dim ProDoc As ProductDocument: Set ProDoc = CATIA.ActiveDocument
    Dim Pros As Products: Set Pros = ProDoc.Product.Products
    If Pros.Count < 2 Then Exit Sub
    
    'オプション変更
    Dim AssyMode As AsmConstraintSettingAtt
    Set AssyMode = CATIA.SettingControllers.Item("CATAsmConstraintSettingCtrl")
    Dim OriginalMode As CatAsmPasteComponentMode
    OriginalMode = AssyMode.PasteComponentMode
    
    'オプション切り替え
    AssyMode.PasteComponentMode = catPasteWithCstOnCopyAndCut
    
    'ソート済み名前リスト
    Dim Names: Set Names = Get_SortedNames(Pros)
    
    'カット
    Dim Sel As Selection: Set Sel = ProDoc.Selection
    Dim Itm As Variant
    
    CATIA.HSOSynchronized = False
    
    Sel.Clear
    For Each Itm In Names
        Sel.Add Pros.Item(Itm)
    Next
    Sel.Cut
    
    'ペースト
    With Sel
        .Clear
        .Add Pros
        .Paste
        .Clear
    End With
    
    CATIA.HSOSynchronized = True
    
    'オプション戻し,UpDate
    AssyMode.PasteComponentMode = OriginalMode
    ProDoc.Product.Update
End Sub

'インスタンス名でソート済みの名前リスト
Private Function Get_SortedNames(ByVal Pros As Products) As Object
    Dim Lst As Object
    Set Lst = KCL.InitLst()
    
    Dim Pro As Product
    For Each Pro In Pros
        Lst.Add Pro.Name
    Next
    
    Lst.Sort
    
    Set Get_SortedNames = Lst
End Function

又、ソート処理が毎回面倒な為、KCLをVer0.0.12としました。
非常に個人的なCATVBA用ライブラリ - C#ATIA

複雑な条件分岐を、出来るだけ清楚に書きたい

ちょっと複雑な条件分岐を、どうやったら清楚に書けるものか
悩んでます。

言葉だけでは伝わらないので、直ぐに思い付いたコードがこちらです。

'vba
Sub Branch_Test()
    Dim NaN& '他言語のNaN代わり
    NaN = -100:
    
    Dim Piyo& '条件1
    Piyo = 2
    
    Dim Huga& '条件2
    Huga = 3
    
    Dim Res '結果
    
    Dim i
    Dim Hoge '調べたいもの
    Hoge = Array(2, 3, 6, 7, 9, -4, -6, -9)
    
    For i = 0 To UBound(Hoge)
        Res = NaN
    
        If Hoge(i) > 0 Then
            If (Hoge(i) Mod Piyo) = 0 Then
                Res = Piyo
            Else
                If (Hoge(i) Mod Huga) = 0 Then
                    Res = Huga
                End If
            End If
        Else
            If (Hoge(i) Mod Huga) = 0 Then
                Res = Huga
            End If
        End If
    
        If Res = NaN Then
            Debug.Print "条件を満たしていません(" & Hoge(i) & ")"
        Else
            Debug.Print Hoge(i) & " は " & Res & " で割り切れます"
        End If
        Debug.Print
    Next
End Sub

良い例が思いつかなかったのですが、配列 Hoge が調査対象になります。

ルールとしては
A) 0以上である事。但し例外有り
B) 条件1(Piyo)を満たしていれば、結果とする
C) 条件2(Huga)を満たしていれば、結果とする
D) 条件1・2両方を満たしていれば、条件1の結果とする
E) 条件2を満たしていれば、A)を満たしていなくても、結果とする
実は E) のルールが非常に邪魔で、条件の強さを不等号で一列に表現できません。

その為、IF文がネストし異なる部分に

            If (Hoge(i) Mod Huga) = 0 Then
                Res = Huga
            End If

と、全く同じ処理が2ヶ所に書かれています。腹が立つ・・・。

一応結果としては、

2 は 2 で割り切れます

3 は 3 で割り切れます

6 は 2 で割り切れます

条件を満たしていません(7)

9 は 3 で割り切れます

条件を満たしていません(-4)

-6 は 3 で割り切れます

-9 は 3 で割り切れます

「6」に関しては、最小公倍数なのですが、ルール D) が適応されています。
「-6」「-9」はルール A)を満たしていないのですが、E) が適応されています。



上記コードをVBA独特の 「Select Case True」 を利用し、この様に
修正してみました。

'vba
Sub Branch_Test2()
    Dim NaN& '他言語のNaN代わり
    NaN = -100:
    
    Dim Piyo& '条件1
    Piyo = 2
    
    Dim Huga& '条件2
    Huga = 3
    
    Dim Res '結果
    
    Dim i
    Dim Hoge '調べたいもの
    Hoge = Array(2, 3, 6, 7, 9, -4, -6, -9)
    
    Dim Res_Na '最低条件の結果
    Dim Res_Pi '条件1の結果
    Dim Res_Hu '条件2の結果
    
    For i = 0 To UBound(Hoge)
        Res = NaN
    
        Res_Na = (Hoge(i) > 0)
        Res_Pi = (Hoge(i) Mod Piyo) = 0
        Res_Hu = (Hoge(i) Mod Huga) = 0
        
        Select Case True
            Case Res_Pi Eqv Res_Na
                If Res_Pi Then
                    Res = Piyo
                End If
            Case Res_Hu
                Res = Huga
        End Select
    
        If Res = NaN Then
            Debug.Print "条件を満たしていません(" & Hoge(i) & ")"
        Else
            Debug.Print Hoge(i) & " は " & Res & " で割り切れます"
        End If
        Debug.Print
    Next
End Sub

論理演算子 Eqv なんて初めて使いました。
実行結果はこちら

2 は 2 で割り切れます

3 は 3 で割り切れます

6 は 2 で割り切れます

条件を満たしていません(7)

9 は 3 で割り切れます

条件を満たしていません(-4)

-6 は 3 で割り切れます

条件を満たしていません(-9)

最初は上手く行ったと思ったのですが、
「-9」はルール E) が適応されていないので正しくない結果となりました。

	・・・
        Select Case True
            Case Res_Hu Xor Res_Na
                Res = Huga
            Case Res_Pi Eqv Res_Na
                If Res_Pi Then
                    Res = Piyo
                End If
            Case Res_Hu
                Res = Huga
        End Select
	・・・

としても、「7」が正しくない結果に・・・。

条件が複雑なので、清楚に書きにくいのは何となく感じるのですが
どの様なキーワードで検索して良いのかもわからず・・・。

良いアイデアありませんかね?

CodeModuleクラスのProcBodyLineプロパティ

この辺に記載されていますが、

Office TANAKA - VBAでVBEを操作する[CodeModuleのプロパティ]
ProcBodyLine プロパティ

ProcBodyLineプロパティの取得に失敗したら例外吐き出すって
記載しておいて欲しい。(本音は-1でも返して欲しい)

ローカルウィンドウにも表示されないのだから、プロパティと言うより
メソッドっぽい挙動なんですけどね・・・。

実行中のプロジェクト名とパス取得する

今まで気が付かなかったのですが・・・。

VBA実行中にプロジェクト名やプロジェクトのファイルパスが欲しいなぁ
と、思った事がありましたがあまり調べていませんでした。

ちょっと試しているうちに発見しました。

'vba 実行中のプロジェクト名とパス取得
Option Explicit

Sub CATMain()
    'Apc取得
    Dim Apc As Object: Set Apc = GetApc()
    If Apc Is Nothing Then Exit Sub
    
    '実行中のVBProject取得
    Dim ExecPjt As Object: Set ExecPjt = Apc.ExecutingProject
    
    Dim Info$
    Info = "現在実行中のマクロのプロジェクト名は" & vbNewLine & _
           "[ " & ExecPjt.Name & " ] です。" & vbNewLine & _
           "プロジェクトファイルパスは" & vbNewLine & _
           "[ " & ExecPjt.DisplayName & " ] です。" 'ReferenceNameかも
    MsgBox Info
End Sub

Private Function GetApc() As Object
    Set GetApc = Nothing
    
    'VBAバージョンチェック
    Dim COMObjectName$
    #If VBA7 Then
        COMObjectName = "MSAPC.Apc.7.1"
    #ElseIf VBA6 Then
        COMObjectName = "MSAPC.Apc.6.2"
    #Else
        MsgBox "VBAのバージョンが未対応です"
        Exit Function
    #End If
    
    'APC取得
    Dim Apc As Object: Set Apc = Nothing
    On Error Resume Next
        Set Apc = CreateObject(COMObjectName)
    On Error GoTo 0
    
    If Apc Is Nothing Then
        MsgBox "MSAPC.Apcが取得できませんでした"
        Exit Function
    End If
    
    Set GetApc = Apc
End Function

一応VBA6でも対応できそうな雰囲気に書いてますが、
試していない為よくわかりません。

こんな感じです。
f:id:kandennti:20171006185315p:plain

Excel等のOffice製品でも取得できるのかどうかもわかりません。
(パスは、ExcelならBookファイルになりそう・・・)

CATIAのバッチモード起動でのマクロ処理は、CATScriptしか出来なさそうなのですが
仕込んだCATScriptから、VBAのProjectを取得し実行できそうな
気がしてます。 バッチモードでもVBAで戦えそう。

Formにボタンを動的に追加し、イベントを発生させたい

色々と思うことが有って、VBAのFormに取り組んでいるのですが
知識が足りず悩んでます。

UserFromにコマンドボタンを動的に追加し、イベントも動的に発生させたいです。
こちらで教わったのですが
Formの内容を、DrawTableに反映する - C#ATIA

こちらを参考にしてみました。
VBA。フォームにコントロールを動的に追加する - Qiita

が、こちらのコード、色々とまずかったのでこんな風に
してみました。


まず、フォームモジュールですが作りましたが何もしません。
とにかく作るだけで、名前は "UserForm1" です。

続いて、クラスモジュール。 名前は "Class1" です。

'vba Class1.cls
Option Explicit

Private WithEvents mBtn As MSForms.CommandButton

Sub InitBtn(ByVal Btn As MSForms.CommandButton)
    Set mBtn = Btn
End Sub

Private Sub mBtn_Click()
    Dim Msg$
    Msg = "オートコンプリートで、" & vbNewLine & _
    "ControlTipText出ませんが" & vbNewLine & _
    "このボタンでは[ " & mBtn.ControlTipText & " ]です"
    MsgBox Msg
End Sub

続いて標準モジュール。 名前は "Module1" です。

'vba Module1.bas
Option Explicit

Sub FormTest()
    Dim CapAry As Variant: CapAry = Split("hoge,piyo,fuga", ",")
    Dim TipAry As Variant: TipAry = Split("foo,bar,baz", ",")
    Dim BtnInfoAry() As Variant: ReDim BtnInfoAry(UBound(CapAry))
    Dim i&
    
    For i = 0 To UBound(CapAry)
        BtnInfoAry(i) = Array(CapAry(i), TipAry(i))
    Next
    
    Call Init_Form(BtnInfoAry)
End Sub
Private Function Init_Form(ByVal InfoAry As Variant) As UserForm1
    Dim BtnCnt&: BtnCnt = UBound(InfoAry)
    Dim Uf As UserForm1: Set Uf = UserForm1
    
    With Uf
        .Width = 70
        .Height = (BtnCnt + 1) * 20 + 30
    End With
    
    Dim i&, Btn As MSForms.CommandButton
    Dim BtnAry() As Class1: ReDim BtnAry(BtnCnt)
    For i = 0 To BtnCnt
        Set Btn = Uf.Controls.Add("Forms.CommandButton.1", i, True)
        With Btn
            .Top = 5 + (i) * 20
            .Left = 5
            .Height = 20
            .Width = 70
            .Caption = InfoAry(i)(0)
            .ControlTipText = InfoAry(i)(1)
        End With
        Set BtnAry(i) = New Class1
        Call BtnAry(i).InitBtn(Btn)
    Next
    UserForm1.Show
End Function

Init_Form関数は戻り値返していないのですが、後のテストの為です。
この関数のキモは、こちら

    Dim Uf As UserForm1: Set Uf = UserForm1

インスタンスを生成しているのではなく、最初に作った空っぽのForm自体を
受け取っています。
で、この状態であれば無事動き、イベントも発生します。
f:id:kandennti:20171006002619p:plain
自宅なのでExcelでやってますが、CATIAでも同じでした。

問題はここから。先程の部分をインスタンスに変更します。

    Dim Uf As UserForm1: Set Uf = New UserForm1

これだと、イベントが発生しません・・・。

又、インスタンスではなく最初の状態に戻し、

'vba Module1.bas
Option Explicit

Sub FormTest()
 ・・・
    Dim Uf As UserForm1
    Set Uf = Init_Form(BtnInfoAry)
    Uf.Show 
End Sub

Private Function Init_Form(ByVal InfoAry As Variant) As UserForm1
    Dim BtnCnt&: BtnCnt = UBound(InfoAry)
    Dim Uf As UserForm1: Set Uf = UserForm1

 ・・・
    Next
    'UserForm1.Show
    Set Init_Form = Uf
End Function

FormTest側で戻り値を受け取り、FormTest側でShowさせても
同様にイベントが発生しません。
(本当はこうしたかったので、関数名をInit_Formしたのに…)

こんなもんなのでしょうか?


追記です。 教えていただきました。
フォームモジュールは空っぽではなく、この様にしました。

'vba UserForm1.frm
Option Explicit

Private mAry As Variant

Sub SetBtn(ByVal Ary As Variant)
    mAry = Ary
End Sub

標準モジュールはこの様に

'vba Module1.bas
Option Explicit

Sub FormTest()
 ・・・
    Dim Uf As UserForm1
    Set Uf = Init_Form(BtnInfoAry)
    Uf.Show 
End Sub

Private Function Init_Form(ByVal InfoAry As Variant) As UserForm1
    Dim BtnCnt&: BtnCnt = UBound(InfoAry)
    Dim Uf As UserForm1: Uf = New UserForm1

 ・・・
    Next
    'UserForm1.Show
    Call Uf.SetBtn(BtnAry)
    Set Init_Form = Uf
End Function

これで上手く行きました。 ありがとうございます。

1つのPartからBody毎にしたProductを作り出す2

予め、お伝えしておきます。
KCLを更新しました。
非常に個人的なCATVBA用ライブラリ - C#ATIA

リンクの画面やカタログ等を開いた状態でマクロを実行すると、
エラーで止まってしまうのを防ぎたかったので。



こちらの続きです。
1つのPartからBody毎にしたProductを作り出す - C#ATIA


前回のコメントに書いたソースコードは少し参考にさせてもらいました。
あちらのものより処理は速いかな? とは思います。

'vba sample_Part2Product_ver0.0.2  using-'ver0.0.11'
'PartからProduct化します
'ボディ・形状セット・時系列形状セットで表示されているもののみ
'(スケッチは対象外)

Option Explicit

Sub CATMain()
    'ドキュメントのチェック
    If Not CanExecute("PartDocument") Then Exit Sub
    
    'Part
    Dim BaseDoc As PartDocument: Set BaseDoc = CATIA.ActiveDocument
    
    Dim BasePath As Variant: BasePath = Array(BaseDoc.FullName)
    
    Dim Pt As Part: Set Pt = BaseDoc.Part
    
    Dim LeafItems As Collection: Set LeafItems = Get_LeafItemLst(Pt.Bodies)
    
    Dim Msg As String
    If LeafItems Is Nothing Then
        Msg = "コピー可能な要素がありません!"
        MsgBox Msg, vbOKOnly + vbExclamation
        Exit Sub
    End If
    
    '確認
    Msg = LeafItems.Count & "個のコピー可能な要素があります。" & vbNewLine & _
          "ペーストするタイプを指定してください" & vbNewLine & vbNewLine & _
          "はい : リンクの結果として(As Result With Link)" & vbNewLine & _
          "いいえ : 結果として(As Result)" & vbNewLine & _
          "キャンセル : マクロ中止"
    Dim PasteType As String
    Select Case MsgBox(Msg, vbQuestion + vbYesNoCancel)
        Case vbYes
            PasteType = "CATPrtResult"
        Case vbNo
            PasteType = "CATPrtResultWithOutLink"
        Case Else
            Exit Sub
    End Select
    
    KCL.SW_Start

    'Assy
    Dim TopDoc As ProductDocument: Set TopDoc = CATIA.Documents.Add("Product")
    
    Call ToProduct(TopDoc, LeafItems, PasteType)
    
    TopDoc.Product.Update
    
    Debug.Print "Time:" & KCL.SW_GetTime & "s"
    MsgBox "Done"
End Sub

'Productにペースト
Private Sub ToProduct(ByVal TopDoc As ProductDocument, _
                      ByVal LeafItems As Collection, _
                      ByVal PasteType As String)
    Dim TopSel As Selection
    Set TopSel = TopDoc.Selection
    
    Dim BaseSel As Selection
    Set BaseSel = KCL.GetParent_Of_T(LeafItems(1), "PartDocument").Selection
    
    Dim Prods As Products
    Set Prods = TopDoc.Product.Products
    
    Dim Itm As AnyObject
    Dim TgtDoc As PartDocument
    Dim ProdsNameDic As Object: Set ProdsNameDic = KCL.InitDic()
    
    CATIA.HSOSynchronized = False
    
    For Each Itm In LeafItems
        If ProdsNameDic.Exists(Itm.Name) Then
            Set TgtDoc = ProdsNameDic.Item(Itm.Name)
        Else
            Set TgtDoc = Init_Part(Prods, Itm.Name)
            ProdsNameDic.Add Itm.Name, TgtDoc
        End If
        
        Call Preparing_Copy(BaseSel, Itm)
        With BaseSel
            .Copy
            .Clear
        End With
        
        With TopSel
            .Clear
            .Add TgtDoc.Part
            .PasteSpecial PasteType
        End With
    Next
    BaseSel.Clear
    TopSel.Clear
    CATIA.HSOSynchronized = True
End Sub

'コピー要素を選択状態にする
Private Sub Preparing_Copy(ByVal Sel As Selection, ByVal Itm As AnyObject)
    Sel.Clear
    
    'Body
    If TypeName(Itm) = "Body" Then
        Sel.Add Itm
        Exit Sub
    End If
    
    'HybridBody
    Dim ShpsLst As Collection: Set ShpsLst = New Collection
    ShpsLst.Add Itm.HybridShapes
    
    Select Case TypeName(Itm)
        Case "HybridBody"
            Set ShpsLst = Get_All_HbShapes(Itm, ShpsLst)
        Case "OrderedGeometricalSet"
            Set ShpsLst = Get_All_OdrGeoSetShapes(Itm, ShpsLst)
    End Select
    
    Dim Shps As HybridShapes, Shp As HybridShape
    For Each Shps In ShpsLst
        For Each Shp In Shps
            Sel.Add Shp
        Next
    Next
End Sub

'指定時系列形状セット以下の全てHybridShapesを取得
'再帰 かなり効率悪いかも
Private Function Get_All_OdrGeoSetShapes(ByVal OdrGeoSet As OrderedGeometricalSet, _
                                         ByVal Lst As Collection) As Collection
    Dim Child As OrderedGeometricalSet
    For Each Child In OdrGeoSet.OrderedGeometricalSets
        Lst.Add Child.HybridShapes
        If Child.OrderedGeometricalSets.Count > 0 Then
            Set Lst = Get_All_OdrGeoSetShapes(Child, Lst)
        End If
    Next
    Set Get_All_OdrGeoSetShapes = Lst
End Function

'指定形状セット以下の全てHybridShapesを取得
'再帰 かなり効率悪いかも
Private Function Get_All_HbShapes(ByVal Hbdy As HybridBody, _
                                  ByVal Lst As Collection) As Collection
    Dim Child As HybridBody
    For Each Child In Hbdy.hybridBodies
        Lst.Add Child.HybridShapes
        If Child.hybridBodies.Count > 0 Then
            Set Lst = Get_All_HbShapes(Child, Lst)
        End If
    Next
    Set Get_All_HbShapes = Lst
End Function

'ルートで、空ではなく表示されているボディ・形状セット取得
Private Function Get_LeafItemLst(ByVal Pt As Part) As Collection
    Set Get_LeafItemLst = Nothing
    
    Dim Sel As Selection: Set Sel = Pt.Parent.Selection
    Dim TmpLst As Collection: Set TmpLst = New Collection
    Dim I As Long

    Dim Filter As String
    Filter = "(CATPrtSearch.BodyFeature.Visibility=Shown " & _
            "+ CATPrtSearch.OpenBodyFeature.Visibility=Shown" & _
            "+ CATPrtSearch.MMOrderedGeometricalSet.Visibility=Shown),sel"
    
    CATIA.HSOSynchronized = False
    
    With Sel
        .Clear
        .Add Pt
        .Search Filter
        For I = 1 To .Count2
            TmpLst.Add .Item(I).Value
        Next
        .Clear
    End With
    
    CATIA.HSOSynchronized = True
    
    If TmpLst.Count < 1 Then Exit Function
    
    Dim LeafHBdys As Object: Set LeafHBdys = KCL.InitDic()
    Dim Hbdy As AnyObject 'HybridBody & OrderedGeometricalSets
    For Each Hbdy In Pt.hybridBodies
        LeafHBdys.Add Hbdy, 0
    Next
    For Each Hbdy In Pt.OrderedGeometricalSets
        LeafHBdys.Add Hbdy, 0
    Next
    
    
    Dim Itm As AnyObject
    Dim Lst As Collection: Set Lst = New Collection
    For Each Itm In TmpLst
        Select Case TypeName(Itm)
            Case "Body"
                If Is_LeafBody(Itm) Then Lst.Add Itm
            Case Else 'HybridBody & OrderedGeometricalSets
                If Is_LeafHybridBody(Itm, LeafHBdys) Then Lst.Add Itm
        End Select
    Next
    If Lst.Count < 1 Then Exit Function
    
    Set Get_LeafItemLst = Lst
End Function

'ルートのボディで中身が有るか?
Private Function Is_LeafBody(ByVal Bdy As Body) As Boolean
    Is_LeafBody = Bdy.InBooleanOperation = False And Bdy.Shapes.Count > 0
End Function

'ルートの形状セットで中身が有り可視か?As HybridBody
'prm:Hbdy - HybridBody & OrderedGeometricalSets
Private Function Is_LeafHybridBody(ByVal Hbdy As AnyObject, _
                                   ByVal Dic As Object) As Boolean
    Is_LeafHybridBody = False
    If Not Dic.Exists(Hbdy) Then Exit Function
    
    CATIA.HSOSynchronized = False
    
    Dim Sel As Selection
    Set Sel = KCL.GetParent_Of_T(Hbdy, "PartDocument").Selection
    
    Dim Cnt As Long
    
    With Sel
        .Clear
        .Add Hbdy
        .Search "Visibility=Shown,sel"
        Cnt = .Count2
        .Clear
    End With
    
    CATIA.HSOSynchronized = True
    
    If Cnt > 1 Then Is_LeafHybridBody = True
End Function

'Part新作
Private Function Init_Part(ByVal Prods As Variant, _
                           ByVal PtNum As String) As PartDocument
    Dim Prod As Product
    On Error Resume Next
        Set Prod = Prods.AddNewComponent("Part", PtNum)
    On Error GoTo 0
    Set Init_Part = Prods.Item(Prods.Count).ReferenceProduct.Parent
End Function

・履歴有りのPartファイルでも、それなりの処理を行います。

・ボディ・形状セット・時系列形状セットでTreeのルート?に
 ぶら下がって、表示されているもののみが対象です。(スケッチは対象外)

・元データの形状セット・時系列形状セットが階層状になっている
 ものは、全て同一レベルでペーストされます。

・ボディ等の名前が同一場合、同一のPartに取り込まれます。

・ボディ内に入っている形状セット等、素直じゃない階層は
 見捨ててます。

・ハイブリッドデザインは、未テストです。

・ペーストする際は "リンクの結果として" "結果として" が選べます。

"リンクの結果として" が可能になるようにしたかったので、
こだわりました。 支給ファイルの差し替えが出来るような気がしたので。
(リンクを切るのは何時でも出来ますし)


手元に大き目のデータが無かった為、GrabCADからお借りしました。
GrabCAD - CAD library
この方、日本人なんですよね。

お借りしたデータで試しました。

結局、保存はしてません・・・。ファイル名まで手動でやろうとすると手間だよなぁ。