VBA 中的 StringFromIID - 避免手动管理内存的好方法是什么？
StringFromIID in VBA - what's a nice way to avoid managing the memory manually?
我想在VBA中调用这个函数：
HRESULT StringFromIID(
REFIID rclsid,
LPOLESTR *lplpsz
);
... 打印 REFIID 用于调试。我已经翻译成 VBA:
Private Declare PtrSafe Function StringFromIID Lib "ole32" (ByVal rclsid As LongPtr, ByVal lpsz As LongPtr) As Long
但是我不知道第二个参数传什么，也很担心怎么释放内存
给定一个指向接口 ID 的指针，我如何以 VBA 惯用的方式获取字符串？
这里是一些有用功能的快速实现。请注意，我使用的是 StringFromCLSID 而不是 StringFromIID，但您明白了：
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
快速测试：
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
如果你想要在 MAC 上运行的东西，那么使用这个比上面的版本更精致的版本：
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
我想在VBA中调用这个函数：
HRESULT StringFromIID(
REFIID rclsid,
LPOLESTR *lplpsz
);
... 打印 REFIID 用于调试。我已经翻译成 VBA:
Private Declare PtrSafe Function StringFromIID Lib "ole32" (ByVal rclsid As LongPtr, ByVal lpsz As LongPtr) As Long
但是我不知道第二个参数传什么，也很担心怎么释放内存
给定一个指向接口 ID 的指针，我如何以 VBA 惯用的方式获取字符串？
这里是一些有用功能的快速实现。请注意，我使用的是 StringFromCLSID 而不是 StringFromIID，但您明白了：
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
快速测试：
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
如果你想要在 MAC 上运行的东西，那么使用这个比上面的版本更精致的版本：
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