VB 自动安装捆绑控件的模块

' ================================================
' 安装程序控件V1.1
' 作者：Huang Guan
' 2005-2-1 14:50
' ================================================

' 获得系统目录路径
Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" ( ByVal lpBuffer As String , ByVal nSize As Long ) As Long
' 等待指定进程运行结束
Private Declare Function OpenProcess Lib "kernel32" ( ByVal dwDesiredAccess As Long , ByVal bInheritHandle As Long , ByVal dwProcessId As Long ) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" _
( ByVal hHandle As Long , ByVal dwMilliseconds As Long ) As Long
Private Declare Function CloseHandle Lib "kernel32" _
( ByVal hObject As Long ) As Long
Private Const INFINITE = - 1 &
Private Const SYNCHRONIZE = &H100000


Private Function GetSysDir() As String
Dim TmpSysPath As String * 256 , TmpLength As Byte
TmpLength = GetSystemDirectory(TmpSysPath, 256 )
GetSysDir = Left(TmpSysPath, TmpLength)
End Function
Private Function FileExist( ByVal FilePath As String ) As Boolean
If Dir(FilePath, vbNormal Or vbSystem Or vbHidden) <> "" Then
FileExist = True
Else
FileExist = False
End If
End Function
Private Function RunAndWait( ByVal FilePath As String , Optional LongTime As Long = 0 ) As Boolean
Dim pid As Long
Dim ExitEvent As Long
Dim hProcess As Long '进程句柄
pid = Shell(FilePath, vbNormalNoFocus)
hProcess = OpenProcess(SYNCHRONIZE, False , pid)
If LongTime = 0 Then
ExitEvent = WaitForSingleObject(hProcess, INFINITE)
Else
ExitEvent = WaitForSingleObject(hProcess, LongTime)
End If
RunAndWait = ExitEvent
ExitEvent = CloseHandle(hProcess)
End Function

Public Sub SetupCtrl( ByVal Files As String , ByVal ResID As String )
On Error GoTo ErrHandle
Dim arrCtrls() As String , TempFile() As Byte , arrRes() As String , SystemPath As String , FileNum As Integer
arrCtrls = Split(Files, "|" )
arrRes = Split(ResID, "|" )
SystemPath = GetSysDir
For i = 0 To UBound(arrCtrls)
If FileExist(SystemPath & "\" & arrCtrls(i)) = False Then
TempFile = LoadResData(arrRes(i), "CUSTOM" )
FileNum = FreeFile
Open SystemPath & "\" & arrCtrls(i) For Binary Access Write As #FileNum '新建文件(把 Winsock等 控件复制到指定目录下)
Put #FileNum, , TempFile
Close #FileNum
RunAndWait "regsvr32 " & SystemPath & "\" & arrCtrls(i) & " /s" , 0 '注册控件,无弹出对话框
End If
Next
Exit Sub
ErrHandle:
MsgBox Err.Description
End Sub