VB Forum / Win API / December 2007

Donald Lessau schrieb:

Hi Don,

Yes it does, here's the code:

Call it like:

  Dim strExe$

  If IsVerbSupported("edit", ".bmp", strExe) Then
          MsgBox ".bmp is edited by """ & strExe & """"
  Else
     MsgBox ".bmp has not ""edit"" association"
  End If

MfG,
Alex

'-------------module-code

Option Explicit

Private Enum ASSOCF

    ASSOCF_INIT_NOREMAPCLSID = &H1
    ASSOCF_INIT_BYEXENAME = &H2
    ASSOCF_OPEN_BYEXENAME = &H2
    ASSOCF_INIT_DEFAULTTOSTAR = &H4
    ASSOCF_INIT_DEFAULTTOFOLDER = &H8
    ASSOCF_NOUSERSETTINGS = &H10
    ASSOCF_NOTRUNCATE = &H20
    ASSOCF_VERIFY = &H40
    ASSOCF_REMAPRUNDLL = &H80
    ASSOCF_NOFIXUPS = &H100
    ASSOCF_IGNOREBASECLASS = &H200

End Enum

Private Enum ASSOCSTR

    ASSOCSTR_COMMAND = 1
    ASSOCSTR_EXECUTABLE
    ASSOCSTR_FRIENDLYDOCNAME
    ASSOCSTR_FRIENDLYAPPNAME
    ASSOCSTR_NOOPEN
    ASSOCSTR_SHELLNEWVALUE
    ASSOCSTR_DDECOMMAND
    ASSOCSTR_DDEIFEXEC
    ASSOCSTR_DDEAPPLICATION
    ASSOCSTR_DDETOPIC
    ASSOCSTR_INFOTIP
    ASSOCSTR_QUICKTIP
    ASSOCSTR_TILEINFO
    ASSOCSTR_CONTENTTYPE
    ASSOCSTR_DEFAULTICON
    ASSOCSTR_SHELLEXTENSION

End Enum

Private Const MAX_PATH = 260
Private Const E_POINTER As Long = &H80004003
Private Const S_FALSE As Long = &H1
Private Const S_OK As Long = &H0

Private Declare Function wu32_AssocQueryString Lib "shlwapi.dll" Alias
"AssocQueryStringA" (ByVal Flags As ASSOCF, ByVal str As ASSOCSTR, ByVal
pszAssoc As String, ByVal pszExtra As String, ByVal pszOut As String,
ByRef pcchOut As Long) As Long

Public Function IsVerbSupported _
        ( _
            ByVal strVerb$, _
            ByVal strExtArg$, _
            Optional ByRef strExecutable$ _
        ) _
    As Boolean

    IsVerbSupported = GetAssocString _
        ( _
            ASSOCSTR_EXECUTABLE, _
            strExtArg, _
            strExecutable, _
            strVerb _
        )

End Function

Private Function GetAssocString _
    ( _
        flgASSOCSTR As ASSOCSTR, _
        strExtArg As String, _
        ByRef strOutString As String, _
        Optional strExtra As String = "open", _
        Optional flgASSOCF As ASSOCF = -1 _
    ) _
    As Boolean

Const FLAGS_DEFAULT As Long = _
    ASSOCF_INIT_DEFAULTTOFOLDER _
    Or ASSOCF_NOTRUNCATE _
    Or ASSOCF_VERIFY

Dim lngLenOutFile As Long
Dim strExtUsed As String
Dim p As Long

    If flgASSOCF = -1 Then
        flgASSOCF = FLAGS_DEFAULT
    End If

    strOutString = String$(MAX_PATH, 0)
    lngLenOutFile = Len(strOutString)

     p = InStrRev(strExtArg, ".")
    If p = 0 Then
        strExtUsed = "." & strExtArg
    Else
        strExtUsed = Mid$(strExtArg, p)
    End If

        Select Case wu32_AssocQueryString _
            ( _
                flgASSOCF, _
                flgASSOCSTR, _
                strExtUsed, _
                strExtra, _
                strOutString, _
                lngLenOutFile _
            )

        Case S_OK:

            p = InStr(1, strOutString, vbNullChar, vbBinaryCompare)
            If p > 0 Then
                strOutString = Left$(strOutString, p - 1)
            End If

            strOutString = Trim(strOutString)
            GetAssocString = True

        'The pszOut buffer is too small to hold the entire string.
        Case E_POINTER:
            GetAssocString = False

        'pszOut is NULL. pcchOut contains the required buffer size.
        Case S_FALSE:
            GetAssocString = False

         'Other error
        Case Else:
            GetAssocString = False

        End Select

End Function