GFProgressBarEx/GFProgressBarEx.frm

VERSION 5.00
Begin VB.Form Form1
   Caption         =   "Form1"
   ClientHeight    =   3185
   ClientLeft      =   65
   ClientTop       =   351
   ClientWidth     =   4680
   LinkTopic       =   "Form1"
   Picture         =   "GFProgressBarEx.frx":0000
   ScaleHeight     =   3185
   ScaleWidth      =   4680
   StartUpPosition =   3 'Windows‑Standard
   Begin VB.PictureBox GFProgressBarSkinPicture
      AutoRedraw      =   ‑1 'True
      Enabled         =   0   'False
      Height          =   675
      Left            =   480
      Picture         =   "GFProgressBarEx.frx":4B146
      ScaleHeight     =   624
      ScaleWidth      =   3861
      TabIndex        =   2
      Top             =   360
      Visible         =   0   'False
      Width           =   3915
   End
   Begin VB.CommandButton Command1
      Caption         =   "Test"
      Height          =   375
      Left            =   2580
      TabIndex        =   1
      Top             =   2700
      Width           =   1995
   End
   Begin VB.PictureBox TestProgressPicture
      ForeColor       =   &H8000000D&
      Height          =   615
      Left            =   480
      ScaleHeight     =   559
      ScaleWidth      =   3861
      TabIndex        =   0
      Top             =   1200
      Width           =   3915
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'(c)2001 by Louis. Looks better than a Win32 progress bar. Use in combination with GFSkinEngine.
'GFProgressBarEx
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As LongByVal X As LongByVal Y As LongByVal nWidth As LongByVal nHeight As LongByVal hSrcDC As LongByVal xSrc As LongByVal ySrc As LongByVal dwRop As Long) As Long
'GFProgressBarEx
Dim GFProgressBarExNumber As Integer
Dim GFProgressBarExDescriptionArray() As String
Dim GFProgressBarExDrawnBlockNumberArray() As Integer
'DEBUG
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'
'NOTE: the GFProgressBarEx works like the GFProgressBar, but
'it doesn't just display ugly blue blocks but parts of a definable picture,
'the ProgressBarSkinPicture.
'

Private Sub Command1_Click()
    'on error resume next
    Dim Temp As Long
    TestProgressPicture.Cls
    Call DefineGFProgressBarEx(TestProgressPicture, 0, RGB(255, 255, 255), GFProgressBarSkinPicture)
    For Temp = 1 To 10000
        'Call Sleep(10)
        Call GFProgressBarEx_ShowProgress("TestProgressBar", TestProgressPicture, GFProgressBarSkinPicture, Temp / 100)
    Next Temp
End Sub

Private Sub DefineGFProgressBarEx(ByRef ProgressBarPicture As PictureBox, ByVal ProgressBarForeColor As LongByVal ProgressBarBackColor As LongByRef ProgressBarSkinPicture As PictureBox)
    'on error resume next 'call at program start up
    ProgressBarPicture.AutoRedraw = True
    ProgressBarPicture.ForeColor = ProgressBarForeColor 'although not used
    ProgressBarPicture.BackColor = ProgressBarBackColor
    ProgressBarSkinPicture.AutoRedraw = True
End Sub

