C#ATIA

↑タイトル詐欺 主にCATIA V5 の VBA

非常に個人的なCATVBA用ライブラリ

公開するコードを短くしたい為、非常に個人的に作成している
CATVBA用ライブラリを公開しておきます。

未だに迷いに迷っている為、今後も変更が確実にあり
場合によっては破壊的な変更も十分ありえます。
(古いライブラリでは実行できたマクロが、新しいライブラリでは動かなくなる
と言う意味です。)

主な内容としては、
・汎用的と思われるCATIAの処理(選択等)
・ファイル操作
・配列操作
・簡易マクロスタート時チェック
・簡易ストップウォッチ
ベクトル演算関係も入れたいような・・・。

'vba Kantoku_CATVBA_Library ver0.0.12
'KCL.bas - 標準モジュール
Option Explicit

Private mSW& '時間計測用

#If VBA7 And Win64 Then
    Private Declare PtrSafe Function timeGetTime Lib "winmm.dll" () As Long
#Else
    Private Declare Function timeGetTime Lib "winmm.dll" () As Long
#End If

'開発用-オブジェクトチェック
Sub CATMain()
    Dim Msg$: Msg = "選択して下さい : ESCキー 終了"
    Dim SI As AnyObject
    Dim Doc As Document: Set Doc = CATIA.ActiveDocument
    Do
        Set SI = SelectItem(Msg)
        If IsNothing(SI) Then Exit Do
        Stop
    Loop
End Sub

'*****CATIAな関数*****
'マクロスタートチェック
''' @param:DocTypes-array(string),string マクロ実行を許可するドキュメントのタイプ
''' @return:Boolean
Public 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

'選択
''' @param:Msg-メッセージ
''' @param:Filter-array(string),string 選択フィルター(指定無し時AnyObject)
''' @return:AnyObject
Public Function SelectItem(ByVal Msg$, _
                           Optional ByVal Filter As Variant = Empty) _
                           As AnyObject
    Dim SE As SelectedElement
    Set SE = SelectElement(Msg, Filter)
    
    If IsNothing(SE) Then
        Set SelectItem = SE
    Else
        Set SelectItem = SE.Value
    End If
End Function

'選択
''' @param:Msg-メッセージ
''' @param:Filter-array(string),string 選択フィルター(指定無し時AnyObject)
''' @return:SelectedElement
Public Function SelectElement(ByVal Msg$, _
                           Optional ByVal Filter As Variant = Empty) _
                           As SelectedElement
    If IsEmpty(Filter) Then Filter = Array("AnyObject")
    If VarType(Filter) = vbString Then Filter = ToStrVriAry(Filter)
    If Not IsFilterType(Filter) Then Exit Function
    
    Dim Sel As Variant: Set Sel = CATIA.ActiveDocument.Selection
    Sel.Clear
    Select Case Sel.SelectElement2(Filter, Msg, False)
        Case "Cancel", "Undo", "Redo"
            Exit Function
    End Select
    Set SelectElement = Sel.Item(1)
    Sel.Clear
End Function

'InternalName
''' @param:AOj-AnyObject
''' @return:String
Public Function GetInternalName$(ByVal AOj As AnyObject)
    If IsNothing(AOj) Then
        GetInternalName = Empty: Exit Function
    End If
    GetInternalName = AOj.GetItem("ModelElement").InternalName
End Function

