Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,806
- Office Version
- 2016
- Platform
- Windows
In an attempt to answer this question and aftter searching this subject in the last few days, I found that the FindExecutable API function doesn't always work for finding the (.exe) associated with a specific document file. This API function works consistently when applied to some file extensions (such as office documents) but appears to be inconsistent with many other file extensions particularly in Windows 10.
I thought I would post here 3 different methods I arrived at for finding the associated executable (and its path ) so that if one method doesn't work, just try another one... The third method being the most complex but the most consistent.
Workbook demo
* Method(1) FindExecutable API
* Method(2) AssocQueryString API
* Method(3) IAssocHandler Interface
Usage Demo:
I hope you find this useful.
I thought I would post here 3 different methods I arrived at for finding the associated executable (and its path ) so that if one method doesn't work, just try another one... The third method being the most complex but the most consistent.
Workbook demo
* Method(1) FindExecutable API
VBA Code:
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
Private Declare PtrSafe Function FindExecutable Lib "shell32.dll" Alias "FindExecutableA" (ByVal lpFile As String, ByVal lpDirectory As String, ByVal lpResult As String) As Long
#Else
Private Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
Private Declare Function FindExecutable Lib "shell32.dll" Alias "FindExecutableA" (ByVal lpFile As String, ByVal lpDirectory As String, ByVal lpResult As String) As Long
#End If
Function FindExecutable_With_FindExecutableAPI(DocumetFileExtension As String) As String
Const MAX_PATH = 260
Dim sFileName As String, sExecutable As String, lRet As Long
If Len(DocumetFileExtension) Then
sFileName = Space(MAX_PATH): sExecutable = Space(MAX_PATH)
Call GetTempFileName(CurDir, vbNullString, 0&, sFileName)
sFileName = Application.Trim(sFileName)
sFileName = Left$(sFileName, Len(sFileName) - 3) & DocumetFileExtension
On Error Resume Next
Open sFileName For Output As #1: Close #1
lRet = FindExecutable(sFileName, vbNullString, sExecutable)
Kill sFileName
On Error GoTo 0
If lRet > 32 Then
FindExecutable_With_FindExecutableAPI = Left$(sExecutable, InStr(sExecutable, Chr(0)) - 1)
End If
End If
End Function
* Method(2) AssocQueryString API
VBA Code:
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function AssocQueryString Lib "shlwapi.dll" Alias "AssocQueryStringA" (ByVal flags As Long, ByVal str As Long, ByVal pszAssoc As String, ByVal pszExtra As String, ByVal pszOut As String, ByRef pcchOut As Long) As Long
#Else
Private Declare Function AssocQueryString Lib "shlwapi.dll" Alias "AssocQueryStringA" (ByVal flags As Long, ByVal str As Long, ByVal pszAssoc As String, ByVal pszExtra As String, ByVal pszOut As String, ByRef pcchOut As Long) As Long
#End If
Function FindExecutable_With_AssocQueryStringAPI(ByVal DocumetFileExtension As String) As String
Const ASSOCSTR_EXECUTABLE = &H2
Const ASSOCF_IGNOREUNKNOWN = &H400
Const S_OK As Long = &H0
Const MAX_PATH = 260
Dim Buffer As String * MAX_PATH
If Len(DocumetFileExtension) Then
DocumetFileExtension = IIf(Left(DocumetFileExtension, 1) = ".", DocumetFileExtension, "." & DocumetFileExtension)
If AssocQueryString(ASSOCF_IGNOREUNKNOWN, ASSOCSTR_EXECUTABLE, DocumetFileExtension, vbNullString, Buffer, Len(Buffer)) = S_OK Then
FindExecutable_With_AssocQueryStringAPI = Application.Trim(Left$(Buffer, Len(Buffer) - 1))
End If
End If
End Function
* Method(3) IAssocHandler Interface
VBA Code:
Option Explicit
Private Enum ASSOC_FILTER
ASSOC_FILTER_NONE = &H0
ASSOC_FILTER_RECOMMENDED = &H1
End Enum
#If VBA7 Then
Private Declare PtrSafe Function SHAssocEnumHandlers Lib "shell32" (ByVal pszExtra As LongPtr, ByVal afFilter As ASSOC_FILTER, ByVal ppEnumHandler As LongPtr) As Long
Private Declare PtrSafe Function DispCallFunc Lib "oleAut32.dll" (ByVal pvInstance As LongPtr, ByVal offsetinVft As Long, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As LongPtr, ByRef retVAR As Variant) As Long
Private Declare PtrSafe Sub SetLastError Lib "kernel32.dll" (ByVal dwErrCode As Long)
Private Declare PtrSafe Function SysReAllocString Lib "oleAut32.dll" (ByVal pBSTR As LongPtr, Optional ByVal pszStrPtr As LongPtr) As Long
#Else
Private Declare Function SHAssocEnumHandlers Lib "shell32" (ByVal pszExtra As Long, ByVal afFilter As ASSOC_FILTER, ByVal ppEnumHandler As Long) As Long
Private Declare Function DispCallFunc Lib "oleAut32.dll" (ByVal pvInstance As Long, ByVal offsetinVft As Long, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As Long, ByRef retVAR As Variant) As Long
Private Declare Sub SetLastError Lib "kernel32.dll" (ByVal dwErrCode As Long)
Private Declare Function SysReAllocString Lib "oleAut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long) As Long
#End If
Function FindExecutable_With_AssocHandlerINTERFACE(ByVal DocumetFileExtension As String) As String
#If Win64 Then
Const vTblOffsetFac_32_64 = 2&
Dim pEnumHandlers As LongLong
Dim pAssocHandler As LongLong
Dim pceltFetched As LongLong
Dim pExecutablePathName As LongLong
#Else
Const vTblOffsetFac_32_64 = 1&
Dim pEnumHandlers As Long
Dim pAssocHandler As Long
Dim pceltFetched As Long
Dim pExecutablePathName As Long
#End If
Const IEnumAssocHandlers_Next = 12 * vTblOffsetFac_32_64
Const IAssocHandler_GetName = 12 * vTblOffsetFac_32_64
Const CC_STDCALL = 4&
Const S_OK = 0&
Dim Unk As IUnknown
If Len(DocumetFileExtension) Then
DocumetFileExtension = IIf(Left(DocumetFileExtension, 1) = ".", DocumetFileExtension, "." & DocumetFileExtension)
If SHAssocEnumHandlers(StrPtr(DocumetFileExtension), ASSOC_FILTER_RECOMMENDED, VarPtr(Unk)) = S_OK Then
pEnumHandlers = ObjPtr(Unk)
If vtblCall(pEnumHandlers, IEnumAssocHandlers_Next, vbLong, CC_STDCALL, 1&, VarPtr(pAssocHandler), VarPtr(pceltFetched)) = S_OK Then
If vtblCall(pAssocHandler, IAssocHandler_GetName, vbLong, CC_STDCALL, VarPtr(pExecutablePathName)) = S_OK Then
FindExecutable_With_AssocHandlerINTERFACE = GetStrFromPtrW(pExecutablePathName)
End If
End If
End If
End If
End Function
#If Win64 Then
Private Function vtblCall(ByVal InterfacePointer As LongLong, ByVal VTableOffset As Long, ByVal FunctionReturnType As Long, ByVal CallConvention As Long, ParamArray FunctionParameters() As Variant) As Variant
Dim vParamPtr() As LongLong
#Else
Private Function vtblCall(ByVal InterfacePointer As Long, ByVal VTableOffset As Long, ByVal FunctionReturnType As Long, ByVal CallConvention As Long, ParamArray FunctionParameters() As Variant) As Variant
Dim vParamPtr() As Long
#End If
If InterfacePointer = 0& Or VTableOffset < 0& Then Exit Function
If Not (FunctionReturnType And &HFFFF0000) = 0& Then Exit Function
Dim pIndex As Long, pCount As Long
Dim vParamType() As Integer
Dim vRtn As Variant, vParams() As Variant
vParams() = FunctionParameters()
pCount = Abs(UBound(vParams) - LBound(vParams) + 1&)
If pCount = 0& Then
ReDim vParamPtr(0 To 0)
ReDim vParamType(0 To 0)
Else
ReDim vParamPtr(0 To pCount - 1&)
ReDim vParamType(0 To pCount - 1&)
For pIndex = 0& To pCount - 1&
vParamPtr(pIndex) = VarPtr(vParams(pIndex))
vParamType(pIndex) = VarType(vParams(pIndex))
Next
End If
pIndex = DispCallFunc(InterfacePointer, VTableOffset, CallConvention, FunctionReturnType, pCount, vParamType(0), vParamPtr(0), vRtn)
If pIndex = 0& Then
vtblCall = vRtn
Else
SetLastError pIndex
End If
End Function
#If Win64 Then
Private Function GetStrFromPtrW(ByVal Ptr As LongLong) As String
#Else
Private Function GetStrFromPtrW(ByVal Ptr As Long) As String
#End If
SysReAllocString VarPtr(GetStrFromPtrW), Ptr
End Function
Usage Demo:
VBA Code:
Option Explicit
Sub Test()
Dim sAssocExecutable As String, vExetensionsArray() As Variant, vExtension As Variant
vExetensionsArray = Array("xls", "wmv", "bmp", "ico", "wav", "dll", "txt", "dat", "jpg", "gif")
For Each vExtension In vExetensionsArray
Debug.Print "Extension : " & CStr(vExtension)
'Method 1
sAssocExecutable = FindExecutable_With_FindExecutableAPI(CStr(vExtension))
Debug.Print Space(10) & "Method (1)" & vbLf & Space(20) & "Executable : " & sAssocExecutable
'Method 2
sAssocExecutable = FindExecutable_With_AssocQueryStringAPI(CStr(vExtension))
Debug.Print Space(10) & "Method (2)" & vbLf & Space(20) & "Executable : " & sAssocExecutable
'Method 3
sAssocExecutable = FindExecutable_With_AssocHandlerINTERFACE(CStr(vExtension))
Debug.Print Space(10) & "Method (3)" & vbLf & Space(20) & "Executable : " & sAssocExecutable
Debug.Print "==================================================="
Next vExtension
End Sub
I hope you find this useful.