使用VB6写一个自定义的进度信息框窗口

一、起因说明

之前有些项目是用Access完成的，当时为了给用户显示一些进度信息，自制了一个进度信息窗体，类似下图所示：

随着项目不断变迁，需要将进度信息按阶段及子进度进行显示，并且出于代码封装的需求，需要将其封装到一个dll文件中。最终完成的效果如下图：

调用该进度信息框的代码类似如下所示：

 1 Private Sub cmdCommand1_Click()
 2     Dim pb As New CProgressBar
 3     pb.AddStage "第一步", 10000
 4     pb.AddStage "第二步", 10000
 5     pb.AddStage "第三步", 10000
 6     pb.AddStage "第四步", 10000
 7     Do Until pb.IsCompleted
 8         pb.NextStep
 9     Loop
10 End Sub

二、设计思路

制作这个Dll，我使用的是VB6，因为考虑到可能在后续的Access项目或者VB6项目中使用，所以没有用VB.net或者Delphi来开发。完成这个项目我建立了1个解决方案，包括2个项目文件，一个是dll项目工程文件，其二是测试工程。

如上图1、2、3包含在dll项目工程中，4在测试工程中，注意要将测试工程设置为启动工程。

1、FProgressBar：进度条窗体模块，主要是界面元素设计，仅提供与界面相关的功能，如刷新显示内容的方法与函数，借鉴MVC概念里的View；

2、CLayoutHelper：窗体布局辅助器，主要为无边框窗体添加外边框、移动控制功能、添加关闭按钮等布局特性；

3、CProgressBar：进度条类模块，该类模块可以被测试工程访问，注意需要将其设置成MultiUse，该模块提供了所有进度条逻辑功能，借鉴MVC概念里的Control的概念；

FProgressBar设计示意

FProgressBar窗体中控件的布局情况如下左图所示，所包含的控件命名清单如下右图所示;

 1 '///////////////////////////////////////////////////////////////////////////////
 2 '模块名称： CProgressBar：进度条显示窗体模块
 3 '相关模块： CLayoutHelper：
 4 '///////////////////////////////////////////////////////////////////////////////
 5 
 6 Private m_LayoutHelper As CLayoutHelper
 7 Private Const BAR_MARGIN = 30
 8 Private mStartTime As Single
 9 
10 Private Sub Form_Initialize()
11     Set m_LayoutHelper = New CLayoutHelper
12     m_LayoutHelper.StartLayout Me, "", Me.ScaleHeight - 70, 0, 30
13     Me.lblStartTime.Caption = Format(Now, "yyyy/m/d h:mm:ss")
14     Me.lblEndTime.Caption = ""
15     Me.lblTotalTime.Caption = ""
16     mStartTime = Timer
17 End Sub
18 
19 Private Sub Form_Unload(Cancel As Integer)
20     Set m_LayoutHelper = Nothing
21 End Sub
22 
23 '设置总进度结束时间信息
24 Public Sub SetEndTime()
25     Me.lblEndTime.Caption = Format(Now, "yyyy/m/d h:mm:ss")
26 End Sub
27 
28 '重画总进度条及其文本内容
29 Public Sub DrawStage(Caption As String, Position As Double)
30     DrawBar picStage, Caption, Position
31 End Sub
32 
33 '重画子进度条及其文本内容
34 Public Sub DrawStep(Position As Double)
35     DrawBar picStep, Format(Position, "0%"), Position
36     Me.lblTotalTime.Caption = GetPassedTime()
37 End Sub
38 
39 '根据起始时间与结束时间计算累计的时间数，返回“×时×分×秒”格式字符串
40 Private Function GetPassedTime() As String
41     Dim mHour As Long, mMinute As Long, mSecond As Long
42     Dim mPassTime As Single
43     mPassTime = Timer - mStartTime
44     mHour = mPassTime  (60 ^ 2)
45     mMinute = (mPassTime - mHour * (60 ^ 2))  60
46     mSecond = mPassTime - mHour * (60 ^ 2) - mMinute * 60
47     GetPassedTime = mHour & "时" & mMinute & "分" & mSecond & "秒"
48 End Function
49 
50 '画进度条的过程
51 Private Sub DrawBar(TargetBar As PictureBox, Caption As String, Position As Double)
52     '画背景进度条
53     TargetBar.Cls
54     TargetBar.ForeColor = RGB(0, 255, 0)
55     TargetBar.Line (BAR_MARGIN, BAR_MARGIN)-Step((TargetBar.ScaleWidth - BAR_MARGIN * 2) * Position, _
56         TargetBar.ScaleHeight - BAR_MARGIN * 2), , BF
57     '画进度文字信息
58     TargetBar.ForeColor = RGB(255, 0, 0)
59     TargetBar.FontSize = 10
60     TargetBar.FontBold = True
61     TargetBar.CurrentX = (TargetBar.ScaleWidth - TargetBar.TextWidth(Caption)) / 2
62     TargetBar.CurrentY = (TargetBar.ScaleHeight - TargetBar.TextHeight(Caption)) / 2
63     TargetBar.Print Caption
64 End Sub