'T型のParent取得 Nameでのチェックも必要
''' @param:AOj-AnyObject
''' @param:T-String
''' @return:AnyObject
Public Function GetParent_Of_T(ByVal AOj As AnyObject, ByVal T$) As AnyObject
    If TypeName(AOj) = TypeName(AOj.Parent) And _
       AOj.Name = AOj.Parent.Name Then
        Set GetParent_Of_T = Nothing
        Exit Function
    End If
    If TypeName(AOj) = T Then
        Set GetParent_Of_T = AOj
    Else
        Set GetParent_Of_T = GetParent_Of_T(AOj.Parent, T)
    End If
End Function

'BrepNameの取得
''' @param:MyBRepName-String
''' @return:String
Public Function GetBrepName(MyBRepName As String) As String
    MyBRepName = Replace(MyBRepName, "Selection_", "")
    MyBRepName = Left(MyBRepName, InStrRev(MyBRepName, "));"))
    MyBRepName = MyBRepName + ");WithPermanentBody;WithoutBuildError;WithSelectingFeatureSupport;MFBRepVersion_CXR15)"
    GetBrepName = MyBRepName
End Function

'言語取得
'return-ISO 639-1 code
'https://ja.wikipedia.org/wiki/ISO_639-1%E3%82%B3%E3%83%BC%E3%83%89%E4%B8%80%E8%A6%A7
Public Function GetLanguage() As String
    GetLanguage = "non"
    If CATIA.Windows.Count < 1 Then Exit Function
    GetLanguage = "other"
    CATIA.ActiveDocument.Selection.Clear
    Dim St As String: St = CATIA.StatusBar
    Select Case True
        Case ExistsKey(St, "object")
            '英語-Select an object or a command
            GetLanguage = "en"
        Case ExistsKey(St, "objet")
            'フランス語-Selectionnez un objet ou une commande
            GetLanguage = "fr"
        Case ExistsKey(St, "Objekt")
            'ドイツ語-Ein Objekt oder einen Befehl auswahlen
            GetLanguage = "de"
        Case ExistsKey(St, "oggetto")
            'イタリア語-Selezionare un oggetto o un comando
            GetLanguage = "it"
        Case ExistsKey(St, "オブジェクト")
            '日本語-オブジェクトまたはコマンドを選択してください
            GetLanguage = "ja"
        Case ExistsKey(St, "объект")
            'ロシア語-Выберите объект или команду
            GetLanguage = "ru"
        Case ExistsKey(St, "象或")
            '中国語-???象或?羅
            GetLanguage = "zh"
        Case Else
            Select Case Len(St)
                Case 13
                    '韓国語-???? ?? ?? ?? unicode未対応の為
                    GetLanguage = "ko"
                Case 23
                    '日本語-日本語版以外のため
                    GetLanguage = "ja"
                Case Else
                    'それ以外
            End Select
    End Select
End Function

'文字列内に指定文字が存在するか?
'大文字小文字は無視
Private Function ExistsKey(ByVal txt As String, ByVal Key As String) As Boolean
    ExistsKey = IIf(InStr(LCase(txt), LCase(Key)) > 0, True, False)
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

'フィルタータイプとして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

'文字型からバリアント配列生成(CATIAの為にすごく無駄・・・)
Private Function ToStrVriAry(ByVal s$) As Variant
    Dim ary As Variant: ary = Split(s, ",")
    Dim vriary() As Variant: ReDim vriary(UBound(ary))
    Dim i&
    For i = 0 To UBound(ary)
        vriary(i) = ary(i)
    Next
    ToStrVriAry = vriary
End Function

'*****システムな関数*****
'Nothing 書き方に統一感が無い為
''' @param:OJ-Variant(Of Object)
''' @return:Boolean
Public Function IsNothing(ByVal Oj As Variant) As Boolean
    IsNothing = Oj Is Nothing
End Function

'Scripting.Dictionary
''' @param:CompareMode-Long
''' @return:Object(Of Dictionary)
Public Function InitDic(Optional CompareMode As Long = vbBinaryCompare) As Object
    Dim Dic As Object
    Set Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = CompareMode
    Set InitDic = Dic
End Function

'ArrayList
''' @return:Object(Of ArrayList)Public
Function InitLst() As Object
    Set InitLst = CreateObject("System.Collections.ArrayList")
End Function

