vbAccelerator - Contents of code file: cMediaProgress.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "cMediaProgress"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

' 2003-07-05: SPM
' * Fix for drawing corruption on Win9x/ME systems
' * Fix for GDI leak on Win9x/ME systems

Private Type POINTAPI
   x As Long
   y As Long
End Type
Private Type RECT
   Left As Long
   Top As Long
   Right As Long
   Bottom As Long
End Type
Private Type TRIVERTEX
   x As Long
   y As Long
   Red As Integer
   Green As Integer
   Blue As Integer
   Alpha As Integer
End Type
Private Type GRADIENT_RECT
    UpperLeft As Long
    LowerRight As Long
End Type
Private Type OSVERSIONINFO
   dwVersionInfoSize As Long
   dwMajorVersion As Long
   dwMinorVersion As Long
   dwBuildNumber As Long
   dwPlatformId As Long
   szCSDVersion(0 To 127) As Byte
End Type

Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA"
 (lpVersionInfo As OSVERSIONINFO) As Long
Private Const VER_PLATFORM_WIN32_NT = 2

Private Declare Function OleTranslateColor Lib "OLEPRO32.DLL" (ByVal OLE_COLOR
 As Long, ByVal HPALETTE As Long, pccolorref As Long) As Long
Private Const CLR_INVALID = -1
Private Const CLR_NONE = CLR_INVALID
Private Declare Function GradientFill Lib "msimg32" ( _
   ByVal hdc As Long, _
   pVertex As TRIVERTEX, _
   ByVal dwNumVertex As Long, _
   pMesh As GRADIENT_RECT, _
   ByVal dwNumMesh As Long, _
   ByVal dwMode As Long) As Long
   
Public Enum GradientFillRectType
   GRADIENT_FILL_RECT_H = 0
   GRADIENT_FILL_RECT_V = 1
End Enum

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
    lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)

Private Type SAFEARRAYBOUND
    cElements As Long
    lLbound As Long
End Type
Private Type SAFEARRAY2D
    cDims As Integer
    fFeatures As Integer
    cbElements As Long
    cLocks As Long
    pvData As Long
    Bounds(0 To 1) As SAFEARRAYBOUND
End Type
Private Declare Function VarPtrArray Lib "msvbvm50.dll" Alias "VarPtr" (Ptr()
 As Any) As Long

Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal x As
 Long, ByVal y As Long, lpPoint As POINTAPI) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal x As
 Long, ByVal y As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal
 nBkMode As Long) As Long
Private Const TRANSPARENT = 1
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal
 nWidth As Long, ByVal crColor As Long) As Long
Private Const PS_SOLID = 0
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal
 crColor As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long)
 As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As
 RECT, ByVal hBrush As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal
 hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As
 Long
Private Declare Function InflateRect Lib "user32" (lpRect As RECT, ByVal x As
 Long, ByVal y As Long) As Long
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
Private Declare Function AlphaBlend Lib "MSIMG32.dll" ( _
  ByVal hdcDest As Long, _
  ByVal nXOriginDest As Long, _
  ByVal nYOriginDest As Long, _
  ByVal nWidthDest As Long, _
  ByVal nHeightDest As Long, _
  ByVal hdcSrc As Long, _
  ByVal nXOriginSrc As Long, _
  ByVal nYOriginSrc As Long, _
  ByVal nWidthSrc As Long, _
  ByVal nHeightSrc As Long, _
  ByVal lBlendFunction As Long _
) As Long
Private Type BLENDFUNCTION
  BlendOp As Byte
  BlendFlags As Byte
  SourceConstantAlpha As Byte
  AlphaFormat As Byte
End Type
' BlendOp:
Private Const AC_SRC_OVER = &H0
' AlphaFormat:
Private Const AC_SRC_ALPHA = &H1

Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As
 Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal
 wFormat As Long) As Long
