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
Mostrar Mensajes
