VERSION 5.00
Begin VB.UserControl lvButtons_H 
   Appearance      =   0  'Flat
   AutoRedraw      =   -1  'True
   BackColor       =   &H00000000&
   ClientHeight    =   495
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   1335
   ClipControls    =   0   'False
   DefaultCancel   =   -1  'True
   BeginProperty Font 
      Name            =   "Times New Roman"
      Size            =   9
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   OLEDropMode     =   1  'Manual
   ScaleHeight     =   33
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   89
   ToolboxBitmap   =   "lvButtons.ctx":0000
End
Attribute VB_Name = "lvButtons_H"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Option Compare Text

' See the Readme.html file provided

'/////// Public Events sent back to the parent container
Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Public Event KeyDown(KeyCode As Integer, Shift As Integer)
Public Event KeyPress(KeyAscii As Integer)
Public Event KeyUp(KeyCode As Integer, Shift As Integer)
Public Event MouseOnButton(OnButton As Boolean)
Public Event Click()
Attribute Click.VB_MemberFlags = "200"
Public Event DoubleClick(Button As Integer)   ' added benefit
Public Event OLECompleteDrag(Effect As Long)
Public Event OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
Public Event OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer)
Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean)
Public Event OLESetData(Data As DataObject, DataFormat As Integer)
Public Event OLEStartDrag(Data As DataObject, AllowedEffects As Long)

' GDI32 Function Calls
' =====================================================================
' DC manipulation
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Integer
Private Declare Function GetMapMode Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function GetGDIObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function SetMapMode Lib "gdi32" (ByVal hDC As Long, ByVal nMapMode As Long) As Long
' Shape Forming functions
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Const RGN_DIFF = 4
Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As POINTAPI, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function SelectClipRgn Lib "gdi32" (ByVal hDC As Long, ByVal hRgn As Long) As Long
' Other drawing functions
Private Declare Function Arc Lib "gdi32" (ByVal hDC As Long, ByVal nLeftRect As Long, ByVal nTopRect As Long, ByVal nRightRect As Long, ByVal nBottomRect As Long, ByVal nXStartArc As Long, ByVal nYStartArc As Long, ByVal nXEndArc As Long, ByVal nYEndArc 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 CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function GetBkColor Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function GetTextColor Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function PatBlt Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function Polyline Lib "gdi32" (ByVal hDC As Long, lpPoint As POINTAPI, ByVal nCount As Long) As Long
Private Declare Function RealizePalette Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function Rectangle Lib "gdi32" (ByVal hDC As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function SelectPalette Lib "gdi32" (ByVal hDC As Long, ByVal hPalette As Long, ByVal bForceBackground As Long) As Long
Private Declare Function SetBkColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hDC As Long, ByVal nBkMode As Long) As Long
Private Declare Function SetPixel Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hDC 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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long

' KERNEL32 Function Calls
' =====================================================================
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal ByteLen As Long)