Private Declare Function DrawTextW Lib "user32" (ByVal hdc As Long, ByVal lpStr
 As Long, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Enum DrawTextFlags
    DT_TOP = &H0
    DT_LEFT = &H0
    DT_CENTER = &H1
    DT_RIGHT = &H2
    DT_VCENTER = &H4
    DT_BOTTOM = &H8
    DT_WORDBREAK = &H10
    DT_SINGLELINE = &H20
    DT_EXPANDTABS = &H40
    DT_TABSTOP = &H80
    DT_NOCLIP = &H100
    DT_EXTERNALLEADING = &H200
    DT_CALCRECT = &H400
    DT_NOPREFIX = &H800
    DT_INTERNAL = &H1000
    DT_EDITCONTROL = &H2000
    DT_PATH_ELLIPSIS = &H4000
    DT_END_ELLIPSIS = &H8000&
    DT_MODIFYSTRING = &H10000
    DT_RTLREADING = &H20000
    DT_WORD_ELLIPSIS = &H40000
    DT_NOFULLWIDTHCHARBREAK = &H80000
    DT_HIDEPREFIX = &H100000
    DT_PREFIXONLY = &H200000
End Enum

Private m_bIsNt As Boolean
Private m_bHasGradient As Boolean
Private m_bCodeAlphaBlend As Boolean

Private m_lMin As Long
Private m_lMax As Long
Private m_lValue As Long
Private m_fPercent As Single

Private m_sText As String
Private m_bAutoSize As Boolean
Private m_bShowPercentage As Boolean

Private m_oBarColor As OLE_COLOR
Private m_fnt As IFont

Private m_cMemDC As cAlphaDibSection

Private m_lWidth As Long
Private m_lMinWidth As Long
Private m_lHeight As Long

Private Function TranslateColor(ByVal oClr As OLE_COLOR, _
                        Optional hPal As Long = 0) As Long
    ' Convert Automation color to Windows color
    If OleTranslateColor(oClr, hPal, TranslateColor) Then
        TranslateColor = CLR_INVALID
    End If
End Function

Private Property Get BlendColor( _
      ByVal oColorFrom As OLE_COLOR, _
      ByVal oColorTo As OLE_COLOR, _
      Optional ByVal Alpha As Long = 128 _
   ) As Long
Dim lCFrom As Long
Dim lCTo As Long
   lCFrom = TranslateColor(oColorFrom)
   lCTo = TranslateColor(oColorTo)
Dim lSrcR As Long
Dim lSrcG As Long
Dim lSrcB As Long
Dim lDstR As Long
Dim lDstG As Long
Dim lDstB As Long
   lSrcR = lCFrom And &HFF
   lSrcG = (lCFrom And &HFF00&) \ &H100&
   lSrcB = (lCFrom And &HFF0000) \ &H10000
   lDstR = lCTo And &HFF
   lDstG = (lCTo And &HFF00&) \ &H100&
   lDstB = (lCTo And &HFF0000) \ &H10000
     
   
   BlendColor = RGB( _
      ((lSrcR * Alpha) / 255) + ((lDstR * (255 - Alpha)) / 255), _
      ((lSrcG * Alpha) / 255) + ((lDstG * (255 - Alpha)) / 255), _
      ((lSrcB * Alpha) / 255) + ((lDstB * (255 - Alpha)) / 255) _
      )
      
End Property

Public Property Get Width() As Long
   Width = m_lWidth
End Property
Public Property Let Width(ByVal rhs As Long)
   If (m_bAutoSize) Then
      Err.Raise 425
   Else
      m_lWidth = rhs
      Refresh
   End If
End Property
Public Property Get MinWidth() As Long
   MinWidth = m_lMinWidth
End Property
Public Property Let MinWidth(ByVal rhs As Long)
   m_lMinWidth = rhs
   If (m_bAutoSize) Then
      Refresh
   End If
End Property

Public Property Get Height() As Long
   Height = m_lHeight
End Property
Public Property Let Height(ByVal rhs As Long)
   m_lHeight = rhs
   Refresh
End Property
Public Property Get Font() As IFont
   Set Font = m_fnt
End Property
Public Property Let Font(ByVal rhs As IFont)
   Set m_fnt = rhs
   Refresh
End Property
Public Property Set Font(ByVal rhs As IFont)
   Set m_fnt = rhs
   Refresh
End Property
Public Property Get BarColor() As OLE_COLOR
   BarColor = m_oBarColor
End Property
Public Property Let BarColor(ByVal rhs As OLE_COLOR)
   m_oBarColor = rhs
   Refresh
End Property
Public Property Get AutoSize() As Boolean
   AutoSize = m_bAutoSize
End Property
Public Property Let AutoSize(ByVal rhs As Boolean)
   m_bAutoSize = rhs
   Refresh
End Property
Public Property Get ShowPercentage() As Boolean
   ShowPercentage = m_bShowPercentage
End Property
Public Property Let ShowPercentage(ByVal rhs As Boolean)
   m_bShowPercentage = rhs
   Refresh
End Property

Public Property Get Text() As String
   Text = m_sText
End Property
Public Property Let Text(ByVal rhs As String)
   m_sText = rhs
   Refresh
End Property
Public Property Get Min() As Long
   Min = m_lMin
End Property
Public Property Let Min(ByVal rhs As Long)
   m_lMin = rhs
   Refresh
End Property
Public Property Get Max() As Long
   Max = m_lMax
End Property
Public Property Let Max(ByVal rhs As Long)
   m_lMax = rhs
   Refresh
End Property
Public Property Get Percent() As Single
   Percent = m_fPercent
End Property
Public Property Let Percent(ByVal rhs As Single)
   m_fPercent = rhs
   Refresh
End Property
Public Property Get Value() As Long
   Value = m_lValue
End Property
Public Property Let Value(ByVal rhs As Long)
   m_lValue = rhs
   If (m_lMax - m_lMin > 0) Then
      m_fPercent = (m_lValue * 1#) / (m_lMax - m_lMin)
   Else
      m_fPercent = 0
   End If
   Refresh
End Property

Public Sub Draw( _
      ByVal lHDC As Long, _
      Optional ByVal lLeft As Long = 0, _
      Optional ByVal lTop As Long = 0, _
      Optional ByVal lWidth As Long = -1, _
      Optional ByVal lHeight As Long = -1, _
      Optional ByVal lConstAlpha As Long = 255 _
   )
   
   If (lWidth = -1) Then
      lWidth = m_lWidth
      If (m_bAutoSize) Then
         If (lWidth < m_lMinWidth) Then
            lWidth = m_lMinWidth
         End If
      End If
   End If
   If (lHeight = -1) Then
      lHeight = m_lHeight
   End If
   
   ' copy into the specified DC:
   If (lConstAlpha = 255) Or Not (m_bCodeAlphaBlend) Then
      BitBlt lHDC, lLeft, lTop, lWidth, lHeight, _
         m_cMemDC.hdc, 0, 0, vbSrcCopy
   Else
      Dim lBlend As Long
      Dim tBlend As BLENDFUNCTION
      tBlend.BlendOp = AC_SRC_OVER
      tBlend.SourceConstantAlpha = lConstAlpha
      CopyMemory lBlend, tBlend, 0
      AlphaBlend lHDC, lLeft, lTop, lWidth, lHeight, _
         m_cMemDC.hdc, 0, 0, lWidth, lHeight, lBlend
   End If
End Sub

Public Function Refresh()
Dim sText As String
Dim hBr As Long
Dim hPen As Long
Dim hPenOld As Long
Dim hFontOld As Long
Dim tR As RECT
Dim tActiveR As RECT
Dim tBarR As RECT
Dim tJunk As POINTAPI
Dim lWidth As Long
Dim bBracket As Boolean
   
   ' Get the text to display:
   sText = m_sText
   If (m_bShowPercentage) Then
      If (Len(sText) > 0) Then
         bBracket = True
         sText = sText & " ("
      End If
      sText = sText & Format$(m_fPercent * 100, "##0") & "%"
      If (bBracket) Then
         sText = sText & ")"
      End If
   End If

   ' Determine the width if we are autosizing:
   If (m_bAutoSize) Then
      tR.Bottom = m_lHeight
      ' determine the size:
      If (m_bIsNt) Then
         If StrPtr(sText) > 0 Then
            DrawTextW m_cMemDC.hdc, StrPtr(sText), -1, tR, _
               DT_CALCRECT Or DT_SINGLELINE
         Else
            tR.Right = tR.Left
         End If
      Else
         DrawText m_cMemDC.hdc, sText, -1, tR, _
            DT_CALCRECT Or DT_SINGLELINE
      End If
      m_lWidth = tR.Right - tR.Left + 4
      lWidth = m_lWidth
      If (m_lWidth < m_lMinWidth) Then
         lWidth = m_lMinWidth
      End If
   Else
      lWidth = m_lWidth
   End If
      
   ' Size
   If lWidth > m_cMemDC.Width Or m_lHeight > m_cMemDC.Height Then
      m_cMemDC.Create _
         IIf(lWidth > m_cMemDC.Width, lWidth, m_cMemDC.Width), _
         IIf(m_lHeight > m_cMemDC.Height, m_lHeight, m_cMemDC.Height)
   End If
   
   ' Fill the background
   tR.Left = 0
   tR.Right = lWidth
   tR.Top = 0
   tR.Bottom = m_lHeight
   hBr = CreateSolidBrush(TranslateColor(&H0&))
   FillRect m_cMemDC.hdc, tR, hBr
   DeleteObject hBr
   
   ' Now draw the border:
   hPen = CreatePen(PS_SOLID, 1, &H646464)
   hPenOld = SelectObject(m_cMemDC.hdc, hPen)
   MoveToEx m_cMemDC.hdc, tR.Left, tR.Top, tJunk
   LineTo m_cMemDC.hdc, tR.Right - 1, tR.Top
   LineTo m_cMemDC.hdc, tR.Right - 1, tR.Bottom - 1
   LineTo m_cMemDC.hdc, tR.Left, tR.Bottom - 1
   LineTo m_cMemDC.hdc, tR.Left, tR.Top
   SelectObject m_cMemDC.hdc, hPenOld ' 2003-07-05: Memory leak fix
   DeleteObject hPen
   
   ' The bar gradient
   LSet tActiveR = tR
   tActiveR.Left = tActiveR.Left + 2
   tActiveR.Top = tActiveR.Top + 2
   tActiveR.Right = tActiveR.Right - 1
   tActiveR.Bottom = tActiveR.Bottom - 2
   
   LSet tBarR = tActiveR
   ' set the right hand position:
   tBarR.Right = (tActiveR.Right - tActiveR.Left + 1) * m_fPercent
   ' Draw the bar:
   GradientFillRect m_cMemDC.hdc, tBarR, &H0, &H646464, GRADIENT_FILL_RECT_H
      
   ' Now we draw the centred text and then alpha blend
   ' it over the background 50%:
   If Len(sText) > 0 Then
      Dim cTextDC As New cAlphaDibSection
      cTextDC.Create _
         tActiveR.Right - tActiveR.Left, _
         tActiveR.Bottom - tActiveR.Top
      cTextDC.Clear
      SetBkMode cTextDC.hdc, TRANSPARENT
      SetTextColor cTextDC.hdc, &HFFFFFF
      hFontOld = SelectObject(cTextDC.hdc, m_fnt.hFont)
      If (m_bIsNt) Then
         DrawTextW cTextDC.hdc, StrPtr(sText), -1, tActiveR, _
            DT_CENTER Or DT_SINGLELINE Or DT_VCENTER
      Else
         DrawText cTextDC.hdc, sText, -1, tActiveR, _
               DT_CENTER Or DT_SINGLELINE Or DT_VCENTER
      End If
      SelectObject cTextDC.hdc, hFontOld
                  
      If (m_bCodeAlphaBlend) Then ' 2003-07-05: Win9x AlphaBlend function does
       not work
         ' Win9x/ME/NT4:
         cTextDC.CodeAlphaBlend m_cMemDC, cTextDC, 1, 1, , , 128
      Else
         cTextDC.AlphaPaintPicture m_cMemDC.hdc, 1, 1, , , , , 128
      End If
      
   End If
   
   ' Now colourise the DC according to the bar colour:
   Dim hue As Single, sat As Single, lum As Single
   Dim hueOut As Single, satOut As Single, lumOut As Single
   Dim r As Long, g As Long, b As Long
   Dim lC As Long
   
   lC = TranslateColor(m_oBarColor)
   RGBToHLS (lC And &HFF&), (lC And &HFF00&) \ &H100&, (lC And &HFF0000) \
    &H10000, _
      hueOut, satOut, lumOut
      
   Dim bDib() As Byte
   Dim x As Long, y As Long
   Dim tSA As SAFEARRAY2D
   Dim bDoIt As Boolean
    
   ' Get the bits in the from DIB section:
   With tSA
      .cbElements = 1
      .cDims = 2
      .Bounds(0).lLbound = 0
      .Bounds(0).cElements = m_cMemDC.Height
      .Bounds(1).lLbound = 0
      .Bounds(1).cElements = m_cMemDC.BytesPerScanLine()
      .pvData = m_cMemDC.DIBSectionBitsPtr
    End With
    CopyMemory ByVal VarPtrArray(bDib()), VarPtr(tSA), 4
   
   For x = 0 To m_cMemDC.BytesPerScanLine - 1 Step 4
      For y = 0 To m_cMemDC.Height - 1
         bDoIt = False
         If (y = 0) Or (y >= m_cMemDC.Height - 1) Then
            bDoIt = True
         Else
            If (x = 0) Or (x < tBarR.Right * 4) Or _
               (x = m_cMemDC.BytesPerScanLine - 4) Then
               bDoIt = True
            End If
         End If
         
         If (bDoIt) Then
            RGBToHLS bDib(x + 2, y), bDib(x + 1, y), bDib(x, y), _
               hue, sat, lum
            HLSToRGB hueOut, satOut, (lum * lumOut), r, g, b
               
            bDib(x + 2, y) = r
            bDib(x + 1, y) = g
            bDib(x, y) = b
         End If
      Next y
   Next x
        
   ' Clear the temporary array descriptor
   ' (This does not appear to be necessary, but
   ' for safety do it anyway)
   CopyMemory ByVal VarPtrArray(bDib), 0&, 4
      
   
   
End Function

Private Sub GradientFillRect( _
      ByVal lHDC As Long, _
      tR As RECT, _
      ByVal oStartColor As OLE_COLOR, _
      ByVal oEndColor As OLE_COLOR, _
      ByVal eDir As GradientFillRectType _
   )
Dim hBrush As Long
Dim lStartColor As Long
Dim lEndColor As Long
Dim lR As Long
   
   ' Use GradientFill:
   If (m_bHasGradient) Then
      lStartColor = TranslateColor(oStartColor)
      lEndColor = TranslateColor(oEndColor)
   
      Dim tTV(0 To 1) As TRIVERTEX
      Dim tGR As GRADIENT_RECT
      
      setTriVertexColor tTV(0), lStartColor
      tTV(0).x = tR.Left
      tTV(0).y = tR.Top
      setTriVertexColor tTV(1), lEndColor
      tTV(1).x = tR.Right
      tTV(1).y = tR.Bottom
      
      tGR.UpperLeft = 0
      tGR.LowerRight = 1
      
      GradientFill lHDC, tTV(0), 2, tGR, 1, eDir
      
   Else
      ' Fill with solid brush:
      hBrush = CreateSolidBrush(TranslateColor(oEndColor))
      FillRect lHDC, tR, hBrush
      DeleteObject hBrush
   End If
   
End Sub

Private Sub setTriVertexColor(tTV As TRIVERTEX, lColor As Long)
Dim lRed As Long
Dim lGreen As Long
Dim lBlue As Long
   lRed = (lColor And &HFF&) * &H100&
   lGreen = (lColor And &HFF00&)
   lBlue = (lColor And &HFF0000) \ &H100&
   setTriVertexColorComponent tTV.Red, lRed
   setTriVertexColorComponent tTV.Green, lGreen
   setTriVertexColorComponent tTV.Blue, lBlue
End Sub

Private Sub setTriVertexColorComponent(ByRef iColor As Integer, ByVal
 lComponent As Long)
   If (lComponent And &H8000&) = &H8000& Then
      iColor = (lComponent And &H7F00&)
      iColor = iColor Or &H8000
   Else
      iColor = lComponent
   End If
End Sub

Private Sub RGBToHLS( _
      ByVal r As Long, ByVal g As Long, ByVal b As Long, _
      h As Single, s As Single, l As Single _
   )
Dim Max As Single
Dim Min As Single
Dim delta As Single
Dim rR As Single, rG As Single, rB As Single

   rR = r / 255: rG = g / 255: rB = b / 255

'{Given: rgb each in [0,1].
' Desired: h in [0,360] and s in [0,1], except if s=0, then h=UNDEFINED.}
        Max = Maximum(rR, rG, rB)
        Min = Minimum(rR, rG, rB)
        l = (Max + Min) / 2    '{This is the lightness}
        '{Next calculate saturation}
        If Max = Min Then
            'begin {Acrhomatic case}
            s = 0
            h = 0
           'end {Acrhomatic case}
        Else
           'begin {Chromatic case}
                '{First calculate the saturation.}
           If l <= 0.5 Then
               s = (Max - Min) / (Max + Min)
           Else
               s = (Max - Min) / (2 - Max - Min)
            End If
            '{Next calculate the hue.}
            delta = Max - Min
           If rR = Max Then
                h = (rG - rB) / delta    '{Resulting color is between yellow
                 and magenta}
           ElseIf rG = Max Then
                h = 2 + (rB - rR) / delta '{Resulting color is between cyan and
                 yellow}
           ElseIf rB = Max Then
                h = 4 + (rR - rG) / delta '{Resulting color is between magenta
                 and cyan}
            End If
            'Debug.Print h
            'h = h * 60
           'If h < 0# Then
           '     h = h + 360            '{Make degrees be nonnegative}
           'End If
        'end {Chromatic Case}
      End If
