Last active
April 26, 2023 08:42
-
-
Save relyky/89b39f1d3a342410fc44 to your computer and use it in GitHub Desktop.
ComWithoutRegister第二版,可真的動態載入DLL函式庫,不需註冊COM也能調用。
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Option Explicit | |
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpSectionName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpbuffurnedString As String, ByVal nBuffSize As Long, ByVal lpFileName As String) As Long | |
Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpSectionName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long | |
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long | |
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long | |
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long | |
Private Declare Function GetModuleHandle Lib "kernel32.dll" Alias "GetModuleHandleA" (ByVal lpModuleName As String) 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 | |
'# ====== ActiveX DLL : pCreditDeskLib.dll ====== | |
Private m_CreditDeskLib_DLLPath As String * 256 | |
Private m_CreditDeskLib_CAutoCheck_ClsId As String * 39 | |
Private m_CreditDeskLib_CCommon_ClsId As String * 39 | |
Private m_CreditDeskLib_CDataIO_ClsId As String * 39 | |
'# parameters | |
Private Const INI_FileName As String = "ComWithoutRegister.ini" | |
'IID_IClassFactory | |
Private Const strIID_IClassFactory As String = "{00000001-0000-0000-C000-000000000046}" | |
Private Sub Class_Initialize() | |
'## get configuration information from INI file. | |
Dim iniPath As String | |
iniPath = App.Path + "\" + INI_FileName | |
'# ====== ActiveX DLL : pCreditDeskLib.dll ====== | |
'Call GetPrivateProfileString("CreditDeskLib", "DlLPath", "D:\Eric\Win7\Library\pCreditDeskLib.dll", m_CreditDeskLib_DLLPath, Len(m_CreditDeskLib_DLLPath), iniPath) | |
Call GetPrivateProfileString("CreditDeskLib", "DlLPath", "pCreditDeskLib.dll", m_CreditDeskLib_DLLPath, Len(m_CreditDeskLib_DLLPath), iniPath) | |
Call GetPrivateProfileString("CreditDeskLib", "CAutoCheck_ClsId", "{2EEEE754-8D79-4B4C-8834-ADD9AD795738}", m_CreditDeskLib_CAutoCheck_ClsId, Len(m_CreditDeskLib_CAutoCheck_ClsId), iniPath) | |
Call GetPrivateProfileString("CreditDeskLib", "CCommon_ClsId", "{C0384219-EDDD-4CC4-A98B-86CB1FF4EE01}", m_CreditDeskLib_CCommon_ClsId, Len(m_CreditDeskLib_CCommon_ClsId), iniPath) | |
Call GetPrivateProfileString("CreditDeskLib", "CDataIO_ClsId", "{357D3923-37F7-457E-88E1-F1726B063EBD}", m_CreditDeskLib_CDataIO_ClsId, Len(m_CreditDeskLib_CDataIO_ClsId), iniPath) | |
End Sub | |
'# ====== ActiveX DLL : pCreditDeskLib.dll ====== | |
Property Get CreditDeskLib_DLLPath() As String | |
CreditDeskLib_DLLPath = m_CreditDeskLib_DLLPath | |
End Property | |
Property Get CreditDeskLib_CAutoCheck_ClsId() As String | |
CreditDeskLib_CAutoCheck_ClsId = m_CreditDeskLib_CAutoCheck_ClsId | |
End Property | |
Property Get CreditDeskLib_CCommon_ClsId() As String | |
CreditDeskLib_CCommon_ClsId = m_CreditDeskLib_CCommon_ClsId | |
End Property | |
Property Get CreditDeskLib_CDataIO_ClsId() As String | |
CreditDeskLib_CDataIO_ClsId = m_CreditDeskLib_CDataIO_ClsId | |
End Property | |
'# ====== Create Instance without system register 關鍵函式====== | |
'your class constructor | |
Public Function CreateInstance(DLLPath As String, ClsId As String) As Object | |
Dim tFac As olelib.IClassFactory | |
Dim tobj As olelib.IUnknown | |
Dim errDesc As String 'error description | |
'## Get the related UUIC | |
Dim clsid_obj As UUID | |
Dim iid_iunknow As UUID | |
Dim iid_iclassfactory As UUID | |
CLSIDFromString strIID_IClassFactory, iid_iclassfactory | |
CLSIDFromString IIDSTR_IUnknown, iid_iunknow | |
CLSIDFromString ClsId, clsid_obj 'your Class-ID | |
'## Get the [DllGetClassObject] function handler | |
Dim fPtr As Long | |
Dim hMod As Long | |
'Load the target DLL module | |
hMod = GetModuleHandle(DLLPath) | |
If hMod = 0& Then | |
hMod = LoadLibrary(DLLPath) | |
If hMod = 0& Then | |
errDesc = "無法載入DLL函式庫!請重新確認函式庫路徑是否正確。" | |
Err.Raise vbObjectError + 512 + 1, TypeName(Me), errDesc | |
End If | |
End If | |
'Get the [DllGetClassObject] function handler | |
fPtr = GetProcAddress(hMod, "DllGetClassObject") | |
'## Call [DllGetClassObject] with [DispCallFunc] API to get IClassFactory object | |
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' | |
Dim lValue As Long, vRtn As Variant | |
Dim pCount As Long, vParam(3) As Variant, vParamPtr(3) As Long, vParamType(3) As Integer | |
vParam(0) = VarPtr(clsid_obj) | |
vParam(1) = VarPtr(iid_iclassfactory) | |
vParam(2) = VarPtr(tFac) | |
pCount = 3 'the parameters length | |
vParamPtr(0) = VarPtr(vParam(0)) | |
vParamType(0) = VarType(vParam(0)) | |
vParamPtr(1) = VarPtr(vParam(1)) | |
vParamType(1) = VarType(vParam(1)) | |
vParamPtr(2) = VarPtr(vParam(2)) | |
vParamType(2) = VarType(vParam(2)) | |
lValue = DispCallFunc(0&, fPtr, CC_STDCALL, CR_LONG, pCount, vParamType(0), vParamPtr(0), vRtn) | |
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' | |
If tFac Is Nothing Then | |
errDesc = "回傳代碼" & vRtn & "。DllGetClassObject函式無法取得IClassFactory物件!請重新確認ClassID是否正確。" | |
Err.Raise vbObjectError + 512 + 1, TypeName(Me), errDesc | |
End If | |
'## Create Instance by IClassFactory | |
tFac.CreateInstance Nothing, iid_iunknow, tobj | |
'## success | |
'return | |
Set CreateInstance = tobj 'return your instance | |
'release resource | |
Set tobj = Nothing | |
Set tFac = Nothing | |
End Function |
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Private Sub cmdTestCreditDeskLibWithoutRegister2_Click() | |
On Error GoTo ErrorHandler | |
Dim m_comWR2 As New ComWithoutRegister2 '專用於引用未註冊的COM元件 | |
Dim comm As Object | |
Set comm = m_comWR2.CreateInstance(m_comWR2.CreditDeskLib_DLLPath, m_comWR2.CreditDeskLib_CCommon_ClsId) '取代CreateObject函式 | |
Dim result As Boolean | |
Dim dstr As String | |
dstr = txtDateStr.Text ' "2015/02/99" | |
result = comm.CheckDate_E(dstr) | |
MsgBox "CheckDate_E " & dstr & " -> " & result | |
'release resource | |
Set comm = Nothing | |
Exit Sub | |
ErrorHandler: | |
lstCheckList.AddItem "ERROR " & Err.Number & " -> " & Err.Description | |
End Sub |
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
規格需求 | |
1) 不註冊調用ActiveX Dll, 即可取代原 CreateObject 功能即可 | |
2) 由INI檔取組態資訊 | |
3) 可動態載入DLL函式庫 | |
關鍵API: | |
DllGetClassObject | |
所有COM元件都必需實作的函式。用來取IClassFactory物件以CreateInstance。 | |
DispCallFunc | |
要注意的是這個函數很容易讓程式crash,使用上要小心。 | |
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 | |
其他參考文件 | |
ComWithoutRegister - 第1版 | |
https://gist.github.com/relyky/a335a6b73d18216cd999 | |
[VB6] Call Functions By Pointer (Universall DLL Calls) | |
http://www.vbforums.com/showthread.php?781595-VB6-Call-Functions-By-Pointer-(Universall-DLL-Calls) | |
不注册调用ActiveX Dll | |
http://blog.csdn.net/lingll/article/details/593567 | |
COM without registering | |
https://gist.github.com/jjeffery/1568627/ | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment