Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function ShellExecuteEx Lib "Shell32" (ByRef lpExecInfo As SHELLEXECUTEINFO) As Long
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function CreateWindowEx Lib "user32" Alias "CreateWindowExW" (ByVal dwExStyle As Long, ByVal lpClassName As LongPtr, ByVal lpWindowName As LongPtr, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hwndParent As LongPtr, ByVal hMenu As LongPtr, ByVal hInstance As LongPtr, lpParam As Any) As LongPtr
Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleW" (ByVal lpModuleName As LongPtr) As LongPtr
Private Declare PtrSafe Function DestroyWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function GetParent Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function SetParent Lib "user32" (ByVal hWndChild As LongPtr, ByVal hWndNewParent As LongPtr) As LongPtr
Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageW" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As Long
Private Declare PtrSafe Function AccessibleObjectFromWindow Lib "oleacc.dll" (ByVal hwnd As LongPtr, ByVal dwId As Long, ByVal riid As LongPtr, ppvObject As Any) As Long
Private Declare PtrSafe Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, ByVal lpiid As LongPtr) As LongPtr
Private Declare PtrSafe Function IsWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Sub SetLastError Lib "kernel32.dll" (ByVal dwErrCode As Long)
Private Declare PtrSafe Function GetLastError Lib "kernel32" () As Long
#Else
Private Enum LongPtr
[_]
End Enum
Private Declare Function ShellExecuteEx Lib "Shell32" (ByRef lpExecInfo As SHELLEXECUTEINFO) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExW" (ByVal dwExStyle As Long, ByVal lpClassName As LongPtr, ByVal lpWindowName As LongPtr, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hwndParent As LongPtr, ByVal hMenu As LongPtr, ByVal hInstance As LongPtr, lpParam As Any) As LongPtr
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleW" (ByVal lpModuleName As LongPtr) As LongPtr
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare Function GetParent Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare Function SetParent Lib "user32" (ByVal hWndChild As LongPtr, ByVal hWndNewParent As LongPtr) As LongPtr
Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
Private Declare Function SendMessage Lib "user32" Alias "SendMessageW" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As Long
Private Declare Function AccessibleObjectFromWindow Lib "oleacc.dll" (ByVal hwnd As LongPtr, ByVal dwId As Long, ByVal riid As LongPtr, ppvObject As Any) As Long
Private Declare Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, ByVal lpiid As LongPtr) As LongPtr
Private Declare Function IsWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare Sub SetLastError Lib "kernel32.dll" (ByVal dwErrCode As Long)
Private Declare Function GetLastError Lib "kernel32" () As Long
#End If
Enum ERROR_CODES
ERROR_FILE_NOT_FOUND = 2&
ERROR_PATH_NOT_FOUND = 3&
ERROR_ACCESS_DENIED = 5&
ERROR_NOT_ENOUGH_MEMORY = 8&
ERROR_NO_ASSOC = 31&
ERROR_SHARING_VIOLATION = 32&
ERROR_CANCELLED = 1223&
ERROR_DDE_FAIL = 1156&
End Enum
#If Win64 Then
Private Const NULL_PTR = 0^
#Else
Private Const NULL_PTR = 0&
#End If
Private Type SHELLEXECUTEINFO
cbSize As Long
fMask As Long
hwnd As LongPtr
lpVerb As String
lpFile As String
lpParameters As String
lpDirectory As String
nShow As Long
hInstApp As LongPtr
'Optional fields
lpIDList As LongPtr
lpClass As String
hkeyClass As LongPtr
dwHotKey As Long
hIcon As LongPtr
hProcess As LongPtr
End Type
Private bProcessing As Boolean
'\\ Note: The code in this vba project uses the accessibility library therefore, it is language dependent.
'So, for languages other than standard english, the code will need some slight tweaking.
Public Function GetExtendedFileProperty(ByVal FilePathName As String, ByVal PropertyName As String) As String
If IsWindow(GetProp(Application.hwnd, "Hidden")) Or bProcessing = False Then
Call DestroyWindow(GetProp(Application.hwnd, "Hidden"))
End If
If bProcessing Then Exit Function
bProcessing = True
GetExtendedFileProperty = "File not found."
If Len(Dir(FilePathName)) And IsPathFile(FilePathName) Then
GetExtendedFileProperty = ExtendedPropertyFromFile(FilePathName, PropertyName)
End If
bProcessing = False
End Function
' ________________________________________ PRIVATE HELPER SUBS ________________________________________________
Private Function ExtendedPropertyFromFile(ByVal FilePathName As String, ByVal PropertyName As String) As String
Const CHILDID_SELF = 0&, NAVDIR_FIRSTCHILD = 7&
Const WM_SYSCOMMAND = &H112, SC_CLOSE = &HF060&
Dim oAccContextMenu As IAccessible, oAccChild As IAccessible, lChildCount As Long
Dim hwnd As LongPtr, hParent As LongPtr
Dim sFileName As String, bPropertyFound As Boolean
Dim sOutputString As String, sngTimer As Single
ExtendedPropertyFromFile = "Extended Property: [" & PropertyName & "] doesn't exist."
Call DestroyWindow(GetProp(Application.hwnd, "Hidden"))
If InvokeShellContextMenu(FilePathName) Then
sFileName = Split(FilePathName, Application.PathSeparator) _
(UBound(Split(FilePathName, Application.PathSeparator)))
sngTimer = Timer
Application.EnableCancelKey = xlDisabled
On Error Resume Next
Do
'DoEvents
If Timer - sngTimer >= 5! Then GoTo Xit
'Language dependent.
hwnd = FindWindow("#32770", sFileName & " Properties")
hParent = GetParent(hwnd)
Call SetParent(hwnd, GetProp(Application.hwnd, "Hidden"))
Loop Until hwnd
Set oAccContextMenu = HwndToAcc(hwnd)
If Not oAccContextMenu Is Nothing Then
Set oAccChild = oAccContextMenu.accNavigate(NAVDIR_FIRSTCHILD, CHILDID_SELF)
For lChildCount = 0& To 2&
Set oAccChild = oAccChild.accNavigate(NAVDIR_FIRSTCHILD, CHILDID_SELF)
Next lChildCount
If Not oAccChild Is Nothing Then
For lChildCount = 1& To oAccChild.accChildCount - 1&
If LCase(oAccChild.accName(lChildCount)) = LCase(PropertyName) Then
If Len(oAccChild.accDescription(lChildCount)) Then
sOutputString = CleanUpString _
((Trim(Replace((oAccChild.accDescription(lChildCount)), "Value:", ""))))
If Len(sOutputString) Then
ExtendedPropertyFromFile = sOutputString
Exit For
End If
Else
ExtendedPropertyFromFile = ""
End If
End If
Next
End If
End If
End If
Xit:
If GetLastError Then
ExtendedPropertyFromFile = "Error: " & FormatErrorCode(GetLastError)
End If
Call SetParent(hwnd, hParent)
Call SendMessage(hwnd, WM_SYSCOMMAND, SC_CLOSE, ByVal 0&)
Call DestroyWindow(GetProp(Application.hwnd, "Hidden"))
End Function
Private Function InvokeShellContextMenu(ByVal FilePathName As String) As Boolean
Const SW_SHOW = 5&, WS_VISIBLE = &H10000000, WS_EX_TOOLWINDOW = &H80
Const SEE_MASK_INVOKEIDLIST = &HC, SEE_MASK_FLAG_NO_UI = &H400
Dim tShInfo As SHELLEXECUTEINFO, hHiddenWindow As LongPtr
hHiddenWindow = CreateWindowEx( _
WS_EX_TOOLWINDOW, StrPtr("EDIT"), StrPtr(Chr(10&)), WS_VISIBLE, _
-200&, -200&, 1&, 1&, NULL_PTR, NULL_PTR, _
GetModuleHandle(StrPtr(vbNullString)), ByVal 0& _
)
If hHiddenWindow Then
Call SetProp(Application.hwnd, "Hidden", hHiddenWindow)
With tShInfo
.cbSize = LenB(tShInfo)
.lpFile = FilePathName & vbNullChar
.nShow = SW_SHOW
.fMask = SEE_MASK_INVOKEIDLIST + SEE_MASK_FLAG_NO_UI
'Language dependent.
.lpVerb = "Properties"
.lpParameters = "Details" & vbNullChar
End With
InvokeShellContextMenu = ShellExecuteEx(tShInfo)
If tShInfo.hInstApp > 32& Then
Call SetLastError(CLng(tShInfo.hInstApp))
End If
End If
End Function
Private Function HwndToAcc(ByVal hwnd As LongPtr) As IAccessible
Const ID_ACCESSIBLE As String = "{618736E0-3C3D-11CF-810C-00AA00389B71}"
Const OBJID_CLIENT = &HFFFFFFFC, S_OK = &H0&
Dim tGUID(0& To 3&) As Long
Dim oIAc As IAccessible
If IIDFromString(StrPtr(ID_ACCESSIBLE), VarPtr(tGUID(0&))) = S_OK Then
If AccessibleObjectFromWindow(hwnd, OBJID_CLIENT, VarPtr(tGUID(0&)), oIAc) = S_OK Then
Set HwndToAcc = oIAc
End If
End If
End Function
Private Function FormatErrorCode(ByVal errCode As ERROR_CODES) As String
Select Case errCode
Case ERROR_FILE_NOT_FOUND: FormatErrorCode = "File not found"
Case ERROR_PATH_NOT_FOUND: FormatErrorCode = "Path not found"
Case ERROR_ACCESS_DENIED: FormatErrorCode = "Access denied"
Case ERROR_NOT_ENOUGH_MEMORY: FormatErrorCode = "Not enough memory"
Case ERROR_NO_ASSOC: FormatErrorCode = "No file association"
Case ERROR_SHARING_VIOLATION: FormatErrorCode = "Sharing violation"
Case ERROR_CANCELLED: FormatErrorCode = "Cancelled"
Case ERROR_DDE_FAIL: FormatErrorCode = "DDE fail"
End Select
End Function
Private Function CleanUpString(ByVal sString As String) As String
Dim i As Long
For i = 1& To Len(sString)
If Asc(Mid(sString, i, 1&)) <> 63& Then
CleanUpString = CleanUpString & Mid(sString, i, 1&)
End If
Next
End Function
Private Function IsPathFile(ByVal Path As String) As Boolean
On Error Resume Next
IsPathFile = CBool(GetAttr(Path) = vbArchive)
End Function
