Option Explicit

Private Declare Function GetPixel Lib "gdi32" ( _
ByVal hdc As Long, _
ByVal x As Long, _
ByVal y As Long) As Long

Dim intpercent As Integer

Private Sub Form_Load()
intpercent = 1
Timer1.Interval = 100
Timer1.Enabled = True
End Sub

Private Sub Timer1_Timer()
If intpercent <= 100 Then
ProgBar Picture1, CLng(intpercent), vbWhite, vbBlue, vbBlack, True, 0
Else
Timer1.Enabled = False
End If
intpercent = intpercent + 1
End Sub

Private Function ProgBar(PicX As PictureBox, _
PercentIn As Long, _
Optional BGcolor As Long = vbWhite, _
Optional FGcolor As Long = vbBlue, _
Optional TextColor = vbBlack, _
Optional DisplayText As Boolean = True, _
Optional Style As Integer = 0) As Boolean

Dim OnePercent As Single
Dim PBarWidth As Long
Dim PBarHeight As Long
Dim T As Long
Dim I As Long
Dim Temp As Long
Static J As Long

On Error GoTo Err_Handler

If J > PercentIn Then PicX.Cls
If J > 0 And J = PercentIn Then Exit Function

With PicX
.AutoRedraw = True
.ScaleMode = 3
.BackColor = BGcolor
.ForeColor = FGcolor
End With

PBarWidth = PicX.Width / Screen.TwipsPerPixelX
PBarHeight = PicX.Height / Screen.TwipsPerPixelY
OnePercent = PBarWidth / 100

Select Case Style

Case 1 ' Barra Vertical

OnePercent = PBarHeight / 100

For T = PBarHeight - (OnePercent * PercentIn) To PBarHeight
PicX.Line (0, T)-(PBarWidth, T)
Next T

If DisplayText = True Then
PicX.CurrentX = PBarWidth / 2 - 10
PicX.CurrentY = PBarHeight / 2 - 8
PicX.ForeColor = TextColor
PicX.Print "" & PercentIn & "%"

For T = PBarHeight - (OnePercent * PercentIn) To PBarHeight
For I = 0 To PBarWidth
If GetPixel(PicX.hdc, I, T) = TextColor _
Then PicX.PSet (I, T), BGcolor
Next I
If T > OnePercent * 60 Then T = PBarHeight
Next T
End If

For T = 0 To OnePercent * (PercentIn - 1)
PicX.Line (T, 0)-(T, PBarHeight)
Next T

For T = 0 To OnePercent * (PercentIn - 1) Step (OnePercent * 7)
PicX.ForeColor = BGcolor
PicX.Line (0, 0)-(PBarWidth - 1, 0)
PicX.Line (1, 1)-(1, PBarHeight - 1)
PicX.Line (PBarWidth - 1, 0)-(PBarWidth - 1, PBarHeight - 1)
PicX.Line (1, PBarHeight - 1)-(PBarWidth, PBarHeight - 1)
PicX.Line (1, PBarHeight - 2)-(PBarWidth, PBarHeight - 2)
PicX.Line (1, PBarHeight - 3)-(PBarWidth, PBarHeight - 3)

PicX.Line (T - 1, 0)-(T - 1, PBarHeight)
PicX.Line (T, 0)-(T, PBarHeight)
PicX.ForeColor = FGcolor
Next T

Case 3

Dim iRed As Integer, iBlue As Integer, iGreen As Integer
Dim nRed As Integer, nBlue As Integer, nGreen As Integer
Dim BlueRange As Long, RedRange As Long, GreenRange As Long
Dim RedPcnt As Single, GreenPcnt As Single, BluePcnt As Single
Dim Red1 As Long, Green1 As Long, Blue1 As Long
Dim rTemp As Long, bTemp As Long, gTemp As Long

Call ColorCodeToRGB(FGcolor, iRed, iGreen, iBlue)
nRed = iBlue: nBlue = iRed: nGreen = 128

RedRange = nRed - iRed
BlueRange = nBlue - iBlue
GreenRange = nGreen - iGreen

RedPcnt = RedRange / 100
GreenPcnt = GreenRange / 100
BluePcnt = BlueRange / 100

For T = 0 To OnePercent * (PercentIn - 1)

Red1 = nRed - RedPcnt * (T / OnePercent + 1)
If Red1 < 0 Then Red1 = 0

Green1 = nGreen - GreenPcnt * (T / OnePercent + 1)
If Green1 < 0 Then Green1 = 0

Blue1 = nBlue - BluePcnt * (T / OnePercent + 1)
If Blue1 < 0 Then Blue1 = 0

PicX.ForeColor = RGB(Red1, Green1, Blue1)
PicX.Line (T, 0)-(T, PBarHeight)
Next T

Case Else
For T = 0 To OnePercent * (PercentIn - 1)
PicX.Line (T, 0)-(T, PBarHeight)
Next T
End Select

If DisplayText = True Then

If Style <> 1 Then
PicX.CurrentX = PBarWidth / 2 - 7
PicX.CurrentY = PBarHeight / 2 - 8
PicX.ForeColor = TextColor
PicX.Print "" & PercentIn & "%"

If PercentIn > 40 Then
For T = OnePercent * 40 To OnePercent * (PercentIn - 1)
For I = 0 To PBarHeight
If GetPixel(PicX.hdc, T, I) = TextColor Then
PicX.PSet (T, I), PicX.BackColor
End If
Next I
If T > OnePercent * 60 Then T = _
OnePercent * (PercentIn - 1)
Next T
End If
End If

End If

J = PercentIn

ProgBar = True: Exit Function

Err_Handler:

ProgBar = False

End Function

Private Function ColorCodeToRGB(lColorCode As Long, _
iRed As Integer, _
iGreen As Integer, _
iBlue As Integer) As Boolean
Dim lColor As Long
lColor = lColorCode 'work long
iRed = lColor Mod &H100 'get red component
lColor = lColor \ &H100 'divide
iGreen = lColor Mod &H100 'get green component
lColor = lColor \ &H100 'divide
iBlue = lColor Mod &H100 'get blue component
ColorCodeToRGB = True
End Function