こちらの続きです。
ﾌｧｲﾙ間ﾘﾝｸの取得8 - C#ATIA
ここがゴールでは無いのですが、ﾌｧｲﾙ間ﾘﾝｸ情報をVBAで取得出来るようになりました。
こちらは、ﾘﾝｸ情報を取得するだけのものです。
WinAPIを利用している為、標準ﾓｼﾞｭｰﾙで作成してください。
Option Explicit
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
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
#If VBA7 And Win64 Then
#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
Sleep 100
Call EnumChildWindows(hwnd, AddressOf CallBack_FindChildWindow, 0)
If mLst_hwnd < 1 Then Exit Function
Dim rows As Long
rows = SendMessageStr(mLst_hwnd, LVM_GETITEMCOUNT, 0, 0)
Dim h_hwnd As Long
h_hwnd = SendMessageStr(mLst_hwnd, LVM_GETHEADER, 0, 0)
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
End Function
Private Function GetCellValue( _
ByVal hwnd As LongPtr, _
ByVal row As Long, _
ByVal clm As Long) _
As String
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)
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)
txtVi = StrConv(txtVi, vbUnicode)
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
mLst_hwnd = hwnd
CallBack_FindChildWindow = 0
Exit Function
End If
End If
CallBack_FindChildWindow = 1
End Function
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関数を呼び出すと、
そのオブジェクトのリンク情報のみを取得出来るようにしています。
（感覚的に手動時と同じ挙動の方が自然ですよね？）
こちらは上記の利用したｻﾝﾌﾟﾙです。
Sub CATMain()
Dim msg As String
Dim filter As String
filter = "DrawingDocument,PartDocument,ProductDocument"
If Not CanExecute(filter) Then Exit Sub
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ﾁｪｯｸ追加
