こちらでコメントを頂いたので、リハビリがてら作ってみました。
Excelフォームボタンからマクロの起動 (未確認) - C#ATIA
'vba sample_ExpPointPos_ver0.0.1 by Kantoku '選択した点の座標値をファイルにエクスポート Option Explicit '*** エクスポートするフォーマットを設定して下さい *** 'txt - スペース区切り 'csv - カンマ区切り 'xls - Excelに直接(要Excel起動) Const ExpType = "csv" '********* Sub CATMain() 'ドキュメントのチェック If Not CanExecute("PartDocument") Then Exit Sub 'ドキュメント Dim Doc As PartDocument Set Doc = CATIA.ActiveDocument 'ドキュメントパス Dim DocPath As Variant DocPath = GetDocDir(Doc) 'excelのみ If ExpType = "xls" Then Dim Xlapp As Object Set Xlapp = GetExcel() End If '点選択 Dim Filter As Variant Filter = Array("Point") Dim Msg As String Msg = "点/頂点を選択してください : [Esc]=キャンセル" Dim Data As Collection '取得データ格納用 Set Data = GetPointInfo(Msg, Filter) If Data.Count < 1 Then End 'データ無し 'エクスポート DocPath(1) = DocPath(1) & "_SelPoint" Dim ExpPath As String Select Case ExpType Case "txt" ExpPath = ExpTxt(DocPath, Data, " ", "txt") Case "csv" ExpPath = ExpTxt(DocPath, Data, ",", "csv") Case "xls" ExpPath = ExpXls(DocPath, Data, Xlapp) End Select Msg = ExpPath & vbNewLine & _ CStr(Data.Count) & "個分の座標値をエクスポートしました" MsgBox Msg End Sub 'エクスポート - excel Private Function ExpXls(ByVal Path As Variant, ByVal Data As Collection, _ ByVal Xlapp As Object) As String Dim Wb As Object 'WookBook Set Wb = Xlapp.Workbooks.Add Dim Ws As Object 'WorkSheet Set Ws = Wb.ActiveSheet Dim I As Long, J As Long For I = 1 To Data.Count For J = 1 To 4 Ws.Cells(I, J).value = Data(I).Item(J) Next Next Path(2) = "xls" Dim ExpPath As String ExpPath = GetNewName(JoinPathName(Path)) Call Wb.SaveAs(ExpPath) ExpXls = ExpPath End Function 'Excel取得 Private Function GetExcel() As Object Dim Xlapp As Object 'As Excel.Application On Error Resume Next Set Xlapp = VBA.GetObject(, "Excel.Application") On Error GoTo 0 If IsNothing(Xlapp) Then MsgBox "Excelを起動してから再度実行してください" End End If Set GetExcel = Xlapp End Function 'エクスポート - txt,csv Private Function ExpTxt(ByVal Path As Variant, ByVal Data As Collection, _ ByVal Delim As String, ByVal Ext As String) As String Dim Tmp As Collection: Set Tmp = New Collection Dim Info As Collection For Each Info In Data Call Tmp.Add(JoinLst(Info, Delim)) Next Path(2) = Ext Dim ExpPath As String ExpPath = GetNewName(JoinPathName(Path)) Call WriteFile(ExpPath, JoinLst(Tmp, vbNewLine)) ExpTxt = ExpPath End Function 'リスト展開 Private Function JoinLst(ByVal Lst As Collection, ByVal Delim As String) Dim t As Variant Dim res As String For Each t In Lst res = res & t & Delim Next JoinLst = Left(res, Len(res) - Len(Delim)) End Function '座標値取得 Private Function GetPointInfo(ByVal Msg As String, _ ByVal Filter As Variant) As Collection Dim Sel As Variant: Set Sel = CATIA.ActiveDocument.Selection Dim Data As Collection: Set Data = New Collection Dim Info As Collection Dim Pnt As Variant 'As Point Dim Pos(2) As Variant 'As Double Do Sel.Clear Select Case Sel.SelectElement2(Filter, Msg, False) Case "Cancel", "Undo", "Redo" Exit Do End Select Set Pnt = Sel.Item(1).value Call Pnt.GetCoordinates(Pos) Set Info = New Collection With Info Call .Add(Pnt.Name) Call .Add(CStr(Pos(0))) Call .Add(CStr(Pos(1))) Call .Add(CStr(Pos(2))) End With Call Data.Add(Info) Loop Set GetPointInfo = Data End Function 'ドキュメントのパス取得 Private Function GetDocDir(ByVal Doc As PartDocument) As Variant Dim Path As Variant Path = SplitPathName(Doc.FullName) If Len(Path(0)) < 1 Then MsgBox "CATPartファイルを一度保存してください!!)" End End If GetDocDir = Path End Function '*** kclより流用 *** 'こちらを同じプロジェクト内にKCL.bas(標準モジュール)として入れてある場合は '以下のコードは不要です。 'http://kantoku.hatenablog.com/entry/2016/06/21/111410 'http://kantoku.hatenablog.com/entry/2016/12/27/194117 'マクロスタートチェック ''' @param:DocTypes-array(string),string マクロ実行を許可するドキュメントのタイプ ''' @return:Boolean Private Function CanExecute(ByVal DocTypes As Variant) As Boolean CanExecute = False If CATIA.Windows.Count < 1 Then MsgBox "ファイルが開かれていません" Exit Function End If If VarType(DocTypes) = vbString Then DocTypes = Split(DocTypes, ",") If Not IsFilterType(DocTypes) Then Exit Function Dim ErrMsg As String ErrMsg = "ファイルのタイプが異なります。" + vbNewLine + "(" + Join(DocTypes, ",") + " のみです)" Dim ActDoc As Document On Error Resume Next Set ActDoc = CATIA.ActiveDocument On Error GoTo 0 If ActDoc Is Nothing Then MsgBox ErrMsg, vbExclamation + vbOKOnly Exit Function End If If UBound(Filter(DocTypes, TypeName(ActDoc))) < 0 Then MsgBox ErrMsg, vbExclamation + vbOKOnly Exit Function End If CanExecute = True End Function 'フィルタータイプとしてOK? Private Function IsFilterType(ByVal Ary As Variant) As Boolean IsFilterType = False Dim ErrMsg$: ErrMsg = "フィルター又はドキュメントタイプの指定は" + vbNewLine + _ "Variant(String)型配列で行ってください" + vbNewLine + _ "(マクロコードのエラーです)" If Not IsStringAry(Ary) Then MsgBox ErrMsg Exit Function End If IsFilterType = True End Function '文字型配列? Private Function IsStringAry(ByVal Ary As Variant) As Boolean IsStringAry = False If Not IsArray(Ary) Then Exit Function Dim I& For I = 0 To UBound(Ary) If Not VarType(Ary(I)) = vbString Then Exit Function Next IsStringAry = True End Function 'FileSystemObject ''' @return:Object(Of FileSystemObject) Private Function GetFSO() As Object Set GetFSO = CreateObject("Scripting.FileSystemObject") End Function 'パス/ファイル名/拡張子 分割 ''' @param:FullPath-ファイルパス ''' @return:Variant(Of Array(Of String)) (0-Path 1-BaseName 2-Extension) Private Function SplitPathName(ByVal FullPath$) As Variant Dim Path(2) As String With GetFSO Path(0) = .getParentFolderName(FullPath) Path(1) = .GetBaseName(FullPath) Path(2) = .GetExtensionName(FullPath) End With SplitPathName = Path End Function 'パス/ファイル名/拡張子 連結 ''' @param:Path-Variant(Of Array(Of String)) (0-Path 1-BaseName 2-Extension) ''' @return:ファイルパス Private Function JoinPathName$(ByVal Path As Variant) If Not IsArray(Path) Then Stop '未対応 If Not UBound(Path) = 2 Then Stop '未対応 JoinPathName = Path(0) + "\" + Path(1) + "." + Path(2) End Function 'ファイル,フォルダの有無 ''' @param:Path-パス ''' @return:Boolean Private Function IsExists(ByVal Path$) As Boolean IsExists = False Dim FSO As Object: Set FSO = GetFSO If FSO.FileExists(Path) Then IsExists = True: Exit Function 'ファイル ElseIf FSO.FolderExists(Path) Then IsExists = True: Exit Function 'フォルダ End If Set FSO = Nothing End Function '重複しない名前取得 ''' @param:Path-ファイルパス ''' @return:新たなファイルパス Private Function GetNewName$(ByVal OldPath$) Dim Path As Variant Path = SplitPathName(OldPath) Path(2) = "." & Path(2) Dim NewPath$: NewPath = Path(0) + "\" + Path(1) If Not IsExists(NewPath + Path(2)) Then GetNewName = NewPath + Path(2) Exit Function End If Dim TempName$, I&: I = 0 Do I = I + 1 TempName = NewPath + "_" + CStr(I) + Path(2) If Not IsExists(TempName) Then GetNewName = TempName Exit Function End If Loop End Function 'ファイルの書き込み ''' @param:Path-ファイルパス ''' @param:Txt-String Private Sub WriteFile(ByVal Path$, ByVal txt) '$) Call GetFSO.OpenTextFile(Path, 2, True).Write(txt) End Sub
マクロ起動後、大したメッセージもありませんが点を次々とクリックして頂き
ESCキーを押す事でCATPartファイルと同じフォルダ内に
"[CATPartファイル名]_SelPoint.xxx "
と言う名称のファイルが出来上がります。
(上書き保存を避けるため、同一名のファイルがある場合 "_[数字]"が追加されます)
・CATPartファイルがアクティブになっている必要が有り、一度保存しておく必要が有ります。
(保存先パスを取得する為)
・事前にコードを設定する必要がありますが(最初の方の部分です)、対応フォーマットは
txt,csv,xlsです。
・xlsの場合、事前にExcelを起動しておく必要が有ります。
・エクスポートされたファイルは以下の状態です。
[名称 , X値 , Y値 , Z値]
・Excel操作部分のコードは、世間の皆様の方がきっと素晴らしいと思います。
・コード内にも記載しましたが、KCLを利用する場合は後半のコードは不要です。
非常に個人的なCATVBA用ライブラリ - C#ATIA
不覚にも、KCLのご利用をお考えの方へ - C#ATIA