' USER32 Function Calls
' =====================================================================
' General Windows related functions
Private Declare Function CopyImage Lib "user32" (ByVal Handle As Long, ByVal imageType As Long, ByVal newWidth As Long, ByVal newHeight As Long, ByVal lFlags As Long) As Long
Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long
Private Declare Function DrawFocusRect Lib "user32" (ByVal hDC As Long, lpRect As RECT) As Long
Private Declare Function DrawIconEx Lib "user32" (ByVal hDC As Long, ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long
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 GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetIconInfo Lib "user32" (ByVal hIcon As Long, piconinfo As ICONINFO) As Long
Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long

' Standard TYPE Declarations used
' =====================================================================
Private Type POINTAPI                ' general use. Typically used for cursor location
    X As Long
    Y As Long
End Type
Private Type RECT                    ' used to set/ref boundaries of a rectangle
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type
Private Type BITMAP                  ' used to determine if an image is a bitmap
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End Type
Private Type ICONINFO                ' used to determine if image is an icon
    fIcon As Long
    xHotSpot As Long
    yHotSpot As Long
    hbmMask As Long
    hbmColor As Long
End Type
Private Type LOGFONT               ' used to create fonts
  lfHeight As Long
  lfWidth As Long
  lfEscapement As Long
  lfOrientation As Long
  lfWeight As Long
  lfItalic As Byte
  lfUnderline As Byte
  lfStrikeOut As Byte
  lfCharSet As Byte
  lfOutPrecision As Byte
  lfClipPrecision As Byte
  lfQuality As Byte
  lfPitchAndFamily As Byte
  lfFaceName As String * 32
End Type

' Custom TYPE Declarations used
' =====================================================================
Private Type ButtonDCInfo    ' used to manage the drawing DC
    hDC As Long              ' the temporary DC handle
    OldBitmap As Long        ' the original bitmap of the DC
    OldPen As Long           ' the original pen of the DC
    OldBrush As Long         ' the original brush of the DC
    ClipRgn As Long          ' used for circular button borders
    OldFont As Long          ' the original font of the DC
End Type
Private Type ButtonProperties
    bCaption As String                           ' button caption
    bCaptionAlign As AlignmentConstants          ' caption alignment (3 options)
    bCaptionStyle As CaptionEffectConstants      ' raised/sunken/default
    bBackStyle As BackStyleConstants             ' style of button (8 options)
    bStatus As Integer                           ' 0=Up, 1=Focus, 2=Down, 4=Hover
    bShape As ButtonStyleConstants               ' shape of button (rect, diagonal, circle)
    bSegPts As POINTAPI                          ' left/right offsets for diagonal button
    bRect As RECT                                ' cached caption's bounding rectangle
    bShowFocus As Boolean                        ' flag to display/hide focus rectangle
    bBackHover As Long                           ' button back color when mouse hovers
    bForeHover As Long                           ' button text color when mouse hovers
    bLockHover As HoverLockConstants             ' allows/restricts hover colors same as normal button colors (4 options)
    bGradient As GradientConstants               ' 4 gradient directions
    bGradientColor As Long                       ' Gradient color to use
    bMode As ButtonModeConstants
    bValue As Boolean
End Type
Private Type ImageProperties
    Image As StdPicture                          ' button image
    Align As ImagePlacementConstants             ' image alignment (6 options)
    Size As Integer                              ' image size (5 options)
    iRect As RECT                                ' cached image's bounding rectangle
    SourceSize As POINTAPI                       ' cached source image dimensions
    Type As Long                                 ' cached source image type (bmp/ico)
End Type

' Standard CONSTANTS as Constants or Enumerators
' =====================================================================
Private Const WHITENESS = &HFF0062
Private Const CI_BITMAP = &H0
Private Const CI_ICON = &H1
Private Const WM_KEYDOWN As Long = &H100
' //////////// Custom Colors \\\\\\\\\\\\\\\\\
Private Const vbGray = 8421504
' //////////// DrawText API Constants \\\\\\\\\\\\\\
Private Const DT_CALCRECT = &H400
Private Const DT_CENTER = &H1
Private Const DT_LEFT = &H0
Private Const DT_RIGHT = &H2
Private Const DT_WORDBREAK = &H10
' ///////////////// PROJECT-WIDE VARIABLES \\\\\\\\\\\\\\
Private ButtonDC As ButtonDCInfo       ' menu DC for drawing menu items
Private myProps As ButtonProperties    ' cached button properties
Private myImage As ImageProperties     ' cached image properties
Private bNoRefresh As Boolean          ' flag to prevent drawing when multiple properties are changing
Private curBackColor As Long           ' control's back color
Private adjBackColorUp As Long         ' cached backcolor in UP state
Private adjBackColorDn As Long         ' cached backcolor in DOWN state
Private adjHoverColor As Long          ' cached hover backcolor
Private mButton As Integer             ' used to prevent right click firing a click event
Private bTimerActive As Boolean        ' indication mouse is over a button
Private cParentBC As Long              ' parent control's back color
Private cCheckBox As Long              ' cached color for checkbox
Private bKeyDown As Boolean            ' used to properly display checkboxes

' Custom CONSTANTS as Constants or Enumerators
' =====================================================================
' ////////////// Used to set/reset HDC objects \\\\\\\\\\\\\\
Private Enum ColorObjects
    cObj_Brush = 0
    cObj_Pen = 1
    cObj_Text = 2
End Enum
' ////////////// Button Properties \\\\\\\\\\\\\\\
Public Enum ImagePlacementConstants ' image alignment
    lv_LeftEdge = 0
    lv_LeftOfCaption = 1
    lv_RightEdge = 2
    lv_RightOfCaption = 3
    lv_TopCenter = 4
    lv_BottomCenter = 5
End Enum
Public Enum ImageSizeConstants      ' image sizes
    lv_16x16 = 0
    lv_24x24 = 1
    lv_32x32 = 2
    lv_Fill_Stretch = 3
    lv_Fill_ScaleUpDown = 4
End Enum
Public Enum ButtonModeConstants
    lv_CommandButton = 0
    lv_CheckBox = 1
    lv_OptionButton = 2
End Enum
Public Enum ButtonStyleConstants    ' button shapes
    lv_Rectangular = 0
    lv_LeftDiagonal = 1
    lv_RightDiagonal = 2
    lv_FullDiagonal = 3
    lv_Round3D = 4                  ' border changes gradients when clicked
    lv_Round3DFixed = 5             ' border does not change gradients
    lv_RoundFlat = 6                ' 1-pixel black border
End Enum
Public Enum HoverLockConstants      ' hover lock options
    lv_LockTextandBackColor = 0
    lv_LockTextColorOnly = 1
    lv_LockBackColorOnly = 2
    lv_NoLocks = 3
End Enum
Public Enum GradientConstants       ' gradient directions
    lv_NoGradient = 0
    lv_Left2Right = 1
    lv_Right2Left = 2
    lv_Top2Bottom = 3
    lv_Bottom2Top = 4
End Enum
Public Enum CaptionEffectConstants  ' caption styles
    lv_default = 0
    lv_Sunken = 1
    lv_Raised = 2
End Enum
Public Enum FontStyles
    lv_PlainStyle = 0
    lv_Bold = 2
    lv_Italic = 4
    lv_Underline = 8
    lv_BoldItalic = 2 Or 4
    lv_BoldUnderline = 2 Or 8
    lv_ItalicUnderline = 4 Or 8
    lv_BoldItalicUnderline = 2 Or 4 Or 8
End Enum

Public Enum BackStyleConstants      ' button styles
    lv_w95 = 0
    lv_w31 = 1
    lv_XP = 2
    lv_Java = 3
    lv_Flat = 4
    lv_Hover = 5
    lv_Netscape = 6
    lv_Macintosh = 7
End Enum
Public Property Let ButtonStyle(Style As BackStyleConstants)
Attribute ButtonStyle.VB_Description = "Various operating system button styles"

' Sets the style of button to be displayed

If Style < 0 Or Style > 7 Then Exit Property
myProps.bBackStyle = Style
CreateButtonRegion                 ' re-create the button shape
CalculateBoundingRects 0, True     ' recalculate the text/image bounding rectangles
GetGDIMetrics "BackColor"          ' cache base colors
Refresh
PropertyChanged "BackStyle"
End Property

Public Property Get ButtonStyle() As BackStyleConstants
ButtonStyle = myProps.bBackStyle
End Property
Public Property Let Mode(nMode As ButtonModeConstants)
Attribute Mode.VB_Description = "Command button, check box or option button mode"

' Sets the button function/mode

If nMode < lv_CommandButton Or nMode > lv_OptionButton Then Exit Property
If myProps.bMode = lv_OptionButton Then
    ' option buttons. Need to remove references if the Mode changed
    If nMode < lv_OptionButton Then Call ToggleOptionButtons(-1)
End If
If myProps.bMode < lv_OptionButton And nMode = lv_OptionButton Then
    Call ToggleOptionButtons(1) ' add this instance to optionbutton collection
End If
If nMode = lv_CommandButton And myProps.bMode > lv_CommandButton Then Me.Value = False
myProps.bMode = nMode
Refresh
PropertyChanged "Mode"
End Property
Public Property Get Mode() As ButtonModeConstants
Mode = myProps.bMode
End Property

Public Property Let Value(bValue As Boolean)

' For option button & check box modes

If myProps.bMode = lv_CommandButton And bValue = True Then
    ' TRUE values for command buttons not allowed
    If Not UserControl.Ambient.UserMode Then
        MsgBox "This property is not applicable for command button modes.", vbInformation + vbOKOnly
    End If
    Exit Property
End If
myProps.bValue = bValue
' if optionbutton now true, need to toggle the other options buttons off
If bValue And myProps.bMode = lv_OptionButton Then Call ToggleOptionButtons(0)
Refresh
PropertyChanged "Value"
End Property
Public Property Get Value() As Boolean
Attribute Value.VB_Description = "Applicable to only check box or option button modes: True or False"
Attribute Value.VB_UserMemId = 0
Value = myProps.bValue
End Property

Public Property Let Caption(sCaption As String)
Attribute Caption.VB_Description = "The caption of the button. Double pipe (||) is a line break."
Attribute Caption.VB_ProcData.VB_Invoke_PropertyPut = ";Appearance"
Attribute Caption.VB_UserMemId = -518
Attribute Caption.VB_MemberFlags = "200"

' Sets the button caption & hot key for the control

Dim I As Integer, J As Integer
' We look from right to left. VB uses this logic & so do I
I = InStrRev(sCaption, "&")
Do While I
    If Mid$(sCaption, I, 2) = "&&" Then
        I = InStrRev(I - 1, sCaption, "&")
    Else
        J = I + 1: I = 0
    End If
Loop
' if found, we use the next character as a hot key
If J Then AccessKeys = Mid$(sCaption, J, 1)
myProps.bCaption = sCaption                         ' cache the caption
CalculateBoundingRects 0, True                      ' recalculate button text/image bounding rects
Refresh
PropertyChanged "Caption"
End Property
Public Property Get Caption() As String
Caption = myProps.bCaption
End Property

Public Property Let CaptionAlign(nAlign As AlignmentConstants)
Attribute CaptionAlign.VB_Description = "Horizontal alignment of caption on the button."
Attribute CaptionAlign.VB_ProcData.VB_Invoke_PropertyPut = ";Appearance"

' Caption options: Left, Right or Center Justified

If nAlign < vbLeftJustify Or nAlign > vbCenter Then Exit Property
If myImage.Align > lv_RightOfCaption And nAlign < vbCenter And (myImage.SourceSize.X + myImage.SourceSize.Y) > 0 Then
    ' also prevent left/right justifying captions when image is centered in caption
    If UserControl.Ambient.UserMode = False Then
        ' if not in user mode, then explain whey it is prevented
        MsgBox "When button images are aligned top/bottom center, " & vbCrLf & "button captions can only be center aligned", vbOKOnly + vbInformation
    End If
    Exit Property
End If
myProps.bCaptionAlign = nAlign
CalculateBoundingRects 0, True                  ' recalculate text/image bounding rects
Refresh
PropertyChanged "CapAlign"
End Property
Public Property Get CaptionAlign() As AlignmentConstants
CaptionAlign = myProps.bCaptionAlign
End Property

Public Property Let CaptionStyle(nStyle As CaptionEffectConstants)
Attribute CaptionStyle.VB_Description = "Flat, Embossed or Engraved effects"

' Sets the style, raised/sunken or flat (default)

If nStyle < lv_default Or nStyle > lv_Raised Then Exit Property
myProps.bCaptionStyle = nStyle
PropertyChanged "CapStyle"
If Len(myProps.bCaption) Then
    CalculateBoundingRects 0, True
    Refresh
End If
End Property
Public Property Get CaptionStyle() As CaptionEffectConstants
CaptionStyle = myProps.bCaptionStyle
End Property

Public Property Let ButtonShape(nShape As ButtonStyleConstants)
Attribute ButtonShape.VB_Description = "Rectangular or various diagonal shapes"
Attribute ButtonShape.VB_ProcData.VB_Invoke_PropertyPut = ";Appearance"

' Sets the button's shape (rectangular, diagonal, or circular)

If nShape < lv_Rectangular Or nShape > lv_RoundFlat Then Exit Property
myProps.bShape = nShape
CreateButtonRegion                          ' create the new shape
DelayDrawing True
If nShape = lv_FullDiagonal Then
    If myProps.bCaptionAlign <> vbCenter Then
        Me.CaptionAlign = vbCenter
    Else
        CalculateBoundingRects 0, True
    End If
Else
    CalculateBoundingRects 0, True        ' recalculate the buttons text/image bounding rects
End If
DelayDrawing False
PropertyChanged "Shape"
End Property
Public Property Get ButtonShape() As ButtonStyleConstants
ButtonShape = myProps.bShape
End Property

Public Property Set Picture(xPic As StdPicture)
Attribute Picture.VB_Description = "The image used to display on the button."

' Sets the button image which to display

Set myImage.Image = xPic
If myImage.Size = 0 Then myImage.Size = 16
GetGDIMetrics "Picture"
CalculateBoundingRects 0, True              ' recalculate button's text/image bounding rects
Refresh
PropertyChanged "Image"
End Property
Public Property Get Picture() As StdPicture
Set Picture = myImage.Image
End Property

Public Property Let PictureAlign(ImgAlign As ImagePlacementConstants)
Attribute PictureAlign.VB_Description = "Alignment of the button image in relation to the caption and/or button."

' Image alignment options for button (6 different positions)

If ImgAlign < lv_LeftEdge Or ImgAlign > lv_BottomCenter Then Exit Property
myImage.Align = ImgAlign
If ImgAlign = lv_BottomCenter Or ImgAlign = lv_TopCenter Then CaptionAlign = vbCenter
CalculateBoundingRects 0, True          ' recalculate button's text/image bounding rects
Refresh
PropertyChanged "ImgAlign"
End Property
Public Property Get PictureAlign() As ImagePlacementConstants
PictureAlign = myImage.Align
End Property

Public Property Let Enabled(bEnabled As Boolean)
Attribute Enabled.VB_Description = "Determines if events are fired for this button."
Attribute Enabled.VB_ProcData.VB_Invoke_PropertyPut = ";Behavior"
Attribute Enabled.VB_UserMemId = -514

' Enables or disables the button

If bEnabled = UserControl.Enabled Then Exit Property
UserControl.Enabled = bEnabled
If myProps.bBackStyle = 3 And myProps.bMode = lv_CommandButton Then
    ' java disabled seems to not have the lower-left/upper-right pixels transparent
    DelayDrawing True
    CreateButtonRegion
    CalculateBoundingRects 0, True
    DelayDrawing False
Else
    Refresh
End If
PropertyChanged "Enabled"
End Property
Public Property Get Enabled() As Boolean
Enabled = UserControl.Enabled
End Property

Public Property Let ShowFocusRect(bShow As Boolean)
Attribute ShowFocusRect.VB_Description = "Allows or prevents a focus rectangle from being displayed. In design mode, this may always be displayed for button set as Default."
Attribute ShowFocusRect.VB_ProcData.VB_Invoke_PropertyPut = ";Appearance"

' Shows/hides the focus rectangle when button comes into focus

myProps.bShowFocus = bShow
If ((myProps.bStatus And 1) = 1) Then
    ' if currently has the focus, then we take it off
    If Ambient.UserMode Then
        myProps.bStatus = myProps.bStatus And Not 1
        Refresh
    Else
        ' however, we don't if it is the default button
        MsgBox "The focus rectangle may appear on default buttons ONLY while in design mode, " & vbCrLf & _
            "but will not appear when the form is running.", vbInformation + vbOKOnly
    End If
Else
    Refresh
End If
PropertyChanged "Focus"
End Property
Public Property Get ShowFocusRect() As Boolean
ShowFocusRect = myProps.bShowFocus
End Property

Public Property Let PictureSize(nSize As ImageSizeConstants)
Attribute PictureSize.VB_Description = "Size of button image. Last two options automatically center image."

' Sets up to 5 picture sizes

If PictureSize < lv_16x16 Or PictureSize > lv_Fill_ScaleUpDown Then Exit Property
myImage.Size = (nSize + 2) * 8      ' I just want the pixel size
CalculateBoundingRects 0, True      ' recalculate text/image bounding rects
Refresh
PropertyChanged "ImgSize"
End Property
Public Property Get PictureSize() As ImageSizeConstants
If myImage.Size = 0 Then myImage.Size = 16
' parameters are 0,1,2,3,4 & 5, but we store them as 16,24,32,40, & 44
PictureSize = Choose(myImage.Size / 8 - 1, lv_16x16, lv_24x24, lv_32x32, lv_Fill_Stretch, lv_Fill_ScaleUpDown)
End Property

Public Property Let MousePointer(nPointer As MousePointerConstants)
Attribute MousePointer.VB_Description = "Various optional mouse pointers to use when mouse is over the button"

' Sets the mouse pointer for the button

UserControl.MousePointer = nPointer
PropertyChanged "mPointer"
End Property
Public Property Get MousePointer() As MousePointerConstants
MousePointer = UserControl.MousePointer
End Property

Public Property Set MouseIcon(nIcon As StdPicture)
Attribute MouseIcon.VB_Description = "Icon or cursor used to display when mouse is over the button. MousePointer must be set to Custom."

' Sets the mouse icon for the button, MousePointer must be vbCustom

On Error GoTo ShowPropertyError
Set UserControl.MouseIcon = nIcon
If Not nIcon Is Nothing Then
    Me.MousePointer = vbCustom
    PropertyChanged "mIcon"
End If
Exit Property
ShowPropertyError:
If Ambient.UserMode = False Then MsgBox Err.Description, vbInformation + vbOKOnly, "Select .ico Or .cur Files Only"
End Property
Public Property Get MouseIcon() As StdPicture
Set MouseIcon = UserControl.MouseIcon
End Property

Public Property Set Font(nFont As StdFont)
Attribute Font.VB_Description = "Font used to display the caption."
Attribute Font.VB_ProcData.VB_Invoke_PropertyPutRef = ";Font"

' Sets the control's font & also the logical font to use on off-screen DC

Set UserControl.Font = nFont
GetGDIMetrics "Font"
CalculateBoundingRects 0, (Me.FontStyle > -1)    ' recalculate caption's text/image bounding rects
Refresh

PropertyChanged "Font"
End Property
Public Property Get Font() As StdFont
Set Font = UserControl.Font
End Property

Public Property Let FontStyle(nStyle As FontStyles)

' Allows direct changes to font attributes

With UserControl.Font
    .Bold = ((nStyle And lv_Bold) = lv_Bold)
    .Italic = ((nStyle And lv_Italic) = lv_Italic)
    .Underline = ((nStyle And lv_Underline) = lv_Underline)
End With
GetGDIMetrics "Font"
CalculateBoundingRects 0, True
PropertyChanged "Font"
Refresh
End Property
Public Property Get FontStyle() As FontStyles
Attribute FontStyle.VB_Description = "Various font attributes that can be changed directly."
Dim nStyle As Integer
nStyle = nStyle Or Abs(UserControl.Font.Bold) * 2
nStyle = nStyle Or Abs(UserControl.Font.Italic) * 4
nStyle = nStyle Or Abs(UserControl.Font.Underline) * 8
FontStyle = nStyle
End Property

Public Property Let ForeColor(nColor As OLE_COLOR)
Attribute ForeColor.VB_Description = "The color of the caption's font ."
Attribute ForeColor.VB_ProcData.VB_Invoke_PropertyPut = ";Appearance"

' Sets the caption text color

If nColor = UserControl.ForeColor Then Exit Property
UserControl.ForeColor = nColor
If myProps.bLockHover = lv_LockTextandBackColor Or myProps.bLockHover = lv_LockTextColorOnly Then
    Me.HoverForeColor = UserControl.ForeColor
End If
bNoRefresh = False
RedrawButton True
PropertyChanged "cFore"
End Property
Public Property Get ForeColor() As OLE_COLOR
ForeColor = UserControl.ForeColor
End Property

Public Property Let BackColor(nColor As OLE_COLOR)
Attribute BackColor.VB_Description = "Button back color. See also ResetDefaultColors"
Attribute BackColor.VB_ProcData.VB_Invoke_PropertyPut = ";Appearance"

' Sets the backcolor of the button

curBackColor = ConvertColor(nColor)
If myProps.bLockHover = lv_LockBackColorOnly Or myProps.bLockHover = lv_LockTextandBackColor Then
    If myProps.bGradient Then
        Me.HoverBackColor = myProps.bGradientColor
    Else
        Me.HoverBackColor = nColor
    End If
End If
GetGDIMetrics "BackColor"
Refresh
PropertyChanged "cBack"
End Property
Public Property Get BackColor() As OLE_COLOR
BackColor = curBackColor
End Property

Public Property Let GradientColor(nColor As OLE_COLOR)

' Sets the gradient color. Gradients are used this way...
' Shade from BackColor to GradientColor
' GradientMode must be set

If (myProps.bLockHover = lv_LockTextandBackColor Or _
    myProps.bLockHover = lv_LockBackColorOnly) And _
    myProps.bGradient > lv_NoGradient Then
        myProps.bBackHover = nColor
        myProps.bBackHover = Me.HoverBackColor
End If
myProps.bGradientColor = nColor
GetGDIMetrics "BackColor"
If myProps.bGradient Then Refresh
PropertyChanged "cGradient"
End Property
Public Property Get GradientColor() As OLE_COLOR
Attribute GradientColor.VB_Description = "Secondary color used for gradient shades. The BackColor property is the primary color."
Attribute GradientColor.VB_ProcData.VB_Invoke_Property = ";Appearance"
GradientColor = myProps.bGradientColor
End Property

Public Property Let GradientMode(nOpt As GradientConstants)

' Sets the direction of gradient shading

If nOpt < lv_NoGradient Or nOpt > lv_Bottom2Top Then Exit Property
myProps.bGradient = nOpt
If myProps.bLockHover = lv_LockBackColorOnly Or myProps.bLockHover = lv_LockTextandBackColor Then
    If nOpt > lv_NoGradient Then
        myProps.bBackHover = myProps.bGradientColor
    Else
        myProps.bBackHover = curBackColor
    End If
    myProps.bBackHover = Me.HoverBackColor
    GetGDIMetrics "BackColor"
End If
Refresh
PropertyChanged "Gradient"
End Property
Public Property Get GradientMode() As GradientConstants
Attribute GradientMode.VB_Description = "Various directions to draw the gradient shading."
Attribute GradientMode.VB_ProcData.VB_Invoke_Property = ";Behavior"
GradientMode = myProps.bGradient
End Property

Public Property Let ResetDefaultColors(nDefault As Boolean)
Attribute ResetDefaultColors.VB_Description = "Resets button's back color and text color to Window's standard. The hover properties are also reset."
Attribute ResetDefaultColors.VB_ProcData.VB_Invoke_PropertyPut = ";Appearance"

' Resets the BackColor, ForeColor, GradientColor,
' HoverBackColor & HoverForeColor to defaults

If Ambient.UserMode Or nDefault = False Then Exit Property
DelayDrawing True
curBackColor = vbButtonFace
Me.ForeColor = vbButtonText
Me.GradientColor = vbButtonFace
Me.GradientMode = lv_NoGradient
Me.HoverColorLocks = lv_LockTextandBackColor
myProps.bGradientColor = Me.GradientColor
GetGDIMetrics "BackColor"
DelayDrawing False
PropertyChanged "cGradient"
PropertyChanged "cBack"
End Property
Public Property Get ResetDefaultColors() As Boolean
ResetDefaultColors = False
End Property

Public Property Let HoverColorLocks(nLock As HoverLockConstants)
Attribute HoverColorLocks.VB_Description = "Can ensure the hover colors match the caption and back colors. Click for more options."
Attribute HoverColorLocks.VB_ProcData.VB_Invoke_PropertyPut = ";Behavior"

' Has two purposes.
' 1. If the lock wasn't set but is now set, then setting it will
' force HoverForeColor=ForeColor & HoverBackColor=Backcolor
' If gradeints in use, then HoverBackColor=GradientColor
' 2. If the lock was already set, then changing BackColor
' will force HoverBackColor to match. If gradients are used then
' it will force HoverBackColor to match GradientColor
' It will also force HoverForeColor to match ForeColor.

' After the locks have been set, manually changing the
' HoverForeColor, HoverBackColor will adjust/remove the lock

myProps.bLockHover = nLock
If myProps.bLockHover = lv_LockTextandBackColor Or _
    myProps.bLockHover = lv_LockBackColorOnly Then
        If myProps.bGradient Then
            myProps.bBackHover = myProps.bGradientColor
        Else
            myProps.bBackHover = curBackColor
        End If
        PropertyChanged "cBHover"
End If
If myProps.bLockHover = lv_LockTextandBackColor Or _
    myProps.bLockHover = lv_LockTextColorOnly Then
        myProps.bForeHover = UserControl.ForeColor
        PropertyChanged "cFHover"
End If
myProps.bBackHover = Me.HoverBackColor
myProps.bForeHover = Me.HoverForeColor
GetGDIMetrics "BackColor"
PropertyChanged "LockHover"
End Property
Public Property Get HoverColorLocks() As HoverLockConstants
HoverColorLocks = myProps.bLockHover
End Property

Public Property Let HoverForeColor(nColor As OLE_COLOR)
Attribute HoverForeColor.VB_Description = "Color of button caption's text when mouse is hovering over it. Affects the HoverLockColors property."
Attribute HoverForeColor.VB_ProcData.VB_Invoke_PropertyPut = ";Appearance"

' Changes the text color when mouse is over the button
' Changing this property will affect the type of HoverLock

If myProps.bForeHover = nColor Then Exit Property
myProps.bForeHover = nColor
PropertyChanged "cFHover"
If nColor <> UserControl.ForeColor Then
    If myProps.bLockHover = lv_LockTextandBackColor Then
        myProps.bLockHover = lv_LockBackColorOnly
    Else
        If myProps.bLockHover = lv_LockTextColorOnly Then myProps.bLockHover = lv_NoLocks
    End If
End If
myProps.bLockHover = Me.HoverColorLocks
PropertyChanged "cFHover"
End Property
Public Property Get HoverForeColor() As OLE_COLOR
HoverForeColor = myProps.bForeHover
End Property

Public Property Let HoverBackColor(nColor As OLE_COLOR)
Attribute HoverBackColor.VB_Description = "Color of button background when mouse is hovering over it. Affects the HoverLockColors property."
Attribute HoverBackColor.VB_ProcData.VB_Invoke_PropertyPut = ";Appearance"

' Changes the backcolor when mouse is over the button
' Changing this property will affect the type of HoverLock

If myProps.bBackHover = nColor Then Exit Property
myProps.bBackHover = nColor
If nColor <> curBackColor Then
    If myProps.bLockHover = lv_LockTextandBackColor Then
        myProps.bLockHover = lv_LockTextColorOnly
    Else
        If myProps.bLockHover = lv_LockBackColorOnly Then myProps.bLockHover = lv_NoLocks
    End If
End If
myProps.bLockHover = Me.HoverColorLocks
GetGDIMetrics "BackColor"
PropertyChanged "cBHover"
End Property
Public Property Get HoverBackColor() As OLE_COLOR
HoverBackColor = myProps.bBackHover
End Property

Public Property Get hDC() As Long

' Makes the control's hDC availabe at runtime

hDC = UserControl.hDC
End Property

Public Property Get hwnd() As Long

' Makes the control's hWnd available at runtime

hwnd = UserControl.hwnd
End Property

' //////////////////// GENERAL FUNCTIONS, PUBLIC \\\\\\\\\\\\\\\\\\\\\
Public Sub Refresh()

' Refreshes the button & can be called from any form/module

RedrawButton True
End Sub

Public Sub DelayDrawing(bDelay As Boolean)

' Used to prevent redrawing button until all properties are set.
' Should you want to set multiple properties of the control during runtime
' call this function first with a TRUE parameter. Set your button
' attributes and then call it again with a FALSE property to update the
' button.   IMPORTANT: If called with a TRUE parameter you must
' also release it with a call and a FALSE parameter

' NOTE: this function will prevent flicker when several properties
' are being changed at once during run time. It is similar to
' the BeginPaint & EndPaint API functionality
bNoRefresh = bDelay
If bDelay = False Then Refresh
End Sub

Private Sub RedrawButton(bDrawEntireButton As Boolean)
' ==================================================
' Main switchboard routine for redrawing a button
' ==================================================
If bNoRefresh = True Then Exit Sub

Dim polyPts(0 To 15) As POINTAPI, polyColors(1 To 12) As Long
Dim ActiveStatus As Integer
Select Case myProps.bBackStyle
    Case 0:  DrawButton_Win95 polyPts(), polyColors(), ActiveStatus
    Case 1: DrawButton_Win31 polyPts(), polyColors(), ActiveStatus
    Case 2: DrawButton_WinXP polyPts(), polyColors(), ActiveStatus
    Case 3: DrawButton_Java polyPts(), polyColors(), ActiveStatus
    Case 4:  DrawButton_Flat polyPts(), polyColors(), ActiveStatus
    Case 5: DrawButton_Hover polyPts(), polyColors(), ActiveStatus
    Case 6: DrawButton_Netscape polyPts(), polyColors(), ActiveStatus
    Case 7: DrawButton_Macintosh polyPts(), polyColors(), ActiveStatus
End Select
Erase polyPts()
Erase polyColors()
GetSetOffDC False    ' copy the offscreen DC onto the control
UserControl.Refresh
End Sub

Private Function ToggleOptionButtons(nMode As Integer) As Boolean

' Function tracks option buttons for each container they are placed on
' It will 1) Toggle others to false when one is set to true
'         2) Add or remove option buttons from a collection
'         3) Query option buttons to see if one is set to true

Dim I As Integer, NrCtrls As Integer
Dim myObjRef As Long, tgtObjRef As Long

NrCtrls = GetProp(CLng(Tag), "lv_OptCount")
On Error GoTo OptionToggleError

If myProps.bValue And (NrCtrls > 0 Or nMode = 1) Then
    ' called when an option button is set to True; set others to false
    Dim optControl As lvButtons_H
    myObjRef = ObjPtr(Me)
    For I = 1 To NrCtrls
        tgtObjRef = GetProp(CLng(Tag), "lv_Obj" & I)
        If tgtObjRef <> myObjRef Then
            CopyMemory optControl, tgtObjRef, &H4
            optControl.Value = False
            CopyMemory optControl, 0&, &H4
        End If
    Next
End If
Select Case nMode
Case 1: ' Add instance to window db
    SetProp CLng(Tag), "lv_OptCount", NrCtrls + nMode
    SetProp CLng(Tag), "lv_Obj" & NrCtrls + nMode, ObjPtr(Me)
Case -1: ' Remove instance from window db
    Dim bOffset As Boolean
    myObjRef = ObjPtr(Me)
    For I = 1 To NrCtrls
        tgtObjRef = GetProp(CLng(Tag), "lv_Obj" & I)
        If tgtObjRef = myObjRef Then
            bOffset = -1
        Else
            If bOffset Then SetProp CLng(Tag), "lv_Obj" & I, tgtObjRef
        End If
    Next
    RemoveProp CLng(Tag), "lv_Obj" & I - 1
    If NrCtrls = 0 Then RemoveProp CLng(Tag), "lv_OptCount"
Case 2: ' See if any option buttons have True values
    For I = 1 To NrCtrls
        tgtObjRef = GetProp(CLng(Tag), "lv_Obj" & I)
        CopyMemory optControl, tgtObjRef, &H4
        If optControl.Value = True Then
            I = NrCtrls + 1
            ToggleOptionButtons = True
        End If
        CopyMemory optControl, 0&, &H4
    Next
End Select
Exit Function

OptionToggleError:
Debug.Print "Err in OptionToggle: " & Err.Description
End Function

Friend Sub TimerUpdate(lvTimerID As Long)

' pretty good way to determine when cursor moves outside of any shape region
' especially useful for my diagonal/round buttons since they are not your typical
' rectangular shape.

Dim mousePt As POINTAPI, cRect As RECT
GetCursorPos mousePt
If WindowFromPoint(mousePt.X, mousePt.Y) <> UserControl.hwnd Then
    ' when exits button area, kill the timer
    KillTimer UserControl.hwnd, lvTimerID
    myProps.bStatus = myProps.bStatus And Not 4
    bTimerActive = False
    bNoRefresh = False
    RaiseEvent MouseOnButton(False)
    bKeyDown = False
    Refresh
End If
End Sub

Private Sub CalculateBoundingRects(adjWidth As Long, bFullRecalc As Boolean, Optional lEdge As Long)

' Routine measures and places the rectangles to draw
' the caption and image on the control. The results
' are cached so this routine doesn't need to run
' every time the button is redrawn/painted

Dim cRect As RECT, tRect As RECT, iRect As RECT
Dim imgOffset As RECT, bImgWidthAdj As Boolean, bImgHeightAdj As Boolean
Dim rEdge As Long, iEdge As Long

' calculations needed for diagonal buttons
Select Case myProps.bShape
Case lv_RightDiagonal
    rEdge = myProps.bSegPts.Y + ((ScaleWidth - myProps.bSegPts.Y) \ 3)
    adjWidth = rEdge
Case lv_LeftDiagonal
    lEdge = myProps.bSegPts.X - (myProps.bSegPts.X \ 3)
    rEdge = ScaleWidth
    adjWidth = ScaleWidth - lEdge
Case lv_FullDiagonal
    lEdge = myProps.bSegPts.X - (myProps.bSegPts.X \ 3)
    rEdge = myProps.bSegPts.Y + ((ScaleWidth - myProps.bSegPts.Y) \ 3)
    adjWidth = rEdge - lEdge
Case Else
    adjWidth = myProps.bSegPts.Y
    rEdge = ScaleWidth
End Select
' return variables to drawing switchboard
If Not bFullRecalc Then Exit Sub

If (myImage.SourceSize.X + myImage.SourceSize.Y) > 0 Then
    ' image in use, calculations for image rectangle
    If myImage.Size < 33 Then
        Select Case myImage.Align
        Case lv_LeftEdge, lv_LeftOfCaption
            imgOffset.Left = myImage.Size
            bImgWidthAdj = True
        Case lv_RightEdge, lv_RightOfCaption
            imgOffset.Right = myImage.Size
            bImgWidthAdj = True
        Case lv_TopCenter
            imgOffset.Top = myImage.Size
            bImgHeightAdj = True
        Case lv_BottomCenter
            imgOffset.Bottom = myImage.Size
            bImgHeightAdj = True
        End Select
    End If
End If


If Len(myProps.bCaption) Then
    Dim sCaption As String  ' note: Replace$ not compatible with VB5
    sCaption = Replace$(myProps.bCaption, "||", vbNewLine)
    ' calculate total available button width available for text
    cRect.Right = adjWidth - 12 - (myImage.Size * Abs(CInt(bImgWidthAdj)))
    cRect.Bottom = ScaleHeight - 12 - (myImage.Size * Abs(CInt(bImgHeightAdj = True And myImage.Align > lv_RightOfCaption)))
    ' calculate size of rectangle to hold that text, using multiline flag
    DrawText ButtonDC.hDC, sCaption, Len(sCaption), cRect, DT_CALCRECT Or DT_WORDBREAK
    If myProps.bCaptionStyle Then
        cRect.Right = cRect.Right + 2
        cRect.Bottom = cRect.Bottom + 2
    End If
End If

' now calculate the position of the text rectangle
If Len(myProps.bCaption) Then
    tRect = cRect
    Select Case myProps.bCaptionAlign
    Case vbLeftJustify
        OffsetRect tRect, imgOffset.Left + lEdge + 6 + (Abs(CInt(imgOffset.Left > 0) * 6)), 0
    Case vbRightJustify
        OffsetRect tRect, rEdge - imgOffset.Right - 6 - cRect.Right - (Abs(CInt(imgOffset.Right > 0) * 6)), 0
    Case vbCenter
        If imgOffset.Left > 0 And myImage.Align = lv_LeftOfCaption Then
            OffsetRect tRect, (adjWidth - (imgOffset.Left + cRect.Right + 6)) \ 2 + lEdge + 6 + imgOffset.Left, 0
        Else
            If imgOffset.Right > 0 And myImage.Align = lv_RightOfCaption Then
                OffsetRect tRect, (adjWidth - (imgOffset.Right + cRect.Right + 6)) \ 2 + lEdge, 0
            Else
                OffsetRect tRect, ((adjWidth - (imgOffset.Left + imgOffset.Right)) - cRect.Right) \ 2 + lEdge + imgOffset.Left, 0
            End If
        End If
    End Select
Else
    cRect.Bottom = -3
End If
If (myImage.SourceSize.X + myImage.SourceSize.Y) > 0 Then
    ' finalize image rectangle position
    Select Case myImage.Align
    Case lv_LeftEdge
        iRect.Left = lEdge + 6
    Case lv_LeftOfCaption
        If Len(myProps.bCaption) Then
            iRect.Left = tRect.Left - 6 - imgOffset.Left
        Else
            iRect.Left = lEdge + 6
        End If
    Case lv_RightOfCaption
        If Len(myProps.bCaption) Then
            iRect.Left = tRect.Right + 6
        Else
            iRect.Left = rEdge - 6 - imgOffset.Right
        End If
    Case lv_RightEdge
        iRect.Left = rEdge - 6 - imgOffset.Right
    Case lv_TopCenter
        iRect.Top = (ScaleHeight - (cRect.Bottom + imgOffset.Top)) \ 2
        OffsetRect tRect, 0, iRect.Top + 2 + imgOffset.Top
    Case lv_BottomCenter
        iRect.Top = (ScaleHeight - (cRect.Bottom + imgOffset.Bottom)) \ 2 + cRect.Bottom + 3
        OffsetRect tRect, 0, iRect.Top - 2 - cRect.Bottom
    End Select
    If myImage.Align < lv_TopCenter Then
        OffsetRect tRect, 0, (ScaleHeight - cRect.Bottom) \ 2
        iRect.Top = (ScaleHeight - myImage.Size) \ 2
    Else
        iRect.Left = (adjWidth - myImage.Size) \ 2 + lEdge
    End If
    iRect.Right = iRect.Left + myImage.Size
    iRect.Bottom = iRect.Top + myImage.Size
Else
    OffsetRect tRect, 0, (ScaleHeight - cRect.Bottom) \ 2
End If
' sanity checks
If tRect.Top < 6 Then tRect.Top = 6
If tRect.Left < 6 Then tRect.Left = 6
If tRect.Right > rEdge Then tRect.Right = rEdge
If tRect.Bottom > ScaleHeight - 6 Then tRect.Bottom = ScaleHeight - 6
myProps.bRect = tRect
If iRect.Top < 6 Then iRect.Top = 6
If iRect.Left < 6 Then iRect.Left = 6
If iRect.Right > rEdge Then iRect.Right = rEdge
If iRect.Bottom > ScaleHeight - 6 Then iRect.Bottom = ScaleHeight - 6
myImage.iRect = iRect
End Sub

Private Sub GetSetOffDC(bSet As Boolean)

' This sets up our off screen DC & pastes results onto our control.

If bSet = True Then
    If ButtonDC.hDC = 0 Then
        ButtonDC.hDC = CreateCompatibleDC(UserControl.hDC)
        SetBkMode ButtonDC.hDC, 3&
        ' by pulling these objects now, we ensure no memory leaks &
        ' changing the objects as needed can be done in 1 line of code
        ' in the SetButtonColors routine
        ButtonDC.OldBrush = SelectObject(ButtonDC.hDC, CreateSolidBrush(0&))
        ButtonDC.OldPen = SelectObject(ButtonDC.hDC, CreatePen(0&, 1&, 0&))
        GetGDIMetrics "Font"
    End If
    If ButtonDC.OldBitmap = 0 Then
        Dim hBmp As Long
        hBmp = CreateCompatibleBitmap(UserControl.hDC, ScaleWidth, ScaleHeight)
        ButtonDC.OldBitmap = SelectObject(ButtonDC.hDC, hBmp)
    End If
Else
    BitBlt UserControl.hDC, 0, 0, ScaleWidth, ScaleHeight, ButtonDC.hDC, 0, 0, vbSrcCopy
End If
End Sub

Private Sub DrawRect(m_hDC As Long, ByVal X1 As Long, ByVal Y1 As Long, _
                                   ByVal X2 As Long, ByVal Y2 As Long, _
                                   tColor As Long, Optional pColor As Long = -1, _
                                   Optional PenWidth As Long = 0, Optional PenStyle As Long = 0)

' Simple routine to draw a rectangle

If pColor <> -1 Then SetButtonColors True, m_hDC, cObj_Pen, pColor, , PenWidth, , PenStyle
SetButtonColors True, m_hDC, cObj_Brush, tColor, (pColor = -1)
Call Rectangle(m_hDC, X1, Y1, X2, Y2)
End Sub


Private Sub SetButtonColors(bSet As Boolean, m_hDC As Long, TypeObject As ColorObjects, lColor As Long, _
    Optional bSamePenColor As Boolean = True, Optional PenWidth As Long = 1, _
    Optional bSwapPens As Boolean = False, Optional PenStyle As Long = 0)

' This is the basic routine that sets a DC's pen, brush or font color

' here we store the most recent "sets" so we can reset when needed
Dim tBrush As Long, tPen As Long
If bSet Then    ' changing a DC's setting
    Select Case TypeObject
    Case cObj_Brush         ' brush is being changed
        DeleteObject SelectObject(ButtonDC.hDC, CreateSolidBrush(lColor))
        If bSamePenColor Then   ' if the pen color will be the same
            DeleteObject SelectObject(ButtonDC.hDC, CreatePen(PenStyle, PenWidth, lColor))
        End If
    Case cObj_Pen   ' pen is being changed (mostly for drawing lines)
        DeleteObject SelectObject(ButtonDC.hDC, CreatePen(PenStyle, PenWidth, lColor))
    Case cObj_Text  ' text color is changing
        SetTextColor m_hDC, ConvertColor(lColor)
    End Select
Else            ' resetting the DC back to the way it was
    DeleteObject SelectObject(ButtonDC.hDC, ButtonDC.OldBrush)
    DeleteObject SelectObject(ButtonDC.hDC, ButtonDC.OldPen)
End If
End Sub

Private Function ConvertColor(tColor As Long) As Long

' Converts VB color constants to real color values

If tColor < 0 Then
    ConvertColor = GetSysColor(tColor And &HFF&)
Else
    ConvertColor = tColor
End If
End Function

Private Sub CreateButtonRegion()

' this function creates the regions for the specific type of button style

Dim rgnA As Long, rgnB As Long, rgn2Use As Long
Dim lRatio As Single, lEdge As Long, rEdge As Long, Wd As Long
Dim ptTRI(0 To 9) As POINTAPI

myProps.bSegPts.X = 0
myProps.bSegPts.Y = ScaleWidth
rgnB = CreateRectRgn(0, 0, 0, 0)

If ButtonDC.ClipRgn Then
    ' this was set for round buttons
    SelectClipRgn ButtonDC.hDC, 0
    DeleteObject ButtonDC.ClipRgn
    ButtonDC.ClipRgn = 0
End If
Select Case myProps.bShape
  Case lv_Round3D, lv_Round3DFixed, lv_RoundFlat
    rgn2Use = CreateEllipticRgn(0, 0, ScaleWidth + 1, ScaleHeight + 1)
    ButtonDC.ClipRgn = CreateEllipticRgn(2 - Abs(myProps.bShape < lv_RoundFlat), 2 - Abs(myProps.bShape < lv_RoundFlat), ScaleWidth - 1 + Abs(myProps.bShape < lv_RoundFlat), ScaleHeight - 1 + Abs(myProps.bShape < lv_RoundFlat))
  Case lv_Rectangular
    rgn2Use = CreateRectRgn(0, 0, ScaleWidth + 1, ScaleHeight + 1)
    Select Case myProps.bBackStyle
        Case 1 'Windows 16-bit
            GoSub LopOffCorners1
            GoSub LopOffCorners2
        Case 2, 7
            GoSub LopOffCorners3
            GoSub LopOffCorners4
        Case 3    'Java
            If UserControl.Enabled Then
                GoSub LopOffCorners1
                GoSub LopOffCorners2
            End If
    End Select
  
  Case Else
    ' here is my trick for ensuring a sharp edge on diagonal buttons.
    ' Basically a bastardized carpenters formula for right angles
    ' (i.e., 3+4=5 < the hypoteneus). Here I want a 60 degree angle,
    ' and not a 45 degree angle. The difference is sharp or choppy.
    ' Based off of the button height, I need to figure how much of
    ' the opposite end I need to cutoff for the diagonal edge
    lRatio = (ScaleHeight + 1) / 4
    Wd = ScaleWidth
    lEdge = (4 * lRatio)
    ' here we ensure a width of at least 5 pixels wide
    Do While Wd - lEdge < 5
        Wd = Wd + 5
    Loop
    If Wd <> ScaleWidth Then
        ' resize the control if necessary
        DelayDrawing True
        UserControl.Width = ScaleX(Wd, vbPixels, Parent.ScaleMode)
        bNoRefresh = False
    End If
    rEdge = ScaleWidth - lEdge
    ' initial dimensions of our rectangle
    ptTRI(0).X = 0: ptTRI(0).Y = 0
    ptTRI(1).X = 0
    ptTRI(1).Y = ScaleHeight + 1
    ptTRI(2).X = ScaleWidth + 1
    ptTRI(2).Y = ScaleHeight + 1
    ptTRI(3).X = ScaleWidth + 1
    ptTRI(3).Y = 0
    ' now modify the left/right side as needed
    If myProps.bShape = lv_FullDiagonal Or myProps.bShape = lv_LeftDiagonal Then
        ptTRI(1).X = lEdge  ' left portion
        myProps.bSegPts.X = lEdge
    End If
    If myProps.bShape = lv_FullDiagonal Or myProps.bShape = lv_RightDiagonal Then
        ptTRI(3).X = rEdge + 1        ' bottom right
        myProps.bSegPts.Y = rEdge
    End If
    ' for rounded corner buttons, we'll take of the corner pixels where appropriate when the
    ' diagonal button is not a fully-segmeneted type. Diagonal edges are always sharp,
    ' never rounded.
    rgn2Use = CreatePolygonRgn(ptTRI(0), 4, 2)
    Select Case myProps.bBackStyle
    Case 1
        If myProps.bShape = lv_RightDiagonal Then GoSub LopOffCorners1
        If myProps.bShape = lv_LeftDiagonal Then GoSub LopOffCorners2
    Case 2, 7
        If myProps.bShape = lv_RightDiagonal Then GoSub LopOffCorners3
        If myProps.bShape = lv_LeftDiagonal Then GoSub LopOffCorners4
    Case 3
        If UserControl.Enabled Then
            If myProps.bShape = lv_RightDiagonal Then GoSub LopOffCorners1
            If myProps.bShape = lv_LeftDiagonal Then GoSub LopOffCorners2
        End If
    End Select
End Select
Erase ptTRI
If rgnA Then DeleteObject rgnA
If rgnB Then DeleteObject rgnB
SetWindowRgn UserControl.hwnd, rgn2Use, True
If myProps.bSegPts.Y = 0 Then myProps.bSegPts.Y = ScaleWidth
Exit Sub

LopOffCorners1: ' left side top/bottom corners (Java/Win3.x)
    If myProps.bBackStyle = 3 Then
        rgnA = CreateRectRgn(0, ScaleHeight, 1, ScaleHeight - 1)
    Else
        rgnA = CreateRectRgn(0, 0, 1, 1)
    End If
    CombineRgn rgnB, rgn2Use, rgnA, RGN_DIFF
    DeleteObject rgnA
    rgnA = CreateRectRgn(0, ScaleHeight, 1, ScaleHeight - 1)
    CombineRgn rgn2Use, rgnB, rgnA, RGN_DIFF
    DeleteObject rgnA
    Return
LopOffCorners2: ' right side top/bottom corners (Java/Win3.x)
    If myProps.bBackStyle = 3 Then
        rgnA = CreateRectRgn(ScaleWidth, 0, ScaleWidth - 1, 1)
    Else
        rgnA = CreateRectRgn(ScaleWidth, ScaleHeight, ScaleWidth - 1, ScaleHeight - 1)
    End If
    CombineRgn rgnB, rgn2Use, rgnA, RGN_DIFF
    DeleteObject rgnA
    rgnA = CreateRectRgn(ScaleWidth, 0, ScaleWidth - 1, 1)
    CombineRgn rgn2Use, rgnB, rgnA, RGN_DIFF
    DeleteObject rgnA
    Return
LopOffCorners3: ' left side top/bottom corners (XP/Mac)
    ptTRI(0).X = 0: ptTRI(0).Y = 0
    ptTRI(1).X = 2: ptTRI(1).Y = 0
    ptTRI(2).X = 0: ptTRI(2).Y = 2
    rgnA = CreatePolygonRgn(ptTRI(0), 3, 2)
    CombineRgn rgnB, rgn2Use, rgnA, RGN_DIFF
    DeleteObject rgnA
    ptTRI(0).X = 0: ptTRI(0).Y = ScaleHeight
    ptTRI(1).X = 3: ptTRI(1).Y = ScaleHeight
    ptTRI(2).X = 0: ptTRI(2).Y = ScaleHeight - 3
    rgnA = CreatePolygonRgn(ptTRI(0), 3, 2)
    CombineRgn rgn2Use, rgnB, rgnA, RGN_DIFF
    DeleteObject rgnA
Return
LopOffCorners4: ' right side top/bottom corners (XP/Mac)
    ptTRI(0).X = ScaleWidth: ptTRI(0).Y = 0
    ptTRI(1).X = ScaleWidth - 2: ptTRI(1).Y = 0
    ptTRI(2).X = ScaleWidth: ptTRI(2).Y = 2
    rgnA = CreatePolygonRgn(ptTRI(0), 3, 2)
    CombineRgn rgnB, rgn2Use, rgnA, RGN_DIFF
    DeleteObject rgnA
    ptTRI(0).X = ScaleWidth: ptTRI(0).Y = ScaleHeight
    ptTRI(1).X = ScaleWidth - 3: ptTRI(1).Y = ScaleHeight
    ptTRI(2).X = ScaleWidth: ptTRI(2).Y = ScaleHeight - 3
    rgnA = CreatePolygonRgn(ptTRI(0), 3, 2)
    CombineRgn rgn2Use, rgnB, rgnA, RGN_DIFF
    DeleteObject rgnA
Return
End Sub

Private Sub DrawTransparentBitmap(lHDCdest As Long, destRect As RECT, _
                                                    lBMPsource As Long, bmpRect As RECT, _
                                                    Optional lMaskColor As Long = -1, _
                                                    Optional lNewBmpCx As Long, _
                                                    Optional lNewBmpCy As Long)
Const DSna = &H220326 '0x00220326
' =====================================================================
' A pretty good transparent bitmap maker I use in several projects
' Modified here to remove stuff I wont use (i.e., Flipping/Rotating images)
' =====================================================================

    Dim lMask2Use As Long 'COLORREF
    Dim lBmMask As Long, lBmAndMem As Long, lBmColor As Long
    Dim lBmObjectOld As Long, lBmMemOld As Long, lBmColorOld As Long
    Dim lHDCMem As Long, lHDCscreen As Long, lHDCsrc As Long, lHDCMask As Long, lHDCcolor As Long
    Dim X As Long, Y As Long, srcX As Long, srcY As Long
    Dim lRatio(0 To 1) As Single
    Dim hPalOld As Long, hPalMem As Long
    
    lHDCscreen = GetDC(0&)
    lHDCsrc = CreateCompatibleDC(lHDCscreen)     'Create a temporary HDC compatible to the Destination HDC
    SelectObject lHDCsrc, lBMPsource             'Select the bitmap

        srcX = lNewBmpCx                  'Get width of bitmap
        srcY = lNewBmpCy                 'Get height of bitmap
        
        If bmpRect.Right = 0 Then bmpRect.Right = srcX Else srcX = bmpRect.Right - bmpRect.Left
        If bmpRect.Bottom = 0 Then bmpRect.Bottom = srcY Else srcY = bmpRect.Bottom - bmpRect.Top
        
        If (destRect.Right) = 0 Then X = lNewBmpCx Else X = (destRect.Right - destRect.Left)
        If (destRect.Bottom) = 0 Then Y = lNewBmpCy Else Y = (destRect.Bottom - destRect.Top)
        If lNewBmpCx > X Or lNewBmpCy > Y Then
            lRatio(0) = (X / lNewBmpCx)
            lRatio(1) = (Y / lNewBmpCy)
            If lRatio(1) < lRatio(0) Then lRatio(0) = lRatio(1)
            lNewBmpCx = lRatio(0) * lNewBmpCx
            lNewBmpCy = lRatio(0) * lNewBmpCy
            Erase lRatio
        End If
    
    lMask2Use = ConvertColor(GetPixel(lHDCsrc, 0, 0))
    
    'Create some DCs & bitmaps
    lHDCMask = CreateCompatibleDC(lHDCscreen)
    lHDCMem = CreateCompatibleDC(lHDCscreen)
    lHDCcolor = CreateCompatibleDC(lHDCscreen)
    
    lBmColor = CreateCompatibleBitmap(lHDCscreen, srcX, srcY)
    lBmAndMem = CreateCompatibleBitmap(lHDCscreen, X, Y)
    lBmMask = CreateBitmap(srcX, srcY, 1&, 1&, ByVal 0&)
    
    lBmColorOld = SelectObject(lHDCcolor, lBmColor)
    lBmMemOld = SelectObject(lHDCMem, lBmAndMem)
    lBmObjectOld = SelectObject(lHDCMask, lBmMask)
    
    ReleaseDC 0&, lHDCscreen
    
' ====================== Start working here ======================
    
    SetMapMode lHDCMem, GetMapMode(lHDCdest)
    hPalMem = SelectPalette(lHDCMem, 0, True)
    RealizePalette lHDCMem
    
    BitBlt lHDCMem, 0&, 0&, X, Y, lHDCdest, destRect.Left, destRect.Top, vbSrcCopy
    
    
    hPalOld = SelectPalette(lHDCcolor, 0, True)
    RealizePalette lHDCcolor
    SetBkColor lHDCcolor, GetBkColor(lHDCsrc)
    SetTextColor lHDCcolor, GetTextColor(lHDCsrc)
    
    BitBlt lHDCcolor, 0&, 0&, srcX, srcY, lHDCsrc, bmpRect.Left, bmpRect.Top, vbSrcCopy
    
    SetBkColor lHDCcolor, lMask2Use
    SetTextColor lHDCcolor, vbWhite
    
    BitBlt lHDCMask, 0&, 0&, srcX, srcY, lHDCcolor, 0&, 0&, vbSrcCopy
    
    SetTextColor lHDCcolor, vbBlack
    SetBkColor lHDCcolor, vbWhite
    BitBlt lHDCcolor, 0, 0, srcX, srcY, lHDCMask, 0, 0, DSna

    StretchBlt lHDCMem, 0, 0, lNewBmpCx, lNewBmpCy, lHDCMask, 0&, 0&, srcX, srcY, vbSrcAnd
    
    StretchBlt lHDCMem, 0&, 0&, lNewBmpCx, lNewBmpCy, lHDCcolor, 0, 0, srcX, srcY, vbSrcPaint
    
    BitBlt lHDCdest, destRect.Left, destRect.Top, X, Y, lHDCMem, 0&, 0&, vbSrcCopy
    
    'Delete memory bitmaps & DCs
    DeleteObject SelectObject(lHDCcolor, lBmColorOld)
    DeleteObject SelectObject(lHDCMask, lBmObjectOld)
    DeleteObject SelectObject(lHDCMem, lBmMemOld)
    DeleteDC lHDCMem
    DeleteDC lHDCMask
    DeleteDC lHDCcolor
    DeleteDC lHDCsrc
End Sub

Private Sub DrawButtonIcon(iRect As RECT, adjWidth As Long, lEdge As Long)

' Routine will draw the button image

If (myImage.SourceSize.X + myImage.SourceSize.Y) = 0 Then Exit Sub

Dim lImgCopy As Long
Dim imgWidth As Long, imgHeight As Long
Dim rcImage As RECT, dRect As RECT
Dim bIsDown As Boolean
Const MAGICROP = &HB8074A

bIsDown = (myImage.iRect.Left <> iRect.Left)
If myImage.Size < 33 Then   ' 16, 24, 32
    imgWidth = myImage.Size
    imgHeight = myImage.Size
Else
    If myImage.Size = 40 Then   ' strectch
        iRect.Left = Abs(CInt(bIsDown))
        iRect.Top = Abs(CInt(bIsDown))
        iRect.Right = ScaleWidth
        iRect.Bottom = ScaleHeight
        imgWidth = ScaleWidth + CInt(bIsDown)
        imgHeight = ScaleHeight + CInt(bIsDown)
    Else ' scale up/down
        Dim ratio(0 To 1) As Single
        ratio(0) = (adjWidth - 12) / myImage.SourceSize.X
        ratio(1) = (ScaleHeight - 12) / myImage.SourceSize.Y
        If ratio(1) < ratio(0) Then ratio(0) = ratio(1)
        ratio(1) = myImage.SourceSize.Y * ratio(0)
        ratio(0) = myImage.SourceSize.X * ratio(0)
        iRect.Left = (adjWidth - CLng(ratio(0))) \ 2 + lEdge + Abs(CInt(bIsDown))
        iRect.Top = (ScaleHeight - CLng(ratio(1))) \ 2 + Abs(CInt(bIsDown))
        iRect.Right = iRect.Left + CLng(ratio(0))
        iRect.Bottom = iRect.Top + CLng(ratio(1))
        imgWidth = CLng(ratio(0))
        imgHeight = CLng(ratio(1))
        Erase ratio
    End If
End If
lImgCopy = CopyImage(myImage.Image.Handle, myImage.Type, imgWidth, imgHeight, 0)
If lImgCopy = 0 Then Exit Sub
' destination rectangle for drawing on the DC
dRect = iRect

Dim hMemDC As Long
If UserControl.Enabled Then
    hMemDC = ButtonDC.hDC
Else
    Dim hBitmap As Long, hOldBitmap As Long
    Dim hOldBrush As Long
    Dim hOldBackColor As Long, hbrShadow As Long, hbrHilite As Long
    
    ' Create a temporary DC and bitmap to hold the image
    hMemDC = CreateCompatibleDC(ButtonDC.hDC)
    hBitmap = CreateCompatibleBitmap(ButtonDC.hDC, imgWidth + 1, imgHeight + 1)
    hOldBitmap = SelectObject(hMemDC, hBitmap)
    PatBlt hMemDC, 0, 0, imgWidth, imgHeight, WHITENESS
    OffsetRect dRect, -dRect.Left, -dRect.Top
End If
    
    If myImage.Type = CI_ICON Then
        ' draw icon directly onto the temporary DC
        ' for icons, we can draw directly on the destination DC
        DrawIconEx hMemDC, dRect.Left, dRect.Top, lImgCopy, 0, 0, 0, 0, &H3
    Else
        ' draw transparent bitmap onto the temporary DC
        DrawTransparentBitmap hMemDC, dRect, lImgCopy, rcImage, , CLng(imgWidth), CLng(imgHeight)
    End If
  
If UserControl.Enabled = False Then
    hOldBackColor = SetBkColor(ButtonDC.hDC, vbWhite)
    hbrHilite = CreateSolidBrush(ShadeColor(&HC0C0C0, 36, False))
    hbrShadow = CreateSolidBrush(ShadeColor(&HC0C0C0, -36, False))
    hOldBrush = SelectObject(ButtonDC.hDC, hbrHilite)
    BitBlt ButtonDC.hDC, iRect.Left - 1, iRect.Top - 1, imgWidth, imgHeight, hMemDC, 0, 0, MAGICROP
    SelectObject ButtonDC.hDC, hbrShadow
    BitBlt ButtonDC.hDC, iRect.Left, iRect.Top, imgWidth, imgHeight, hMemDC, 0, 0, MAGICROP
  
    SetBkColor ButtonDC.hDC, hOldBackColor
    SelectObject ButtonDC.hDC, hOldBrush
    SelectObject hMemDC, hOldBitmap
    DeleteObject hbrHilite
    If hbrShadow Then DeleteObject hbrShadow
    DeleteObject hBitmap
    DeleteDC hMemDC
End If
If myImage.Type = CI_ICON Then DestroyIcon lImgCopy Else DeleteObject lImgCopy
End Sub

Private Function ShadeColor(lColor As Long, shadeOffset As Integer, lessBlue As Boolean, _
    Optional bFocusRect As Boolean, Optional bInvert As Boolean) As Long

' Basically supply a value between -255 and +255. Positive numbers make
' the passed color lighter and negative numbers make the color darker

Dim valRGB(0 To 2) As Integer, I As Integer

CalcNewColor:
valRGB(0) = (lColor And &HFF) + shadeOffset
valRGB(1) = ((lColor And &HFF00&) / 255&) + shadeOffset
If lessBlue Then
    valRGB(2) = (lColor And &HFF0000) / &HFF00&
    valRGB(2) = valRGB(2) + ((valRGB(2) * CLng(shadeOffset)) \ &HC0)
Else
    valRGB(2) = (lColor And &HFF0000) / &HFF00& + shadeOffset
End If

For I = 0 To 2
    If valRGB(I) > 255 Then valRGB(I) = 255
    If valRGB(I) < 0 Then valRGB(I) = 0
    If bInvert = True Then valRGB(I) = Abs(255 - valRGB(I))
Next
ShadeColor = valRGB(0) + 256& * valRGB(1) + 65536 * valRGB(2)
Erase valRGB

If bFocusRect = True And (ShadeColor = vbBlack Or ShadeColor = vbWhite) Then
    shadeOffset = -shadeOffset
    If shadeOffset = 0 Then shadeOffset = 64
    GoTo CalcNewColor
End If
End Function

Private Sub GetGDIMetrics(sObject As String)

' This routine caches information we don't want to keep gathering every time a button is redrawn.

Select Case sObject
Case "Font"
    ' called when font is changed or control is initialized
    Dim newFont As LOGFONT
    newFont.lfCharSet = 1
    newFont.lfFaceName = UserControl.Font.Name & Chr$(0)
    newFont.lfHeight = (UserControl.Font.Size * -20) / Screen.TwipsPerPixelY
    newFont.lfWeight = UserControl.Font.Weight
    newFont.lfItalic = Abs(CInt(UserControl.Font.Italic))
    newFont.lfStrikeOut = Abs(CInt(UserControl.Font.Strikethrough))
    newFont.lfUnderline = Abs(CInt(UserControl.Font.Underline))
    If ButtonDC.OldFont Then
        DeleteObject SelectObject(ButtonDC.hDC, CreateFontIndirect(newFont))
    Else
        ButtonDC.OldFont = SelectObject(ButtonDC.hDC, CreateFontIndirect(newFont))
    End If
Case "Picture"
    ' get key image information
    Dim bmpInfo As BITMAP, icoInfo As ICONINFO
    If Not myImage.Image Is Nothing Then
        GetGDIObject myImage.Image.Handle, LenB(bmpInfo), bmpInfo
        If bmpInfo.bmBits = 0 Then
            GetIconInfo myImage.Image.Handle, icoInfo
            If icoInfo.hbmColor <> 0 Then
                ' downside... API creates 2 bitmaps that we need to destroy since they aren't used in this
                ' routine & are not destroyed automatically. To prevent memory leak, we destroy them here
                GetGDIObject icoInfo.hbmColor, LenB(bmpInfo), bmpInfo
                DeleteObject icoInfo.hbmColor
                If icoInfo.hbmMask <> 0 Then DeleteObject icoInfo.hbmMask
                myImage.Type = CI_ICON        ' flag indicating image is an icon
            End If
        Else
            myImage.Type = CI_BITMAP     ' flag indicating image is a bitmap
        End If
    End If
    myImage.SourceSize.X = bmpInfo.bmWidth
    myImage.SourceSize.Y = bmpInfo.bmHeight
Case "BackColor"
    adjBackColorUp = ConvertColor(curBackColor)
    adjBackColorDn = adjBackColorUp
    adjHoverColor = ConvertColor(myProps.bBackHover)
    If myProps.bBackStyle = 7 Then
        adjBackColorUp = ShadeColor(adjBackColorUp, &H1F, False)
        adjBackColorDn = ShadeColor(vbGray, -&H10, False)
        adjHoverColor = ShadeColor(adjHoverColor, &H1F, False)
        cCheckBox = ShadeColor(vbGray, &H10, True)
    ElseIf myProps.bBackStyle = 2 Then
        adjBackColorUp = ShadeColor(adjBackColorUp, &H30, True)
        adjHoverColor = ShadeColor(adjHoverColor, &H30, True)
        adjBackColorDn = ShadeColor(adjBackColorUp, -&H20, True)
        cCheckBox = ShadeColor(vbWhite, -&H20, True)
    Else
        If myProps.bBackStyle = 3 Then
            adjBackColorDn = ShadeColor(vbGray, &HC, False)
            cCheckBox = ShadeColor(adjBackColorDn, &H1F, False)
        Else
            cCheckBox = ShadeColor(vbWhite, -&H20, False)
        End If
    End If
End Select
End Sub

Private Sub DrawButtonBackground(bColor As Long, ActiveStatus As Integer, _
                Optional bGradientColor As Long = -1, Optional bHoverColor As Long = -1)
                
' Fill the button with the appropriate backcolor

Dim I As Integer, bColor2Use As Long
Dim focusOffset As Byte, isDown As Byte

focusOffset = Abs(((myProps.bStatus And 1) = 1))
isDown = Abs((myProps.bStatus And 6) = 6)
If isDown Then ActiveStatus = 2 Else ActiveStatus = focusOffset
                            
If bHoverColor < 0 Then bHoverColor = bColor
If bTimerActive And (((myProps.bMode = lv_CommandButton And isDown = 0) Or _
    (myProps.bValue = False And myProps.bMode > lv_CommandButton))) Then
    bColor2Use = bHoverColor
Else
    bColor2Use = bColor
End If

If myProps.bShape > lv_FullDiagonal Then
    SelectClipRgn ButtonDC.hDC, 0
    If bTimerActive = True Or ((myProps.bStatus And 6) = 6) Or myProps.bBackStyle <> 5 Then
        If myProps.bShape < lv_RoundFlat Then
            ' this little trick gives us a good edge to our round button
            ' Too simple really--draw over the entire button a gradient background
            ' then set a clipping region excluding the border size and draw the
            ' rest of the button. Text/images can't overlap the border this way
            If ((myProps.bStatus And 6) = 6) = False Or myProps.bShape = lv_Round3D Then
                I = myProps.bGradient
                myProps.bGradient = 3 + Abs(((myProps.bStatus And 6) = 6))
                DrawGradient ShadeColor(cParentBC, &HAC, False), ShadeColor(cParentBC, -&H20, False)
                myProps.bGradient = I
            End If
        Else
            SetButtonColors True, ButtonDC.hDC, cObj_Pen, vbBlack, , 2
            Arc ButtonDC.hDC, 0, 0, ScaleWidth, ScaleHeight, 0, 0, 0, 0
        End If
        SelectClipRgn ButtonDC.hDC, ButtonDC.ClipRgn
    End If
End If
If myProps.bGradient And myProps.bValue = False Then
    If bTimerActive = True And ((myProps.bStatus And 6) = 6) = False And _
        (myProps.bGradientColor <> myProps.bBackHover) Then
        DrawRect ButtonDC.hDC, 0, 0, ScaleWidth, ScaleHeight, bHoverColor
    Else
        If bGradientColor < 0 Then bGradientColor = bColor
        DrawGradient bColor, bGradientColor
    End If
Else
    If myProps.bBackStyle = 2 And (UserControl.Enabled = True Or myProps.bMode > lv_CommandButton) Then
        For I = 1 To ScaleHeight - 1
            DrawRect ButtonDC.hDC, 1, I, ScaleWidth - 1, I + 1, ShadeColor(bColor2Use, -(25 / ScaleHeight) * I, True)
        Next
    Else
        DrawRect ButtonDC.hDC, 0, 0, ScaleWidth, ScaleHeight, bColor2Use
    End If
End If
End Sub

Private Sub DrawButtonBorder(polyPts() As POINTAPI, polyColors() As Long, ActiveStatus As Integer, _
                    Optional OuterBorderStyle As Long = -1)

' This routine draws the border depending on the button style

Dim I As Integer, J As Integer, xColorRef As Integer
Dim lBorderStyle As Long, lastColor As Long
Dim polyOffset As POINTAPI

' need to run special calculations for diagonal buttons
If myProps.bShape > lv_Rectangular And myProps.bShape < lv_Round3D Then
        polyOffset.X = Abs(CInt(myProps.bShape <> lv_RightDiagonal))
        polyOffset.Y = Abs(CInt(myProps.bShape <> lv_LeftDiagonal))
End If
' calculate X,Y points for all three levels of borders
polyPts(0).X = 2 + myProps.bSegPts.X - polyOffset.X * 4: polyPts(0).Y = ScaleHeight - 3
polyPts(1).X = 2 + polyOffset.X * 2: polyPts(1).Y = 2
polyPts(2).X = myProps.bSegPts.Y - 3 + polyOffset.Y * 3: polyPts(2).Y = 2
polyPts(3).X = ScaleWidth - 3 - polyOffset.Y * 3: polyPts(3).Y = ScaleHeight - 3
polyPts(4).X = 1 + myProps.bSegPts.X - polyOffset.X * 4: polyPts(4).Y = ScaleHeight - 3
For I = 5 To 9
    polyPts(I).X = polyPts(I - 5).X + Choose(I - 4, polyOffset.X - 1, -1 - polyOffset.X, 1 - polyOffset.Y, 1 + polyOffset.Y, -1, -1)
    polyPts(I).Y = polyPts(I - 5).Y + Choose(I - 4, 1, -1, -1, 1, 1, 1)
Next
polyPts(10).X = myProps.bSegPts.X - polyOffset.X: polyPts(10).Y = ScaleHeight - 1 + polyOffset.X
polyPts(11).X = 0: polyPts(11).Y = 0
polyPts(12).X = myProps.bSegPts.Y - 1 + polyOffset.Y: polyPts(12).Y = 0
polyPts(13).X = ScaleWidth - 1: polyPts(13).Y = ScaleHeight - 1 + polyOffset.Y
polyPts(14).X = myProps.bSegPts.X - 1 - polyOffset.X * 2: polyPts(14).Y = ScaleHeight - 1
lastColor = -1

For I = 0 To 13
    Select Case I
        Case Is < 4: xColorRef = I + 1
        Case Is > 8:
            xColorRef = I - 1   ' next line used for dashed borders
            If OuterBorderStyle > -1 Then lBorderStyle = OuterBorderStyle
        Case Else: xColorRef = I
    End Select
    If (I <> 4 And I <> 9) Then
        ' if -1 is the color, we skip that level
        If polyColors(xColorRef) > -1 Then
            ' change the pen color if needed
            If lastColor <> polyColors(xColorRef) Then SetButtonColors True, ButtonDC.hDC, cObj_Pen, polyColors(xColorRef), , , , lBorderStyle
            Polyline ButtonDC.hDC, polyPts(I), 2
            lastColor = polyColors(xColorRef)
        End If
    End If
Next
If polyOffset.Y <> ScaleWidth Then
    ' tweak to ensure bottom, outer border draws correctly on diagonal buttons
    polyPts(15).X = ScaleWidth - 1: polyPts(15).Y = ScaleHeight - 1
    Polyline ButtonDC.hDC, polyPts(14), 2
End If
End Sub

Private Sub DrawFocusRectangle(fColor As Long, _
        bSolid As Boolean, bOnText As Boolean, polyPts() As POINTAPI)

' Draws focus rectangles for the button style & button mode

If ((myProps.bStatus And 1) <> 1) Then Exit Sub
If myProps.bShape > lv_Rectangular And myProps.bShape < lv_Round3D Then
    ' diagonal buttons
    Dim polyOffset As POINTAPI
    If myProps.bSegPts.X Then polyOffset.X = 1
    If myProps.bSegPts.Y < ScaleWidth Then polyOffset.Y = 1
    polyPts(0).X = 4 + myProps.bSegPts.X - polyOffset.X * 6: polyPts(0).Y = ScaleHeight - 5
    polyPts(1).X = 4 + polyOffset.X * 4: polyPts(1).Y = 4
    polyPts(2).X = myProps.bSegPts.Y - 5 + polyOffset.Y * 4: polyPts(2).Y = 4
    polyPts(3).X = ScaleWidth - 5 - polyOffset.Y * 6: polyPts(3).Y = ScaleHeight - 5
    polyPts(4).X = 3 + myProps.bSegPts.X - polyOffset.X * 4: polyPts(4).Y = ScaleHeight - 5
    SetButtonColors True, ButtonDC.hDC, cObj_Pen, fColor
    Polyline ButtonDC.hDC, polyPts(0), 5
Else
  Dim fRect As RECT
    Dim focusOffset As Integer
    If myProps.bShape > lv_FullDiagonal Then    ' round buttons
        SelectClipRgn ButtonDC.hDC, 0
        SetButtonColors True, ButtonDC.hDC, cObj_Pen, fColor
        focusOffset = Abs(CInt(myProps.bShape = lv_RoundFlat))
        Arc ButtonDC.hDC, 3 - focusOffset, 3 - focusOffset, ScaleWidth - 3 + focusOffset, ScaleHeight - 3 + focusOffset, 0, 0, 0, 0
        SelectClipRgn ButtonDC.hDC, ButtonDC.ClipRgn
    Else
        If bOnText = True Then
            If Len(myProps.bCaption) Then fRect = myProps.bRect Else fRect = myImage.iRect
            If bSolid Then   ' for now, only used on Java buttons
                SetButtonColors True, ButtonDC.hDC, cObj_Pen, fColor
                polyPts(0).X = fRect.Left - 3: polyPts(0).Y = fRect.Top - 3
                polyPts(1).X = fRect.Right + 3: polyPts(1).Y = fRect.Top - 3
                polyPts(2).X = fRect.Right + 3: polyPts(2).Y = fRect.Bottom + 3
                polyPts(3).X = fRect.Left - 3: polyPts(3).Y = fRect.Bottom + 3
                polyPts(4).X = fRect.Left - 3: polyPts(4).Y = fRect.Top - 3
                Polyline ButtonDC.hDC, polyPts(0), 5
            Else            ' for now, only used on Macintosh buttons
                focusOffset = Abs(((myProps.bStatus And 6) = 6) Or myProps.bValue = True)
                OffsetRect fRect, -3 + focusOffset, -3 + focusOffset
                fRect.Right = fRect.Right + 6
                fRect.Bottom = fRect.Bottom + 6
                DrawFocusRect ButtonDC.hDC, fRect
            End If
        Else
            fRect.Top = 0
            fRect.Left = 0
            fRect.Right = myProps.bSegPts.Y - (myProps.bSegPts.X + 8)
            fRect.Bottom = ScaleHeight - 8
            OffsetRect fRect, 4 + myProps.bSegPts.X, 4
            If bSolid Then ' used when option buttons/checkboxes have focus if Value=True
                polyPts(0).X = fRect.Left: polyPts(0).Y = fRect.Bottom
                polyPts(1).X = fRect.Left: polyPts(1).Y = fRect.Top
                polyPts(2).X = fRect.Right: polyPts(2).Y = fRect.Top
                polyPts(3).X = fRect.Right: polyPts(3).Y = fRect.Bottom
                polyPts(4).X = fRect.Left: polyPts(4).Y = fRect.Bottom
                SetButtonColors True, ButtonDC.hDC, cObj_Pen, fColor
                Polyline ButtonDC.hDC, polyPts(0), 5
            Else
                DrawFocusRect ButtonDC.hDC, fRect
            End If
        End If
    End If
End If
End Sub

Private Sub DrawCaptionIcon(bColor As Long, Optional tColorDisabled As Long = -1, _
            Optional bOffsetTextDown As Boolean = False, _
            Optional bSingleDisableColor As Boolean = False)

' Routine draws the caption & calls the DrawButtonIcon routine

Dim tRect As RECT, iRect As RECT, adjWidth As Long, lEdge As Long
Dim lColor As Long
' let's get the adjWidth property from the following function
CalculateBoundingRects adjWidth, False, lEdge

' set these rectangles & they may be adjusted a little later
tRect = myProps.bRect
iRect = myImage.iRect
' if the button is in a down position, we'll offset the image/text rects by 1
If (((myProps.bStatus And 6) = 6) Or bOffsetTextDown) And myProps.bBackStyle <> 3 Then
    OffsetRect tRect, 1 + Int(myProps.bShape > lv_FullDiagonal), 1
    OffsetRect iRect, 1 + Int(myProps.bShape > lv_FullDiagonal), 1
End If

DrawButtonIcon iRect, adjWidth, lEdge
If Len(myProps.bCaption) = 0 Then Exit Sub

Dim sCaption As String  ' note Replace$ not compatible with VB5
sCaption = Replace$(myProps.bCaption, "||", vbNewLine)
' Setting text colors and offsets
If UserControl.Enabled = False Then
    If tColorDisabled > -1 And myProps.bGradient = lv_NoGradient Then
        lColor = tColorDisabled
    Else
        lColor = vbWhite
        OffsetRect tRect, 1, 1
        bSingleDisableColor = False
    End If
Else
    ' get the right forecolor to use
    If bTimerActive = True And ((myProps.bStatus And 6) = 6) = False Then
        lColor = ConvertColor(myProps.bForeHover)
    Else
        If myProps.bGradient Then
            lColor = ConvertColor(UserControl.ForeColor)
        Else
            If myProps.bBackStyle = 7 Then
                lColor = tColorDisabled
            Else
                lColor = ConvertColor(UserControl.ForeColor)
            End If
        End If
    End If
    If (myProps.bCaptionStyle And UserControl.Enabled = True) Then
        ' drawing raised/sunken caption styles
        Dim shadeOffset As Integer
        If myProps.bCaptionStyle = lv_Raised Then shadeOffset = 40 Else shadeOffset = -40
        SetButtonColors True, ButtonDC.hDC, cObj_Text, ShadeColor(bColor, shadeOffset, False)
        OffsetRect tRect, -1, 0
        DrawText ButtonDC.hDC, sCaption, Len(sCaption), tRect, DT_WORDBREAK Or Choose(myProps.bCaptionAlign + 1, DT_LEFT, DT_RIGHT, DT_CENTER)
        SetButtonColors True, ButtonDC.hDC, cObj_Text, ShadeColor(bColor, -shadeOffset, False)
        OffsetRect tRect, 2, 2
        DrawText ButtonDC.hDC, sCaption, Len(sCaption), tRect, DT_WORDBREAK Or Choose(myProps.bCaptionAlign + 1, DT_LEFT, DT_RIGHT, DT_CENTER)
        OffsetRect tRect, -1, -1
    End If
End If
SetButtonColors True, ButtonDC.hDC, cObj_Text, lColor
DrawText ButtonDC.hDC, sCaption, Len(sCaption), tRect, DT_WORDBREAK Or Choose(myProps.bCaptionAlign + 1, DT_LEFT, DT_RIGHT, DT_CENTER)
If UserControl.Enabled = False And bSingleDisableColor = False Then
    ' finish drawing the disabled caption
    SetButtonColors True, ButtonDC.hDC, cObj_Text, vbGray
    OffsetRect tRect, -1, -1
    DrawText ButtonDC.hDC, sCaption, Len(sCaption), tRect, DT_WORDBREAK Or Choose(myProps.bCaptionAlign + 1, DT_LEFT, DT_RIGHT, DT_CENTER)
End If

End Sub

Private Sub DrawGradient(ByVal Color1 As Long, ByVal Color2 As Long)
Dim mRect As RECT
Dim I As Long, rctOffset As Integer
Dim PixelStep As Long, rIndex As Long
Dim Colors() As Long

' The gist is to draw 1 pixel rectangles of various colors to create
' the gradient effect. If the size of the rectangle is greater than a
' quarter of the screen size, we'll step it up to 2 pixel rectangles
' to speed things up a bit


On Error Resume Next
mRect.Right = ScaleWidth
mRect.Bottom = ScaleHeight
rctOffset = 1
If myProps.bGradient < 3 Then
        If (Screen.Width \ Screen.TwipsPerPixelX) \ ScaleWidth < 4 Then
            PixelStep = ScaleWidth \ 2
            rctOffset = 2
        Else
            PixelStep = ScaleWidth
        End If
Else
    If (Screen.Height \ Screen.TwipsPerPixelY) \ ScaleHeight < 4 Then
        PixelStep = ScaleHeight \ 2
        rctOffset = 2
    Else
        PixelStep = ScaleHeight
    End If
End If
ReDim Colors(0 To PixelStep - 1) As Long
LoadGradientColors Colors(), Color1, Color2
If myProps.bGradient > 2 Then mRect.Bottom = rctOffset Else mRect.Right = rctOffset
For I = 0 To PixelStep - 1
    If myProps.bGradient Mod 2 Then rIndex = I Else rIndex = PixelStep - I - 1
    DrawRect ButtonDC.hDC, mRect.Left, mRect.Top, mRect.Right, mRect.Bottom, Colors(rIndex)
    If myProps.bGradient > 2 Then
        OffsetRect mRect, 0, rctOffset
    Else
        OffsetRect mRect, rctOffset, 0
    End If
Next
End Sub

Private Sub LoadGradientColors(Colors() As Long, ByVal Color1 As Long, ByVal Color2 As Long)
Dim I As Integer, J As Integer
Dim sBase(0 To 2) As Single
Dim xBase(0 To 2) As Long
Dim lRatio(0 To 2) As Single

' routine adds/removes colors between a range of two colors
' Used by the DrawGradient routine. A variation of the ShadeColor routine


sBase(0) = (Color1 And &HFF)
sBase(1) = (Color1 And &HFF00&) / 255&
sBase(2) = (Color1 And &HFF0000) / &HFF00&
xBase(0) = (Color2 And &HFF)
xBase(1) = (Color2 And &HFF00&) / 255&
xBase(2) = (Color2 And &HFF0000) / &HFF00&

For J = 0 To 2
    lRatio(J) = (xBase(J) - sBase(J)) / UBound(Colors)
Next
Colors(0) = Color1
For J = 1 To UBound(Colors)
    For I = 0 To 2
        sBase(I) = sBase(I) + lRatio(I)
        If sBase(I) > 255 Then sBase(I) = 255
        If sBase(I) < 0 Then sBase(I) = 0
    Next
    Colors(J) = Int(sBase(0)) + 256& * Int(sBase(1)) + 65536 * Int(sBase(2))
Next

Erase sBase
Erase xBase
Erase lRatio
End Sub


' //////////////////// USER CONTROL EVENTS  \\\\\\\\\\\\\\\\\\\\\\\\

Private Sub UserControl_AmbientChanged(PropertyName As String)

' something on the parent container changed

On Error GoTo AbortCheck
    Select Case PropertyName
    Case "DisplayAsDefault" 'changing focus
        If Ambient.DisplayAsDefault = True And myProps.bShowFocus = True Then
            myProps.bStatus = myProps.bStatus Or 1
        Else
            myProps.bStatus = myProps.bStatus And Not 1
        End If
        Refresh
    Case "BackColor"
        cParentBC = ConvertColor(Ambient.BackColor)
        If myProps.bShape > lv_FullDiagonal Or myProps.bBackStyle = 5 Then Refresh
    End Select
AbortCheck:
End Sub

Private Sub UserControl_AccessKeyPress(KeyAscii As Integer)

' This happens when hot key is pressed or button is default/cancel and
' Enter/Escape key is pressed. Basically, we need to fire a click event

If (KeyAscii = 13 Or KeyAscii = 27) And myProps.bMode > lv_CommandButton Then Exit Sub
If ((myProps.bStatus And 1) <> 1) And (KeyAscii <> 13 And KeyAscii <> 27) Then Refresh
' flag that needs to be set in order to fire a click event
mButton = vbLeftButton
Call UserControl_Click  ' now trigger a click event
End Sub

Private Sub UserControl_KeyPress(KeyAscii As Integer)
' not used by me, but we'll send the event
RaiseEvent KeyPress(KeyAscii)
End Sub

Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)

