VBA实战技巧30：创建自定义的进度条1
宏是Excel中最好的工具之一，可以让我们节省时间。
使用VBA宏，可以自动执行重复、单调且有时非常无聊的任务。在某些情况下，这有可能将数小时的工作减少到几分钟或几秒钟。
但并非所有宏都可以实现此类性能要求，有时候数据实在太庞大了，电脑只能运行这么快。在极端情况下，任务可能进展得极其缓慢，以致我们认为系统可能已锁定或崩溃。
因此，发明了进度条。
在Windows的早期，机器被认为是缓慢且容易崩溃的。通过向用户提供进度的视觉指示器，我们知道系统仍在工作，并且可以合理猜测任务何时完成。
在宏执行可能需要相当长时间的情况下，为用户提供进度条是一个不错的选择。
本文所介绍的进度条创建过程代码可以用于其他任务中，示例中，我们的自动化过程将遍历表中的记录，在每条记录处暂停1/10秒。
1.设置可视化界面
使用VBA的用户窗体创建进度条。首先，在VBE中，单击“插入——用户窗体”，结果如下图1所示。
图1
重新命名该窗体名称为“UserForm_v1”，标题为“创建PDF文档”，如下图2所示。
图2
在窗体中：
- 插入一个标签并设置合适的标题；
- 插入一幅图像；
- 插入一个框架，用作滚动条的边框并显示数字百分比计数器。将其标题设置为“0%”，这将在代码执行期间更改为读取进度百分比。
- 在框架内，插入另一个标签，该标签将不包含文本，而是充当滚动条。这是通过为标签内部着色并逐渐调整其大小来执行的，随着宏的执行，它会越来越大。标签的属性可能是：BackColor– &H00C00000& (蓝色)，BackStyle –1-fmBackStyleOpaque，BorderColor– &H80000006& (灰色)，Height – 30，SpecialEffect –1-fmSpecialEffectRaised，Width –18。
结果如下图3所示。
图3
2.编写用户窗体代码
双击用户窗体进入其代码模块，在UserForm_Activate事件中，输入代码。
声明变量如下：
Dim startrow As Integer
Dim endrow As Integer
Dim i As Integer
Dim myScrollTest As Object
关闭屏幕更新和警告消息：
Application.ScreenUpdating = False
Application.DisplayAlerts = False
检查确保表中至少有一条被处理的记录：
With myScrollTest
'起始位置
startrow= .Range("A1").Row + 1
'结束位置
endrow =.Range("A1").End(xlDown).Row
If .Range("A2").Value= "" Then
MsgBox "请从第 2 行开始粘贴您的实体代码."
ExitSub
End If
End With
遍历表中的行：
'开始遍历
For i = startrow To endrow
Pct = (i - startrow + 1) / (endrow - startrow + 1)
Call UpdateProgress(Pct)
'这是你的工作簿执行许多需要一些时间的事情的地方
startTime = Timer '捕获当前时间
Do
Loop Until Timer - startTime >= 0.1 '1/10 秒后前进
'这是你的工作簿完成重复工作的地方
Next i
上述代码中：
- 表中有“N”行，循环将执行“N”次。
- PCT = 计算出不断增加的百分比，从1/N开始，以N/N结束（即1%到100%）。表中的记录越多，百分比计算的粒度就越细。
- 计时器将计数到1/10秒，从而产生非常小的暂停效果，这可以防止进度条在此演示中移动得太快。在实际中，可能希望忽略这种自我限制的“暂停”，因为它会妨碍性能。
- Call UpdateProgress(Pct)行将计算出的百分比(Pct)传递给UpdateProgress，该百分比将显示在框架的标题中。
完成时从屏幕移除窗体：
Unload UserForm_v1
3.启动用户窗体
插入一个标准模块，输入下面的代码：
Load UserForm_v1
With UserForm_v1
.StartUpPosition = 0
.Left =Application.Left + (0.5 * Application.Width) - (0.5 * .Width)
.Top =Application.Top + (0.5 * Application.Height) - (0.5 * .Height)
.Show
End With
为了确保用作进度条的用户窗体显示在屏幕中央，使用一些巧妙的数学计算中心位置。计算完成后，我们显示内存加载的用户窗体。
4.宣告代码完成
可以通过多种方式通知用户代码已完成。这里的代码将显示一个消息框，通知用户从打印机获取他们的报告。
MsgBox "生成报告完成" & vbLf& vbLf _
&"请从打印机取回你的报告",vbInformation
5.清理
重新启用屏幕更新和警告消息。
Application.ScreenUpdating = True
Application.DisplayAlerts = True
6.使滚动条“拉伸”
上面的代码调用了另一个名为“UpdateProgress”的宏，向该宏传递了一个存储在名为 Pct的变量中的值。
Call UpdateProgress(Pct)
变量Pct中的值有两个用途：
- Pct的值显示在框架的标题中
- Pct用于计算标签对象的Width属性
- .Repaint指令强制标签对象根据新计算的Width进行可视化刷新
With UserForm_v1
.FrameProgress.Caption = Format(Pct, "0%")
.LabelProgress.Width = Pct * (.FrameProgress.Width - 10)
.Repaint
End With
通过以越来越宽地重新绘制标签对象，实现了标签对象正在增长的错觉。巧妙！
“DoEvents”指令允许VBA通过键盘检测用户交互，这在用户可能希望早点退出长时间循环的宏很有用。
7.将宏指定给按钮
添加一个Excel图标图像并将宏指定给该图像，这是通过右键单击图像并选择“指定宏”来实现的。
8.测试进度条
结果如下图4所示。
图4
完整的代码如下：
1.标准模块中的代码
Sub GetMyForm_v1()
Load UserForm_v1
With UserForm_v1
.StartUpPosition= 0
.Left= Application.Left + (0.5 * Application.Width) - (0.5 * .Width)
.Top= Application.Top + (0.5 * Application.Height) - (0.5 * .Height)
.Show
End With
End Sub
2.用户窗体模块中的代码
Private Sub UserForm_Activate()
Dim startrow As Integer
Dim endrow As Integer
Dim i As Integer
Dim myScrollTest As Object
Set mainbook = ThisWorkbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set myScrollTest = Worksheets("ScrollTest_v1")
mylabel =Worksheets("ScrollTest_v1").Range("A2").Value
With myScrollTest
'起始位置
startrow = .Range("A1").Row + 1
'结束位置
endrow = .Range("A1").End(xlDown).Row
If .Range("A2").Value = "" Then
MsgBox "请从第 2 行开始粘贴您的实体代码."
Exit Sub
End If
End With
'开始遍历
For i =startrow To endrow
Pct =(i - startrow + 1) / (endrow - startrow + 1)
Call UpdateProgress(Pct)
'这是你的工作簿执行许多需要一些时间的事情的地方
startTime = Timer '捕获当前时间
Do
Loop Until Timer - startTime >= 0.1 '1/10 秒后前进
'这是你的工作簿完成重复工作的地方
Next i
Unload UserForm_v1
myScrollTest.Select
MsgBox"生成报告完成"& vbLf & vbLf _
&"请从打印机取回你的报告",vbInformation
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Sub UpdateProgress(Pct)
With UserForm_v1
.FrameProgress.Caption = Format(Pct, "0%")
.LabelProgress.Width = Pct * (.FrameProgress.Width - 10)
.Repaint
End With
DoEvents
End Sub