當(dāng)你的程序執(zhí)行時(shí)間較長(zhǎng)時(shí)，使用一個(gè)進(jìn)度條來(lái)展示程序執(zhí)行的狀態(tài)是非常必要的。
進(jìn)度條設(shè)計(jì)
打開(kāi)VBE，插入一個(gè)用戶(hù)窗體。
1.在屬性窗口中，將該用戶(hù)窗體命名為urfProgress。
2.設(shè)置其ShowModal屬性為False，這樣在該用戶(hù)窗體處于打開(kāi)狀態(tài)時(shí)仍能繼續(xù)運(yùn)行程序。
3.調(diào)整該用戶(hù)窗體為合適的大小（高110*寬240）。
進(jìn)行適當(dāng)設(shè)置后，目前表示進(jìn)度條的用戶(hù)窗體如下圖1所示。
圖6
編寫(xiě)程序
隱藏標(biāo)題欄
在VBE中插入一個(gè)標(biāo)準(zhǔn)模塊，輸入下面使用Windows API的代碼來(lái)隱藏用戶(hù)窗體的標(biāo)題欄：
Public Const GWL_STYLE = -16
Public Const WS_CAPTION = &HC00000
#If VBA7 Then
Public Declare PtrSafe Function GetWindowLong _
Lib “user32” Alias “GetWindowLongA” ( _
ByVal hWnd As Long,_
ByVal nIndex As Long) As Long
Public Declare PtrSafe Function SetWindowLong _
Lib “user32” Alias “SetWindowLongA” ( _
ByVal hWnd As Long,_
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Public Declare PtrSafe Function DrawMenuBar_
Lib “user32” ( _
ByVal hWnd As Long) As Long
Public Declare PtrSafe Function FindWindowA_
Lib “user32” (ByVallpClassName As String, _
ByVal lpWindowName As String) As Long
#Else
Public Declare Function GetWindowLong _
Lib “user32” Alias “GetWindowLongA” ( _
ByVal hWnd As Long, _
ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong _
Lib “user32” Alias “SetWindowLongA” ( _
ByVal hWnd As Long,_
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Public Declare Function DrawMenuBar _
Lib”user32″ ( _
ByVal hWnd As Long) As Long
Public Declare Function FindWindowA _
Lib”user32″ (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
#End If
Sub HideTitleBar(frm As Object)
Dim lngWindow As Long
Dim lFrmHdl As Long
lFrmHdl = FindWindowA(vbNullString,frm.Caption)
lngWindow = GetWindowLong(lFrmHdl,GWL_STYLE)
lngWindow = lngWindow And (Not WS_CAPTION)
Call SetWindowLong(lFrmHdl, GWL_STYLE,lngWindow)
Call DrawMenuBar(lFrmHdl)
End Sub
用戶(hù)窗體初始化
在用戶(hù)窗體urfProgress中，添加Initialize事件代碼：
Private Sub UserForm_Initialize()
Me.Height = Me.Height – 10
HideTitleBar.HideTitleBar Me
End Sub
顯示進(jìn)度條
本文的示例以遍歷工作表所有已使用的行來(lái)更新進(jìn)度條：
Sub DemoProgress()
Dim i As Long
Dim lngLastRow As Long
Dim pct As Single
lngLastRow = Range(“A” &Rows.Count).End(xlUp).Row
‘進(jìn)度條寬度從0開(kāi)始
urfProgress.lblProgress.Width = 0
urfProgress.Show
For i = 1 To lngLastRow
pct = i / lngLastRow
‘計(jì)算進(jìn)度條百分比并增加相應(yīng)寬度
With urfProgress
.lblCaption.Caption = “正在處理” & lngLastRow &”行中的第” & i & “行.”
.lblProgress.Width = pct *(.fraProgress.Width)
End With
DoEvents
‘可以在這里插入真正要執(zhí)行操作的程序
‘如果進(jìn)度完成則卸載用戶(hù)窗體
If i = lngLastRow Then Unload urfProgress
Next i
End Sub
運(yùn)行程序后的效果如下圖7所示。
圖7
上面的示例是在程序中剛好也有循環(huán)時(shí)，在執(zhí)行循環(huán)過(guò)程的同時(shí)顯示進(jìn)度條。但是，如果沒(méi)有循環(huán)呢？也可以模擬程序執(zhí)行進(jìn)度：
Sub DemoProgress2()
‘開(kāi)始顯示進(jìn)度條
urfProgress.lblProgress.Width = 0
urfProgress.Show
‘模擬完成進(jìn)度
DoPrecent (0)
‘放置程序代碼
‘模擬完成進(jìn)度
DoPrecent (0.25)
‘放置程序代碼
‘模擬完成進(jìn)度
DoPrecent (0.5)
‘放置程序代碼
‘模擬完成進(jìn)度
DoPrecent (0.75)
‘放置程序代碼
‘模擬完成進(jìn)度
DoPrecent (1)
‘卸載窗體,即關(guān)閉進(jìn)度條
Unload urfProgress
EndSub
Sub DoPrecent(pctdone As Single)
With urfProgress
.lblCaption.Caption = pctdone * 100& “% 完成”
.lblProgress.Width = pctdone *(.fraProgress.Width)
End With
DoEvents
End Sub
如果過(guò)程占用大量資源，可能會(huì)發(fā)現(xiàn)進(jìn)度條不更新或顯示為白色，此時(shí)可在End With前面添加代碼：
urfProgress.Repaint
強(qiáng)制VBA重新繪制進(jìn)度條，這樣在每次更改用戶(hù)窗體時(shí)都會(huì)更新。
