PDA

View Full Version : ماژول رجیستر کردن خودکار کامپوننت ها



ho3ein.3ven
یک شنبه 11 دی 1390, 19:59 عصر
سلام بر همگی
من یه ماژول گیرم اومده که خودکار تمام کامپوننت ها رو رجیستر می کنه.
اگه ممکنه یکی تستش کنه ببینیم چطوره؟
Option Explicit
Private Declare Function LoadLibraryA Lib "kernel32" (ByVal lLibFileName As String) As Long
Private Declare 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 Lib "kernel32" (ByVal hHandle As Long, ByVal lMilliseconds As Long) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lProcName As String) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function GetExitCodeThread Lib "kernel32" (ByVal hThread As Long, lExitCode As Long) As Long
Private Declare Sub ExitThread Lib "kernel32" (ByVal lExitCode As Long)
'Purpose : This function registers and Unregisters OLE components
'Inputs : sFilePath The path to the DLL/OCX or ActiveX EXE
' bRegister If True Registers the control, else unregisters control
'Outputs : Returns True if successful
'Notes : This is the API equivalent of RegSvr32.exe.
'Example :
' If RegisterComponent("C:\MyPath\MyFile.dll") = True Then
' Msgbox "Component Successfully Registered"
' Else
' Msgbox "Failed to Registered Component"
' End If
'Revisions : 1/Jan/2002. Updated to include code for registering ActiveX Exes.
Function RegisterComponent(ByVal sFilePath 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 ErrFailed
If Len(sFilePath) > 0 And Len(Dir(sFilePath)) > 0 Then
'File exists
If UCase$(Right$(sFilePath, 3)) = "EXE" Then
'Register/Unregister ActiveX EXE
If bRegister Then
'Register EXE
Shell sFilePath & " /REGSERVER", vbHide
Else
'Unregister ActiveX EXE
Shell sFilePath & " /UNREGSERVER", vbHide
End If
RegisterComponent = True
Else
'Register/Unregister DLL
If bRegister Then
sRegister = "DllRegisterServer"
Else
sRegister = "DllUnRegisterServer"
End If

'Load library into current process
lLibAddress = LoadLibraryA(sFilePath)

If lLibAddress Then
'Get address of the DLL function
lProcAddress = GetProcAddress(lLibAddress, sRegister)
If lProcAddress Then
lThread = CreateThread(ByVal 0&, 0&, ByVal lProcAddress, ByVal 0&, 0&, lThread)
If lThread Then
'Created thread and wait for it to terminate
lSuccess = (WaitForSingleObject(lThread, clMaxTimeWait) = 0)
If Not lSuccess Then
'Failed to register, close thread
Call GetExitCodeThread(lThread, lExitCode)
Call ExitThread(lExitCode)
RegisterComponent = False
Else
'Successfully registered component
RegisterComponent = True
Call CloseHandle(lThread)
End If
End If
Call FreeLibrary(lLibAddress)
Else
'Object doesn't expose OLE interface
Call FreeLibrary(lLibAddress)
End If
End If
End If
End If
Exit Function
ErrFailed:
Debug.Print Err.Description
Debug.Assert False
On Error GoTo 0
End Function

میخوام ببینم درست عمل میکنه یا نه ؟
ممنون