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?
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://learn.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