CLayoutHelper代码示意

CLayoutHelper模块为无边框窗体提供鼠标拖动功能、增添外边框、添加关闭按钮、置顶等功能。其中的MoveBar用于拖动窗体，LineBar是MoveBar与内容区域的分割线，FProgressBar的MoveBar与窗体同高，LineBar为0，可以点击FProgressBar所有位置进行拖动。TitleLabel用于在MoveBar左上角显示文本信息。

  1 '///////////////////////////////////////////////////////////////////////////////
  2 '模块名称： CLayoutHelper：控制动态库中包含窗口的布局
  3 '相关模块：
  4 '///////////////////////////////////////////////////////////////////////////////
  5 
  6 Private WithEvents m_TargetForm As VB.Form
  7 Private WithEvents m_MoveBar As Label
  8 Private m_TitleLabel As Label
  9 Private m_LineBar As Label
 10 Private m_BackGround As Label
 11 Private WithEvents m_CloseBarBG As Label
 12 Private WithEvents m_CloseBar As Label
 13 Private m_PrePos As Point
 14 
 15 Private m_MoveBarHeight As Long
 16 Private m_LineBarHeight As Long
 17 Private m_BorderWidth As Long
 18 
 19 Private m_MoveBarColor As Long
 20 Private m_LineBarColor As Long
 21 Private m_BorderColor As Long
 22 
 23 Private Sub Class_Initialize()
 24     m_MoveBarColor = RGB(190, 205, 219)
 25     m_LineBarColor = RGB(140, 140, 140)
 26     m_BorderColor = RGB(0, 0, 0)
 27 End Sub
 28 
 29 Public Property Get MoveBarColor() As Long
 30     MoveBarColor = m_MoveBarColor
 31 End Property
 32 
 33 Public Property Let MoveBarColor(ByVal vData As Long)
 34     m_MoveBarColor = vData
 35     m_MoveBar.BackColor = vData
 36     m_CloseBarBG.BackColor = vData
 37 End Property
 38 
 39 Public Property Get LineBarColor() As Long
 40     LineBarColor = m_LineBarColor
 41 End Property
 42 
 43 Public Property Let LineBarColor(ByVal vData As Long)
 44     m_LineBarColor = vData
 45     m_LineBar.BackColor = vData
 46 End Property
 47 
 48 Public Property Get BorderColor() As Long
 49     BorderColor = m_BorderColor
 50 End Property
 51 
 52 Public Property Let BorderColor(ByVal vData As Long)
 53     m_BorderColor = vData
 54     m_TargetForm.BackColor = vData
 55 End Property
 56 
 57 Public Property Set TargetForm(ByVal vData As VB.Form)
 58     Set m_TargetForm = vData
 59     m_TargetForm.BackColor = RGB(0, 0, 0)
 60 End Property
 61 
 62 Public Property Get Title() As String
 63     Title = m_TitleLabel.Caption
 64 End Property
 65 
 66 Public Property Let Title(ByVal vData As String)
 67     m_TitleLabel.Caption = vData
 68 End Property
 69 
 70 Public Property Get MoveBarHeight() As Long
 71     MoveBarHeight = m_MoveBarHeight
 72 End Property
 73 
 74 Public Property Let MoveBarHeight(ByVal vData As Long)
 75     If vData <= 0 Then
 76         m_MoveBarHeight = 700
 77     Else
 78         m_MoveBarHeight = vData
 79     End If
 80 End Property
 81 
 82 Public Property Get LineBarHeight() As Long
 83     LineBarHeight = m_LineBarHeight
 84 End Property
 85 
 86 Public Property Let LineBarHeight(ByVal vData As Long)
 87     If vData < 0 Then
 88         m_LineBarHeight = 0
 89     Else
 90         m_LineBarHeight = vData
 91     End If
 92 End Property
 93 
 94 Public Property Get BorderWidth() As Long
 95     BorderWidth = m_BorderWidth
 96 End Property
 97 
 98 Public Property Let BorderWidth(ByVal vData As Long)
 99     If vData <= 0 Then
