こちらでｺﾒﾝﾄを頂いたので、ﾘﾊﾋﾞﾘがてら作ってみました。
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
