vbAccelerator - Contents of code file: cLogoButton.cls

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

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 Type RECT
   Left As Long
   Top As Long
   Right As Long
   Bottom As Long
End Type
Private Declare Function LoadImageLong Lib "user32" Alias "LoadImageA" (ByVal
 hInst As Long, ByVal lpsz As Long, ByVal uType As Long, ByVal cx As Long,
 ByVal cy As Long, ByVal uFlags As Long) As Long
Private Declare Function LoadImageString Lib "user32" Alias "LoadImageA" (ByVal
 hInst As Long, ByVal lpsz As String, ByVal uType As Long, ByVal cx As Long,
 ByVal cy As Long, ByVal uFlags As Long) As Long
Private Const IMAGE_BITMAP = 0
Private Const IMAGE_ICON = 1
Private Const IMAGE_CURSOR = 2
Private Const LR_DEFAULTCOLOR = &H0
Private Const LR_MONOCHROME = &H1
Private Const LR_COLOR = &H2
Private Const LR_COPYRETURNORG = &H4
Private Const LR_COPYDELETEORG = &H8
Private Const LR_LOADFROMFILE = &H10
Private Const LR_LOADTRANSPARENT = &H20
Private Const LR_DEFAULTSIZE = &H40
Private Const LR_VGACOLOR = &H80
Private Const LR_LOADMAP3DCOLORS = &H1000&
Private Const LR_CREATEDIBSECTION = &H2000&
Private Const LR_COPYFROMRESOURCE = &H4000&
Private Const LR_SHARED = &H8000&

Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As
 Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long

Private m_cAlphaLogo As cAlphaDibSection
Private m_cAlphaLogoDown As cAlphaDibSection
Private m_cDisabledLogo As cAlphaDibSection

Private m_lAlphaLogoId As Long
Private m_sAlphaLogoFileName As String
Private m_lAlphaLogoDownId As Long
Private m_sAlphaLogoDownFileName As String
Private m_hInst As Long

Private m_tR As RECT
Private m_objDraw As Object

Private m_bOver As Boolean
Private m_bPressed As Boolean

Private WithEvents m_cMouseTrack As cMouseTrack

Private m_bEnabled As Boolean

Public Event Click()

Public Property Get Top() As Long
   Top = m_tR.Top
End Property
Public Property Let Top(ByVal value As Long)
   m_tR.Top = value
End Property
Public Property Get Left() As Long
   Left = m_tR.Left
End Property
Public Property Let Left(ByVal value As Long)
   m_tR.Left = value
End Property
Public Property Get Width() As Long
   Width = m_cAlphaLogo.Width
End Property
Public Property Get Height() As Long
   Height = m_cAlphaLogo.Height
End Property
Public Sub LoadImages()
   '
   Set m_cMouseTrack = New cMouseTrack
   m_cMouseTrack.AttachMouseTracking m_objDraw
   Set m_cAlphaLogo = New cAlphaDibSection
   Set m_cAlphaLogoDown = New cAlphaDibSection
   Dim hBmp As Long
   If (m_hInst = 0) Then
      
      hBmp = LoadImageString(App.hInstance, m_sAlphaLogoFileName, 0, 0, 0,
       LR_LOADFROMFILE)
      m_cAlphaLogo.CreateFromHBitmap hBmp
      DeleteObject hBmp
           
      hBmp = LoadImageString(App.hInstance, m_sAlphaLogoDownFileName, 0, 0, 0,
       LR_LOADFROMFILE)
      m_cAlphaLogoDown.CreateFromHBitmap hBmp
      DeleteObject hBmp
           
   Else
      
      hBmp = LoadImageLong(m_hInst, m_lAlphaLogoId, IMAGE_BITMAP, 0, 0, 0)
      'MsgBox "Alpha Logo" & vbCrLf & hBmp & vbCrLf & m_hInst & vbCrLf &
       m_lAlphaLogoId
      m_cAlphaLogo.CreateFromHBitmap hBmp
      DeleteObject hBmp
            
      hBmp = LoadImageLong(m_hInst, m_lAlphaLogoDownId, IMAGE_BITMAP, 0, 0, 0)
      'MsgBox "Alpha Down Logo" & vbCrLf & hBmp & vbCrLf & m_hInst & vbCrLf &
       m_lAlphaLogoId
      m_cAlphaLogoDown.CreateFromHBitmap hBmp
      DeleteObject hBmp
            
   End If
   
   '