100         m_BorderWidth = 30
101     Else
102         m_BorderWidth = vData
103     End If
104 End Property
105 
106 Public Property Get InnerLeft() As Long
107     InnerLeft = m_BorderWidth
108 End Property
109 
110 Public Property Get InnerTop() As Long
111     InnerTop = m_BorderWidth + m_MoveBar.Height + m_LineBar.Height
112 End Property
113 
114 Public Property Get InnerWidth() As Long
115     InnerWidth = m_TargetForm.ScaleWidth - 2 * m_BorderWidth
116 End Property
117 
118 Public Property Get InnerHeight() As Long
119     InnerHeight = m_TargetForm.ScaleHeight - 2 * m_BorderWidth - m_MoveBar.Height - m_LineBar.Height
120 End Property
121 
122 Public Sub StartLayout(Optional TargetForm As VB.Form = Nothing, _
123     Optional TitleText As String = "信息提示", _
124     Optional MoveBarHeight As Long = 700, _
125     Optional LineBarHeight As Long = 30, _
126     Optional BorderWidth As Long = 30, _
127     Optional TopMost As Boolean = True)
128 
129     If TargetForm Is Nothing And m_TargetForm Is Nothing Then Exit Sub
130     Set Me.TargetForm = TargetForm
131     Me.MoveBarHeight = MoveBarHeight
132     Me.LineBarHeight = LineBarHeight
133     Me.BorderWidth = BorderWidth
134 
135     Set m_CloseBar = CreateCloseLabel(m_TargetForm, RGB(0, 0, 0))
136     Set m_CloseBarBG = CreateCloseBGLabel(m_TargetForm, m_MoveBarColor)
137     Set m_TitleLabel = CreateTitleLabel(m_TargetForm, TitleText)
138     Set m_MoveBar = CreateLabel(m_TargetForm, m_CloseBarBG.BackColor)
139     Set m_LineBar = CreateLabel(m_TargetForm, m_LineBarColor)
140 '    If LineBarHeight = 0 Then m_LineBar.Visible = False
141 
142     Call ResizeForm
143     If TopMost Then Call BringToTop
144 End Sub
145 
146 Private Function CreateTitleLabel(TargetForm As VB.Form, Text As String) As Label
147     Dim m_label As Label
148     Static iCount As Long
149     iCount = iCount + 1
150     Set m_label = TargetForm.Controls.Add("VB.Label", "TitleLabel" & iCount)
151     m_label.BackStyle = 0  '透明
152     m_label.BorderStyle = 0 'none
153     m_label.Appearance = 0  'flat
154     m_label.AutoSize = True
155     m_label.FontBold = True
156     m_label.FontSize = 12
157     m_label.Caption = Text
158     m_label.Visible = True
159     Set CreateTitleLabel = m_label
160     Set m_label = Nothing
161 End Function
162 
163 Private Function CreateLabel(TargetForm As VB.Form, BackColor As Long) As Label
164     Dim m_label As Label
165     Static iCount As Long
166     iCount = iCount + 1
167     Set m_label = TargetForm.Controls.Add("VB.Label", "udfLabel" & iCount)
168     m_label.BackStyle = 1   'opaque
169     m_label.BorderStyle = 0 'none
170     m_label.Appearance = 0  'flat
171     m_label.AutoSize = False
172     m_label.BackColor = BackColor
173     m_label.Visible = True
174     Set CreateLabel = m_label
175     Set m_label = Nothing
176 End Function
177 
178 Private Function CreateCloseBGLabel(TargetForm As VB.Form, BackColor As Long) As Label
179     Dim m_label As Label
180     Static iCount As Long
181     iCount = iCount + 1
182     Set m_label = TargetForm.Controls.Add("VB.Label", "udfCloseBGLabel" & iCount)
183     m_label.BackStyle = 1   'opaque
184     m_label.BorderStyle = 0 'none
185     m_label.Appearance = 0  'flat
186     m_label.AutoSize = False
187     m_label.BackColor = BackColor
188     m_label.Width = 400
189     m_label.Height = m_label.Width
190     m_label.Visible = True
191 
192     Set CreateCloseBGLabel = m_label
193     Set m_label = Nothing
194 End Function
195 
196 Private Function CreateCloseLabel(TargetForm As VB.Form, ForeColor As Long) As Label
197     Dim m_label As Label
198     Static iCount As Long
199     iCount = iCount + 1
200     Set m_label = TargetForm.Controls.Add("VB.Label", "udfCloseLabel" & iCount)
201     m_label.BackStyle = 0   'Transparent
202     m_label.BorderStyle = 0 'none
203     m_label.Appearance = 0  'flat
204     m_label.AutoSize = True
205     m_label.ForeColor = ForeColor
206     m_label.FontBold = True
207     m_label.FontSize = 12
208     m_label.Caption = "×"
209     m_label.Visible = True
210     Set CreateCloseLabel = m_label
211     Set m_label = Nothing
212 End Function
213 
214 Private Sub m_CloseBar_Click()
215     Unload m_TargetForm
216 End Sub
217 
218 Private Sub m_CloseBarBG_Click()
219     Unload m_TargetForm
220 End Sub
221 
222 Private Sub m_CloseBar_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
223     m_CloseBar.ForeColor = RGB(255, 255, 255)
224     m_CloseBarBG.BackColor = m_BorderColor
225 End Sub
226 
227 Private Sub m_CloseBarBG_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
228     m_CloseBar.ForeColor = RGB(255, 255, 255)
229     m_CloseBarBG.BackColor = m_BorderColor
230 End Sub
231 
232 Private Sub ResizeForm()
233     m_MoveBar.Move Me.BorderWidth, Me.BorderWidth, m_TargetForm.Width - Me.BorderWidth * 2, m_MoveBarHeight
234     m_TitleLabel.Move m_MoveBar.Left + 200, m_MoveBar.Top + (m_MoveBar.Height - m_TitleLabel.Height) / 2
235     m_CloseBarBG.Move m_MoveBar.Left + m_MoveBar.Width - m_CloseBarBG.Width - 10, Me.BorderWidth
236     m_CloseBar.Move m_CloseBarBG.Left + (m_CloseBarBG.Width - m_CloseBar.Width) / 2, _
237         m_CloseBarBG.Top + (m_CloseBarBG.Height - m_CloseBar.Height) / 2 - 40
238     m_LineBar.Move Me.BorderWidth, Me.BorderWidth + m_MoveBarHeight, m_TargetForm.Width - Me.BorderWidth * 2, m_LineBarHeight
239 End Sub
240 
241 Private Sub m_MoveBar_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
242     If (Button And vbLeftButton) > 0 Then
243         m_PrePos.X = X
244         m_PrePos.Y = Y
245     End If
246 End Sub
247 
248 Private Sub m_MoveBar_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
249     If m_TargetForm.WindowState = 2 Then Exit Sub
250     If (Button And vbLeftButton) > 0 Then
251         m_TargetForm.Move m_TargetForm.Left + X - m_PrePos.X, m_TargetForm.Top + Y - m_PrePos.Y
252     End If
253     m_CloseBar.ForeColor = RGB(0, 0, 0)
254     m_CloseBarBG.BackColor = m_MoveBar.BackColor
255 End Sub
256 
257 Private Sub BringToTop()
258     SetWindowPos m_TargetForm.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE  '窗体置顶
259 End Sub

