modprocessbar.bas

绘制进度条

Attribute VB_Name = "modProcessBar"
Option Explicit

'---------------------------------------------------
' modProcessBar.bas 用于绘制进度条,由小李飞刀编制
' 欢迎访问小李飞刀的个人主页
'       主页地址:   http://go.163.com/~lihui48
'       虚拟域名:   http://vbfighter.126.com
'---------------------------------------------------

'===================================================
'更新进度条(普通样式)。
Public Sub DrawProc(pic As PictureBox, _
                    ByVal nPercent!, _
                    ByVal nForecolor&)
    On Local Error Resume Next
    With pic
        pic.Line (0, 0)-((nPercent! * .ScaleWidth), .ScaleHeight), nForecolor&, BF
    End With
    On Error GoTo 0
End Sub
'===================================================

'===================================================
'更新进度条(增强样式,代有百分数)。
Public Sub DrawProcEx(pic As PictureBox, _
                      ByVal sngPercent!, _
                      ByVal nForecolor&, _
                      Optional ByVal fBorderCase)
    On Local Error Resume Next
    Dim strPercent As String
    Dim intX As Integer
    Dim intY As Integer
    Dim intWidth As Integer
    Dim intHeight As Integer
    Dim lngForeColor&, lngBackColor&

    If IsMissing(fBorderCase) Then fBorderCase = True
    If nForecolor = &H0 Then nForecolor = &HFF0000
    
    '要使之工作得更漂亮，我们需要一个白色的背景和彩色的前景 (蓝色)
    Const colBackground = &HFFFFFF ' 白色
    Const colForeground = &HFF0000 ' 亮蓝色
    
    pic.AutoRedraw = True
    pic.ForeColor = nForecolor
    pic.BackColor = colBackground
    
    '
    '格式化百分比并获取文本特性
    '
    Dim intPercent
    intPercent = Int(100 * sngPercent + 0.5)
    
    '绝不允许百分比的值是 0 或 100，除非它确实是这个值。
    '它保证，例如，除非我们完全完成了的情况，状态栏才达到 100%。
    If intPercent = 0 Then
        If Not fBorderCase Then
            intPercent = 1
        End If
    ElseIf intPercent = 100 Then
        If Not fBorderCase Then
            intPercent = 99
        End If
    End If
    
    strPercent = Format$(intPercent) & "%"
    intWidth = pic.TextWidth(strPercent)
    intHeight = pic.TextHeight(strPercent)

    '
    '现在，设置起始位置的 intX 和 intY，显示百分比。
    '
    intX = pic.Width / 2 - intWidth / 2
    intY = pic.Height / 2 - intHeight / 2

    '
    '需要画一个填好了背景色的框来擦除以前显示的百分比 (如果有)
    '
    pic.DrawMode = 13 ' 复制笔
    pic.Line (intX, intY)-Step(intWidth, intHeight), pic.BackColor, BF

    '
    '返回到中心打印位置并打印文本
    '
    pic.CurrentX = intX
    pic.CurrentY = intY
    pic.Print strPercent

    '
    '现在用带状的颜色填充框，表示所需的百分比。
    '如果百分比为 0，用背景色填充整个框来清除之。
    '使用 "Not XOR" 笔，使我们无论何时接触到它的时候，都将把文本改为白色，把背景改为蓝色。
    '
    pic.DrawMode = 10 ' Not XOR Pen
    If sngPercent > 0 Then
        pic.Line (0, 0)-(pic.ScaleWidth * sngPercent, pic.ScaleHeight), pic.ForeColor, BF
    Else
        pic.Line (0, 0)-(pic.ScaleWidth, pic.ScaleHeight), pic.BackColor, BF
    End If

    pic.Refresh
    On Error GoTo 0
End Sub
'===================================================