'end {RGB_to_HLS}
End Sub

Private Sub HLSToRGB( _
      ByVal h As Single, ByVal s As Single, ByVal l As Single, _
      r As Long, g As Long, b As Long _
   )
Dim rR As Single, rG As Single, rB As Single
Dim Min As Single, Max As Single

   If s = 0 Then
      ' Achromatic case:
      rR = l: rG = l: rB = l
   Else
      ' Chromatic case:
      ' delta = Max-Min
      If l <= 0.5 Then
         's = (Max - Min) / (Max + Min)
         ' Get Min value:
         Min = l * (1 - s)
      Else
         's = (Max - Min) / (2 - Max - Min)
         ' Get Min value:
         Min = l - s * (1 - l)
      End If
      ' Get the Max value:
      Max = 2 * l - Min
      
      ' Now depending on sector we can evaluate the h,l,s:
      If (h < 1) Then
         rR = Max
         If (h < 0) Then
            rG = Min
            rB = rG - h * (Max - Min)
         Else
            rB = Min
            rG = h * (Max - Min) + rB
         End If
      ElseIf (h < 3) Then
         rG = Max
         If (h < 2) Then
            rB = Min
            rR = rB - (h - 2) * (Max - Min)
         Else
            rR = Min
            rB = (h - 2) * (Max - Min) + rR
         End If
      Else
         rB = Max
         If (h < 4) Then
            rR = Min
            rG = rR - (h - 4) * (Max - Min)
         Else
            rG = Min
            rR = (h - 4) * (Max - Min) + rG
         End If
         
      End If
            
   End If
   r = rR * 255: g = rG * 255: b = rB * 255
