StringFromIID in VBA - what's a nice way to avoid managing the memory manually?-CodePudding

I would like to call this function in VBA:

HRESULT StringFromIID(
  REFIID   rclsid,
  LPOLESTR *lplpsz
);

... to print a REFIID for debugging. I've translated to VBA:

Private Declare PtrSafe Function StringFromIID Lib "ole32" (ByVal rclsid As LongPtr, ByVal lpsz As LongPtr) As Long

however I'm not sure what to pass for the second parameter, and am also worried about how to release the memory.

Given a pointer to an interface ID, how can I get a string in a VBA idiomatic way?

CodePudding user response：

Here is a quick implementation of a few useful functions. Note I am using StringFromCLSID instead of StringFromIID but you get the idea:

Option Explicit

Public Declare PtrSafe Function CLSIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, ByRef pclsid As Any) As Long
Public Declare PtrSafe Function StringFromCLSID Lib "ole32.dll" (ByRef rclsid As Any, ByRef lplpsz As LongPtr) As Long
Public Declare PtrSafe Function ProgIDFromCLSID Lib "ole32.dll" (ByRef clsID As Any, ByRef lplpszProgID As LongPtr) As Long
Public Declare PtrSafe Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As LongPtr, Optional ByVal pszStrPtr As LongPtr) As Long
Public Declare PtrSafe Sub CoTaskMemFree Lib "ole32.dll" (Optional ByVal pv As LongPtr)

Public Type GUID
      Data1 As Long
      Data2 As Integer
      Data3 As Integer
      Data4(0 To 7) As Byte
End Type

Public Function GetProgIDFromCLSIDString(ByVal clsidString As String) As String
    Const S_OK As Long = 0
    Dim gID As GUID
    Dim resPtr As LongPtr
    '
    If CLSIDFromString(StrPtr(clsidString), gID) = S_OK Then
        If ProgIDFromCLSID(gID, resPtr) = S_OK Then
            SysReAllocString VarPtr(GetProgIDFromCLSIDString), resPtr
            CoTaskMemFree resPtr
        End If
    End If
End Function

Public Function GetStringFromCLSID(ByRef clsID As GUID) As String
    Const S_OK As Long = 0
    Dim resPtr As LongPtr
    '
    If StringFromCLSID(clsID, resPtr) = S_OK Then
        SysReAllocString VarPtr(GetStringFromCLSID), resPtr
        CoTaskMemFree resPtr
    End If
End Function

Public Function GetCLSIDFromString(ByVal clsID As String) As GUID
    Const S_OK As Long = 0
    Dim gID As GUID
    '
    If CLSIDFromString(StrPtr(clsID), gID) = S_OK Then
        GetCLSIDFromString = gID
    End If
End Function

A quick test:

Sub Test()
    Const clsID As String = "{00020400-0000-0000-C000-000000000046}"
    Dim gID As GUID: gID = GetCLSIDFromString(clsID)
    Debug.Print GetStringFromCLSID(gID) 'Returns original clsID
End Sub

If you want something that works on a MAC then use this version which is a bit more polished than the one above:

Option Explicit
Option Private Module
Option Compare Binary

#If Mac Then
#ElseIf VBA7 Then
    Private Declare PtrSafe Function CLSIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, ByRef pclsid As Any) As Long
    Private Declare PtrSafe Function ProgIDFromCLSID Lib "ole32.dll" (ByRef clsID As Any, ByRef lplpszProgID As LongPtr) As Long
    Private Declare PtrSafe Function StringFromCLSID Lib "ole32.dll" (ByRef rclsid As Any, ByRef lplpsz As LongPtr) As Long
    Private Declare PtrSafe Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As LongPtr, Optional ByVal pszStrPtr As LongPtr) As Long
    Private Declare PtrSafe Sub CoTaskMemFree Lib "ole32.dll" (Optional ByVal pv As LongPtr)
#Else
    Private Declare Function CLSIDFromString Lib "ole32.dll" (ByVal lpsz As Long, ByRef pclsid As Any) As Long
    Private Declare Function ProgIDFromCLSID Lib "ole32.dll" (ByRef clsID As Any, ByRef lplpszProgID As Long) As Long
    Private Declare Function StringFromCLSID Lib "ole32.dll" (ByRef rclsid As Any, ByRef lplpsz As Long) As Long
    Private Declare Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long) As Long
    Private Declare Sub CoTaskMemFree Lib "ole32.dll" (Optional ByVal pv As Long)
#End If

Public Type GUID
    data1 As Long
    data2 As Integer
    data3 As Integer
    data4(0 To 7) As Byte
End Type

Public Const S_OK As Long = 0