'===================================================
' 函数: DrawProcSpectrum
'
' 功能: 绘制过渡色的进度条,应先使用函数GradateColors取得一个过渡色数组
'
' 入口: pic             '要绘制的PictureBox对象
'       sngPercent      '进度条的百分比进度
'       nForecolor()    '过渡色数组
'
Public Sub DrawProcSpectrum(pic As PictureBox, _
                            ByVal sngPercent!, _
                            nForecolor&())
    On Local Error Resume Next
    Dim i&, lw&, startPos&
    
    With pic
        lw& = .ScaleWidth / UBound(nForecolor&)
        
        For i& = 0 To Format((sngPercent! * UBound(nForecolor&)), "Fixed")
            DoEvents
            pic.Line (startPos&, 0)-(startPos& + lw&, pic.ScaleHeight), nForecolor&(i&), BF
            
            startPos& = startPos& + lw&
        Next i&
        
        If sngPercent! = 1 Then
            pic.Line (startPos&, 0)-(pic.ScaleWidth, pic.ScaleHeight), nForecolor&(i& - 1), BF
        End If
    End With
    On Error GoTo 0
End Sub
'===================================================


'===================================================
'取过渡色,函数会将结果存放到gColor()数组中。
'例: 彩虹。
'Call GradateColors(Colors&, &HFF, &H80FF&, &HFFFF&, &HFF00&, &HFFFF00, &HFF0000, &HFF00FF)
Sub GradateColors(Colors&(), ParamArray gColor())
    On Local Error Resume Next
    
    Dim i&, j&
    Dim dblR#, dblG#, dblB#
    Dim addR#, addG#, addB#
    Dim bckR#, bckG#, bckB#
    Dim Color1&, Color2&
    
    
    For i& = 0 To UBound(gColor) - 1
    
        Color1& = CDbl(gColor(i&))
        Color2& = CDbl(gColor(i& + 1))
    
        dblR = CDbl(Color1 And &HFF)
        dblG = CDbl(Color1 And &HFF00&) / &HFF&
        dblB = CDbl(Color1 And &HFF0000) / &HFF00&
        bckR = CDbl(Color2 And &HFF&)
        bckG = CDbl(Color2 And &HFF00&) / &HFF&
        bckB = CDbl(Color2 And &HFF0000) / &HFF00&

        addR = (bckR - dblR) / (UBound(Colors) / UBound(gColor))
        addG = (bckG - dblG) / (UBound(Colors) / UBound(gColor))
        addB = (bckB - dblB) / (UBound(Colors) / UBound(gColor))

        For j& = (i& * (UBound(Colors) / UBound(gColor))) _
            To ((i& + 1) * (UBound(Colors) / UBound(gColor)))
            dblR = dblR + addR
            dblG = dblG + addG
            dblB = dblB + addB
            
            If dblR > 255 Then dblR = 255
            If dblG > 255 Then dblG = 255
            If dblB > 255 Then dblB = 255
            If dblR < 0 Then dblR = 0
            If dblG < 0 Then dblG = 0
            If dblG < 0 Then dblB = 0
            
            Colors(j&) = RGB(dblR, dblG, dblB)
        Next j&
    Next i&
    On Error GoTo 0
End Sub
'===================================================


'===================================================
' 函数: DrawProcStardard
'
' 功能: 绘制一个标准样式的进度条,完全可以代替进度条控件
'
' 入口: pic             要绘制的PictureBox对象
'       sngPercent      进度条的百分比进度
'       nForecolor      进度条的颜色
'
Sub DrawProcStardard(pic As PictureBox, _
                     ByVal sngPercent!, _
                     ByVal nForecolor&)
    Dim nWidth!, nGap!
    
    nWidth! = pic.ScaleHeight - pic.ScaleX(3, vbPixels, pic.ScaleMode)
    nGap! = pic.ScaleY(1, vbPixels, pic.ScaleMode)
    
    On Local Error Resume Next
    Dim i&, lw!, startPos!
    
    With pic
        pic.Line (0, nGap)-((sngPercent * .ScaleWidth), .ScaleHeight - 2 * nGap), nForecolor&, BF
        
        For i = 1 To (pic.ScaleWidth / nWidth)
            pic.Line (i * (nWidth + nGap) - nGap, 0)-(i * (nWidth + nGap), pic.ScaleHeight), pic.BackColor, BF
        Next i
    End With
    On Error GoTo 0
End Sub
'===================================================