' forward arrow keys as next/previous controls

Select Case KeyCode
Case vbKeyRight
    KeyCode = 0             ' simulate a tab key
    PostMessage CLng(Tag), WM_KEYDOWN, ByVal &H27, ByVal &H4D0001
Case vbKeyDown
    KeyCode = 0
    PostMessage CLng(Tag), WM_KEYDOWN, ByVal &H28, ByVal &H500001
Case vbKeyLeft
    KeyCode = 0             ' simulate a shift+tab key
    PostMessage CLng(Tag), WM_KEYDOWN, ByVal &H25, ByVal &H4B0001
Case vbKeyUp
    KeyCode = 0
    PostMessage CLng(Tag), WM_KEYDOWN, ByVal &H26, ByVal &H480001
Case vbKeySpace
    ' space key on a button is same as enter, but shows the button state changes
    If ((myProps.bStatus And 2) <> 2) Then
        bKeyDown = True
        ' we only want to do this once. Subsequent space keys will still fire
        ' a KeyDown event, but won't keep changing button state
        ' tell routines that mouse is over button & it is "down"
        myProps.bStatus = myProps.bStatus Or 4
        myProps.bStatus = myProps.bStatus Or 2
        Refresh
        ' reset the mouse hover status if needed
        If Not bTimerActive Then myProps.bStatus = myProps.bStatus And Not 4
    End If