'OLE Automation Protocol GUIDs
Public Const IID_IRecordInfo = "{0000002F-0000-0000-C000-000000000046}"
Public Const IID_IDispatch = "{00020400-0000-0000-C000-000000000046}"
Public Const IID_ITypeComp = "{00020403-0000-0000-C000-000000000046}"
Public Const IID_ITypeInfo = "{00020401-0000-0000-C000-000000000046}"
Public Const IID_ITypeInfo2 = "{00020412-0000-0000-C000-000000000046}"
Public Const IID_ITypeLib = "{00020402-0000-0000-C000-000000000046}"
Public Const IID_ITypeLib2 = "{00020411-0000-0000-C000-000000000046}"
Public Const IID_IUnknown = "{00000000-0000-0000-C000-000000000046}"
Public Const IID_IEnumVARIANT = "{00020404-0000-0000-C000-000000000046}"
Public Const IID_NULL = "{00000000-0000-0000-0000-000000000000}"

'*******************************************************************************
'Converts a string to a GUID struct
'Note that 'CLSIDFromString' win API is only slightly faster (<10%) compared
'   to the pure VB approach (used for MAc only) but it has the advantage of
'   raising other types of errors (like class is not in registry)
'*******************************************************************************
#If Mac Then
Public Function GUIDFromString(ByVal sGUID As String) As GUID
    Const methodName As String = "GUIDFromString"
    Const hexPrefix As String = "&H"
    Static pattern As String
    '
    If pattern = vbNullString Then pattern = Replace(IID_NULL, "0", "[0-9A-F]")
    If Not sGUID Like pattern Then Err.Raise 5, methodName, "Invalid string"
    '
    Dim parts() As String: parts = Split(Mid$(sGUID, 2, Len(sGUID) - 2), "-")
    Dim I As Long
    '
    With GUIDFromString
        .data1 = CLng(hexPrefix & parts(0))
        .data2 = CInt(hexPrefix & parts(1))
        .data3 = CInt(hexPrefix & parts(2))
        For I = 0 To 1
            .data4(I) = CByte(hexPrefix & Mid$(parts(3), I * 2   1, 2))
        Next I
        For I = 2 To 7
            .data4(I) = CByte(hexPrefix & Mid$(parts(4), (I - 1) * 2 - 1, 2))
        Next I
    End With
End Function
#Else
'https://docs.microsoft.com/en-us/windows/win32/api/combaseapi/nf-combaseapi-clsidfromstring
Public Function GUIDFromString(ByVal sGUID As String) As GUID
    Const methodName As String = "GUIDFromString"
    Dim hResult As Long: hResult = CLSIDFromString(StrPtr(sGUID), GUIDFromString)
    If hResult <> S_OK Then Err.Raise hResult, methodName, "Invalid string"
End Function
#End If

'*******************************************************************************
'Converts a GUID struct to a string
'Note that this approach is 4 times faster than running a combination of the
'   following 3 Windows APIs: StringFromCLSID, SysReAllocString, CoTaskMemFree
'*******************************************************************************
Public Function GUIDToString(ByRef gID As GUID) As String
    Dim parts(0 To 4) As String
    '
    With gID
        parts(0) = AlignHex(Hex$(.data1), 8)
        parts(1) = AlignHex(Hex$(.data2), 4)
        parts(2) = AlignHex(Hex$(.data3), 4)
        parts(3) = AlignHex(Hex$(.data4(0) * 256&   .data4(1)), 4)
        parts(4) = AlignHex(Hex$(.data4(2) * 65536   .data4(3) * 256&   .data4(4)) _
                          & Hex$(.data4(5) * 65536   .data4(6) * 256&   .data4(7)), 12)
    End With
    GUIDToString = "{" & Join(parts, "-") & "}"
End Function
Private Function AlignHex(ByRef h As String, ByVal charsCount As Long) As String
    Const maxHex As String = "0000000000000000" '16 chars (LongLong max chars)
    If Len(h) < charsCount Then
        AlignHex = Right$(maxHex & h, charsCount)
    Else
        AlignHex = h
    End If
End Function

'*******************************************************************************
'Converts a CLSID string to a progid string. Windows only
'Returns an empty string if not successful
'*******************************************************************************
#If Mac Then
#Else
Public Function GetProgIDFromCLSID(ByRef cID As GUID) As String
    #If VBA7 Then
        Dim resPtr As LongPtr
    #Else
        Dim resPtr As Long
    #End If
    If ProgIDFromCLSID(cID, resPtr) = S_OK Then
        SysReAllocString VarPtr(GetProgIDFromCLSID), resPtr
        CoTaskMemFree resPtr
    End If
End Function
#End If