久々の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" の新たなファイルを
作成します。