C#ATIA

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

指定した要素を新たなPartにコピペして保存

久々のCATIAのマクロです。

アクティブなPartファイル上で指定した要素を、新たなPartに ”結果として” で
コピペし保存します。

'vba NewPart_CopyAndPasteResult  using-'KCL0.0.13'  by Kantoku
'指定した要素を新たなPartファイルに"結果として"でコピペする

Option Explicit

Private Const FOOTER = "_copy"

Sub CATMain()

    'ドキュメントのチェック
    If Not CanExecute("PartDocument") Then Exit Sub
    
    '元パス
    Dim docPath As String
    docPath = CATIA.ActiveDocument.FullName
    
    'コピー
    Dim msg As String
    msg = "新たなPartにコピーする要素を選択してください / ESC-キャンセル"
    
    Call SelectItemsCopy(msg, Array("AnyObject"))
    
    'ペースト
    Dim docs As Documents
    Set docs = CATIA.Documents
    
    Dim newDoc As PartDocument
    Set newDoc = docs.Add("Part")
    
    Call SelectItems(newDoc)
    CATIA.RefreshDisplay = True
    
    '保存
    Dim newPath As String
    newPath = GetNewPath(docPath)
    
    Call newDoc.SaveAs(newPath)
    
    MsgBox "done"
    
End Sub

'ペーストパス
Private Function GetNewPath( _
    ByVal path As String) As String
    
    Dim tmp As Variant
    tmp = KCL.SplitPathName(path)
    tmp(1) = tmp(1) & FOOTER
    
    GetNewPath = KCL.GetNewName(KCL.JoinPathName(tmp))
End Function

'ペースト
Private Sub SelectItems( _
    ByVal newDoc As PartDocument)
    
    newDoc.Activate
    
    Dim sel As Selection
    Set sel = newDoc.Selection
    
    CATIA.HSOSynchronized = False
    
    With sel
        .Clear
        .Add newDoc.part
        .PasteSpecial "CATPrtResultWithOutLink"
        .Clear
    End With
    
    CATIA.HSOSynchronized = True
    
End Sub

'コピー
Private Sub SelectItemsCopy( _
    ByVal msg As String, _
    ByVal filter As Variant)
    
    Dim sel As Variant
    Set sel = CATIA.ActiveDocument.Selection
    
    sel.Clear
    Select Case sel.SelectElement3(filter, _
                                   msg, _
                                   True, _
                                   CATMultiSelTriggWhenUserValidatesSelection, _
                                   False)
        Case "Cancel", "Undo", "Redo"
            End
    End Select
    
    If sel.count < 1 Then End
    
    sel.Copy
    sel.Clear
End Sub

特に何て事の無い内容で、単に加工のためのPowerMill用にエクスポートする為です。
(ある意味、履歴無しのPartファイルを作っているような感じです)

元のPartファイルと同一フォルダに、元のファイル名 + "_copy" の新たなファイルを
作成します。