Windows10のデスクトップアイコンのファイル名の取得方法について

Question

前提・実現したいこと

Windowsのデスクトップアイコンの位置とファイル名を取得するマクロを作成しています。

発生している問題・エラーメッセージ

Windows7ではうまく動いたのですが、Windows10ではファイル名が取得できません。(ブランクになってしまう)

該当のソースコード

Option Explicit

'ウィンドウ検索
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
            (ByVal lpClassName As String, _
             ByVal lpWindowName As String) As Long

'ウィンドウ取得
Private Declare Function GetWindow Lib "user32" _
            (ByVal hwnd As Long, _
             ByVal uCmd As Long) As Long

'ウィンドウへのメッセージ送付
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
            (ByVal hwnd As Long, _
             ByVal wMsg As Long, _
             ByVal wParam As Long, _
             ByVal lParam As Any) As Long

'ウィンドウのプロセスIDとスレッドIDを取得
Private Declare Function GetWindowThreadProcessId Lib "user32" _
            (ByVal hwnd As Long, _
             lpdwProcessId As Long) As Long
 
'プロセスOpen
Private Declare Function OpenProcess Lib "kernel32" _
            (ByVal dwDesiredAccess As Long, _
             ByVal bInheritHandle As Long, _
             ByVal dwProcessId As Long) As Long

'仮想メモリ確保
Private Declare Function VirtualAllocEx Lib "kernel32" _
            (ByVal hProcess As Long, _
             ByVal lpAddress As Long, _
             ByVal dwSize As Long, _
             ByVal flAllocationType As Long, _
             ByVal flProtect As Long) As Long

'仮想メモリ解放
Private Declare Function VirtualFreeEx Lib "kernel32" _
            (ByVal hProcess As Long, _
             lpAddress As Any, _
             ByVal dwSize As Long, _
             ByVal dwFreeType As Long) As Long
             
'ハンドルクローズ
Private Declare Function CloseHandle Lib "kernel32" _
            (ByVal hObject As Long) As Long
 
'ウィンドウ位置・サイズ取得
Private Declare Function GetWindowRect Lib "user32" _
            (ByVal hwnd As Long, _
             lpRect As RECT) As Long

'メモリへの書込み
Private Declare Function WriteProcessMemory Lib "kernel32" _
            (ByVal hProcess As Long, _
             lpBaseAddress As Any, _
             lpBuffer As Any, _
             ByVal nSize As Long, _
             lpNumberOfBytesWritten As Long) As Long
 
'メモリからの読込み
Private Declare Function ReadProcessMemory Lib "kernel32" _
            (ByVal hProcess As Long, _
             lpBaseAddress As Any, _
             lpBuffer As Any, _
             ByVal nSize As Long, _
            lpNumberOfBytesWritten As Long) As Long

'==============
' ユーザ定義型
'==============

'リストビューアイテム構造体
Private Type LV_ITEM
    mask As Long
    iItem As Long
    iSubItem As Long
    state As Long
    stateMask As Long
    lpszText As Long
    cchTextMax As Long
    iImage As Long
    lParam As Long
    iIndent As Long
End Type

'データエリア構造体
Type LV_TEXT
    sItemText As String * 80
End Type

'サイズ・位置情報構造体
Public Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type


'==========
' 定数定義
'==========

Private Const LVM_GETITEMCOUNT As Long = &H1004
Private Const LVM_GETITEM As Long = &H1005
Private Const LVM_GETITEMRECT As Long = &H100E
Private Const LVM_SETITEMPOSITION As Long = &H100F
Private Const LVM_SETEXTENDEDLISTVIEWSTYLE = &H1036
Private Const LVM_GETEXTENDEDLISTVIEWSTYLE = &H1037

Private Const LVS_EX_SNAPTOGRID = &H80000

Private Const GW_CHILD As Long = 5
 
Private Const LVIR_BOUNDS As Long = 0
Private Const LVIR_ICON As Long = 1
Private Const LVIR_LABEL As Long = 2
Private Const LVIR_SELECTBOUNDS As Long = 3
 
Private Const LVIF_TEXT = &H1

Private Const PROCESS_VM_OPERATION = &H8
Private Const PROCESS_VM_READ = &H10
Private Const PROCESS_VM_WRITE = &H20
 
Private Const MEM_COMMIT = &H1000
Private Const MEM_RESERVE = &H2000
Private Const MEM_DECOMMIT = &H4000
Private Const MEM_RELEASE = &H8000
 
Private Const PAGE_READWRITE = &H4&


'共有メモリ確保
Public Function GetSharedMem(ByVal pid As Long, ByVal memSize As Long, hProc As Long) As Long
    hProc = OpenProcess(PROCESS_VM_OPERATION Or PROCESS_VM_READ Or PROCESS_VM_WRITE, False, pid)
    GetSharedMem = VirtualAllocEx(ByVal hProc, ByVal 0&, ByVal memSize, MEM_RESERVE Or MEM_COMMIT, PAGE_READWRITE)
