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 String, ByRef 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 String, ByVal 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]