C#ATIA

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

ファイル間リンクの取得9

こちらの続きです。
ファイル間リンクの取得8 - C#ATIA

ここがゴールでは無いのですが、ファイル間リンク情報をVBAで取得出来るようになりました。
こちらは、リンク情報を取得するだけのものです。
WinAPIを利用している為、標準モジュールで作成してください。

'vba GetLinksInfo.bas ver0.0.2  by Kantoku
'これ自体はKCLには依存していません
'リンクダイアログのテーブルを配列として取得

'ver0.0.1:完成 日本語と英語のみ対応
'ver0.0.2:言語判定精度改善,64bitチェック追加

Option Explicit

'--- win api ---
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

'--
Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" ( _
    ByVal hwnd As LongPtr, _
    ByVal lpClassName As String, _
    ByVal nMaxCount As Long) _
    As Long

'--
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageW" ( _
    ByVal hwnd As LongPtr, _
    ByVal msg As Long, _
    ByVal wParam As Long, _
    ByVal lParam As Any _
    ) As Long

Private Declare PtrSafe Function SendMessageStr Lib "user32" Alias "SendMessageW" ( _
    ByVal hwnd As LongPtr, _
    ByVal wMsg As Long, _
    ByVal wParam As Long, _
    ByVal lParam As String) _
    As Long

Private Declare PtrSafe Function SendMessageAny Lib "user32" Alias "SendMessageW" ( _
    ByVal hwnd As LongPtr, _
    ByVal wMsg As Long, _
    ByVal wParam As Long, _
    lParam As Any) _
    As Long

Private Const WM_GETTEXT = &HD
Private Const HDM_GETITEMCOUNT = (&H1200 + 0)
Private Const WM_CLOSE = &H10

Private Const LVM_FIRST As Long = &H1000
Private Const LVM_GETITEMCOUNT = (LVM_FIRST + 4)
Private Const LVM_GETITEM As Long = (LVM_FIRST + 5)
Private Const LVM_GETHEADER = (LVM_FIRST + 31)
Private Const LVM_SETITEMSTATE = (LVM_FIRST + 43)
Private Const LVM_GETITEMSTATE = (LVM_FIRST + 44)
Private Const LVM_GETITEMTEXT = LVM_FIRST + 45

'--
Private Declare PtrSafe Function EnumChildWindows Lib "user32" ( _
    ByVal hWndParent As LongPtr, _
    ByVal lpEnumFunc As LongPtr, _
    ByVal lParam As Long) _
    As Long
    
Private Declare PtrSafe Function ShowWindow Lib "user32" ( _
    ByVal hwnd As LongPtr, _
    ByVal nCmdShow As Long) _
    As Long
Private Const SW_HIDE = 0
Private Const SW_SHOW = 5
    
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" ( _
    ByVal lpClassName As String, _
    ByVal lpWindowName As String) _
    As LongPtr

Private Declare PtrSafe Function GetWindow Lib "user32" ( _
    ByVal hwnd As LongPtr, _
    ByVal wCmd As Long) _
    As LongPtr
Private Const GW_HWNDNEXT = 2

Private Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" ( _
    ByVal hwnd As LongPtr, _
    ByVal lpString As String, _
    ByVal cch As Long) _
    As Long

Private Declare PtrSafe Function GetForegroundWindow Lib "user32" () _
    As LongPtr
    
'--
Private Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" ( _
    ByVal hwnd As LongPtr, _
    lpdwProcessId As Long) _
    As Long

'--
Private Declare PtrSafe Function OpenProcess Lib "kernel32" ( _
    ByVal dwDesiredAccess As Long, _
    ByVal bInheritHandle As Long, _
    ByVal dwProcessId As Long) _
    As LongPtr
    
Private Const PROCESS_VM_OPERATION = &H8
Private Const PROCESS_VM_READ = &H10
Private Const PROCESS_VM_WRITE = &H20