End Select
If KeyCode Then RaiseEvent KeyDown(KeyCode, Shift)
End Sub

Private Sub UserControl_KeyUp(KeyCode As Integer, Shift As Integer)

' Key up events.

bKeyDown = False
Select Case KeyCode
Case vbKeySpace
    ' if space bar released & button state is "down", we make button "normal"
    If ((myProps.bStatus And 2) = 2) Then
        mButton = vbLeftButton
        myProps.bStatus = myProps.bStatus And Not 2
        If myProps.bMode > lv_CommandButton Then
            RaiseEvent KeyUp(KeyCode, Shift)
            KeyCode = 0
        Else
            Refresh
        End If
        Call UserControl_Click      ' simulate a click event
    End If
Case vbKeyRight, vbKeyDown, vbKeyLeft, vbKeyUp
    KeyCode = 0
    If myProps.bMode = lv_OptionButton And myProps.bValue = False Then
        mButton = vbLeftButton
        Call UserControl_Click
    End If
Case vbKeyShift
    KeyCode = 0
End Select
If KeyCode Then RaiseEvent KeyUp(KeyCode, Shift)
End Sub

Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

' Only allow left clicks to fire a click event

' key variable... this tells our mouse routines & the click event
' whether or not the left button is doing the clicking
mButton = Button
If Button = vbLeftButton Then
    bKeyDown = True
    myProps.bStatus = myProps.bStatus Or 2      ' simulate a "down" state
    bNoRefresh = False
    Refresh
    ' we need this in case the user clicks & drags mouse off of the control
    ' Without it, we may never get the mouse up event
    SetCapture UserControl.hwnd