End Sub
Private Function Maximum(rR As Single, rG As Single, rB As Single) As Single
   If (rR > rG) Then
      If (rR > rB) Then
         Maximum = rR
      Else
         Maximum = rB
      End If
   Else
      If (rB > rG) Then
         Maximum = rB
      Else
         Maximum = rG
      End If
   End If
End Function
Private Function Minimum(rR As Single, rG As Single, rB As Single) As Single
   If (rR < rG) Then
      If (rR < rB) Then
         Minimum = rR
      Else
         Minimum = rB
      End If
   Else
      If (rB < rG) Then
         Minimum = rB
      Else
         Minimum = rG
      End If
   End If
End Function


Private Sub VerInitialise()
  
   Dim tOSV As OSVERSIONINFO
   tOSV.dwVersionInfoSize = Len(tOSV)
   GetVersionEx tOSV
   
   m_bHasGradient = False
   m_bCodeAlphaBlend = True
   
   m_bIsNt = ((tOSV.dwPlatformId And VER_PLATFORM_WIN32_NT) =
    VER_PLATFORM_WIN32_NT)
   If (tOSV.dwMajorVersion > 5) Then
      m_bHasGradient = True
      m_bCodeAlphaBlend = False
      'm_bIsXp = True
   ElseIf (tOSV.dwMajorVersion = 5) Then
      m_bHasGradient = True
      m_bCodeAlphaBlend = False
      'If (tOSV.dwMinorVersion >= 1) Then
      '   m_bIsXp = True
      'End If
   ElseIf (tOSV.dwMajorVersion = 4) Then ' NT4 or 9x/ME/SE
      If (tOSV.dwMinorVersion >= 10) Then
         m_bHasGradient = True
      End If
   End If
   
End Sub

Private Sub Class_Initialize()
   
   m_oBarColor = &H9CD8F4
   VerInitialise
   Set m_cMemDC = New cAlphaDibSection
   m_bShowPercentage = True
   m_lHeight = 20
   m_lWidth = 100
   Set m_fnt = New StdFont
   m_fnt.Name = "Tahoma"
   m_fnt.Size = 8.25
   m_lMinWidth = 16
   
End Sub