vb 进度条问题请教？
用VB写了个运行外部程序的工具，想在运行外部程序时，在FORM窗体上显示该程序的进度条，现在是外部程序是可以运行了，可是运行时窗体上什么动作都没有，现在的想法是，能不能在窗体上做一个进度条来显示程序的运行进程，请高手花点时间帮帮忙，在此谢谢了！
我的代码如下：
Option Explicit
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (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 Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
Const PROCESS_QUERY_INFORMATION = &H400
Const STILL_ALIVE = &H103
Const INFIN99vE = &HFFFF
Private ExitCode As Long
Private hProcess As Long
Private isDone As Long
Private Sub Form_Load()
Dim DrvNum As Single
Dim DrvName As String
Dim DrvSys As String
Dim DrvSet As String
Dim DrvType As Integer
Dim i As Integer
Dim StrBuff As String
Dim rtn As Long
Me.AutoRedraw = True
Drvbox.Visible = False
StrBuff = Space(255)
rtn = GetWindowsDirectory(StrBuff, 255)
drvlisttitle.AddItem "盘符 " + "磁盘类型" + " 是否系统盘"
DrvNum = Asc("a") - 1
For i = 0 To Drvbox.ListCount
DrvNum = DrvNum + 1
DrvName = Chr(DrvNum) + ":\"
DrvType = GetDriveType(DrvName)
DrvSet = Left(StrBuff, 1)
DrvSys = Left(DrvName, 1)
Select Case GetDriveType(DrvName)
Case 3
If DrvSet = UCase(DrvSys) Then drvlist.AddItem Trim(UCase(Chr(DrvNum))) + " 本地硬盘" + " 是" Else drvlist.AddItem Trim(UCase(Chr(DrvNum))) + " 本地硬盘" + " 否"
End Select
Next i
SELTYPE1.Value = False
SELTYPE2.Value = False
SELTYPE1.Caption = "FAT32"
SELTYPE2.Caption = "NTFS"
enter.Enabled = False
End Sub
Private Sub SELTYPE1_Click()
If SELTYPE1.Value = True And drvlist.Text <> "" Then enter.Enabled = True
End Sub
Private Sub SELTYPE2_Click()
If SELTYPE2.Value = True And drvlist.Text <> "" Then enter.Enabled = True
End Sub
Private Sub drvlist_Click()
If drvlist.Text <> "" And SELTYPE1.Value = True Or SELTYPE2.Value = True Then enter.Enabled = True
End Sub
Private Sub enter_Click()
Dim ParPath As String, SelTypeV As String
ParPath = Left(drvlist.Text, 1) + ":"
If SELTYPE1.Value = True Then SelTypeV = "FAT32" Else If SELTYPE2.Value = True Then SelTypeV = "NTFS" Else MsgBox "请选择格式类型！"
Dim str2 As Integer
str2 = MsgBox("安装程序将要对你选择的分区格式,你确认要格式化吗?", vbOKCancel, "格式化确认")
If str2 = vbOK Then
settext.Visible = False
drvlisttitle.Visible = False
drvlist.Visible = False
fortype.Visible = False
SELTYPE1.Visible = False
SELTYPE2.Visible = False
enter.Enabled = False
title.FontSize = 12
title.Top = 800
title.Caption = "正在格式化你选择的分区,请稍候...."
Dim ForPro As Long, BTSect As Long, CopySys As Long, lngPHandle As Long, PathCD As String, i As Integer, DrvNum As Single, DrvName As String
DrvNum = Asc("a") - 1
For i = 0 To Drvbox.ListCount
DrvNum = DrvNum + 1
DrvName = Chr(DrvNum) + ":\"
Select Case GetDriveType(DrvName)
Case 5
PathCD = Trim(UCase(Chr(DrvNum))) + ":\SOURCES"
End Select
Next i
ForPro = Shell(PathCD + "\ " + ParPath + " /fs:" + SelTypeV + " /q /y", vbHide)
hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, 0, ForPro)
isDone = False
Do
cancel.Enabled = False
Call GetExitCodeProcess(hProcess, ExitCode)
Debug.Print ExitCode
DoEvents
Loop While ExitCode = STILL_ALIVE
Call CloseHandle(hProcess)
isDone = True
title.Caption = "正在设置分区,请稍候...."
BTSect = Shell(PathCD + ".\btsect.exe /NT52 " + ParPath, vbHide)
hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, 0, BTSect)
isDone = False
Do
Call GetExitCodeProcess(hProcess, ExitCode)
Debug.Print ExitCode
DoEvents
Loop While ExitCode = STILL_ALIVE
Call CloseHandle(hProcess)
isDone = True
title.Caption = "正在安装系统,这将需要几分钟时间,请稍候...."
CopySys = Shell(PathCD + ".\7z.exe x .\SOURCES\setup.exe -O" + ParPath + "\", vbHide)
hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, 0, CopySys)
isDone = False
Do
Call GetExitCodeProcess(hProcess, ExitCode)
Debug.Print ExitCode
DoEvents
Loop While ExitCode = STILL_ALIVE
Call CloseHandle(hProcess)
isDone = True
cancel.Enabled = True
title.Caption = "系统文件复制完成,请重新启动计算机以完成安装!"
enter.Visible = False
complete.Visible = True
End If
End Sub
Private Sub complete_Click()
Unload Me
End Sub
Private Sub cancel_Click()
Unload Me
End Sub
