Code:
Sub TestSqliteComDll()
Dim Cnn As cConnection
Set Cnn = New_cConnection
MsgBox Cnn.Version
End SubCode:
Option Explicit
'免注册加载DLL-
''COM DLL可以放在当前目录或SysWOW64就能引用成功,
'C:\Windows\SysWOW64
'Set cn2 = CreateObjectXX("sqlite3.dll", ClsStr_Obj) '放在系统目录，可以不带路径
'Set cn2 = CreateObjectXX(ThisWorkbook.path & "\sqlite3.dll", ClsStr_Obj)
'DLL放在当前目录，要添加完整路径
Private Type UUID
d1 As Long
d2 As Integer
d3 As Integer
d4(7) As Byte
End Type
Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, id As UUID) As Long
Private Declare Function IIDFromString Lib "ole32" (ByVal str As Long, id As UUID) As Long
Private Declare Function DispCallFunc Lib "oleaut32.dll" (ByVal pvInstance As Long, ByVal offsetinVft As Long, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As Long, ByRef retVAR As Variant) As Long
Private Declare Function GetProcAddress Lib "kernel32.dll" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function LoadLibrary Lib "kernel32.dll" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Function New_cRecordset() As cRecordset
Set New_cRecordset = CreateObjectXX(App.Path & "\dhRichClient3.dll", _
"{351A3F14-5448-40A6-8E25-1F55A2CF989D}")
End Function
Function New_cConnection() As cConnection
Set New_cConnection = CreateObjectXX(App.Path & "\dhRichClient3.dll", _
"{6B16C696-FB30-42CE-827C-090956209CEC}")
End Function
Function CreateObjectXX(DllFileName As String, sCLSID As String, Optional ForIID_IDispatch As Boolean, Optional H As Long) As Object
'先声明对象真实类型才可以免注册加载COM DLL
Const sIID_IClassFactory As String = "{00000001-0000-0000-C000-000000000046}"
Const sIID_IDispatch As String = "{00020400-0000-0000-C000-000000000046}"
Const sIID_IUnknown As String = "{00000000-0000-0000-C000-000000000046}"
Dim lCLSID As UUID, IID_IClassFactory As UUID, IID_IDispatch As UUID, IID_IUnknown As UUID
Dim lOle As Object, fo As Object
Dim FUNC As Long, ret As Variant, ty(2) As Integer, pm(2) As Long, vParams(2) As Variant
IIDFromString StrPtr(sIID_IClassFactory), IID_IClassFactory
IIDFromString StrPtr(sIID_IDispatch), IID_IDispatch
IIDFromString StrPtr(sIID_IUnknown), IID_IUnknown
CLSIDFromString StrPtr(sCLSID), lCLSID
H = LoadLibrary(DllFileName)
FUNC = GetProcAddress(H, "DllGetClassObject")
ty(0) = vbLong
ty(1) = vbLong
ty(2) = vbObject
vParams(0) = VarPtr(lCLSID)
vParams(1) = VarPtr(IID_IClassFactory)
vParams(2) = VarPtr(fo)
pm(0) = VarPtr(vParams(0))
pm(1) = VarPtr(vParams(1))
pm(2) = VarPtr(vParams(2))
Dim l As Long
l = DispCallFunc(0&, FUNC, 4, vbObject, 3, ty(0), pm(0), ret)
' DispCallFunc ObjPtr(fo), 32, 1, vbLong, 0, 0, 0, ret
If fo Is Nothing Then Exit Function
vParams(0) = 0&
If ForIID_IDispatch Then
vParams(1) = VarPtr(IID_IDispatch) '一般的COM DLL可以用这个
Else
vParams(1) = VarPtr(IID_IUnknown) ' tlbinf32.dll只能用这个(默认就用这种方法）
End If
vParams(2) = VarPtr(lOle)
DispCallFunc ObjPtr(fo), 12&, 4, vbObject, 3, ty(0), pm(0), ret
Set CreateObjectXX = lOle
Set fo = Nothing
Set lOle = Nothing
End Function