'--
Private Declare PtrSafe Function VirtualAllocEx Lib "kernel32" ( _
    ByVal hProcess As LongPtr, _
    ByVal lpAddress As Long, _
    ByVal dwSize As Long, _
    ByVal flAllocationType As Long, _
    ByVal flProtect As Long) _
    As LongPtr
    
Private Declare PtrSafe Function VirtualFreeEx Lib "kernel32" ( _
    ByVal hProcess As LongPtr, _
    lpAddress As Any, _
    ByVal dwSize As Long, _
    ByVal dwFreeType As Long) _
    As LongPtr
    
Private Const PAGE_READWRITE = &H4&

Private Const MEM_RESERVE = &H2000
Private Const MEM_COMMIT = &H1000
Private Const MEM_RELEASE = &H8000

'--
Private Declare PtrSafe Function CloseHandle Lib "kernel32" ( _
    ByVal hObject As LongPtr) _
    As Long

Private Declare PtrSafe Function ReadProcessMemory Lib "kernel32" ( _
    ByVal hProcess As LongPtr, _
    lpBaseAddress As Any, _
    lpBuffer As Any, _
    ByVal nSize As LongPtr, _
    lpNumberOfBytesWritten As LongPtr) _
    As Long

Private Declare PtrSafe Function WriteProcessMemory Lib "kernel32" ( _
    ByVal hProcess As LongPtr, _
    lpBaseAddress As Any, _
    lpBuffer As Any, _
    ByVal nSize As LongPtr, _
    lpNumberOfBytesWritten As LongPtr) _
    As Long

'-- リストビュー用 構造体
Private Type LVITEM
    mask As Long
    iItem As Long
    iSubitem As Long
    state As Long
    stateMask As Long
    pszText As LongPtr
    cchTextMax As Long
    iImage As Long
    lParam As LongPtr
    iIndent As Long
End Type
Private Const LVIF_TEXT = &H1

'--
Private mLst_hwnd As LongPtr 'リンクダイアログ内リストビューハンドル
Private mLstCount As Long 'リンクダイアログ内リストビュー検索用

'言語別コマンド,ダイアログ文字列
'return:ary (0)-コマンド (1)-未選択時のダイアログ名称 (2)-選択時のダイアログ名称
Private Function GetCommandKey() _
    As Variant
    
    Dim ary As Variant
    Select Case GetLanguage
        Case "en"
            ary = Array("Links...", "Links of document", "Links of element")
        Case "ja"
            ary = Array("リンク...", "ドキュメントのリンク", "エレメントのリンク")
        Case Else
            ary = Array()
    End Select
    
    GetCommandKey = ary
End Function