End Sub
Public Property Get DrawObject() As Object
   Set DrawObject = m_objDraw
End Property
Public Property Let DrawObject(obj As Object)
   Set m_objDraw = obj
   Draw
End Property
Public Property Set DrawObject(obj As Object)
   Set m_objDraw = obj
   Draw
End Property
Public Sub Draw()
Dim lhDC As Long
   If Not m_objDraw Is Nothing Then
      m_objDraw.Cls
      If Not m_bEnabled Then
         If Not m_cDisabledLogo Is Nothing Then
            lhDC = m_objDraw.hdc
            m_cDisabledLogo.AlphaPaintPicture lhDC, m_tR.Left, m_tR.Top,
             lConstantAlpha:=192
         End If
      Else
         If Not m_cAlphaLogo Is Nothing Then
            lhDC = m_objDraw.hdc
            If (m_bPressed) Then
               If (m_bOver) Then
                  m_cAlphaLogoDown.AlphaPaintPicture lhDC, m_tR.Left + 2,
                   m_tR.Top + 2
               Else
                  m_cAlphaLogo.AlphaPaintPicture lhDC, m_tR.Left, m_tR.Top,
                   lConstantAlpha:=230
               End If
            Else
               If (m_bOver) Then
                  m_cAlphaLogo.AlphaPaintPicture lhDC, m_tR.Left, m_tR.Top,
                   lConstantAlpha:=230
               Else
                  m_cAlphaLogo.AlphaPaintPicture lhDC, m_tR.Left, m_tR.Top,
                   lConstantAlpha:=192
               End If
            End If
         End If
      End If
      m_objDraw.Refresh
   End If
End Sub
Public Sub Colourise(ByVal hue As Single)
   
   If Not (m_cAlphaLogo Is Nothing) Then
      Dim tImage As SAFEARRAY2D
      Dim bImage() As Byte
      
      With tImage
         .cbElements = 1
         .cDims = 2
         .Bounds(0).lLbound = 0
         .Bounds(0).cElements = m_cAlphaLogo.Height
         .Bounds(1).lLbound = 0
         .Bounds(1).cElements = m_cAlphaLogo.BytesPerScanLine()
         .pvData = m_cAlphaLogo.DIBSectionBitsPtr
      End With
      CopyMemory ByVal VarPtrArray(bImage()), VarPtr(tImage), 4
       
      Dim r As Long, g As Long, b As Long
      Dim x As Long, y As Long
      Dim h As Single, s As Single, l As Single
      For x = 0 To m_cAlphaLogo.BytesPerScanLine - 4 Step 4
         For y = 0 To m_cAlphaLogo.Height - 1
            RGBToHSL bImage(x, y), bImage(x + 1, y), bImage(x + 2, y), h, s, l
            HLSToRGB hue, s, l, r, g, b
            bImage(x + 2, y) = r
            bImage(x + 1, y) = g
            bImage(x, y) = b
         Next y
      Next x
       
      CopyMemory ByVal VarPtrArray(bImage), 0&, 4
   End If
   
   If Not (m_cAlphaLogoDown Is Nothing) Then
      
      With tImage
         .cbElements = 1
         .cDims = 2
         .Bounds(0).lLbound = 0
         .Bounds(0).cElements = m_cAlphaLogoDown.Height
         .Bounds(1).lLbound = 0
         .Bounds(1).cElements = m_cAlphaLogoDown.BytesPerScanLine()
         .pvData = m_cAlphaLogoDown.DIBSectionBitsPtr
      End With
      CopyMemory ByVal VarPtrArray(bImage()), VarPtr(tImage), 4
       
      For x = 0 To m_cAlphaLogoDown.BytesPerScanLine - 4 Step 4
         For y = 0 To m_cAlphaLogoDown.Height - 1
            RGBToHSL bImage(x, y), bImage(x + 1, y), bImage(x + 2, y), h, s, l
            HLSToRGB hue, s, l, r, g, b
            bImage(x + 2, y) = r
            bImage(x + 1, y) = g
            bImage(x, y) = b
         Next y
      Next x
       
      CopyMemory ByVal VarPtrArray(bImage), 0&, 4
   End If
      
   Draw
   
