在VB中注册控件

Private   Declare   Function LoadLibraryA() Function LoadLibraryA Lib "kernel32" (ByVal lLibFileName As String) As Long
Private Declare Function CreateThread()Function CreateThread Lib "kernel32" (lThreadAttributes As Any, ByVal lStackSize As Long, ByVal lStartAddress As Long, ByVal larameter As Long, ByVal lCreationFlags As Long, lThreadID As Long) As Long
Private Declare Function WaitForSingleObject()Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal lMilliseconds As Long) As Long
Private Declare Function GetProcAddress()Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lProcName As String) As Long
Private Declare Function FreeLibrary()Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function CloseHandle()Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function GetExitCodeThread()Function GetExitCodeThread Lib "kernel32" (ByVal hThread As Long, lExitCode As Long) As Long
Private Declare Sub ExitThread()Sub ExitThread Lib "kernel32" (ByVal lExitCode As Long)
'输入 : sDllPath DLL/OCX 的全名
' bRegister 注册为true , 反注册为false
'输出 : 如成功返回true
'描述 : 注册/反注册控件(ocx /dll)

Function RegisterServer()Function RegisterServer(ByVal sDllPath As String, Optional bRegister As Boolean = True) As Boolean
Dim lLibAddress As Long, lProcAddress As Long, lThreadID As Long, lSuccess As Long, lExitCode As Long, lThread As Long
Dim sRegister As String
Const clMaxTimeWait As Long = 20000 'Wait 20 secs for register to
complete
On Error GoTo ExitFunc
If Len(sDllPath) > 0 And Len(Dir(sDllPath)) > 0 Then
'File exists
If bRegister Then
sRegister = "DllRegisterServer"
Else
sRegister = "DllUnregisterServer"
End If
'Load library into current process
lLibAddress = LoadLibraryA(sDllPath)
If lLibAddress Then
'Get address of the DLL function
lProcAddress = GetProcAddress(lLibAddress, sRegister)
If lProcAddress Then
'Found interface, make call to component
lThread = CreateThread(ByVal 0&, 0&, ByVal lProcAddress, ByVal 0&, 0&, lThread)
If lThread Then
'Created thread
lSuccess = (WaitForSingleObject(lThread, clMaxTimeWait) = 0)
If Not lSuccess Then
'Failed to register, close thread
Call GetExitCodeThread(lThread, lExitCode)
Call ExitThread(lExitCode)
RegisterServer = False
Else
'Register control
RegisterServer = True
Call CloseHandle(lThread)
End If
End If
Else
'Object doesn't expose OLE interface
FreeLibrary lLibAddress
End If
Call FreeLibrary(lLibAddress)
End If
End If
ExitFunc:
On Error GoTo 0
End Function