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

一、起因说明

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

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

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

 Private Sub cmdCommand1_Click()
     Dim pb As New CProgressBar
     pb.AddStage "第一步",
     pb.AddStage "第二步",
     pb.AddStage "第三步",
     pb.AddStage "第四步",
     Do Until pb.IsCompleted
         pb.NextStep
     Loop
 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窗体中控件的布局情况如下左图所示，所包含的控件命名清单如下右图所示;

 '///////////////////////////////////////////////////////////////////////////////
 '模块名称： CProgressBar：进度条显示窗体模块
 '相关模块： CLayoutHelper：
 '///////////////////////////////////////////////////////////////////////////////

 Private m_LayoutHelper As CLayoutHelper
 Private Const BAR_MARGIN =
 Private mStartTime As Single

 Private Sub Form_Initialize()
     Set m_LayoutHelper = New CLayoutHelper
     m_LayoutHelper.StartLayout Me, "", Me.ScaleHeight - , ,
     Me.lblStartTime.Caption = Format(Now, "yyyy/m/d h:mm:ss")
     Me.lblEndTime.Caption = ""
     Me.lblTotalTime.Caption = ""
     mStartTime = Timer
 End Sub

 Private Sub Form_Unload(Cancel As Integer)
     Set m_LayoutHelper = Nothing
 End Sub

 '设置总进度结束时间信息
 Public Sub SetEndTime()
     Me.lblEndTime.Caption = Format(Now, "yyyy/m/d h:mm:ss")
 End Sub

 '重画总进度条及其文本内容
 Public Sub DrawStage(Caption As String, Position As Double)
     DrawBar picStage, Caption, Position
 End Sub

 '重画子进度条及其文本内容
 Public Sub DrawStep(Position As Double)
     DrawBar picStep, Format(Position, "0%"), Position
     Me.lblTotalTime.Caption = GetPassedTime()
 End Sub

 '根据起始时间与结束时间计算累计的时间数，返回“×时×分×秒”格式字符串
 Private Function GetPassedTime() As String
     Dim mHour As Long, mMinute As Long, mSecond As Long
     Dim mPassTime As Single
     mPassTime = Timer - mStartTime
     mHour = mPassTime \ ( ^ )
     mMinute = (mPassTime - mHour * ( ^ )) \
     mSecond = mPassTime - mHour * ( ^ ) - mMinute *
     GetPassedTime = mHour & "时" & mMinute & "分" & mSecond & "秒"
 End Function

 '画进度条的过程
 Private Sub DrawBar(TargetBar As PictureBox, Caption As String, Position As Double)
     '画背景进度条
     TargetBar.Cls
     TargetBar.ForeColor = RGB(, , )
     TargetBar.Line (BAR_MARGIN, BAR_MARGIN)-Step((TargetBar.ScaleWidth - BAR_MARGIN * ) * Position, _
         TargetBar.ScaleHeight - BAR_MARGIN * ), , BF
     '画进度文字信息
     TargetBar.ForeColor = RGB(, , )
     TargetBar.FontSize =
     TargetBar.FontBold = True
     TargetBar.CurrentX = (TargetBar.ScaleWidth - TargetBar.TextWidth(Caption)) /
     TargetBar.CurrentY = (TargetBar.ScaleHeight - TargetBar.TextHeight(Caption)) /
     TargetBar.Print Caption
 End Sub