Private Sub GFProgressBarEx_ShowProgress(ByVal ProgressBarDescription As StringByRef ProgressBarPicture As PictureBox, ByRef ProgressBarSkinPicture As PictureBox, ByVal ProgressPercentage As Single)
    'on error resume next 'v1.2, if drawn 'forwards' then no blocks will be deleted (maybe some bugs in it)
    Dim ProgressBarPictureWidth As Single 'scale width minus border space
    Dim ProgressBarGapFactor As Single 'blockwidth * gapfactor = gap width
    Dim BlockWidth As Single
    Dim BlockNumber As Integer
    Dim BlockDrawnNumber As Integer 'number of blocks that have been drawn since last call of this sub
    Dim BlockDrawNumber As Integer 'number of blocks to draw
    Dim BlockLoop As Integer
    'verify
    Select Case ProgressPercentage
    Case Is < 0
        ProgressPercentage = 0
    Case Is > 100
        ProgressPercentage = 100
    End Select
    'preset
    ProgressBarPictureWidth = ProgressBarPicture.ScaleWidth ‑ 2 * Screen.TwipsPerPixelX
    'begin
    'NOTE: ProgressBarPicture.ScaleWidth Mod BlockWidth must be 0.
    BlockNumber = Int(ProgressBarPictureWidth / (ProgressBarPicture.ScaleHeight ‑ 2 * Screen.TwipsPerPixelY))
    Do
        BlockLoop = BlockLoop + 1
        BlockWidth = (ProgressBarPictureWidth / BlockNumber)
        If (ProgressBarPictureWidth Mod BlockWidth) = 0 Then
            Exit Do
        Else
            BlockNumber = BlockNumber + 1
            If BlockLoop > 7 Then 'prime number
                Exit Do
            End If
        End If
    Loop
    BlockLoop = 0 'reset
    ProgressBarGapFactor = 0.15! 'preset
    Do
        BlockLoop = BlockLoop + 1
        ProgressBarGapFactor = ProgressBarGapFactor + 0.025!
        If ((BlockWidth * ProgressBarGapFactor * 10000!) Mod 10000!) = 0 Then
            Exit Do
        Else
            If BlockLoop > 7 Then 'prime number
                Exit Do
            End If
        End If
    Loop
    BlockDrawnNumber = 0 'reset
    For BlockLoop = 1 To BlockNumber 'always loop through all blocks
        If (CSng(BlockLoop) * BlockWidth) > (ProgressBarPictureWidth * (ProgressPercentage / 100!)) Then
            'delete block
        Else
            'draw block
            BlockDrawnNumber = BlockDrawnNumber + 1
        End If
    Next BlockLoop
    BlockDrawnNumber = GFProgressBarEx_GetDrawnBlockNumber(ProgressBarDescription)
    If Not (BlockDrawNumber = BlockDrawnNumber) Then
        'number of blocks to draw has changed since last drawing
        For BlockLoop = 1 To BlockNumber 'always loop through all blocks
            If (CSng(BlockLoop) * BlockWidth) > (ProgressBarPictureWidth * (ProgressPercentage / 100!)) Then
                'delete block
                If Not (BlockLoop > BlockDrawnNumber) Then
                    ProgressBarPicture.Line ( _
                        Screen.TwipsPerPixelX + CSng(BlockLoop ‑ 1) * BlockWidth, Screen.TwipsPerPixelY)‑ _
                        (Screen.TwipsPerPixelX + CSng(BlockLoop ‑ 0) * BlockWidth ‑ (BlockWidth * ProgressBarGapFactor), ProgressBarPicture.ScaleHeight ‑ 2 * Screen.TwipsPerPixelY), ProgressBarPicture.BackColor, BF
                End If
            Else
                'draw block
                'ProgressBarPicture.Line ( _
                '    Screen.TwipsPerPixelX + CSng(BlockLoop ‑ 1) * BlockWidth, Screen.TwipsPerPixelY)‑ _
                '    (Screen.TwipsPerPixelX + CSng(BlockLoop ‑ 0) * BlockWidth ‑ (BlockWidth * ProgressBarGapFactor), ProgressBarPicture.ScaleHeight ‑ 2 * Screen.TwipsPerPixelY), ProgressBarPicture.ForeColor, BF
                Dim X As Long
                Dim Y As Long
                X = (Screen.TwipsPerPixelX + CSng(BlockLoop ‑ 1) * BlockWidth) / Screen.TwipsPerPixelX
                Y = (Screen.TwipsPerPixelY) / Screen.TwipsPerPixelY
                Call BitBlt(ProgressBarPicture.hDC, _
                    X, Y, _
                    ((Screen.TwipsPerPixelX + CSng(BlockLoop ‑ 0) * BlockWidth ‑ (BlockWidth * ProgressBarGapFactor)) + 1) / Screen.TwipsPerPixelX ‑ X, _
                    ((ProgressBarPicture.ScaleHeight ‑ 2 * Screen.TwipsPerPixelY) + 1) / Screen.TwipsPerPixelY ‑ Y, _
                    ProgressBarSkinPicture.hDC, X, Y, vbSrcCopy)
            End If
        Next BlockLoop
        ProgressBarPicture.Refresh 'important
        Call GFProgressBarEx_SetDrawnBlockNumber(ProgressBarDescription, BlockDrawnNumber)
    End If
End Sub

Private Sub GFProgressBarEx_SetDrawnBlockNumber(ByVal ProgressBarDescription As StringByVal ProgressBarDrawnBlockNumber As Integer)
    'on error resume next 'sets number of drawn blocks for a progress bar
    Dim TestLoop As Integer
    For TestLoop = 1 To GFProgressBarExNumber
        If GFProgressBarExDescriptionArray(TestLoop) = ProgressBarDescription Then
            GFProgressBarExDrawnBlockNumberArray(TestLoop) = ProgressBarDrawnBlockNumber
            Exit Sub 'ok
        End If
    Next TestLoop
    If Not (GFProgressBarExNumber = 32767) Then 'verify
        GFProgressBarExNumber = GFProgressBarExNumber + 1
    Else
        'NOTE: array items (progress bars) cannot be removed.
        MsgBox "internal error in GFProgressBarEx_SetDrawnBlockNumber(): overflow !", vbOKOnly + vbExclamation, "GFProgressBarEx"
        Exit Sub 'error
    End If
    ReDim Preserve GFProgressBarExDescriptionArray(1 To GFProgressBarExNumber) As String
    ReDim Preserve GFProgressBarExDrawnBlockNumberArray(1 To GFProgressBarExNumber) As Integer
    GFProgressBarExDescriptionArray(GFProgressBarExNumber) = ProgressBarDescription
    GFProgressBarExDrawnBlockNumberArray(GFProgressBarExNumber) = ProgressBarDrawnBlockNumber
    Exit Sub 'ok
End Sub

Private Function GFProgressBarEx_GetDrawnBlockNumber(ByVal ProgressBarDescription As String) As Integer
    'on error resume next 'returns number of drawn blocks in a progress bar or True for error
    Dim TestLoop As Integer
    For TestLoop = 1 To GFProgressBarExNumber
        If GFProgressBarExDescriptionArray(TestLoop) = ProgressBarDescription Then
            GFProgressBarEx_GetDrawnBlockNumber = GFProgressBarExDrawnBlockNumberArray(TestLoop)
            Exit Function 'ok
        End If
    Next TestLoop
    GFProgressBarEx_GetDrawnBlockNumber = True
    Exit Function 'error
End Function


[END OF FILE]