home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 4_2005-2006.ISO / data / Zips / Java_Effec189601622005.psc / ProgressBar.bas < prev    next >
BASIC Source File  |  2004-03-30  |  6KB  |  151 lines
  1. Attribute VB_Name = "ProgressBar"
  2. Option Explicit
  3. Option Base 1
  4. Option Private Module
  5.  
  6. Private Declare Function GetPixel Lib "gdi32" ( _
  7.     ByVal hDC As Long, _
  8.     ByVal x As Long, _
  9.     ByVal y As Long _
  10.     ) As Long
  11.  
  12. Public Function ProgBar(PicX As PictureBox, _
  13.     PercentIn As Long, _
  14.     Optional BGcolor As Long = vbWhite, _
  15.     Optional FGcolor As Long = vbBlue, _
  16.     Optional TextColor = vbBlack, _
  17.     Optional DisplayText As Boolean = True, _
  18.     Optional Style As Integer = 0) As Boolean
  19.     
  20.     Dim OnePercent As Single
  21.     Dim PBarWidth As Long
  22.     Dim PBarHeight As Long
  23.     Dim T As Long
  24.     Dim i As Long
  25.     Dim Temp As Long
  26.     Dim StrProcess As String
  27.     Static J As Long
  28.     On Error GoTo Err_Handler
  29.     If J > PercentIn Then PicX.Cls
  30.     If J > 0 And J = PercentIn Then Exit Function
  31.     With PicX
  32.         .AutoRedraw = True
  33.         .ScaleMode = 3
  34.         .BackColor = BGcolor
  35.         .ForeColor = FGcolor
  36.         .Font.Bold = True
  37.     End With
  38.     PBarWidth = PicX.Width / Screen.TwipsPerPixelX
  39.     PBarHeight = PicX.Height / Screen.TwipsPerPixelY
  40.     OnePercent = PBarWidth / 100
  41.     Select Case Style
  42.         Case 1
  43.             OnePercent = PBarHeight / 100
  44.             For T = PBarHeight - (OnePercent * PercentIn) To PBarHeight
  45.                 PicX.Line (0, T)-(PBarWidth, T)
  46.             Next T
  47.             If DisplayText = True Then
  48.                 PicX.CurrentX = PBarWidth / 2 - 10
  49.                 PicX.CurrentY = PBarHeight / 2 - 8
  50.                 PicX.ForeColor = TextColor
  51.                 PicX.Print vbNullString & Format(PercentIn, "##%")
  52.                 For T = PBarHeight - (OnePercent * PercentIn) To PBarHeight
  53.                     For i = 0 To PBarWidth
  54.                         If GetPixel(PicX.hDC, i, T) = TextColor _
  55.                             Then PicX.PSet (i, T), BGcolor
  56.                     Next i
  57.                     If T > OnePercent * 60 Then T = PBarHeight
  58.                 Next T
  59.             End If
  60.         Case 2
  61.             For T = 0 To OnePercent * (PercentIn - 1)
  62.                 PicX.Line (T, 0)-(T, PBarHeight)
  63.             Next T
  64.             For T = 0 To OnePercent * (PercentIn - 1) Step (OnePercent * 7)
  65.                 PicX.ForeColor = BGcolor
  66.                 PicX.Line (0, 0)-(PBarWidth - 1, 0)
  67.                 PicX.Line (1, 1)-(1, PBarHeight - 1)
  68.                 PicX.Line (PBarWidth - 1, 0)-(PBarWidth - 1, PBarHeight - 1)
  69.                 PicX.Line (1, PBarHeight - 1)-(PBarWidth, PBarHeight - 1)
  70.                 PicX.Line (1, PBarHeight - 2)-(PBarWidth, PBarHeight - 2)
  71.                 PicX.Line (1, PBarHeight - (1 * 3))-(PBarWidth, PBarHeight - (1 * 3))
  72.                 PicX.Line (T - 1, 0)-(T - 1, PBarHeight)
  73.                 PicX.Line (T, 0)-(T, PBarHeight)
  74.                 PicX.ForeColor = FGcolor
  75.             Next T
  76.         Case 3
  77.             Dim iRed As Integer, iBlue As Integer, iGreen As Integer
  78.             Dim nRed As Integer, nBlue As Integer, nGreen As Integer
  79.             Dim BlueRange As Long, RedRange As Long, GreenRange As Long
  80.             Dim RedPcnt As Single, GreenPcnt As Single, BluePcnt As Single
  81.             Dim Red1 As Long, Green1 As Long, Blue1 As Long
  82.             Dim rTemp As Long, bTemp As Long, gTemp As Long
  83.             Call ColorCodeToRGB(FGcolor, iRed, iGreen, iBlue)
  84.             nRed = iBlue: nBlue = iRed: nGreen = 128
  85.             RedRange = nRed - iRed
  86.             BlueRange = nBlue - iBlue
  87.             GreenRange = nGreen - iGreen
  88.             RedPcnt = RedRange / 100
  89.             GreenPcnt = GreenRange / 100
  90.             BluePcnt = BlueRange / 100
  91.             For T = 0 To OnePercent * (PercentIn - 1)
  92.                 Red1 = nRed - RedPcnt * (T / OnePercent + 1)
  93.                 If Red1 < 0 Then Red1 = 0
  94.                 Green1 = nGreen - GreenPcnt * (T / OnePercent + 1)
  95.                 If Green1 < 0 Then Green1 = 0
  96.                 Blue1 = nBlue - BluePcnt * (T / OnePercent + 1)
  97.                 If Blue1 < 0 Then Blue1 = 0
  98.                 PicX.ForeColor = RGB(Red1, Green1, Blue1)
  99.                 PicX.Line (T, 0)-(T, PBarHeight)
  100.             Next T
  101.         Case Else
  102.             For T = 0 To OnePercent * (PercentIn - 1)
  103.                 PicX.Line (T, 0)-(T, PBarHeight)
  104.             Next T
  105.     End Select
  106.     If DisplayText = True Then
  107.         If Not Style = 1 Then
  108.             PicX.CurrentX = PBarWidth / 2 - 7
  109.             PicX.CurrentY = PBarHeight / 2 - 8
  110.             PicX.ForeColor = TextColor
  111.             If PercentIn <= 9 Then
  112.                 StrProcess = "0" & PercentIn
  113.             Else
  114.                 StrProcess = PercentIn
  115.             End If
  116.             PicX.Print vbNullString & StrProcess & "%"
  117.             If PercentIn > 40 Then
  118.                 For T = OnePercent * 40 To OnePercent * (PercentIn - 1)
  119.                     For i = 0 To PBarHeight
  120.                         If GetPixel(PicX.hDC, T, i) = TextColor Then
  121.                             PicX.PSet (T, i), PicX.BackColor
  122.                         End If
  123.                     Next i
  124.                     If T > OnePercent * 60 Then T = _
  125.                         OnePercent * (PercentIn - 1)
  126.                 Next T
  127.             End If
  128.         End If
  129.     End If
  130.     J = PercentIn
  131.     ProgBar = True
  132.     Exit Function
  133.     
  134. Err_Handler:
  135.     ProgBar = False
  136. End Function
  137.  
  138. Public Function ColorCodeToRGB(lColorCode As Long, _
  139.     iRed As Integer, _
  140.     iGreen As Integer, _
  141.     iBlue As Integer) As Boolean
  142.     Dim lColor As Long
  143.     lColor = lColorCode
  144.     iRed = lColor Mod &H100
  145.     lColor = lColor \ &H100
  146.     iGreen = lColor Mod &H100
  147.     lColor = lColor \ &H100
  148.     iBlue = lColor Mod &H100
  149.     ColorCodeToRGB = True
  150. End Function
  151.