CLayoutHelper代码示意

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

 '///////////////////////////////////////////////////////////////////////////////
 '模块名称： CLayoutHelper：控制动态库中包含窗口的布局
 '相关模块：
 '///////////////////////////////////////////////////////////////////////////////

 Private WithEvents m_TargetForm As VB.Form
 Private WithEvents m_MoveBar As Label
 Private m_TitleLabel As Label
 Private m_LineBar As Label
 Private m_BackGround As Label
 Private WithEvents m_CloseBarBG As Label
 Private WithEvents m_CloseBar As Label
 Private m_PrePos As Point

 Private m_MoveBarHeight As Long
 Private m_LineBarHeight As Long
 Private m_BorderWidth As Long

 Private m_MoveBarColor As Long
 Private m_LineBarColor As Long
 Private m_BorderColor As Long

 Private Sub Class_Initialize()
     m_MoveBarColor = RGB(, , )
     m_LineBarColor = RGB(, , )
     m_BorderColor = RGB(, , )
 End Sub

 Public Property Get MoveBarColor() As Long
     MoveBarColor = m_MoveBarColor
 End Property

 Public Property Let MoveBarColor(ByVal vData As Long)
     m_MoveBarColor = vData
     m_MoveBar.BackColor = vData
     m_CloseBarBG.BackColor = vData
 End Property

 Public Property Get LineBarColor() As Long
     LineBarColor = m_LineBarColor
 End Property

 Public Property Let LineBarColor(ByVal vData As Long)
     m_LineBarColor = vData
     m_LineBar.BackColor = vData
 End Property

 Public Property Get BorderColor() As Long
     BorderColor = m_BorderColor
 End Property

 Public Property Let BorderColor(ByVal vData As Long)
     m_BorderColor = vData
     m_TargetForm.BackColor = vData
 End Property

 Public Property Set TargetForm(ByVal vData As VB.Form)
     Set m_TargetForm = vData
     m_TargetForm.BackColor = RGB(, , )
 End Property

 Public Property Get Title() As String
     Title = m_TitleLabel.Caption
 End Property

 Public Property Let Title(ByVal vData As String)
     m_TitleLabel.Caption = vData
 End Property

 Public Property Get MoveBarHeight() As Long
     MoveBarHeight = m_MoveBarHeight
 End Property

 Public Property Let MoveBarHeight(ByVal vData As Long)
     If vData <=  Then
         m_MoveBarHeight =
     Else
         m_MoveBarHeight = vData
     End If
 End Property

 Public Property Get LineBarHeight() As Long
     LineBarHeight = m_LineBarHeight
 End Property

 Public Property Let LineBarHeight(ByVal vData As Long)
     If vData <  Then
         m_LineBarHeight =
     Else
         m_LineBarHeight = vData
     End If
 End Property

 Public Property Get BorderWidth() As Long
     BorderWidth = m_BorderWidth
 End Property

 Public Property Let BorderWidth(ByVal vData As Long)
     If vData <=  Then
         m_BorderWidth =
     Else
         m_BorderWidth = vData
     End If
 End Property

 Public Property Get InnerLeft() As Long
     InnerLeft = m_BorderWidth
 End Property

 Public Property Get InnerTop() As Long
     InnerTop = m_BorderWidth + m_MoveBar.Height + m_LineBar.Height
 End Property

 Public Property Get InnerWidth() As Long
     InnerWidth = m_TargetForm.ScaleWidth -  * m_BorderWidth
 End Property

 Public Property Get InnerHeight() As Long
     InnerHeight = m_TargetForm.ScaleHeight -  * m_BorderWidth - m_MoveBar.Height - m_LineBar.Height
 End Property

 Public Sub StartLayout(Optional TargetForm As VB.Form = Nothing, _
     Optional TitleText As String = "信息提示", _
     Optional MoveBarHeight As Long = , _
     Optional LineBarHeight As Long = , _
     Optional BorderWidth As Long = , _
     Optional TopMost As Boolean = True)

     If TargetForm Is Nothing And m_TargetForm Is Nothing Then Exit Sub
     Set Me.TargetForm = TargetForm
     Me.MoveBarHeight = MoveBarHeight
     Me.LineBarHeight = LineBarHeight
     Me.BorderWidth = BorderWidth

     Set m_CloseBar = CreateCloseLabel(m_TargetForm, RGB(, , ))
     Set m_CloseBarBG = CreateCloseBGLabel(m_TargetForm, m_MoveBarColor)
     Set m_TitleLabel = CreateTitleLabel(m_TargetForm, TitleText)
     Set m_MoveBar = CreateLabel(m_TargetForm, m_CloseBarBG.BackColor)
     Set m_LineBar = CreateLabel(m_TargetForm, m_LineBarColor)
 '    If LineBarHeight = 0 Then m_LineBar.Visible = False

     Call ResizeForm
     If TopMost Then Call BringToTop
 End Sub

 Private Function CreateTitleLabel(TargetForm As VB.Form, Text As String) As Label
     Dim m_label As Label
     Static iCount As Long
     iCount = iCount +
     Set m_label = TargetForm.Controls.Add("VB.Label", "TitleLabel" & iCount)
     m_label.BackStyle =   '透明
     m_label.BorderStyle =  'none
     m_label.Appearance =   'flat
     m_label.AutoSize = True
     m_label.FontBold = True
     m_label.FontSize =
     m_label.Caption = Text
     m_label.Visible = True
     Set CreateTitleLabel = m_label
     Set m_label = Nothing
 End Function

 Private Function CreateLabel(TargetForm As VB.Form, BackColor As Long) As Label
     Dim m_label As Label
     Static iCount As Long
     iCount = iCount +
     Set m_label = TargetForm.Controls.Add("VB.Label", "udfLabel" & iCount)
     m_label.BackStyle =    'opaque
     m_label.BorderStyle =  'none
     m_label.Appearance =   'flat
     m_label.AutoSize = False
     m_label.BackColor = BackColor
     m_label.Visible = True
     Set CreateLabel = m_label
     Set m_label = Nothing
 End Function

 Private Function CreateCloseBGLabel(TargetForm As VB.Form, BackColor As Long) As Label
     Dim m_label As Label
     Static iCount As Long
     iCount = iCount +
     Set m_label = TargetForm.Controls.Add("VB.Label", "udfCloseBGLabel" & iCount)
     m_label.BackStyle =    'opaque
     m_label.BorderStyle =  'none
     m_label.Appearance =   'flat
     m_label.AutoSize = False
     m_label.BackColor = BackColor
     m_label.Width =
     m_label.Height = m_label.Width
     m_label.Visible = True

     Set CreateCloseBGLabel = m_label
     Set m_label = Nothing
 End Function

 Private Function CreateCloseLabel(TargetForm As VB.Form, ForeColor As Long) As Label
     Dim m_label As Label
     Static iCount As Long
     iCount = iCount +
     Set m_label = TargetForm.Controls.Add("VB.Label", "udfCloseLabel" & iCount)
     m_label.BackStyle =    'Transparent
     m_label.BorderStyle =  'none
     m_label.Appearance =   'flat
     m_label.AutoSize = True
     m_label.ForeColor = ForeColor
     m_label.FontBold = True
     m_label.FontSize =
     m_label.Caption = "×"
     m_label.Visible = True
     Set CreateCloseLabel = m_label
     Set m_label = Nothing
 End Function

 Private Sub m_CloseBar_Click()
     Unload m_TargetForm
 End Sub

 Private Sub m_CloseBarBG_Click()
     Unload m_TargetForm
 End Sub

 Private Sub m_CloseBar_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
     m_CloseBar.ForeColor = RGB(, , )
     m_CloseBarBG.BackColor = m_BorderColor
 End Sub

 Private Sub m_CloseBarBG_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
     m_CloseBar.ForeColor = RGB(, , )
     m_CloseBarBG.BackColor = m_BorderColor
 End Sub

 Private Sub ResizeForm()
     m_MoveBar.Move Me.BorderWidth, Me.BorderWidth, m_TargetForm.Width - Me.BorderWidth * , m_MoveBarHeight
     m_TitleLabel.Move m_MoveBar.Left + , m_MoveBar.Top + (m_MoveBar.Height - m_TitleLabel.Height) /
     m_CloseBarBG.Move m_MoveBar.Left + m_MoveBar.Width - m_CloseBarBG.Width - , Me.BorderWidth
     m_CloseBar.Move m_CloseBarBG.Left + (m_CloseBarBG.Width - m_CloseBar.Width) / , _
         m_CloseBarBG.Top + (m_CloseBarBG.Height - m_CloseBar.Height) /  -
     m_LineBar.Move Me.BorderWidth, Me.BorderWidth + m_MoveBarHeight, m_TargetForm.Width - Me.BorderWidth * , m_LineBarHeight
 End Sub

 Private Sub m_MoveBar_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
     If (Button And vbLeftButton) >  Then
         m_PrePos.X = X
         m_PrePos.Y = Y
     End If
 End Sub

 Private Sub m_MoveBar_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
     If m_TargetForm.WindowState =  Then Exit Sub
     If (Button And vbLeftButton) >  Then
         m_TargetForm.Move m_TargetForm.Left + X - m_PrePos.X, m_TargetForm.Top + Y - m_PrePos.Y
     End If
     m_CloseBar.ForeColor = RGB(, , )
     m_CloseBarBG.BackColor = m_MoveBar.BackColor
 End Sub

 Private Sub BringToTop()
     SetWindowPos m_TargetForm.hwnd, HWND_TOPMOST, , , , , SWP_NOMOVE Or SWP_NOSIZE  '窗体置顶
 End Sub

