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 Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal 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 Long, ByVal ProgressBarBackColor As Long, ByRef 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 String, ByRef 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 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 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]