CProgressBar代码示意

CProgressBar的代码内容并不多，主要完成整个进度条控件的功能调度，并完成一些逻辑控制操作，代码如下所示：

 1 '///////////////////////////////////////////////////////////////////////////////
 2 '模块名称： CProgressBar：进度条显示窗体模块
 3 '相关模块： CLayoutHelper：
 4 '///////////////////////////////////////////////////////////////////////////////
 5 Private Type StageInfo
 6     Caption As String
 7     StepNumber As Integer
 8 End Type
 9 
10 Private mProgressBar As FProgressBar    '进度信息窗体对象
11 Private mStages() As StageInfo          '进度阶段信息数组
12 Private mLength As Integer              '数组的长度
13 Private mCurrentStage As Integer        '当前所处的阶段号
14 Private mCurrentStep As Integer         '当前所处的子进度号
15 Private mIsCompleted As Boolean         '是否所有进度完成
16 
17 Property Get IsCompleted() As Boolean
18 On Error GoTo Exit_Handler
19     If mCurrentStage = UBound(mStages) And _
20             mCurrentStep = mStages(mCurrentStage).StepNumber Then
21         mIsCompleted = True
22         mProgressBar.SetEndTime
23     End If
24     IsCompleted = mIsCompleted
25     Exit Property
26 Exit_Handler:
27     IsCompleted = False
28 End Property
29 
30 '添加一条阶段进度初始信息
31 Public Sub AddStage(Caption As String, StepNumber As Integer)
32     mLength = mLength + 1
33     ReDim Preserve mStages(1 To mLength)
34     mStages(mLength).Caption = Caption
35     mStages(mLength).StepNumber = StepNumber
36 End Sub
37 
38 Public Sub NextStep()
39     If mProgressBar.Visible = False Then mProgressBar.Show
40     If mLength = 0 Or mStages(UBound(mStages)).StepNumber = 0 Then Exit Sub
41     If Me.IsCompleted Then Exit Sub
42     If mCurrentStage = 0 Then
43         mCurrentStage = 1
44         mProgressBar.DrawStage mStages(mCurrentStage).Caption, mCurrentStage / mLength
45     End If
46     mCurrentStep = mCurrentStep + 1
47     If mCurrentStep > mStages(mCurrentStage).StepNumber Then
48         mCurrentStep = 1
49         mCurrentStage = mCurrentStage + 1
50         mProgressBar.DrawStage mStages(mCurrentStage).Caption, mCurrentStage / mLength
51     End If
52     mProgressBar.DrawStep mCurrentStep / mStages(mCurrentStage).StepNumber
53     DoEvents
54 End Sub
55 
56 Private Sub Class_Initialize()
57     Set mProgressBar = New FProgressBar
58 End Sub
59 
60 Private Sub Class_Terminate()
61     Set mProgressBar = Nothing
62 End Sub