こちらの続きです。
ファイル間リンクの取得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関数を呼び出すと、アクティブなドキュメントのリンク情報を配列で
受け取れます。
戻り値の配列の状態は
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チェック追加