End Sub
Public Property Get Enabled() As Boolean
   Enabled = m_bEnabled
End Property
Public Property Let Enabled(ByVal bState As Boolean)
   m_bEnabled = bState
   createDisabled
   Draw
End Property
Private Sub createDisabled()
   Set m_cDisabledLogo = New cAlphaDibSection
   m_cDisabledLogo.Create m_cAlphaLogo.Width, m_cAlphaLogo.Height
   m_cAlphaLogo.PaintPicture m_cDisabledLogo.hdc
   
      Dim tImage As SAFEARRAY2D
      Dim bImage() As Byte
      
      With tImage
         .cbElements = 1
         .cDims = 2
         .Bounds(0).lLbound = 0
         .Bounds(0).cElements = m_cAlphaLogo.Height
         .Bounds(1).lLbound = 0
         .Bounds(1).cElements = m_cAlphaLogo.BytesPerScanLine()
         .pvData = m_cAlphaLogo.DIBSectionBitsPtr
      End With
      CopyMemory ByVal VarPtrArray(bImage()), VarPtr(tImage), 4
       
      Dim tDisabled As SAFEARRAY2D
      Dim bDisabled() As Byte
      
      With tDisabled
         .cbElements = 1
         .cDims = 2
         .Bounds(0).lLbound = 0
         .Bounds(0).cElements = m_cDisabledLogo.Height
         .Bounds(1).lLbound = 0
         .Bounds(1).cElements = m_cDisabledLogo.BytesPerScanLine()
         .pvData = m_cDisabledLogo.DIBSectionBitsPtr
      End With
      CopyMemory ByVal VarPtrArray(bDisabled()), VarPtr(tDisabled), 4
       
      Dim r As Long, g As Long, b As Long
      Dim x As Long, y As Long
      Dim h As Single, s As Single, l As Single
      Dim hue As Single, saturation As Single, luminance As Single
      Dim lC As Long
      lC = GetSysColor(vbButtonFace And &H1F&)
      r = (lC And &HFF&)
      g = (lC And &HFF00&) \ &H100&
      b = (lC And &HFF0000) \ &H10000
      RGBToHSL r, g, b, hue, saturation, luminance
      saturation = saturation * 0.1
      For x = 0 To m_cAlphaLogo.BytesPerScanLine - 4 Step 4
         For y = 0 To m_cAlphaLogo.Height - 1
            RGBToHSL bImage(x, y), bImage(x + 1, y), bImage(x + 2, y), h, s, l
            If (l > luminance) Then luminance = l
            HLSToRGB hue, saturation, l, r, g, b
            bDisabled(x + 2, y) = r
            bDisabled(x + 1, y) = g
            bDisabled(x, y) = b
         Next y
      Next x
       
      CopyMemory ByVal VarPtrArray(bImage), 0&, 4
   
