C#ATIA

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

クリックした点の座標値を外部ファイルにエクスポート

こちらでコメントを頂いたので、リハビリがてら作ってみました。
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