'リンクダイアログのテーブルを配列として取得
Function GetInfo() _
    As Variant
    
    '64bit check
    #If VBA7 And Win64 Then
        'ok
    #Else
        msg = "VBA環境が VBA7 & Win64 では無い為" & vbCrLf & _
            "正しく処理正しく処理出来ません!" & vbCrLf & _
            "中止します"
        MsgBox msg, vbExclamation
        Exit Function
    #End If
    
    '初期化
    GetInfo = Array()
    mLstCount = 0
    Dim msg As String
    
    Dim cmdkey As Variant
    cmdkey = GetCommandKey()
    If UBound(cmdkey) < 1 Then
        msg = "CATIAの言語判定が出来ない" & vbCrLf & _
            "又は、未対応の言語設定です"
        MsgBox msg, vbExclamation
        Exit Function
    End If
    
    Dim dlgkey As String
    If CATIA.ActiveDocument.Selection.Count2 < 1 Then
        dlgkey = cmdkey(1)
    Else
        dlgkey = cmdkey(2)
    End If
    
    'コマンド実行
    CATIA.StartCommand CStr(cmdkey(0))
    CATIA.RefreshDisplay = True
    
    'リンクダイアログ取得
    Dim hwnd As LongPtr 'リンクダイアログハンドル
    hwnd = FindWindowLike(dlgkey)
    ShowWindow hwnd, SW_HIDE
    If hwnd < 1 Then Exit Function
    
    'リンクダイアログ内のリストビュー(SysListView32)ハンドル取得
    Sleep 100
    Call EnumChildWindows(hwnd, AddressOf CallBack_FindChildWindow, 0)
    If mLst_hwnd < 1 Then Exit Function
    
    'Row数
    Dim rows As Long
    rows = SendMessageStr(mLst_hwnd, LVM_GETITEMCOUNT, 0, 0)
    
    'リストビューヘッダーのハンドル取得 : Column数取得に必要
    Dim h_hwnd As Long
    h_hwnd = SendMessageStr(mLst_hwnd, LVM_GETHEADER, 0, 0)

    'Column数
    Dim cols As Long
    cols = SendMessageStr(h_hwnd, HDM_GETITEMCOUNT, 0, 0)
    If rows < 1 Then Exit Function
    
    
    'セル値取得
    Dim infos() As Variant
    ReDim infos(rows - 1)
    
    Dim info() As String
    Dim r As Long, c As Long
    For r = 0 To rows - 1
        ReDim info(cols - 1)
        For c = 0 To cols - 1
            info(c) = GetCellValue(mLst_hwnd, r, c)
        Next
        infos(r) = info
    Next
        
    'リンクダイアログ閉じる
    ShowWindow hwnd, SW_SHOW
    Call SendMessage(hwnd, WM_CLOSE, 0, ByVal 0&)
    
    GetInfo = infos
    'MsgBox UBound(infos)
    
End Function

'セル値取得
Private Function GetCellValue( _
    ByVal hwnd As LongPtr, _
    ByVal row As Long, _
    ByVal clm As Long) _
    As String
    
    'プロセスID
    Dim prcId As Long
    Call GetWindowThreadProcessId(hwnd, prcId)
    If prcId = 0 Then
        Debug.Print "プロセスID NG"
        Exit Function
    End If
    
    'プロセスハンドル
    Dim prcHwnd As LongPtr
    prcHwnd = OpenProcess(PROCESS_VM_OPERATION Or _
                          PROCESS_VM_READ Or _
                          PROCESS_VM_WRITE, _
                          False, _
                          prcId)
    If prcHwnd = 0 Then
        Debug.Print "プロセスハンドル NG"
        Exit Function
    End If
    
    '書き出し準備
    Dim txtVi As String
    txtVi = String(255, vbNullChar)
    'txtVi = Space$(255)
    Dim txtViPtr As LongPtr
    txtViPtr = StrPtr(txtVi)
    
    Dim txtViSiz As LongPtr
    txtViSiz = LenB(txtVi)
    
    Dim txtViAlc As LongPtr
    txtViAlc = VirtualAllocEx(prcHwnd, _
                              0&, _
                              txtViSiz, _
                              MEM_RESERVE Or MEM_COMMIT, _
                              PAGE_READWRITE)
    
    Dim typLstItm As LVITEM
    
    Dim typViPtr As LongPtr
    typViPtr = VarPtr(typLstItm)
    
    Dim typViSiz As LongPtr
    typViSiz = LenB(typLstItm)
    
    Dim typViAlc As LongPtr
    typViAlc = VirtualAllocEx(prcHwnd, _
                              0&, _
                              typViSiz, _
                              MEM_RESERVE Or MEM_COMMIT, _
                              PAGE_READWRITE)
    
    With typLstItm
        .cchTextMax = 255
        .iItem = row
        .iSubitem = clm
        .mask = LVIF_TEXT
        .pszText = txtViAlc
    End With
    
    '書き出し
    Call WriteProcessMemory(prcHwnd, _
                            ByVal txtViAlc, _
                            ByVal txtViPtr, _
                            txtViSiz, _
                            0)
                            
    Call WriteProcessMemory(prcHwnd, _
                            ByVal typViAlc, _
                            ByVal typViPtr, _
                            typViSiz, _
                            0)
                            
    Call SendMessageAny(hwnd, _
                        LVM_GETITEM, _
                        ByVal 0, _
                        ByVal typViAlc)
    'ここ
    Call ReadProcessMemory(prcHwnd, _
                           ByVal txtViAlc, _
                           ByVal txtViPtr, _
                           txtViSiz, _
                           0)
    
    '値取得
    'vbFromUnicode
    'txtVi = StrConv(txtVi, vbUnicode, 1041)
    txtVi = StrConv(txtVi, vbUnicode)
    'txtVi = StrConv(txtVi, vbWide)
    GetCellValue = Left(txtVi, InStr(1, txtVi, vbNullChar) - 1)
    
    'プロセス終了
    Call VirtualFreeEx(prcHwnd, _
                       ByVal txtViAlc, _
                       txtViSiz, _
                       MEM_RELEASE)
                       
    Call VirtualFreeEx(prcHwnd, _
                       ByVal typViAlc, _
                       typViSiz, _
                       MEM_RELEASE)
                       
    Call CloseHandle(prcHwnd)
            
