VBA中的StringFromIID - 避免手动管理内存的好方法是啥？
Posted
技术标签:
【中文标题】VBA中的StringFromIID - 避免手动管理内存的好方法是啥？【英文标题】：StringFromIID in VBA - what's a nice way to avoid managing the memory manually?VBA中的StringFromIID - 避免手动管理内存的好方法是什么？ 【发布时间】：2021-11-03 16:18:42 【问题描述】：我想在 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 惯用的方式获取字符串？
【问题讨论】：
我的 VBA 还是生锈了，但是 lplpsz 是一个指向字符串的指针（也是一个指针），所以我猜应该是ByRef lplpsz As LongPtr。一旦分配，您必须在收到的字符串指针上调用CoTaskMemFree。否则，只需使用 StringFromGUID2 和预分配的 VBA unicode 字符串，例如类似于 GetWindowText。
CLSID、IID 和 GUID 之间确实没有区别，所以我只使用 StringFromGUID2()，并让 VBA 代码分配自己的本地缓冲区。 GUID/IID 字符串的最大字符数为 38（39 个带空终止符）。
【参考方案1】：
这里是一些有用功能的快速实现。请注意，我使用的是 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中的StringFromIID - 避免手动管理内存的好方法是啥？的主要内容，如果未能解决你的问题，请参考以下文章
VBA：更新后无法自动重新计算 Excel 公式 - 需要手动交互
一个网页已经手动打开并登陆成功，怎样用VBA接管操作这个网页中的元素。