End If
RaiseEvent MouseDown(Button, Shift, X, Y)
End Sub

Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

' Here we may fire 2 events: MouseMove & MouseOnButton

On Error GoTo RaiseTheMouseEvent
' if we are already over the button, simply fire the MouseMove event
If bTimerActive Then Err.Raise 5
' if we are outside of the mouse we fire the MouseMove event only.
' Note. We don't use SetCapture/ReleaseCapture, except in one special
' case, because it affects the actual control (not my button control)
' that should rightfully have the focus. However, should the mouse
' be down on this button & the use drags mouse off of the button,
' we will continue to get mouse move events & will fire them accordingly;
' and this is the only appropriate exception for using SetCapture

If X < 0 Or Y < 0 Or X > ScaleWidth Or Y > ScaleHeight Then Err.Raise 5

' An improvement over most other button routines out there....
' A soft timer. No timer control needed. The trick is to get the timer
' to fire back to this instance of the button control. We do that by
' setting a reference to this instance in our Window properties. When
' the timer routine (see modLvTimer) gets an event, the hWnd is passed
' along & with that, the timer routine can retrieve the property we set.
' All this allows the timer routine to positively identify this instance.

myProps.bStatus = myProps.bStatus Or 4      ' set a mouse hover state
RaiseEvent MouseOnButton(True)              ' fire this event
' The MouseOnButton event allows users to change the properties of the
' button while the mouse is over it. For instance, you can supply a different
' image/font/etc & replace it when the mouse leaves the button area