CProgressBar代码示意

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

 '///////////////////////////////////////////////////////////////////////////////
 '模块名称： CProgressBar：进度条显示窗体模块
 '相关模块： CLayoutHelper：
 '///////////////////////////////////////////////////////////////////////////////
 Private Type StageInfo
     Caption As String
     StepNumber As Integer
 End Type

 Private mProgressBar As FProgressBar    '进度信息窗体对象
 Private mStages() As StageInfo          '进度阶段信息数组
 Private mLength As Integer              '数组的长度
 Private mCurrentStage As Integer        '当前所处的阶段号
 Private mCurrentStep As Integer         '当前所处的子进度号
 Private mIsCompleted As Boolean         '是否所有进度完成

 Property Get IsCompleted() As Boolean
 On Error GoTo Exit_Handler
     If mCurrentStage = UBound(mStages) And _
             mCurrentStep = mStages(mCurrentStage).StepNumber Then
         mIsCompleted = True
         mProgressBar.SetEndTime
     End If
     IsCompleted = mIsCompleted
     Exit Property
 Exit_Handler:
     IsCompleted = False
 End Property

 '添加一条阶段进度初始信息
 Public Sub AddStage(Caption As String, StepNumber As Integer)
     mLength = mLength +
     ReDim Preserve mStages( To mLength)
     mStages(mLength).Caption = Caption
     mStages(mLength).StepNumber = StepNumber
 End Sub

 Public Sub NextStep()
     If mProgressBar.Visible = False Then mProgressBar.Show
     If mLength =  Or mStages(UBound(mStages)).StepNumber =  Then Exit Sub
     If Me.IsCompleted Then Exit Sub
     If mCurrentStage =  Then
         mCurrentStage =
         mProgressBar.DrawStage mStages(mCurrentStage).Caption, mCurrentStage / mLength
     End If
     mCurrentStep = mCurrentStep +
     If mCurrentStep > mStages(mCurrentStage).StepNumber Then
         mCurrentStep =
         mCurrentStage = mCurrentStage +
         mProgressBar.DrawStage mStages(mCurrentStage).Caption, mCurrentStage / mLength
     End If
     mProgressBar.DrawStep mCurrentStep / mStages(mCurrentStage).StepNumber
     DoEvents
 End Sub

 Private Sub Class_Initialize()
     Set mProgressBar = New FProgressBar
 End Sub

 Private Sub Class_Terminate()
     Set mProgressBar = Nothing
 End Sub