End Function
 
'共有メモリ開放
Public Sub FreeSharedMem(ByVal hProc As Long, ByVal MemAddress As Long, ByVal memSize As Long)
   Call VirtualFreeEx(hProc, ByVal MemAddress, memSize, MEM_RELEASE)
   CloseHandle hProc
End Sub


Sub get_icon_pos_name()
    
    '変数定義
    Dim lngTopWindow As Long        'Topウィンドウのウィンドウハンドル
    Dim lngChildWindow As Long      '子ウィンドウのウィンドウハンドル
    Dim lngSysListView32 As Long    'デスクトップのウィンドウハンドル
    Dim rc As RECT                  '位置・サイズ格納用
    
    Dim pid As Long                 'プロセスID
    Dim tid As Long                 'スレッドID
    Dim hProc As Long               'プロセスハンドル
    Dim li As LV_ITEM               'パラメータ
    Dim lt As LV_TEXT               'テキストエリア
    Dim lpShared1 As Long           'パラメータエリア
    Dim lpShared2 As Long           'データエリア
    Dim lpShared3 As Long           '位置
    Dim lWritten As Long            '書込済バイト数
    Dim lngRC As Long               '処理結果格納用
    Dim maxitem As Long             'デスクトップのアイコン数
    Dim i As Long                   'ループカウンタ
    Dim p As Long                   'テキスト終端文字列の位置
    Dim iconName As String          'アイコンの名前
    Dim NetObj As Object            'NetworkObject
    Dim strCompName As String       'コンピュータ名
    
    'ExplorerのTopウィンドウを見つける
    lngTopWindow = FindWindow("Progman", "Program Manager")
    
    'Topウィンドウが見つかった時
    If lngTopWindow Then
    
        '子ウィンドウを取得
        lngChildWindow = GetWindow(lngTopWindow, GW_CHILD)
        
        '子ウィンドウが取得できたとき
        If lngChildWindow Then
        
            'さらにその子ウィンドウを取得(これがデスクトップ)
            lngSysListView32 = GetWindow(lngChildWindow, GW_CHILD)
            
            'デスクトップのウィンドウが取得できたとき
            If lngSysListView32 Then
                    
                'デスクトップサイズの取得
                GetWindowRect lngSysListView32, rc
                
                
                'デスクトップアイコンの数を取得
                maxitem = SendMessage(lngSysListView32, _
                                      LVM_GETITEMCOUNT, _
                                      0&, _
                                      ByVal 0&)
                
                'コンピュータ名を取得
                Set NetObj = CreateObject("WScript.Network")
                strCompName = NetObj.ComputerName
                Set NetObj = Nothing
                
                'デスクトップのプロセスIDとスレッドIDを取得
                tid = GetWindowThreadProcessId(lngSysListView32, pid)
                 
                'デスクトップとの共有メモリを確保(アドレスが返ってくる)
                lpShared1 = GetSharedMem(pid, LenB(li), hProc)  'リストビュー構造体
                lpShared2 = GetSharedMem(pid, LenB(lt), hProc)  '取得文字列用
                lpShared3 = GetSharedMem(pid, LenB(rc), hProc)  'アイコン位置用
                
                
                'デスクトップのアイコン数分ループする
                For i = 0 To maxitem - 1
                
                    'LVM_GETITEMへSendMessageする際のパラメータを設定
                    li.mask = LVIF_TEXT         '文字情報取得
                    li.iItem = i                '行インデックス
                    li.iSubItem = 0             '列インデックス
                    li.lpszText = lpShared2     '文字格納アドレス
                    li.cchTextMax = LenB(lt)    '文字数最大値
                    
                    'ローカル変数の値を共有メモリに書き込み
                    lngRC = WriteProcessMemory(hProc, ByVal lpShared1, li, LenB(li), lWritten)
                    lngRC = WriteProcessMemory(hProc, ByVal lpShared2, lt, LenB(lt), lWritten)
                    
                    'デスクトップに対して情報の取得依頼(ファイル名)
                    lngRC = SendMessage(lngSysListView32, LVM_GETITEM, 0, ByVal lpShared1)
                    
                    '共有メモリからローカル変数に読み込み
                    lngRC = ReadProcessMemory(hProc, ByVal lpShared2, lt, LenB(lt), lWritten)
                    
                    'アイコン名を初期化
                    iconName = ""
                    
                    '文字数を取得(終端文字がNullCharなのでその前まで)
                    p = InStr(lt.sItemText, vbNullChar) - 1
                    
                    '空っぽでなければ
                    If p > 0 Then
                    
                        'アイコン名を取得
                        iconName = Left(lt.sItemText, p)
                    
                    End If
                    
                    'LVM_GETITEMRECTへSendMessageする際のパラメータを設定
                    rc.Left = LVIR_ICON     'アイコンの外接する四角形サイズ取得
                    
                    'ローカル変数の値を共有メモリに書き込み
                    lngRC = WriteProcessMemory(hProc, ByVal lpShared3, rc, LenB(rc), lWritten) '書込み
                    
                    'デスクトップに対して情報の取得依頼(アイコン位置)
                    lngRC = SendMessage(lngSysListView32, LVM_GETITEMRECT, i, ByVal lpShared3) '取得依頼
                    
                    '共有メモリからローカル変数に読み込み
                    lngRC = ReadProcessMemory(hProc, ByVal lpShared3, rc, LenB(rc), lWritten)  '読込
                    
                    Debug.Print "No.     :" & i
                    Debug.Print "TOP     :" & rc.Top
                    Debug.Print "LEFT    :" & rc.Left
                    Debug.Print "RIGHT   :" & rc.Right
                    Debug.Print "BOTTOM  :" & rc.Bottom
                    Debug.Print "iconName:" & iconName
                    
                Next
                
                '共有メモリ開放
                FreeSharedMem hProc, lpShared1, LenB(li)
                FreeSharedMem hProc, lpShared2, LenB(lt)
                FreeSharedMem hProc, lpShared3, LenB(rc)
            
            End If
        End If
    End If