SetProp UserControl.hwnd, "lv_ClassID", ObjPtr(Me)
' the next line is used with expandability in mind. May use multiple timers in future upgrade
SetProp UserControl.hwnd, "lv_TimerID", 237
SetTimer UserControl.hwnd, 237, 50, AddressOf lv_TimerCallBack
bTimerActive = True                         ' flag used for drawing
bNoRefresh = False                         ' ensure flag is reset
If Button = vbLeftButton Then bKeyDown = True
Refresh

RaiseTheMouseEvent:
RaiseEvent MouseMove(Button, Shift, X, Y)
End Sub

Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

' The only tweak here is to trigger a fake click event if user
' double clicked on this button

bKeyDown = False
If Button = vbLeftButton Then
    ReleaseCapture
    myProps.bStatus = myProps.bStatus And Not 2     ' "normal" state
    bNoRefresh = False                              ' ensure flag is reset
    If myProps.bMode = lv_CommandButton Then Refresh
End If
RaiseEvent MouseUp(Button, Shift, X, Y)            ' fire event
' key flag. Update
mButton = Button
End Sub

Private Sub UserControl_Click()

' Again, only allow left mouse button to fire click events. Keyboard
' actions may set the mButton variable to ensure event is fired

If mButton = vbLeftButton Then
    If myProps.bMode > lv_CommandButton Then
        If myProps.bValue = True And myProps.bMode = lv_OptionButton Then Exit Sub
        Me.Value = Not myProps.bValue
    End If
    RaiseEvent Click