End Function

'ダイアログ内リストビュ-
Private Function CallBack_FindChildWindow( _
    ByVal hwnd As LongPtr, _
    ByVal prm As Long) _
    As Long

    Dim cls As String
    cls = String(255, vbNullChar)
    
    Dim cnt As Long
    cnt = GetClassName(hwnd, cls, 63&)
    cls = Left(cls, cnt)
    
    If cls = "SysListView32" Then
        mLstCount = mLstCount + 1
        If mLstCount > 1 Then '2個目のリストビュー
            mLst_hwnd = hwnd
            CallBack_FindChildWindow = 0
            Exit Function
        End If
    End If
    CallBack_FindChildWindow = 1 '終了サイン
    
End Function

'指定文字を含んだWindow取得
Private Function FindWindowLike( _
    key As String) _
    As LongPtr
    
    Dim hwnd As LongPtr
    Dim winTxt As String
    Dim cnt As Integer
    hwnd = GetForegroundWindow
    
    Do Until hwnd = 0
        winTxt = String(255, vbNullChar)
        cnt = GetWindowText(hwnd, winTxt, 255)
        winTxt = Left(winTxt, cnt)
        
        If InStr(1, LCase(winTxt), LCase(key)) > 0 Then Exit Do
        hwnd = GetWindow(hwnd, GW_HWNDNEXT)
    Loop
    FindWindowLike = hwnd
    
End Function

'言語判定
Private Function GetSelectedItems() _
    As Collection
    
    Dim sel As Selection
    Set sel = CATIA.ActiveDocument.Selection
    
    Dim lst As Collection
    Set lst = New Collection
    
    Dim i As Long
    For i = 1 To sel.Count2
        lst.Add sel.Item2(i).Value
    Next
    
    Set GetSelectedItems = lst
    
End Function

Private Sub SetSelectItems( _
    ByVal lst As Collection)
    
    If lst.count < 1 Then Exit Sub
    
    Dim sel As Selection
    Set sel = CATIA.ActiveDocument.Selection
    
    CATIA.HSOSynchronized = False
    
    Dim elm As AnyObject
    For Each elm In lst
        sel.Add elm
    Next
    
    CATIA.HSOSynchronized = True
    
End Sub


'言語判定
Private Function GetLanguage() _
    As String
    
    GetLanguage = "non"
    If CATIA.Windows.count < 1 Then Exit Function
    
    GetLanguage = "other"
    
    Dim lst As Collection
    Set lst = GetSelectedItems()
    
    CATIA.ActiveDocument.Selection.Clear
    SendKeys "{ESC}"
    Sleep 100
    SendKeys "{ESC}"
    CATIA.RefreshDisplay = True
    
    Dim st As String
    st = CATIA.StatusBar
    
    Select Case True
        Case ExistsKey(st, "object")
            GetLanguage = "en"
        Case ExistsKey(st, "objet")
            GetLanguage = "fr"
        Case ExistsKey(st, "Objekt")
            GetLanguage = "de"
        Case ExistsKey(st, "oggetto")
            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
                    GetLanguage = "ko"
                Case 23
                    GetLanguage = "ja"
                Case Else
                
            End Select
    End Select
    
    Call SetSelectItems(lst)
    
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

