GFProgressBar/Mfrm.frm

VERSION 5.00
Begin VB.Form Mfrm
   Caption         =   "Form1"
   ClientHeight    =   3075
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4635
   LinkTopic       =   "Form1"
   ScaleHeight     =   3075
   ScaleWidth      =   4635
   StartUpPosition =   3 'Windows‑Standard
   Begin VB.CommandButton Command1
      Caption         =   "Test"
      Height          =   375
      Left            =   2640
      TabIndex        =   1
      Top             =   2640
      Width           =   1935
   End
   Begin VB.PictureBox TestProgressPicture
      ForeColor       =   &H8000000D&
      Height          =   375
      Left            =   60
      Picture         =   "Mfrm.frx":0000
      ScaleHeight     =   315
      ScaleWidth      =   4455
      TabIndex        =   0
      Top             =   1020
      Width           =   4515
   End
End
Attribute VB_Name = "Mfrm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'(c)2001 by Louis. Looks like a Win32 progress bar.
'GFProgressBar
Dim GFProgressBarNumber As Integer
Dim GFProgressBarDescriptionArray() As String
Dim GFProgressBarDrawnBlockNumberArray() As Integer
'DEBUG
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Sub Command1_Click()
    'on error resume next
    Dim Temp As Long
    'reset
    TestProgressPicture.Cls
    'preset
    Call DefineGFProgressBar(TestProgressPicture)
    'begin
    For Temp = 10000 To 1 Step (‑1)
        Call GFProgressBar_ShowProgress("TestProgressBar", TestProgressPicture, Temp / 100)
    Next Temp
End Sub

Private Sub DefineGFProgressBar(ByRef ProgressBarPicture As PictureBox)
    'on error resume next 'call at program start up
    ProgressBarPicture.AutoRedraw = True
    ProgressBarPicture.ForeColor = &H8000000D 'marking
    ProgressBarPicture.BackColor = &H8000000F 'control item ("Schaltflaeche")
End Sub

Private Sub GFProgressBar_ShowProgress(ByVal ProgressBarDescription As StringByRef ProgressBarPicture 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
    BlockDrawNumber = 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
            BlockDrawNumber = BlockDrawNumber + 1
        End If
    Next BlockLoop
    BlockDrawnNumber = GFProgressBar_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
            End If
        Next BlockLoop
        ProgressBarPicture.Refresh 'important
        Call GFProgressBar_SetDrawnBlockNumber(ProgressBarDescription, BlockDrawNumber)
    End If
End Sub

Private Sub GFProgressBar_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 GFProgressBarNumber
        If GFProgressBarDescriptionArray(TestLoop) = ProgressBarDescription Then
            GFProgressBarDrawnBlockNumberArray(TestLoop) = ProgressBarDrawnBlockNumber
            Exit Sub 'ok
        End If
    Next TestLoop
    If Not (GFProgressBarNumber = 32767) Then 'verify
        GFProgressBarNumber = GFProgressBarNumber + 1
    Else
        'NOTE: array items (progress bars) cannot be removed.
        MsgBox "internal error in GFProgressBar_SetDrawnBlockNumber(): overflow !", vbOKOnly + vbExclamation, "GFProgressBar"
        Exit Sub 'error
    End If
    ReDim Preserve GFProgressBarDescriptionArray(1 To GFProgressBarNumber) As String
    ReDim Preserve GFProgressBarDrawnBlockNumberArray(1 To GFProgressBarNumber) As Integer
    GFProgressBarDescriptionArray(GFProgressBarNumber) = ProgressBarDescription
    GFProgressBarDrawnBlockNumberArray(GFProgressBarNumber) = ProgressBarDrawnBlockNumber
    Exit Sub 'ok
End Sub

Private Function GFProgressBar_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 GFProgressBarNumber
        If GFProgressBarDescriptionArray(TestLoop) = ProgressBarDescription Then
            GFProgressBar_GetDrawnBlockNumber = GFProgressBarDrawnBlockNumberArray(TestLoop)
            Exit Function 'ok
        End If
    Next TestLoop
    GFProgressBar_GetDrawnBlockNumber = True
    Exit Function 'error
End Function


[END OF FILE]