End If
End Sub

Private Sub UserControl_DblClick()

' Typical Window buttons do not have a double click event. Each
' double click event on a typical button is registered as 2 clicks
' with 2 sets of MouseDown & MouseUp events. We simulate that too

Dim mousePt As POINTAPI
' another plus... other button routines out there may not pass the
' true X,Y coordinates when firing a fake 2nd click event
GetCursorPos mousePt
ScreenToClient UserControl.hwnd, mousePt
RaiseEvent DoubleClick(CInt(mButton))   ' added benefit/information
If mButton = vbLeftButton Then
    ' double clicked with left mouse button fire a mouse down event
    Call UserControl_MouseDown(vbLeftButton, 0, CSng(mousePt.X), CSng(mousePt.Y))
    ' key variable. This flag indicates we will be sending a fake click event
    mButton = -1
Else
    ' double clicked with middle/right mouse button, send this event only
    RaiseEvent MouseDown(vbLeftButton, 0, CSng(mousePt.X), CSng(mousePt.Y))
End If
End Sub

Private Sub UserControl_GotFocus()

' If no option button in the group is set to True, then the first one that
' gets the focus is set to True by default

If myProps.bMode = lv_OptionButton And myProps.bValue = False Then
    If ToggleOptionButtons(2) = False Then
        mButton = vbLeftButton
        Call UserControl_Click
    End If
