ftest.frm

一款精美小巧的（绝对比VB自带进度条强）进度条控件。

      mouseicon       =   "fTest.frx":3BEF6
   End
   Begin VB.Label lblInfo7 
      BackStyle       =   0  'Transparent
      Caption         =   "左键单击/右键单击:"
      ForeColor       =   &H00FFFFFF&
      Height          =   300
      Left            =   330
      TabIndex        =   12
      Top             =   5310
      Width           =   4440
   End
   Begin VB.Label lblProgressBar7 
      BackColor       =   &H00FF8080&
      Caption         =   "值:"
      ForeColor       =   &H00FFFFFF&
      Height          =   180
      Left            =   3735
      TabIndex        =   13
      Top             =   5655
      Width           =   1650
   End
   Begin VB.Label lblProgressBar8 
      BackColor       =   &H00FF8080&
      Caption         =   "值:"
      ForeColor       =   &H00FFFFFF&
      Height          =   180
      Left            =   3735
      TabIndex        =   14
      Top             =   5970
      Width           =   1650
   End
   Begin VB.Label lblProgressBar9 
      BackColor       =   &H00FF8080&
      Caption         =   "值:"
      ForeColor       =   &H00FFFFFF&
      Height          =   180
      Left            =   3735
      TabIndex        =   15
      Top             =   6285
      Width           =   1650
   End
   Begin VB.Label lblInfo6 
      BackColor       =   &H00FFFFFF&
      Caption         =   "示例 4 *新*: 精确值 + 长整"
      ForeColor       =   &H00C00000&
      Height          =   210
      Left            =   180
      TabIndex        =   11
      Top             =   4935
      Width           =   6975
   End
   Begin VB.Label lblInfo5 
      BackColor       =   &H00FFFFFF&
      Caption         =   "示例 3: 垂直进度条"
      ForeColor       =   &H00C00000&
      Height          =   210
      Left            =   4950
      TabIndex        =   9
      Top             =   2190
      Width           =   2205
   End
   Begin VB.Label lblInfo1 
      BackColor       =   &H00FFFFFF&
      Caption         =   "示例 1: 滚动条功能"
      BeginProperty Font 
         Name            =   "Tahoma"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00C00000&
      Height          =   210
      Left            =   180
      TabIndex        =   0
      Top             =   270
      Width           =   6975
   End
   Begin VB.Label lblInfo4 
      BackStyle       =   0  'Transparent
      Caption         =   "间隔: [0,100] - 自定义标题"
      ForeColor       =   &H00FFFFFF&
      Height          =   195
      Left            =   360
      TabIndex        =   7
      Top             =   4035
      Width           =   2640
   End
   Begin VB.Label lblInfo3 
      BackStyle       =   0  'Transparent
      Caption         =   "间隔: [-300,300]"
      ForeColor       =   &H00FFFFFF&
      Height          =   195
      Left            =   360
      TabIndex        =   5
      Top             =   2595
      Width           =   2640
   End
   Begin VB.Label lblInfo2 
      BackColor       =   &H00FFFFFF&
      Caption         =   "示例 2: 显示文字格式 [*新*: 支持自定义标题]"
      ForeColor       =   &H00C00000&
      Height          =   210
      Left            =   180
      TabIndex        =   4
      Top             =   2190
      Width           =   4650
   End
   Begin VB.Shape Shape1 
      BackColor       =   &H00FF8080&
      BackStyle       =   1  'Opaque
      BorderColor     =   &H00404040&
      Height          =   1770
      Left            =   165
      Top             =   255
      Width           =   7005
   End
   Begin VB.Shape Shape2 
      BackColor       =   &H00FF8080&
      BackStyle       =   1  'Opaque
      BorderColor     =   &H00404040&
      Height          =   2595
      Left            =   165
      Top             =   2175
      Width           =   4680
   End
   Begin VB.Shape Shape3 
      BackColor       =   &H00FF8080&
      BackStyle       =   1  'Opaque
      BorderColor     =   &H00404040&
      Height          =   2595
      Left            =   4935
      Top             =   2175
      Width           =   2235
   End
   Begin VB.Shape Shape4 
      BackColor       =   &H00FF8080&
      BackStyle       =   1  'Opaque
      BorderColor     =   &H00404040&
      Height          =   1785
      Left            =   165
      Top             =   4920
      Width           =   7005
   End
End
Attribute VB_Name = "fTest"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False


Option Explicit

Private m_nDir As Long
Private m_snt  As Single

