日志

[转]自动安装捆绑控件的模块

已有 260 次阅读2008-3-9 20:19 |个人分类:API

获得系统目录路径
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

收藏分享邀请使用道具 | 编辑| 删除|

的个人空间 http://www.office-cn.net/?0 [收藏] [复制] [分享] [RSS]

日志

[转]自动安装捆绑控件的模块

评论 (0 个评论)