End If
End Sub

Private Sub UserControl_OLECompleteDrag(Effect As Long)
' not used by me, but we'll send the event
RaiseEvent OLECompleteDrag(Effect)
End Sub

Private Sub UserControl_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
' not used by me, but we'll send the event
RaiseEvent OLEDragDrop(Data, Effect, Button, Shift, X, Y)
End Sub

Private Sub UserControl_OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer)
' not used by me, but we'll send the event
RaiseEvent OLEDragOver(Data, Effect, Button, Shift, X, Y, State)
End Sub

Private Sub UserControl_OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean)
' not used by me, but we'll send the event
RaiseEvent OLEGiveFeedback(Effect, DefaultCursors)
End Sub

Private Sub UserControl_OLESetData(Data As DataObject, DataFormat As Integer)
' not used by me, but we'll send the event
RaiseEvent OLESetData(Data, DataFormat)
End Sub

Private Sub UserControl_OLEStartDrag(Data As DataObject, AllowedEffects As Long)
' not used by me, but we'll send the event
RaiseEvent OLEStartDrag(Data, AllowedEffects)
End Sub

Private Sub UserControl_Paint()

' this routine typically called by Windows when another window covering
' this button is removed, or when the parent is moved/minimized/etc.

bNoRefresh = False
RedrawButton False
End Sub

Private Sub UserControl_InitProperties()

' Initial properties for a new button

Tag = UserControl.ContainerHwnd
With myProps
    .bCaption = Ambient.DisplayName
    .bCaptionAlign = vbCenter
    .bShowFocus = True
    .bForeHover = vbButtonText
    .bBackHover = vbButtonFace
End With
cParentBC = ConvertColor(Ambient.BackColor)
curBackColor = vbButtonFace         ' this will be the button's initial backcolor
GetGDIMetrics "Font"
GetGDIMetrics "BackColor"
PropertyChanged "Caption"
PropertyChanged "CapAlign"
PropertyChanged "Focus"
PropertyChanged "cFHover"
PropertyChanged "cBHover"
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)

' Write properties

Tag = UserControl.ContainerHwnd
cParentBC = ConvertColor(Ambient.BackColor)
DelayDrawing True
With PropBag
    myProps.bCaption = .ReadProperty("Caption", "")
    myProps.bCaptionAlign = .ReadProperty("CapAlign", 2)
    myProps.bBackStyle = .ReadProperty("BackStyle", 0)
    myProps.bShape = .ReadProperty("Shape", 0)
    myProps.bGradient = .ReadProperty("Gradient", 0)
    myProps.bGradientColor = .ReadProperty("cGradient", vbButtonFace)
    UserControl.ForeColor = .ReadProperty("cFore", vbButtonText)
    Set UserControl.Font = .ReadProperty("Font", UserControl.Font)
    myProps.bShowFocus = .ReadProperty("Focus", True)
    myProps.bMode = .ReadProperty("Mode", 0)
    myProps.bValue = .ReadProperty("Value", False)
    Set myImage.Image = .ReadProperty("Image", Nothing)
    myImage.Size = .ReadProperty("ImgSize", 16)
    myImage.Align = .ReadProperty("ImgAlign", 0)
    myProps.bForeHover = .ReadProperty("cFHover", vbButtonText)
    UserControl.Enabled = .ReadProperty("Enabled", True)
    curBackColor = .ReadProperty("cBack", Parent.BackColor)
    myProps.bBackHover = .ReadProperty("cBHover", curBackColor)
    myProps.bLockHover = .ReadProperty("LockHover", 0)
    myProps.bCaptionStyle = .ReadProperty("CapStyle", 0)
    Set Me.MouseIcon = .ReadProperty("mIcon", Nothing)
    Me.MousePointer = .ReadProperty("mPointer", 0)
End With
GetGDIMetrics "Picture"
GetGDIMetrics "Font"
GetGDIMetrics "BackColor"
Me.Caption = myProps.bCaption      ' sets the hot key if needed
If myProps.bMode = lv_OptionButton Then ToggleOptionButtons (1)
bNoRefresh = False
Call UserControl_Resize
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)

' Store Properties

With PropBag
    .WriteProperty "Caption", myProps.bCaption, ""
    .WriteProperty "CapAlign", myProps.bCaptionAlign, 0
    .WriteProperty "BackStyle", myProps.bBackStyle, 0
    .WriteProperty "Shape", myProps.bShape, 0
    .WriteProperty "Font", UserControl.Font, Nothing
    .WriteProperty "cFore", UserControl.ForeColor, vbButtonText
    .WriteProperty "cFHover", myProps.bForeHover, vbButtonText
    .WriteProperty "cBhover", myProps.bBackHover, curBackColor
    .WriteProperty "Focus", myProps.bShowFocus, True
    .WriteProperty "LockHover", myProps.bLockHover, 0
    .WriteProperty "cGradient", myProps.bGradientColor, vbButtonFace
    .WriteProperty "Gradient", myProps.bGradient, 0
    .WriteProperty "CapStyle", myProps.bCaptionStyle, 0
    .WriteProperty "Mode", myProps.bMode
    .WriteProperty "Value", myProps.bValue
    .WriteProperty "ImgAlign", myImage.Align, 0
    .WriteProperty "Image", myImage.Image, Nothing
    .WriteProperty "ImgSize", myImage.Size, 16
    .WriteProperty "Enabled", UserControl.Enabled, True
    .WriteProperty "cBack", curBackColor
    .WriteProperty "mPointer", UserControl.MousePointer, 0
    .WriteProperty "mIcon", UserControl.MouseIcon, Nothing
End With
End Sub

Private Sub UserControl_Resize()

' since we are using a separate DC for drawing, we need to resize the
' bitmap in that DC each time the control resizes

If bNoRefresh Then Exit Sub

CreateButtonRegion
If ButtonDC.hDC Then
    DeleteObject SelectObject(ButtonDC.hDC, ButtonDC.OldBitmap)
    ButtonDC.OldBitmap = 0  ' this will force a new bitmap for existing DC
End If
GetSetOffDC True
CalculateBoundingRects 0, True
Refresh
End Sub

Private Sub UserControl_Terminate()

' Button is ending, let's clean up

' should never happen that we have a timer left over; but just in case
If bTimerActive Then KillTimer UserControl.hwnd, 1
' circular buttons have a clipping region, kill that too
If ButtonDC.ClipRgn Then DeleteObject ButtonDC.ClipRgn
If ButtonDC.hDC Then
    ' get rid of left over pen & brush
    SetButtonColors False, ButtonDC.hDC, cObj_Pen, 0
    ' get rid of logical font
    DeleteObject SelectObject(ButtonDC.hDC, ButtonDC.OldFont)
    ' destroy the separate Bitmap & select original back into DC
    DeleteObject SelectObject(ButtonDC.hDC, ButtonDC.OldBitmap)
    ' destroy the temporary DC
    DeleteDC ButtonDC.hDC
End If
End Sub