'型チェック
''' @param:OJ-Object
''' @param:T-String
''' @return:Boolean
Public Function IsType_Of_T(ByVal Oj As Object, ByVal T$) As Boolean
    IsType_Of_T = IIf(TypeName(Oj) = T, True, False)
End Function


'*****配列な関数*****
'配列の連結
''' @param:Ary1-Variant(Of Array)
''' @param:Ary2-Variant(Of Array)
''' @return:Variant(Of Array)
Public Function JoinAry(ByVal Ary1 As Variant, ByVal Ary2 As Variant)
    Select Case True
        Case Not IsArray(Ary1) And Not IsArray(Ary2)
            JoinAry = Empty: Exit Function
        Case Not IsArray(Ary1)
            JoinAry = Ary2: Exit Function
        Case Not IsArray(Ary2)
            JoinAry = Ary1: Exit Function
    End Select
    Dim StCount&: StCount = UBound(Ary1)
    ReDim Preserve Ary1(UBound(Ary1) + UBound(Ary2) + 1)
    Dim i&
    If IsObject(Ary2(0)) Then
        For i = StCount + 1 To UBound(Ary1)
            Set Ary1(i) = Ary2(i - StCount - 1)
        Next
    Else
        For i = StCount + 1 To UBound(Ary1)
            Ary1(i) = Ary2(i - StCount - 1)
        Next
    End If
    JoinAry = Ary1
End Function

'配列の抽出
''' @param:Ary-Variant(Of Array)
''' @param:StartIdx-Long
''' @param:EndIdx-Long
''' @return:Variant(Of Array)
Public Function GetRangeAry(ByVal ary As Variant, ByVal StartIdx&, ByVal EndIdx&) As Variant
    If Not IsArray(ary) Then Exit Function
    If EndIdx - StartIdx < 0 Then Exit Function
    If StartIdx < 0 Then Exit Function
    If EndIdx > UBound(ary) Then Exit Function
    
    Dim RngAry() As Variant: ReDim RngAry(EndIdx - StartIdx)
    Dim i&
    For i = StartIdx To EndIdx
        RngAry(i - StartIdx) = ary(i)
    Next
    GetRangeAry = RngAry
End Function

'配列のクローン
''' @param:Ary-Variant(Of Array)
''' @return:Variant(Of Array)
Public Function CloneAry(ByVal ary As Variant) As Variant
    If Not IsArray(ary) Then Exit Function
    CloneAry = GetRangeAry(ary, 0, UBound(ary))
End Function

'配列の値が一致するか?
''' @param:Ary1-Variant(Of Array)
''' @param:Ary2-Variant(Of Array)
''' @return:Boolean
Public Function IsAryEqual(ByVal Ary1 As Variant, ByVal Ary2 As Variant) As Boolean
    IsAryEqual = False
    If Not IsArray(Ary1) Or Not IsArray(Ary2) Then Exit Function
    If Not UBound(Ary1) = UBound(Ary2) Then Exit Function
    Dim i&
    For i = 0 To UBound(Ary1)
        If Not Ary1(i) = Ary2(i) Then Exit Function
    Next
    IsAryEqual = True
End Function


'*****IOな関数*****
'FileSystemObject
''' @return:Object(Of FileSystemObject)
Public 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)
Public 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:ファイルパス
Public 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
Public 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:新たなファイルパス
Public 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
Public Sub WriteFile(ByVal Path$, ByVal txt) '$)
    Call GetFSO.OpenTextFile(Path, 2, True).Write(txt)
End Sub

'ファイル読み込み
''' @param:Path-ファイルパス
''' @return:Variant(Of Array(Of String))
Public Function ReadFile(ByVal Path$) As Variant
    With GetFSO.GetFile(Path).OpenAsTextStream
        ReadFile = Split(.ReadAll, vbNewLine)
        .Close
    End With
End Function


'*****ストップウォッチな関数*****
'時間計測スタート
Public Sub SW_Start()
    mSW = timeGetTime
End Sub

'計測取得
''' @return:Double(Unit:s)
Public Function SW_GetTime#()
    SW_GetTime = IIf(mSW = 0, -1, (timeGetTime - mSW) * 0.001)
End Function

Ver0.05-ストップウォッチな関数追加
Ver0.06-SelectItem関数でキャンセル時、IIfではエラーになるのを修正
Ver0.07-SelectItem/SelectElement関数のフィルタ指定を緩和
-CanExecute関数を追加
Ver0.08-CloneAry関数バグ修正
Ver0.09-JoinPathName関数バグ修正
Ver0.0.10-VBA7(64bit)対応
Ver0.0.11-CanExecute関数 ちょっと強化
Ver0.0.12-InitDicにCompareModeオプション追加
     InitLst(DotNet-ArrayList)追加