End Sub
Public Function hitTest(ByVal x As Single, ByVal y As Single) As Boolean
   If m_bEnabled Then
      x = x + 1
      y = y + 1
      If (x >= 0 And x <= m_cAlphaLogo.Width - 1) Then
         If (y >= 0 And y <= m_cAlphaLogo.Height - 1) Then
   
            ' check in alpha logo where we are:
            Dim tImage As SAFEARRAY2D
            Dim bImage() As Byte
            
            With tImage
               .cbElements = 1
               .cDims = 2
               .Bounds(0).lLbound = 0
               .Bounds(0).cElements = m_cAlphaLogo.Height
               .Bounds(1).lLbound = 0
               .Bounds(1).cElements = m_cAlphaLogo.BytesPerScanLine()
               .pvData = m_cAlphaLogo.DIBSectionBitsPtr
            End With
            CopyMemory ByVal VarPtrArray(bImage()), VarPtr(tImage), 4
             
            If bImage(x * 4 + 3, y) > 0 Then
               ' not an alpha area, register a hit:
               hitTest = True
            End If
             
            CopyMemory ByVal VarPtrArray(bImage), 0&, 4
         End If
      End If
   End If
End Function

Public Sub MouseDown(ByVal Button As MouseButtonConstants, ByVal Shift As
 ShiftConstants, ByVal x As Single, ByVal y As Single)
   '
   Dim bOver As Boolean
   bOver = hitTest(x, y)
   If (bOver) Then
      m_bPressed = True
      m_bOver = True
      Draw
   Else
      If Not (bOver = m_bOver) Then
         m_bOver = bOver
         Draw
      End If
   End If
   '
End Sub

Public Sub MouseMove(ByVal Button As MouseButtonConstants, ByVal Shift As
 ShiftConstants, ByVal x As Single, ByVal y As Single)
   '
   Dim bOver As Boolean
   bOver = hitTest(x, y)
   If Not (bOver = m_bOver) Then
      m_bOver = bOver
      Draw
   End If
   If Not m_cMouseTrack Is Nothing Then
      If Not m_cMouseTrack.Tracking Then
         m_cMouseTrack.StartMouseTracking
      End If
   End If
   '
End Sub

Public Sub MouseUp(ByVal Button As MouseButtonConstants, ByVal Shift As
 ShiftConstants, ByVal x As Single, ByVal y As Single)
   '
   m_bPressed = False
   m_bOver = hitTest(x, y)
   Draw
   If (m_bOver) Then
      RaiseEvent Click
   End If
   m_cMouseTrack.StartMouseTracking
   '
End Sub


Public Property Get hInstance() As Long
   hInstance = m_hInst
End Property
Public Property Let hInstance(ByVal hInst As Long)
   m_hInst = hInst
End Property
Public Property Get AlphaLogoId() As Long
   AlphaLogoId = m_lAlphaLogoId
End Property
Public Property Let AlphaLogoId(ByVal lId As Long)
   m_lAlphaLogoId = lId
End Property
Public Property Get AlphaLogoFileName() As String
   AlphaLogoFileName = m_sAlphaLogoFileName
End Property
Public Property Let AlphaLogoFileName(ByVal sFileName As String)
   m_sAlphaLogoFileName = sFileName
End Property
Public Property Get AlphaLogoDownId() As Long
   AlphaLogoDownId = m_lAlphaLogoDownId
End Property
Public Property Let AlphaLogoDownId(ByVal lId As Long)
   m_lAlphaLogoDownId = lId
End Property
Public Property Get AlphaLogoDownFileName() As String
   AlphaLogoDownFileName = m_sAlphaLogoDownFileName
End Property
Public Property Let AlphaLogoDownFileName(ByVal sFileName As String)
   m_sAlphaLogoDownFileName = sFileName
End Property

Private Sub RGBToHSL( _
      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( _
      h As Single, s As Single, 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 Class_Initialize()
   m_bEnabled = True
End Sub

Private Sub m_cMouseTrack_MouseHover(Button As MouseButtonConstants, Shift As
 ShiftConstants, x As Single, y As Single)
   '
   m_cMouseTrack.StartMouseTracking
   '
End Sub

Private Sub m_cMouseTrack_MouseLeave()
   '
   If (m_bOver) Then
      m_bOver = False
      Draw
   End If
End Sub