WinAPIがグリグリゴリゴリで吐き気がしそうなやつです。
”もうちょっとこうしたら効率が良いんじゃないの?”
と言うご意見があれば教えて頂けると助かります。
(動いたからもう見たくない)

GetInfo関数を呼び出すと、アクティブなドキュメントのリンク情報を配列で
受け取れます。
f:id:kandennti:20190227181810p:plain
戻り値の配列の状態は
array(赤側のインデックス)(緑側のインデックス)
で全てString型です。(緑側は0~9の10個固定になるはず)

StartCommandを利用している為、CATIAの言語に依存されますが、
一応、日本語、英語は対応させています。日本語のみ確認しています。
日本語、英語は対応させています。但し、VBA7、WIN64が条件です。
こちらを参照してください。(当方OS:Win7 64bit Catia V5-6 R2015)
ファイル間リンクの取得10 - C#ATIA
(他言語は要望があれば追加しますが、面倒です)

又、C#時にはドキュメント全体のリンク情報しか取得できませんでしたが、
VBA版はオブジェクトを選択した状態でGetInfo関数を呼び出すと、
そのオブジェクトのリンク情報のみを取得出来るようにしています。
(感覚的に手動時と同じ挙動の方が自然ですよね?)


こちらは上記の利用したサンプルです。

'vba sample_GetLinksInfo
'using-'KCL0.0.13','GetLinksInfo'  by Kantoku

'GetLinksInfoを使ったサンプルです
'手動同様に何も選択していなければアクティブなDocumentの全リンク情報
'選択していれば、選択しているものだけのリンク情報を
'ファイルと同一のフォルダにCSVファイルで出力します


Sub CATMain()

    Dim msg As String
    
    'ドキュメントのチェック
    Dim filter As String
    filter = "DrawingDocument,PartDocument,ProductDocument"
    If Not CanExecute(filter) Then Exit Sub
    
    'Doc
    Dim doc As Document
    Set doc = CATIA.ActiveDocument
    
    '出力パス
    Dim path As String
    path = doc.FullName
    If InStr(1, path, "\") < 1 Then
        msg = "出力パスが確定しない為、一度保存してください!"
        MsgBox msg, vbExclamation
        Exit Sub
    End If
    
    Dim dmy As Variant
    dmy = KCL.SplitPathName(path)
    dmy(1) = dmy(1) & "_LinksInfo"
    dmy(2) = "csv"
    
    Dim exp As String
    exp = KCL.GetNewName(KCL.JoinPathName(dmy))
    
    '確認
    msg = "リンク情報を出力しますか?"
    If MsgBox(msg, vbQuestion + vbYesNo) = vbNo Then Exit Sub
    
    Dim infos As Variant
    infos = GetLinksInfo.GetInfo()
    
    If UBound(infos) < 1 Then
        msg = "外部リンクが無い、又は正常に取得できませんでした!"
        MsgBox msg, vbExclamation
        Exit Sub
    End If
    
    '書き出し
    Call KCL.WriteFile(exp, Info2Str(infos))
    
    '終わり
    MsgBox "done"
    
End Sub

Private Function Info2Str( _
    ary As Variant)
    
    Dim ex() As Variant
    ReDim ex(UBound(ary))
    
    Dim i As Long
    For i = 0 To UBound(ary)
        ex(i) = Join(ary(i), ",")
    Next
    
    Info2Str = Join(ex, vbCrLf)
    
End Function

DrawingDocument,PartDocument,ProductDocument問わず、
アクティブなドキュメントと同じフォルダ内に、リンク情報の
CSVファイルを作成します。
選択時、未選択時で出力される内容が変わることが確認出来ると
思います。

もうちょっとで届きそう!

※Ver0.0.2にしました。言語判定精度改善,64bitチェック追加