End Sub

試したこと

共有メモリの使い方等、色々調べてみたのですが、原因が分からないので質問させていただきました。

補足情報（FW/ツールのバージョンなど）

Excel 2010 VBA

Answer 1

うまく動かなかった Windows 10 環境は 64 ビットではないでしょうか？
その場合、構造体のアライメントの問題で提示されているコードは正しく動作しません。
下記のようにアライメントを 64 ビットに合わせるためにフィールドを追加する必要があります。

Private Type LV_ITEM
    mask As Long
    iItem As Long
    iSubItem As Long
    state As Long
    stateMask As Long
    dummy1 As Long
    lpszText As Long
    dummy2 As Long
    cchTextMax As Long
    iImage As Long
    lParam As Long
    iIndent As Long
End Type

上記の変更を実施すると 32 ビット環境では動作しなくなります。両方の環境で動作させるためには構造体の定義をそれぞれ持つことになります。

また、デスクトップのリストビューのウィンドウハンドルが取れていないのであれば、ウィンドウハンドルを取得する方法を変更する必要があります。Windows 7 以降ではデスクトップの親ウィンドウのクラス名が Progman ではないことがあります。そのため以下に示すようにウィンドウのクラス名が WorkerW のウィンドウを検索する必要があります。

'ウィンドウ検索Ex
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
            (ByVal hwndParent As Long, _
             ByVal hwndChildAfter As Long, _
             ByVal lpClassName As String, _
             ByVal lpWindowName As String) As Long

Function FindDesktopListView(ByVal topWindowClassName As String) As Long

    Dim lngTopWindow As Long
    Dim lngChildWindow As Long

    lngTopWindow = FindWindowEx(0, 0, topWindowClassName, vbNullString)
    Do
        lngChildWindow = FindWindowEx(lngTopWindow, 0, "SHELLDLL_DefView", vbNullString)
        If lngChildWindow <> 0 Then
            FindDesktopListView = FindWindowEx(lngChildWindow, 0, vbNullString, vbNullString)
            Exit Function
        End If
        lngTopWindow = FindWindowEx(0, lngTopWindow, topWindowClassName, vbNullString)
    Loop While lngTopWindow <> 0
   
End Function

Sub get_icon_pos_name()
    ．．．

    lngSysListView32 = FindDesktopListView("Progman")
    If lngSysListView32 = 0 Then
        lngSysListView32 = FindDesktopListView("WorkerW")
    End If

上記以外ではメモリおよびハンドルが解放できていない問題があります。VirtualFreeEx に MEM_RELEASE を指定する場合、解放するメモリのサイズを指定してはなりません。その場合、パラメータ違反で解放が失敗します。また、OpenProcess と CloseHandle は全体処理で1回のみ実行すれば良く現在のコードでは正しくハンドルが解放できていません。GetSharedMem と FreeSharedMem は以下のようにハンドルの取得と解放を行わないように修正し、OpenProcess と CloseHandle の呼び出しは GetSharedMem 前に OpenProcess を1回だけ呼び出し、すべての FreeSharedMem が終了した後で CloseHandle を呼び出すようにしましょう。

Public Function GetSharedMem(ByVal hProc As Long, ByVal memSize As Long) As Long
    GetSharedMem = VirtualAllocEx(ByVal hProc, ByVal 0&, ByVal memSize, MEM_RESERVE Or MEM_COMMIT, PAGE_READWRITE)
End Function

Public Sub FreeSharedMem(ByVal hProc As Long, ByVal MemAddress As Long)
   Call VirtualFreeEx(hProc, ByVal MemAddress, 0, MEM_RELEASE)
End Sub

Comments

[Markn]

アライメントを修正したら、アイコン名が取得できるようになりました。Windows10の環境が64bit版だったからなんですね。
親ウィンドウのクラス名の取得方法やメモリやハンドルの解放等、まだまだ知識不足のところがあり、大変勉強になりました。
ありがとうございました。