Private Sub Form_Load()
    m_nDir = 1
End Sub



'-- 示例 1

Private Sub lstEvents_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    Call lstEvents.Clear
End Sub

Private Sub btnPlay_Click()

  Static bPlay As Boolean

    bPlay = Not bPlay

    If (btnPlay.Caption = "开始") Then
        btnPlay.Caption = "停止"
      Else
        btnPlay.Caption = "开始"
    End If
    
    Do While bPlay
        If (VBA.Timer - m_snt > 1) Then
            ucProgressBar1 = ucProgressBar1 + m_nDir
            m_snt = VBA.Timer
        End If
        Call VBA.DoEvents
    Loop
End Sub

Private Sub ucProgressBar1_ArrivedFirst()
    m_nDir = 1
    lstEvents.AddItem lstEvents.ListCount & ": ArrivedFirst"
    lstEvents.ListIndex = lstEvents.ListCount - 1
End Sub

Private Sub ucProgressBar1_ArrivedLast()
    m_nDir = -1
    lstEvents.AddItem lstEvents.ListCount & ": ArrivedLast"
    lstEvents.ListIndex = lstEvents.ListCount - 1
End Sub

Private Sub ucProgressBar1_Click()
    lstEvents.AddItem lstEvents.ListCount & ": 单击"
    lstEvents.ListIndex = lstEvents.ListCount - 1
End Sub

Private Sub ucProgressBar1_Change()
    sbSample1 = ucProgressBar1
    lstEvents.AddItem lstEvents.ListCount & ": 改变"
    lstEvents.ListIndex = lstEvents.ListCount - 1
End Sub

Private Sub sbSample1_Change()
    ucProgressBar1 = sbSample1
End Sub

Private Sub sbSample1_Scroll()
    Call sbSample1_Change
End Sub

'-- 示例 2

Private Sub cmdGo_Click()

  Dim i As Long

    For i = ucProgressBar2.Min To ucProgressBar2.Max Step 1
        ucProgressBar2 = i: Call ucProgressBar2.Refresh
        ucProgressBar3 = i: Call ucProgressBar3.Refresh
        ucProgressBar4 = i: Call ucProgressBar4.Refresh
    Next i

    For i = ucProgressBar2.Max To ucProgressBar2.Min Step -1
        ucProgressBar2 = i: Call ucProgressBar2.Refresh
        ucProgressBar3 = i: Call ucProgressBar3.Refresh
        ucProgressBar4 = i: Call ucProgressBar4.Refresh
    Next i
End Sub

Private Sub cmdGo2_Click()

  Dim i As Long

    For i = ucProgressBar5.Min To ucProgressBar5.Max Step 1
        ucProgressBar5 = i: Call ucProgressBar5.Refresh
    Next i
    For i = ucProgressBar5.Max To ucProgressBar5.Min Step -1
        ucProgressBar5 = i: Call ucProgressBar5.Refresh
    Next i
End Sub

Private Sub ucProgressBar5_Change()
    ucProgressBar5.CaptionCustom = Format$(ucProgressBar5, "000") & " of 100"
End Sub

'-- 示例3

Private Sub btnPlay2_Click()

  Dim a As Long
  Dim b As Long

  Static bPlay2 As Boolean

    bPlay2 = Not bPlay2

    If (btnPlay2.Caption = "开始") Then
        btnPlay2.Caption = "停止"
      Else
        btnPlay2.Caption = "开始"
    End If
    
    Do While bPlay2
        a = -1 + Int(Rnd * 3)
        b = Int(Rnd * 8)
        If (ucProgressBar6(b) + a >= 0 And ucProgressBar6(b) + a <= ucProgressBar6(b).Max) Then
            ucProgressBar6(b) = ucProgressBar6(b) + a
        End If
        Call VBA.DoEvents
    Loop
End Sub

'-- 示例4

Private Sub ucProgressBar7_Change()
    lblProgressBar7 = "值: " & ucProgressBar7
End Sub

Private Sub ucProgressBar8_Change()
    lblProgressBar8 = "值: " & ucProgressBar8
End Sub

Private Sub ucProgressBar9_Change()
    lblProgressBar9 = "值: " & Format$(ucProgressBar9, "#,#")
End Sub
'
Private Sub Form_Unload(Cancel As Integer)
    If (btnPlay.Caption = "停止") Then btnPlay_Click
    If (btnPlay2.Caption = "停止") Then btnPlay2_Click
End Sub