[Jasa] Pasang Gwarnet Dirumah

Apa itu Gwarnet ? Click Here

Bingung pengen main pakai Gwarnet tapi koneksi pakai MODEM USB ?
jangan khawatir gan , disini bisa masangin di Laptop / PC ente yang make koneksi Modem colok 

Apa Keuntungan Gwarnet yang kamu bisa dapatkan di GWarnet Gold?

Setelah komputer agan dipasang Gwarnet Gold maka otomatis char agan akan mendapat bonus seperti dibawah ini

CEK KOMPATIBILITAS GAME DAN KONEKSI

Periksa tabel dibawah ini. karena gwarnet gold  di rumah bergantung pada jenis koneksi yang dipake dan game yang dimainkan. pastikan game dan koneksi yang agan gunakan cocok.

CARA ORDER JASA PEMASANGAN GWARNET GOLD

Tarif Jasa Gwarnet Gold

1. Rp 30.000/unit   Garansi 1 bulan
2. Rp 25.000/unit   Garansi 3 bulan (minimal 5 unit pemesanan)

Pembayaran bisa melalui 

• Voucher Gcash 
• Unipin
• Pulsa 3
• 3,5K Gold (Dragonnest only) [Vestinel]

[-]Jika sudah ORDER
Download file = [Google Drive]

Pemasangan melalui :

Team Viewer = Link download 

Pengerjaan :

Sebelum pengerjaan install terlebih dahulu Team Viewer (Untuk meremote PC agan)

-Setelah teamviewer berjalan ,berikan id pass teamviewer ke saya. biar bisa ngeremot komputer agan. 
-Jangan close teamviewer sebelum dan selama pemasangan (Kalo diclose entar ga bisa ngeremote -__-)
-jika sudah selesai proses pemasangan GW, silakan tutup aplikasi teamviewer agan.supaya gk bisa d remot.baca disini untuk detail info keamanan 
-tugas Selesai tinggal siap pakai ^_^

Ayo ORDER Sekarang ^^

pembayaran hubungi melalui

BBM : 2BB4B3C9
FB : Click Here

Alay Text Generators

New . aplikasi ALAY TEXT GENERATORS

Hahahaha Aneh yah !

nah kalo agan punya TEMEN yang Alay Banget ,, nah kita bingung kan mau jawab Pake LéßÃÿ 6h7ü KÄÑ
nah Sekarang Saya akan Share Aplikasi ALAY TEXT GENERATORS buatan saya !!!

Download Here..............!!! No Leachers

Sound Guard 2.1 (PREMIUM) / (PRO)

 

Download Injectors          

Download Password RAR

akhirnya dapat juga source 2.1

SEDIKIT MEMAKAI TRIAL 3Hari

jika ingin Teregister Anda Daftar Dulu / Beli Lewat pulsa / transfer pulsa ke saya dengan harga Rp.- 5.000

kirim ke 082171565417

nanti saya akan membalas SMS anda dengan "Serial number"

Tips memasuki Injectors pada saat login

- ketikan "CLUE" Tanpa "

- Pecahkan huruf huruf yang di * dengan huruf yang TEPAT

Source Glass Button For VB6

Kalo masih BINGUNG nih Download aja Source nya => =..====....=====...==.=.==


Buka VB6 => Klick New Project => Klick Project => Pilih Add user Control =>  Pilih New User Control

isi User Control Dengan Source ini

Option Explicit

'-Selfsub declarations----------------------------------------------------------------------------
Private Enum eMsgWhen                                                       'When to callback
  MSG_BEFORE = 1                                                            'Callback before the original WndProc
  MSG_AFTER = 2                                                             'Callback after the original WndProc
  MSG_BEFORE_AFTER = MSG_BEFORE Or MSG_AFTER                                'Callback before and after the original WndProc
End Enum

Private Const ALL_MESSAGES  As Long = -1                                    'All messages callback
Private Const MSG_ENTRIES   As Long = 32                                    'Number of msg table entries
Private Const WNDPROC_OFF   As Long = &H38                                  'Thunk offset to the WndProc execution address
Private Const GWL_WNDPROC   As Long = -4                                    'SetWindowsLong WndProc index
Private Const IDX_SHUTDOWN  As Long = 1                                     'Thunk data index of the shutdown flag
Private Const IDX_HWND      As Long = 2                                     'Thunk data index of the subclassed hWnd
Private Const IDX_WNDPROC   As Long = 9                                     'Thunk data index of the original WndProc
Private Const IDX_BTABLE    As Long = 11                                    'Thunk data index of the Before table
Private Const IDX_ATABLE    As Long = 12                                    'Thunk data index of the After table
Private Const IDX_PARM_USER As Long = 13                                    'Thunk data index of the User-defined callback parameter data index

Private z_ScMem             As Long                                         'Thunk base address
Private z_Sc(64)            As Long                                         'Thunk machine-code initialised here
Private z_Funk              As Collection                                   'hWnd/thunk-address collection

Private Declare Function CallWindowProcA Lib "USER32" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Function GetModuleHandleA Lib "kernel32" (ByVal lpModuleName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function GetWindowThreadProcessId Lib "USER32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Private Declare Function IsBadCodePtr Lib "kernel32" (ByVal lpfn As Long) As Long
Private Declare Function IsWindow Lib "USER32" (ByVal hwnd As Long) As Long
Private Declare Function SetWindowLongA Lib "USER32" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function VirtualAlloc Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
Private Declare Function VirtualFree Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Public Event Status(ByVal sStatus As String)

Private Const WM_MOUSEMOVE    As Long = &H200
Private Const WM_MOUSELEAVE   As Long = &H2A3
Private Const WM_MOVING       As Long = &H216
Private Const WM_SIZING       As Long = &H214
Private Const WM_EXITSIZEMOVE As Long = &H232
Private Const WM_PAINT = &HF

Private Enum TRACKMOUSEEVENT_FLAGS
  TME_HOVER = &H1&
  TME_LEAVE = &H2&
  TME_QUERY = &H40000000
  TME_CANCEL = &H80000000
End Enum

Private Type TRACKMOUSEEVENT_STRUCT
  cbSize                      As Long
  dwFlags                     As TRACKMOUSEEVENT_FLAGS
  hwndTrack                   As Long
  dwHoverTime                 As Long
End Type

Private bTrack                As Boolean
Private bTrackUser32          As Boolean
Private IsHover               As Boolean
Private bMoving               As Boolean

Public Event Click()
Public Event DblClick()
Public Event MouseEnter()
Public Event MouseLeave()
Public Event MouseMove(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 MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function LoadLibraryA Lib "kernel32" (ByVal lpLibFileName As String) As Long
Private Declare Function TrackMouseEvent Lib "USER32" (lpEventTrack As TRACKMOUSEEVENT_STRUCT) As Long
Private Declare Function TrackMouseEventComCtl Lib "Comctl32" Alias "_TrackMouseEvent" (lpEventTrack As TRACKMOUSEEVENT_STRUCT) As Long

'-Candy Button declarations----------------------------------------------------------------------------
Public Enum eAlignment
    PIC_TOP
    PIC_BOTTOM
    PIC_LEFT
    PIC_RIGHT
End Enum

Public Enum eStyle
    XP_Button
    XP_ToolBarButton
    Crystal
    Mac
    Mac_Variation
    WMP
    Plastic
    Iceblock
End Enum

Public Enum eColorScheme
    Custom
    Aqua
    WMP10
    DeepBlue
    DeepRed
    DeepGreen
    DeepYellow
End Enum

Public Enum eState
    eNormal
    ePressed
    eFocus
    eHover
    eChecked
End Enum

Private Type tCrystalParam
    Ref_MixColorFrom As Long
    Ref_Intensity As Long
    Ref_Left As Long
    Ref_Top As Long
    Ref_Radius As Long
    Ref_Height As Long
    Ref_Width As Long
    RadialGXPercent As Long
    RadialGYPercent As Long
    RadialGOffsetX As Long
    RadialGOffsetY As Long
    RadialGIntensity As Long
End Type

Private Type BITMAPINFOHEADER    '40 bytes
   biSize As Long
   biWidth As Long
   biHeight As Long
   biPlanes As Integer
   biBitCount As Integer
   biCompression As Long
   biSizeImage As Long
   biXPelsPerMeter As Long
   biYPelsPerMeter As Long
   biClrUsed As Long
   biClrImportant As Long
End Type

Private Type RGBQUAD
   rgbBlue As Byte
   rgbGreen As Byte
   rgbRed As Byte
   rgbReserved As Byte
End Type

Private Type BITMAP    '24 bytes
  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 BITMAPINFO
  bmiHeader As BITMAPINFOHEADER
  bmiColors As RGBQUAD
End Type

Private Const BI_RGB = 0&
Private Const DIB_RGB_COLORS = 0&

Private m_PictureAlignment                      As eAlignment
Private m_Style                                 As eStyle
Private m_Checked                               As Boolean
Private m_hasFocus                              As Boolean
Private m_Caption                               As String
Private m_StdPicture                            As StdPicture
Private m_Font                                  As StdFont
Private m_ColorButtonHover                      As OLE_COLOR
Private m_ColorButtonUp                         As OLE_COLOR
Private m_ColorButtonDown                       As OLE_COLOR
Private m_ColorBright                           As OLE_COLOR
Private m_ForeColor                             As OLE_COLOR
Private m_DisplayHand                           As Boolean
Private CornerRadius                            As Long
Private m_BorderBrightness                      As Long
Private m_ColorScheme                           As eColorScheme
Private m_bHighLited                            As Boolean
Private m_bIconHighLite                         As Boolean
Private m_lIconHighLiteColor                    As OLE_COLOR
Private m_bCaptionHighLite                      As Boolean
Private m_lCaptionHighLiteColor                 As OLE_COLOR
Private m_bEnabled                              As Boolean
Private m_InitCompleted                         As Boolean
Private hButtonRegion                              As Long

Private Const m_def_ForeColor                   As Long = vbBlack
Private Const m_def_PictureAlignment            As Byte = 0
Private Const DST_TEXT                          As Long = &H1
Private Const DST_PREFIXTEXT                    As Long = &H2
Private Const DST_COMPLEX                       As Long = &H0
Private Const DST_ICON                          As Long = &H3
Private Const DST_BITMAP                        As Long = &H4
Private Const DSS_NORMAL                        As Long = &H0
Private Const DSS_UNION                         As Long = &H10
Private Const DSS_DISABLED                      As Long = &H20
Private Const DSS_MONO                          As Long = &H80
Private Const DSS_RIGHT                         As Long = &H8000
Private Const RGN_XOR = 3
Private Const MK_LBUTTON = &H1

Private Type POINTAPI
    X As Long
    Y As Long
End Type

Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type

Private Declare Function SetWindowRgn Lib "USER32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
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 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 CreateRoundRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long
Private Declare Function DrawState Lib "USER32" Alias "DrawStateA" (ByVal hdc As Long, ByVal hBrush As Long, ByVal lpDrawStateProc As Long, ByVal lParam As Long, ByVal wParam As Long, ByVal X As Long, ByVal Y As Long, ByVal cX As Long, ByVal cY As Long, ByVal fuFlags As Long) As Long
Private Declare Function DrawStateText Lib "USER32" Alias "DrawStateA" (ByVal hdc As Long, ByVal hBrush As Long, ByVal lpDrawStateProc As Long, ByVal lParam As String, ByVal wParam As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal n3 As Long, ByVal n4 As Long, ByVal un As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function SetPixelV Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Private Declare Function TranslateColor Lib "olepro32.dll" Alias "OleTranslateColor" (ByVal clr As OLE_COLOR, ByVal palet As Long, Col As Long) As Long
Private Declare Function PtInRegion Lib "gdi32" (ByVal hRgn As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function InflateRect Lib "USER32" (lpRect As RECT, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function Ellipse 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 SetRect Lib "USER32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function IsRectEmpty Lib "USER32" (lpRect As RECT) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) 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 FillRect Lib "USER32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long


Public Property Let DisplayHand(newValue As Boolean)
    m_DisplayHand = newValue
End Property

Public Property Get DisplayHand() As Boolean
    DisplayHand = m_DisplayHand
End Property

'Description: Enable or disable the control
Public Property Let Enabled(bEnabled As Boolean)
On Error GoTo Handler
    m_bEnabled = bEnabled
    PropertyChanged "Enabled"
    '/*** added
    DrawButton (eNormal)
Handler:
End Property

Public Property Get Enabled() As Boolean
On Error GoTo Handler
    Enabled = m_bEnabled
    Refresh
    Exit Property
Handler:
End Property

Public Property Let ColorScheme(newValue As eColorScheme)
    Select Case newValue
        Case Aqua
            ColorButtonUp = &HD06720
            ColorButtonHover = &HE99950
            ColorButtonDown = &HA06710
            ColorBright = &HFFEDB0
        Case WMP10
            ColorButtonUp = &HD09060
            ColorButtonHover = &HE06000
            ColorButtonDown = &HA98050
            ColorBright = &HFFFAFA
        Case DeepBlue
            ColorButtonUp = &H800000
            ColorButtonHover = &HA00000
            ColorButtonDown = &HF00000
            ColorBright = &HFF0000
        Case DeepRed
            ColorButtonUp = &H80&
            ColorButtonHover = &HA0&
            ColorButtonDown = &HF0&
            ColorBright = &HFF&
        Case DeepGreen
            ColorButtonUp = &H8000&
            ColorButtonHover = &HA000&
            ColorButtonDown = &HC000&
            ColorBright = &HFF00&
        Case DeepYellow
            ColorButtonUp = &H8080&
            ColorButtonHover = &HA0A0&
            ColorButtonDown = &HC0C0&
            ColorBright = &HFFFF&
    End Select
    m_ColorScheme = newValue
    PropertyChanged "m_ColorScheme"
    DrawButton (eNormal)
End Property

Public Property Get ColorScheme() As eColorScheme
    ColorScheme = m_ColorScheme
End Property

Public Property Let BorderBrightness(newValue As Long)
    m_BorderBrightness = SetBound(newValue, -100, 100)
    PropertyChanged "m_BorderBrightness"
    DrawButton (eNormal)
End Property

Public Property Get BorderBrightness() As Long
    BorderBrightness = m_BorderBrightness
End Property

'/*** enable icon mouse over highliting
Public Property Get IconHighLite() As Boolean
    IconHighLite = m_bIconHighLite
End Property

Public Property Let IconHighLite(PropVal As Boolean)
    m_bIconHighLite = PropVal
    PropertyChanged "IconHighLite"
End Property

'/*** enable icon mouse over highliting
Public Property Get IconHighLiteColor() As OLE_COLOR
    IconHighLiteColor = m_lIconHighLiteColor
End Property

Public Property Let IconHighLiteColor(PropVal As OLE_COLOR)
    m_lIconHighLiteColor = PropVal
    PropertyChanged "IconHighLiteColor"
End Property

'/*** enable caption mouse over highliting
Public Property Get CaptionHighLite() As Boolean
    CaptionHighLite = m_bCaptionHighLite
End Property

Public Property Let CaptionHighLite(PropVal As Boolean)
    m_bCaptionHighLite = PropVal
    PropertyChanged "CaptionHighLite"
End Property

Public Property Get CaptionHighLiteColor() As OLE_COLOR
    CaptionHighLiteColor = m_lCaptionHighLiteColor
End Property

Public Property Let CaptionHighLiteColor(PropVal As OLE_COLOR)
    m_lCaptionHighLiteColor = PropVal
    PropertyChanged "CaptionHighLiteColor"
End Property

Public Property Let ColorBright(newValue As OLE_COLOR)
    m_ColorBright = newValue
    If m_ColorScheme <> Custom Then m_ColorScheme = Custom:  PropertyChanged "m_ColorScheme"
    PropertyChanged "m_ColorBright"
    DrawButton (eNormal)
End Property

Public Property Get ColorBright() As OLE_COLOR
    ColorBright = m_ColorBright
End Property

Public Property Let ColorButtonDown(newValue As OLE_COLOR)
    m_ColorButtonDown = newValue
    If m_ColorScheme <> Custom Then m_ColorScheme = Custom:  PropertyChanged "m_ColorScheme"
    PropertyChanged "m_ColorButtonDown"
    DrawButton (eNormal)
End Property

Public Property Get ColorButtonDown() As OLE_COLOR
    ColorButtonDown = m_ColorButtonDown
End Property

Public Property Let ColorButtonUp(newValue As OLE_COLOR)
    m_ColorButtonUp = newValue
    If m_ColorScheme <> Custom Then m_ColorScheme = Custom:  PropertyChanged "m_ColorScheme"
    PropertyChanged "m_ColorButtonUp"
    DrawButton (eNormal)
End Property

Public Property Get ColorButtonUp() As OLE_COLOR
    ColorButtonUp = m_ColorButtonUp
End Property

Public Property Let ColorButtonHover(newValue As OLE_COLOR)
    m_ColorButtonHover = newValue
    If m_ColorScheme <> Custom Then m_ColorScheme = Custom:  PropertyChanged "m_ColorScheme"
    PropertyChanged "m_ColorButtonHover"
    DrawButton (eNormal)
End Property

Public Property Get ColorButtonHover() As OLE_COLOR
    ColorButtonHover = m_ColorButtonHover
End Property

Public Property Let ForeColor(ByVal NewForeColor As OLE_COLOR)
     m_ForeColor = NewForeColor
     UserControl.ForeColor = m_ForeColor
     PropertyChanged "ForeColor"
     DrawButton (eNormal)
End Property

Public Property Get ForeColor() As OLE_COLOR
     ForeColor = m_ForeColor
End Property

Public Property Set Picture(value As StdPicture)
    Set m_StdPicture = value
    PropertyChanged "Picture"
    DrawButton (eNormal)
End Property

Public Property Get Picture() As StdPicture
    Set Picture = m_StdPicture
End Property

Public Property Let Checked(value As Boolean)
    m_Checked = value
    If value Then
        DrawButton (eChecked)
    Else
        If IsHover Then
            DrawButton (eHover)
        Else
            DrawButton (eNormal)
        End If
    End If
    PropertyChanged "Checked"
End Property

Public Property Get Checked() As Boolean
    Checked = m_Checked
End Property

Public Property Let Style(eVal As eStyle)
    If eVal <> m_Style Then
        m_Style = eVal
        PropertyChanged "Style"
        Init_Style
        DrawButton (eNormal)
    End If
End Property

Public Property Get Style() As eStyle
    Style = m_Style
End Property

Public Property Let PictureAlignment(eVal As eAlignment)
    If eVal <> m_PictureAlignment Then
        m_PictureAlignment = eVal
        PropertyChanged "PictureAlignment"
        DrawButton (eNormal)
    End If
End Property

Public Property Get PictureAlignment() As eAlignment
    PictureAlignment = m_PictureAlignment
End Property

Public Property Let Caption(ByVal New_Caption As String)
    m_Caption = New_Caption
    PropertyChanged "Caption"
    DrawButton (eNormal)
End Property

Public Property Get Caption() As String
    Caption = m_Caption
End Property

Public Property Set Font(ByVal NewFont As StdFont)
     Set UserControl.Font = NewFont
     PropertyChanged "Font"
     DrawButton (eNormal)
End Property

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

Private Sub UserControl_Initialize()
    m_Style = Style
End Sub

Private Sub UserControl_InitProperties()
    If Not Ambient.UserMode Then
        m_bEnabled = True
        m_ColorButtonHover = &HFFC090
        m_ColorButtonUp = &HE99950
        m_ColorBright = &HFFEDB0
        m_ColorButtonDown = &HE99950
        m_Caption = UserControl.Name
        UserControl.Picture = LoadPicture("")
    End If
    m_Caption = Extender.Name
    m_InitCompleted = True
End Sub

Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
    If Not m_bEnabled Then Exit Sub
    If KeyCode = vbKeyReturn Then UserControl_MouseDown 1, 0, 0, 0
End Sub

Private Sub UserControl_KeyUp(KeyCode As Integer, Shift As Integer)
    If Not m_bEnabled Then Exit Sub
    If KeyCode = vbKeyReturn Then
        UserControl_MouseUp 1, 0, 0, 0
        RaiseEvent Click
    End If
End Sub

Private Sub UserControl_Click()
    If Not m_bEnabled Then Exit Sub
    RaiseEvent Click
End Sub

Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Not m_bEnabled Then Exit Sub
    m_hasFocus = True
    DrawButton (ePressed)
    RaiseEvent MouseDown(Button, Shift, X, Y)
End Sub

Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Not m_bEnabled Then Exit Sub
    RaiseEvent MouseMove(Button, Shift, X, Y)
    If Button = 1 And (X < 0 Or X > ScaleWidth Or _
        Y < 0 Or Y > ScaleHeight) Then
        IsHover = False
        DrawButton (eNormal)
    End If
End Sub

Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Not m_bEnabled Then Exit Sub
    If Not m_Checked Then
        If IsHover Then
            DrawButton (eHover)
        Else
            If m_hasFocus Then DrawButton (eFocus)
        End If
    End If
    RaiseEvent MouseUp(Button, Shift, X, Y)
End Sub

Private Sub UserControl_DblClick()
    If Not m_bEnabled Then Exit Sub
    DrawButton (ePressed)
    RaiseEvent DblClick
End Sub

Private Sub UserControl_EnterFocus()
    m_hasFocus = True
    If Not m_bEnabled Then Exit Sub
    If Not m_Checked And Not IsHover Then DrawButton (eFocus)
End Sub

Private Sub UserControl_ExitFocus()
    m_hasFocus = False
    If Not m_bEnabled Then Exit Sub
    If Not m_Checked Then DrawButton (eNormal)
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    With PropBag
        .WriteProperty "Enabled", m_bEnabled, True
        .WriteProperty "Font", UserControl.Font, Ambient.Font
        .WriteProperty "Caption", m_Caption, UserControl.Name
        .WriteProperty "IconHighLite", m_bIconHighLite, False
        .WriteProperty "IconHighLiteColor", m_lIconHighLiteColor, &HFF00&
        .WriteProperty "CaptionHighLite", m_bCaptionHighLite, False
        .WriteProperty "CaptionHighLiteColor", m_lCaptionHighLiteColor, &HFF00&
        .WriteProperty "ForeColor", m_ForeColor, m_def_ForeColor
        .WriteProperty "Picture", m_StdPicture, Nothing
        .WriteProperty "PictureAlignment", m_PictureAlignment, m_def_PictureAlignment
        .WriteProperty "Style", m_Style, 0
        .WriteProperty "Checked", m_Checked
        .WriteProperty "ColorButtonHover", m_ColorButtonHover
        .WriteProperty "ColorButtonUp", m_ColorButtonUp
        .WriteProperty "ColorButtonDown", m_ColorButtonDown
        .WriteProperty "BorderBrightness", m_BorderBrightness
        .WriteProperty "ColorBright", m_ColorBright
        .WriteProperty "DisplayHand", m_DisplayHand
        .WriteProperty "ColorScheme", m_ColorScheme
    End With
End Sub

Private Sub UserControl_Resize()
    Init_Style
    DrawButton (eNormal)
End Sub

Private Sub UserControl_Show()
    Init_Style
    DrawButton (eNormal)
End Sub

Private Sub DrawButton(vState As eState)
    If m_Checked Then vState = eChecked
    If m_InitCompleted Then
        UserControl.Picture = LoadPicture("")
        Select Case m_Style
            Case XP_Button
                DrawXPButton vState
            Case Crystal, Mac, WMP, Mac_Variation, Iceblock
                DrawCrystalButton vState
            Case Plastic
                DrawPlasticButton vState
            Case XP_ToolBarButton
                DrawXPToolbarButton vState
        End Select
        DrawIconWCaption vState
    End If
End Sub

Public Sub DrawIconWCaption(vState As eState)
    Dim pW As Long, pH As Long, lW As Long, lH As Long
    Dim StartX As Long, StartY As Long, lBrush As Long, lFlags As Long
    Dim lTemp As Long, XCoord As Long, YCoord As Long
   
    If Not m_StdPicture Is Nothing Then
        pW = ScaleX(m_StdPicture.Width, vbHimetric, vbPixels)
        pH = ScaleY(m_StdPicture.Height, vbHimetric, vbPixels)
    End If
   
    If LenB(m_Caption) Then
        lW = TextWidth(m_Caption)
        lH = TextHeight(m_Caption)
    End If
   
    Select Case m_PictureAlignment
        Case Is = PIC_TOP
            StartX = ((ScaleWidth - pW) \ 2) + 1
            StartY = (ScaleHeight - (pH + lH)) \ 2 + 1
            XCoord = Abs(ScaleWidth \ 2 - lW \ 2)
            YCoord = Abs(ScaleHeight \ 2 + pH \ 2 - lH \ 2)
        Case Is = PIC_BOTTOM
            StartX = (ScaleWidth - pW) \ 2
            StartY = (ScaleHeight - (pH - lH)) \ 2 + 1
            XCoord = Abs(ScaleWidth \ 2 - lW \ 2)
            YCoord = Abs(ScaleHeight \ 2 - (pH + lH) \ 2)
        Case Is = PIC_LEFT
            If CornerRadius Then StartX = CornerRadius Else StartX = 8
            StartY = (ScaleHeight - pH) \ 2 + 1
            XCoord = Abs(ScaleWidth \ 2 - lW \ 2)
            YCoord = Abs(ScaleHeight \ 2 - lH \ 2)
        Case Is = PIC_RIGHT
            If CornerRadius Then StartX = ScaleWidth - CornerRadius - pW Else StartX = ScaleWidth - 8 - pW
            StartY = (ScaleHeight - pH) \ 2 + 1
            XCoord = Abs(ScaleWidth \ 2 - lW \ 2)
            YCoord = Abs(ScaleHeight \ 2 - lH \ 2)
    End Select
    If vState = ePressed Then
        StartX = StartX + 1: XCoord = XCoord + 1
        StartY = StartY + 1: YCoord = YCoord + 1
    End If
    If m_bEnabled Then lFlags = DST_PREFIXTEXT Or DSS_NORMAL Else lFlags = DST_PREFIXTEXT Or DSS_DISABLED
   
    If vState = eHover And m_bCaptionHighLite Then
        lTemp = UserControl.ForeColor
        UserControl.ForeColor = m_lCaptionHighLiteColor
    End If
    If LenB(m_Caption) Then Call DrawStateText(hdc, 0&, 0&, m_Caption, Len(m_Caption), _
               XCoord, YCoord, 0&, 0&, lFlags)
    'Return the old forecolor state
    If vState = eHover And m_bCaptionHighLite Then UserControl.ForeColor = lTemp
   
    If Not m_StdPicture Is Nothing Then
        If m_StdPicture.Type = vbPicTypeBitmap Then
            lFlags = DST_BITMAP
        ElseIf m_StdPicture.Type = vbPicTypeIcon Then
            lFlags = DST_ICON
        End If
        If Not m_bEnabled Then
            lFlags = lFlags Or DSS_DISABLED 'Draw disabled
        ElseIf vState = eHover And m_bIconHighLite Then
            lBrush = CreateSolidBrush(m_lIconHighLiteColor)
            lFlags = lFlags Or DSS_MONO 'Draw highlighted
        End If
        With m_StdPicture
            DrawState hdc, lBrush, 0, .Handle, 0, CLng(StartX), _
                    CLng(StartY), .Width, .Height, lFlags
        End With
        'm_StdPicture.Render Usercontrol.hDC, CLng(StartX), CLng(StartY), CLng(pW), CLng(pH), _
                    0, m_StdPicture.Height, m_StdPicture.Width, -m_StdPicture.Height, ByVal 0&
        If vState = eHover And m_bIconHighLite Then DeleteObject lBrush
    End If
   
    UserControl.Refresh
End Sub

Private Function DrawXPToolbarButton(vState As eState)
Dim i As Long
Dim r1 As Long, g1 As Long, b1 As Long
Dim r2 As Long, g2 As Long, b2 As Long
Dim uH As Long, uW As Long
    uH = ScaleHeight - 1
    uW = ScaleWidth - 1
    On Error Resume Next
        Line (0, 0)-(uW, uH), Parent.BackColor, BF
    On Error GoTo 0
    If vState = ePressed Then
        r1 = 220: g1 = 218: b1 = 209
        r2 = 231: g2 = 230: b2 = 224
        For i = 0 To 3
            Line (0, 1 + i)-(uW, 1 + i), RGB(r2 * (i / 3) + r1 - (r1 * (i / 3)), g2 * (i / 3) + g1 - (g1 * (i / 3)), b2 * (i / 3) + b1 - (b1 * (i / 3)))
        Next
        r1 = 231: g1 = 230: b1 = 224
        r2 = 225: g2 = 224: b2 = 216
        For i = 4 To uH - 4
            Line (0, i)-(uW, i), RGB(r2 * (i / (uH - 6)) + r1 - (r1 * (i / (uH - 6))), g2 * (i / (uH - 6)) + g1 - (g1 * (i / (uH - 6))), b2 * (i / (uH - 6)) + b1 - (b1 * (i / (uH - 6))))
        Next
        r1 = 225: g1 = 224: b1 = 216
        r2 = 235: g2 = 234: b2 = 229
        For i = 0 To 3
            Line (0, uH - 4 + i)-(uW, uH - 4 + i), RGB(r2 * (i / 3) + r1 - (r1 * (i / 3)), g2 * (i / 3) + g1 - (g1 * (i / 3)), b2 * (i / 3) + b1 - (b1 * (i / 3)))
        Next
        PSet (1, 0), RGB(215, 215, 204): PSet (0, 1), RGB(215, 215, 204)
        Line (0, 2)-(2, 0), RGB(179, 179, 168) '7617536
        Line (2, 0)-(uW - 2, 0), RGB(157, 157, 146)
        PSet (uW - 1, 0), RGB(215, 215, 204): PSet (uW, 1), RGB(215, 215, 204)
        Line (uW - 2, 0)-(uW, 2), RGB(179, 179, 168) '7617536
        Line (uW, 2)-(uW, uH - 2), RGB(157, 157, 146)
        PSet (uW, uH - 1), RGB(215, 215, 204): PSet (uW - 1, uH), RGB(215, 215, 204)
        Line (uW, uH - 2)-(uW - 2, uH), RGB(179, 179, 168) ' 7617536
        Line (uW - 2, uH)-(2, uH), RGB(157, 157, 146)
        PSet (1, uH), RGB(215, 215, 204): PSet (0, uH - 1), RGB(215, 215, 204)
        Line (2, uH)-(0, uH - 2), RGB(179, 179, 168) '7617536
        Line (0, uH - 2)-(0, 2), RGB(157, 157, 146)
    ElseIf vState = eHover Then
        r1 = 254: g1 = 254: b1 = 253
        r2 = 252: g2 = 252: b2 = 249
        For i = 0 To 3
            Line (0, 1 + i)-(uW, 1 + i), RGB(r2 * (i / 3) + r1 - (r1 * (i / 3)), g2 * (i / 3) + g1 - (g1 * (i / 3)), b2 * (i / 3) + b1 - (b1 * (i / 3)))
        Next
        r1 = 252: g1 = 252: b1 = 249
        r2 = 238: g2 = 237: b2 = 229
        For i = 4 To uH - 4
            Line (0, i)-(uW, i), RGB(r2 * (i / (uH - 6)) + r1 - (r1 * (i / (uH - 6))), g2 * (i / (uH - 6)) + g1 - (g1 * (i / (uH - 6))), b2 * (i / (uH - 6)) + b1 - (b1 * (i / (uH - 6))))
        Next
        r1 = 238: g1 = 237: b1 = 229
        r2 = 215: g2 = 210: b2 = 198
        For i = 0 To 3
            Line (0, uH - 4 + i)-(uW, uH - 4 + i), RGB(r2 * (i / 3) + r1 - (r1 * (i / 3)), g2 * (i / 3) + g1 - (g1 * (i / 3)), b2 * (i / 3) + b1 - (b1 * (i / 3)))
        Next
       
        PSet (1, 0), RGB(232, 232, 221): PSet (0, 1), RGB(232, 232, 221)
        Line (0, 2)-(2, 0), RGB(216, 216, 205) '7617536
        Line (2, 0)-(uW - 2, 0), RGB(206, 206, 195)
        PSet (uW - 1, 0), RGB(232, 232, 221): PSet (uW, 1), RGB(232, 232, 221)
        Line (uW - 2, 0)-(uW, 2), RGB(216, 216, 205) '7617536
        Line (uW, 2)-(uW, uH - 2), RGB(206, 206, 195)
        PSet (uW, uH - 1), RGB(232, 232, 221): PSet (uW - 1, uH), RGB(232, 232, 221)
        Line (uW, uH - 2)-(uW - 2, uH), RGB(216, 216, 205) ' 7617536
        Line (uW - 2, uH)-(2, uH), RGB(206, 206, 195)
        PSet (1, uH), RGB(232, 232, 221): PSet (0, uH - 1), RGB(232, 232, 221)
        Line (2, uH)-(0, uH - 2), RGB(216, 216, 205) '7617536
        Line (0, uH - 2)-(0, 2), RGB(206, 206, 195)
    ElseIf vState = eChecked Then
        Line (1, 1)-(uW - 1, uH - 1), vbWhite, BF
        PSet (1, 0), RGB(203, 213, 214): PSet (0, 1), RGB(203, 213, 214)
        Line (0, 2)-(2, 0), RGB(152, 175, 190) '7617536
        Line (2, 0)-(uW - 2, 0), RGB(122, 152, 175)
        PSet (uW - 1, 0), RGB(203, 213, 214): PSet (uW, 1), RGB(203, 213, 214)
        Line (uW - 2, 0)-(uW, 2), RGB(152, 175, 190) '7617536
        Line (uW, 2)-(uW, uH - 2), RGB(122, 152, 175)
        PSet (uW, uH - 1), RGB(203, 213, 214): PSet (uW - 1, uH), RGB(203, 213, 214)
        Line (uW, uH - 2)-(uW - 2, uH), RGB(152, 175, 190) ' 7617536
        Line (uW - 2, uH)-(2, uH), RGB(122, 152, 175)
        PSet (1, uH), RGB(203, 213, 214): PSet (0, uH - 1), RGB(203, 213, 214)
        Line (2, uH)-(0, uH - 2), RGB(152, 175, 190) '7617536
        Line (0, uH - 2)-(0, 2), RGB(122, 152, 175)
    End If
End Function

Private Function DrawXPButton(vState As eState)
Dim i As Long
Dim r1 As Long, g1 As Long, b1 As Long
Dim r2 As Long, g2 As Long, b2 As Long
Dim uH As Long, uW As Long
    uH = ScaleHeight - 1
    uW = ScaleWidth - 1
    On Error Resume Next
        Line (0, 0)-(uW, uH), Parent.BackColor, BF
    On Error GoTo 0
    If vState = ePressed Then
        r1 = 209: g1 = 204: b1 = 193
        r2 = 229: g2 = 228: b2 = 221
        For i = 0 To 3
            Line (0, 1 + i)-(uW, 1 + i), RGB(r2 * (i / 3) + r1 - (r1 * (i / 3)), g2 * (i / 3) + g1 - (g1 * (i / 3)), b2 * (i / 3) + b1 - (b1 * (i / 3)))
        Next
        r1 = 229: g1 = 228: b1 = 221
        r2 = 226: g2 = 226: b2 = 218
        For i = 4 To uH - 4
            Line (0, i)-(uW, i), RGB(r2 * (i / (uH - 6)) + r1 - (r1 * (i / (uH - 6))), g2 * (i / (uH - 6)) + g1 - (g1 * (i / (uH - 6))), b2 * (i / (uH - 6)) + b1 - (b1 * (i / (uH - 6))))
        Next
        r1 = 226: g1 = 226: b1 = 218
        r2 = 242: g2 = 241: b2 = 238
        For i = 0 To 4
            Line (0, uH - 4 + i)-(uW, uH - 4 + i), RGB(r2 * (i / 3) + r1 - (r1 * (i / 3)), g2 * (i / 3) + g1 - (g1 * (i / 3)), b2 * (i / 3) + b1 - (b1 * (i / 3)))
        Next
    Else
        r1 = 236: g1 = 235: b1 = 230
        r2 = 214: g2 = 208: b2 = 197
        For i = 0 To uH - 3
            Line (1, i)-(uW, i), RGB(r1 * (i / (uH - 3)) + 255 - (255 * (i / (uH - 3))), g1 * (i / (uH - 3)) + 255 - (255 * (i / (uH - 3))), b1 * (i / (uH - 3)) + 255 - (255 * (i / (uH - 3))))
        Next
   
        For i = 0 To 3
            Line (0, uH - 4 + i)-(uW, uH - 4 + i), RGB(r2 * (i / 3) + r1 - (r1 * (i / 3)), g2 * (i / 3) + g1 - (g1 * (i / 3)), b2 * (i / 3) + b1 - (b1 * (i / 3)))
        Next
    End If
   
    Select Case vState
        Case Is = eFocus
            Line (0, 1)-(uW, 1), RGB(206, 231, 255)
            Line (0, 2)-(uW, 2), RGB(188, 212, 246)
            r1 = 188: g1 = 212: b1 = 246
            r2 = 137: g2 = 173: b2 = 228
            For i = 3 To uH - 3
                Line (0, i)-(3, i), RGB(r2 * (i / uH) + r1 - (r1 * (i / uH)), g2 * (i / uH) + g1 - (g1 * (i / uH)), b2 * (i / uH) + b1 - (b1 * (i / uH)))
                Line (uW - 2, i)-(uW, i), RGB(r2 * (i / uH) + r1 - (r1 * (i / uH)), g2 * (i / uH) + g1 - (g1 * (i / uH)), b2 * (i / uH) + b1 - (b1 * (i / uH)))
            Next
            Line (0, uH - 2)-(uW, uH - 2), RGB(137, 173, 228)
            Line (0, uH - 1)-(uW, uH - 1), RGB(105, 130, 238)
        Case Is = eHover
            Line (0, 1)-(uW, 1), RGB(255, 240, 202)
            Line (0, 2)-(uW, 2), RGB(253, 216, 137)
            r1 = 253: g1 = 216: b1 = 137
            r2 = 248: g2 = 178: b2 = 48
            For i = 3 To uH - 3
                Line (0, i)-(3, i), RGB(r2 * (i / uH) + r1 - (r1 * (i / uH)), g2 * (i / uH) + g1 - (g1 * (i / uH)), b2 * (i / uH) + b1 - (b1 * (i / uH)))
                Line (uW - 2, i)-(uW, i), RGB(r2 * (i / uH) + r1 - (r1 * (i / uH)), g2 * (i / uH) + g1 - (g1 * (i / uH)), b2 * (i / uH) + b1 - (b1 * (i / uH)))
            Next
            Line (0, uH - 2)-(uW, uH - 2), RGB(248, 178, 48)
            Line (0, uH - 1)-(uW, uH - 1), RGB(229, 151, 0)
    End Select
   
    PSet (0, 1), RGB(122, 149, 168): PSet (1, 0), RGB(122, 149, 168)
    Line (0, 2)-(2, 0), RGB(37, 87, 131) '7617536
    Line (2, 0)-(uW - 2, 0), 7617536
    PSet (uW - 1, 0), RGB(122, 149, 168): PSet (uW, 1), RGB(122, 149, 168)
    Line (uW - 2, 0)-(uW, 2), RGB(37, 87, 131)  '7617536
    Line (uW, 2)-(uW, uH - 2), 7617536
    PSet (uW, uH - 1), RGB(122, 149, 168): PSet (uW - 1, uH), RGB(122, 149, 168)
    Line (uW, uH - 2)-(uW - 2, uH), RGB(37, 87, 131) ' 7617536
    Line (uW - 2, uH)-(2, uH), 7617536
    PSet (1, uH), RGB(122, 149, 168): PSet (0, uH - 1), RGB(122, 149, 168)
    Line (2, uH)-(0, uH - 2), RGB(37, 87, 131)  '7617536
    Line (0, uH - 2)-(0, 2), 7617536
End Function

Private Function DrawCrystalButton(vState As eState)
    Dim CrystalParam As tCrystalParam
    If m_Style = Mac Then 'Mac
        'CrystalParam.Ref_MixColorFrom = 0 '20
        CrystalParam.Ref_Intensity = 70 '50
        CrystalParam.Ref_Left = (CornerRadius \ 3)
        'CrystalParam.Ref_Top = 0
        CrystalParam.Ref_Height = 12 'CornerRadius - 2
        CrystalParam.Ref_Width = ScaleWidth + 2 * CornerRadius
        CrystalParam.Ref_Radius = 10 'CornerRadius \ 2
        CrystalParam.RadialGXPercent = 200
        CrystalParam.RadialGYPercent = 100 - (7 * 100 \ ScaleHeight)
        If CrystalParam.RadialGYPercent > 80 Then CrystalParam.RadialGYPercent = 80
        CrystalParam.RadialGOffsetX = ScaleWidth / 2
        CrystalParam.RadialGOffsetY = ScaleHeight
        CrystalParam.RadialGIntensity = 130
    ElseIf m_Style = WMP Then 'WMP
        CrystalParam.Ref_Intensity = 40
        CrystalParam.Ref_Left = -CornerRadius \ 2 - 1
        CrystalParam.Ref_Top = -CornerRadius
        CrystalParam.Ref_Height = (CornerRadius) + 1
        CrystalParam.Ref_Width = ScaleWidth + 2 * CornerRadius
        CrystalParam.Ref_Radius = CornerRadius
        CrystalParam.RadialGXPercent = 60
        CrystalParam.RadialGYPercent = 60
        CrystalParam.RadialGOffsetX = ScaleWidth / 2
        CrystalParam.RadialGOffsetY = ScaleHeight
        CrystalParam.RadialGIntensity = 130
    ElseIf m_Style = Mac_Variation Then
        CrystalParam.Ref_Intensity = 70
        CrystalParam.Ref_Left = (CornerRadius \ 3) - 1
        CrystalParam.Ref_Height = CornerRadius
        CrystalParam.Ref_Width = ScaleWidth + 2 * CornerRadius
        'CrystalParam.Ref_Top = 0
        CrystalParam.Ref_Radius = (CornerRadius \ 2)
        CrystalParam.RadialGXPercent = 200
        CrystalParam.RadialGYPercent = 70
        CrystalParam.RadialGOffsetX = ScaleWidth / 2
        CrystalParam.RadialGOffsetY = ScaleHeight
        CrystalParam.RadialGIntensity = 130
    ElseIf m_Style = Crystal Then
        CrystalParam.Ref_Intensity = 50
        CrystalParam.Ref_Left = CornerRadius \ 2
        CrystalParam.Ref_Height = CornerRadius * 1.1
        CrystalParam.Ref_Width = ScaleWidth + 2 * CornerRadius
        CrystalParam.Ref_Top = 1
        CrystalParam.Ref_Radius = CornerRadius \ 2
        CrystalParam.RadialGXPercent = 300
        CrystalParam.RadialGYPercent = 60
        CrystalParam.RadialGOffsetX = ScaleWidth / 2
        CrystalParam.RadialGOffsetY = ScaleHeight
        CrystalParam.RadialGIntensity = 120
    ElseIf m_Style = Iceblock Then
        CrystalParam.Ref_Intensity = 50
        CrystalParam.Ref_Left = CornerRadius / 2
        CrystalParam.Ref_Top = 2
        CrystalParam.Ref_Height = CornerRadius + 1
        CrystalParam.Ref_Width = ScaleWidth - CornerRadius
        CrystalParam.Ref_Radius = CornerRadius / 2
        CrystalParam.RadialGXPercent = 60
        CrystalParam.RadialGYPercent = 60
        CrystalParam.RadialGOffsetX = ScaleWidth / 2
        CrystalParam.RadialGOffsetY = ScaleHeight / 2
        CrystalParam.RadialGIntensity = 100
    End If
    Select Case vState
        Case eHover
            DrawCrystal ScaleWidth, ScaleHeight, m_ColorButtonHover, CrystalParam
        Case ePressed, eChecked
            DrawCrystal ScaleWidth, ScaleHeight, ColorButtonDown, CrystalParam
        Case eNormal, eFocus
            DrawCrystal ScaleWidth, ScaleHeight, m_ColorButtonUp, CrystalParam
    End Select
End Function

Private Sub DrawCrystal(lWidth As Long, lHeight As Long, ByVal Color As Long, CrystalParam As tCrystalParam)
Dim i As Long, j As Long, ptColor As Long, ColorBright As Long
Dim RGXPercent As Single, RGYPercent As Single, RadialGradient As Long
Dim hHlRgn As Long, Bordercolor As Long, nBrush As Long, ClientRct As RECT
   
    If CornerRadius < 1 Then CornerRadius = 1
    ColorBright = m_ColorBright
    'In Disabled state Color = 11583680 (light gray)
    'and ColorBright = vbWhite
    If Not m_bEnabled Then Color = 11583680: ColorBright = vbWhite
   
    RGYPercent = (100 - CrystalParam.RadialGYPercent) / (lHeight * 2)
    RGXPercent = (100 - CrystalParam.RadialGXPercent) / lWidth
   
    If m_BorderBrightness >= 0 Then
        Bordercolor = BlendColors(Color, vbWhite, m_BorderBrightness)
    Else
        Bordercolor = BlendColors(Color, vbBlack, -m_BorderBrightness)
    End If
    'Create Highlite region (hHlRgn), we will use PtInRegion to
    'check if we are inside the highlite Rounded rectangle
    'you could simply use IsInRoundRect(i ,j ,CrystalParam.Ref_Left, CrystalParam.Ref_Top, CrystalParam.Ref_Width, CrystalParam.Ref_Height, CrystalParam.Ref_Radius * 2, CrystalParam.Ref_Radius * 2)
    'instead of PtInRegion and remove these lines, but will be slower.
    hHlRgn = CreateRoundRectRgn(CrystalParam.Ref_Left, CrystalParam.Ref_Top, CrystalParam.Ref_Width, CrystalParam.Ref_Height, CrystalParam.Ref_Radius * 2, CrystalParam.Ref_Radius * 2)
    'Paint the Background Color
    SetRect ClientRct, 0, 0, lWidth, lHeight
    nBrush = CreateSolidBrush(Color)
    FillRect hdc, ClientRct, nBrush
    DeleteObject nBrush
    'Draw a radial Gradient
    DrawElipse hdc, CrystalParam, lWidth, lHeight, Color, ColorBright
    For j = 0 To lHeight
        For i = 0 To lWidth \ 2
            If PtInRegion(hButtonRegion, i, j) Then
                'We are inside the button
                If PtInRegion(hHlRgn, i, j) Then
                    ptColor = BlendColors(vbWhite, Color, CrystalParam.Ref_MixColorFrom + j * CrystalParam.Ref_Intensity \ CornerRadius)
                    Line (i, j)-(lWidth - i + 1, j), ptColor
                    i = 0: j = j + 1
                End If
            Else
                'this draw a thin border
                SetPixelV hdc, i, j, Bordercolor
                SetPixelV hdc, lWidth - i, j, Bordercolor
            End If
        Next i
    Next j
    DeleteObject hHlRgn
End Sub

Private Sub DrawElipse(lhDC As Long, CrystalParam As tCrystalParam, lWidth, lHeight, FromColor As Long, ToColor As Long)
Dim oldBrush As Long, newBrush As Long, newPen As Long, oldPen As Long
Dim incX As Single, incY As Single, RadX As Long, RadY As Long
Dim klr As Long, rc As RECT
    klr = 1
    RadX = CrystalParam.RadialGXPercent * lWidth / 100
    RadY = CrystalParam.RadialGYPercent * lHeight / 100
    SetRect rc, CrystalParam.RadialGOffsetX - RadX, CrystalParam.RadialGOffsetY - RadY, _
                CrystalParam.RadialGOffsetX + RadX, CrystalParam.RadialGOffsetY + RadY
    incX = 1: incY = 1
    If RadX > RadY Then
        incX = (RadX / RadY)
    Else
        incY = (RadY / RadX)
    End If
    newBrush = CreateSolidBrush(FromColor)
    oldBrush = SelectObject(lhDC, newBrush)
    newPen = CreatePen(5, 0, FromColor)
    oldPen = SelectObject(lhDC, newPen)
    Do Until Not IsRectEmpty(rc) = 0
        Ellipse lhDC, rc.Left, rc.Top, rc.Right, rc.Bottom
        InflateRect rc, -incX, -incY
        klr = klr + 1
        newBrush = CreateSolidBrush(BlendColors(FromColor, ToColor, klr * CrystalParam.RadialGIntensity / RadY))
        DeleteObject SelectObject(lhDC, newBrush)
    Loop
    DeleteObject SelectObject(lhDC, oldBrush)
    DeleteObject SelectObject(lhDC, oldPen)
End Sub

Private Function DrawPlasticButton(vState As eState)
    Select Case vState
        Case eHover
            DrawPlastic 0, 0, ScaleWidth - 1, ScaleHeight - 1, m_ColorButtonHover
        Case ePressed, eChecked
            DrawPlastic 0, 0, ScaleWidth - 1, ScaleHeight - 1, ColorButtonDown
        Case eNormal, eFocus
            DrawPlastic 0, 0, ScaleWidth - 1, ScaleHeight - 1, m_ColorButtonUp
    End Select
End Function

Private Sub DrawPlastic(X As Long, Y As Long, lWidth As Long, lHeight As Long, Color As Long)
Dim i As Long, j As Long, HighlightColor As Long, ShadowColor As Long
Dim ptColor As Long, LinearGPercent As Long
    ShadowColor = BlendColors(vbBlack, Color, 50)
   
    For j = 0 To lHeight
        If j < CornerRadius Then
            HighlightColor = BlendColors(vbWhite, Color, j * 30 \ CornerRadius)
        End If
        LinearGPercent = Abs((2 * j - lHeight) * 100 \ lHeight)
        For i = 0 To lWidth \ 2
            If IsInRoundRect(i, j, 1, 1, lWidth - 2, lHeight - 2, CornerRadius) Then
                'Drawing the button properly
                If IsInRoundRect(i, j, 4, 2, lWidth - CornerRadius, 2 * CornerRadius - 1, 2 * CornerRadius \ 3) _
                And Not IsInRoundRect(i, j, 4, CornerRadius \ 2, lWidth - CornerRadius, 2 * CornerRadius - 1, 2 * CornerRadius \ 3) Then
                    ptColor = HighlightColor 'draw reflected highlight
                Else
                    ptColor = BlendColors(Color, m_ColorBright, LinearGPercent)
                End If
                SetPixelV hdc, i, j, ptColor
                SetPixelV hdc, lWidth - i, j, ptColor
            ElseIf IsInRoundRect(i, j, 0, 0, lWidth, lHeight, CornerRadius) Then
                'this draw a thin border
                SetPixelV hdc, i, j, ShadowColor
                SetPixelV hdc, lWidth - i, j, ShadowColor
            End If
        Next i
    Next j
End Sub

'/----------------------------------------------------------------------------------/
'/                                                                                  /
'/ Init_Style                                                                       /
'/ -------------------                                                              /
'/ Description:                                                                     /
'/                                                                                  /
'/ Init_Style will create the window region according to the button style           /
'/ and will be responsible of storing the same region (but without the border)      /
'/ in hButtonRegion. This will be used later to determine if a point                /
'/ is inside the button region.                                                     /
'/----------------------------------------------------------------------------------/
Private Sub Init_Style()
Dim lCornerRad As Long
    'Remove the older Region
    If hButtonRegion Then DeleteObject hButtonRegion
    Select Case m_Style
        Case Crystal, WMP, Mac_Variation
            lCornerRad = SetBound(ScaleHeight \ 2 + 1, 1, ScaleWidth \ 2)
        Case Mac
            lCornerRad = 12
        Case Iceblock
            lCornerRad = SetBound(ScaleHeight \ 4 + 1, 1, ScaleWidth \ 4)
        Case Plastic
            lCornerRad = SetBound(ScaleHeight \ 3, 1, ScaleWidth \ 3)
    End Select

    If m_Style = Crystal Or m_Style = WMP Or m_Style = Mac Or _
        m_Style = Mac_Variation Or m_Style = Plastic Or m_Style = Iceblock Then
        hButtonRegion = CreateRoundedRegion(0, 0, ScaleWidth, ScaleHeight, lCornerRad)
       
        'Set the Button Region
        Call SetWindowRgn(hwnd, hButtonRegion, True)
        DeleteObject hButtonRegion
        'Store the region but exclude the border
        hButtonRegion = CreateRoundedRegion(1, 1, ScaleWidth - 2, ScaleHeight - 2, lCornerRad)
    Else
        Call SetWindowRgn(hwnd, 0, True)
    End If
End Sub

'/----------------------------------------------------------------------------------/
'/                                                                                  /
'/ CreateRoundedRegion                                                              /
'/ -------------------                                                              /
'/ Description:                                                                     /
'/                                                                                  /
'/ CreateRoundedRegion returns a rounded region based on a given Width, Height      /
'/ and a CornerRadius. We will use this function instead of normal CreateRoundRect  /
'/ because this will give us a better rounded rectangle for our purposes.           /
'/----------------------------------------------------------------------------------/
Private Function CreateRoundedRegion(X As Long, Y As Long, lWidth As Long, lHeight As Long, Radius As Long) As Long
Dim i As Long, j As Long, i2 As Long, j2 As Long, i3 As Long, j3 As Long
Dim hRgn As Long
    CornerRadius = Radius
    If CornerRadius < 1 Then CornerRadius = 1
    '/* Create initial region
    hRgn = CreateRectRgn(0, 0, X + lWidth, Y + lHeight)
    For j = 0 To Y + lHeight
        For i = 0 To (X + lWidth) \ 2
            If Not IsInRoundRect(i, j, X, Y, lWidth, lHeight, CornerRadius) Then
                '/* substract the pixels outside of the rounded rectangle
                '/* (it doesn't exclude the border)
                If Not j = j2 Then
                    '*** If 2 * i2 <> Width Then i2 = i2 + 1
                    ExcludePixelsFromRegion hRgn, X + lWidth - i2, j2, lWidth - i, j
                    If Not 2 * i2 = X + lWidth Then
                        i2 = i2 + 1
                    End If
                    ExcludePixelsFromRegion hRgn, i, j, i2, j2
                End If
                i2 = i
                j2 = j
            End If
        Next i
    Next j
    CreateRoundedRegion = hRgn
End Function

Private Sub ExcludePixelsFromRegion(hRgn As Long, X1 As Long, Y1 As Long, X2 As Long, Y2 As Long)
    Dim hRgnTemp As Long
    hRgnTemp = CreateRectRgn(X1, Y1, X2, Y2)
    CombineRgn hRgn, hRgn, hRgnTemp, RGN_XOR
    DeleteObject hRgnTemp
End Sub

Private Function IsInRoundRect(i As Long, j As Long, X As Long, Y As Long, lWidth As Long, lHeight As Long, Radius As Long) As Boolean
Dim offX As Long, offY As Long
    offX = i - X
    offY = j - Y
    If offY > Radius And offY + Radius < lHeight And offX > Radius And offX + Radius < lWidth Then
        '/* This is to catch early most cases
        IsInRoundRect = True
    ElseIf offX < Radius And offY <= Radius Then
        If IsInCircle(offX - Radius, offY, Radius) Then IsInRoundRect = True
    ElseIf offX + Radius > lWidth And offY <= Radius Then
        If IsInCircle(offX - lWidth + Radius, offY, Radius) Then IsInRoundRect = True
    ElseIf offX < Radius And offY + Radius >= lHeight Then
        If IsInCircle(offX - Radius, offY - lHeight + Radius * 2, Radius) Then IsInRoundRect = True
    ElseIf offX + Radius > lWidth And offY + Radius >= lHeight Then
        If IsInCircle(offX - lWidth + Radius, offY - lHeight + Radius * 2, Radius) Then IsInRoundRect = True
    Else
        If offX > 0 And offX < lWidth And offY > 0 And offY < lHeight Then IsInRoundRect = True
    End If
End Function

Private Function IsInCircle(ByRef X As Long, ByRef Y As Long, ByRef r As Long) As Boolean
Dim lResult As Long
    '/* this detect a circunference centered on y=-r and x=0
    lResult = (r * r) - (X * X)
    If lResult >= 0 Then
        lResult = Sqr(lResult)
        If Abs(Y - r) < lResult Then IsInCircle = True
    End If
End Function

Public Function BlendColors(ByRef Color1 As Long, ByRef Color2 As Long, ByRef Percentage As Long) As Long
Dim r(2) As Long, G(2) As Long, b(2) As Long
   
    Percentage = SetBound(Percentage, 0, 100)
   
    GetRGB r(0), G(0), b(0), Color1
    GetRGB r(1), G(1), b(1), Color2
   
    r(2) = r(0) + (r(1) - r(0)) * Percentage \ 100
    G(2) = G(0) + (G(1) - G(0)) * Percentage \ 100
    b(2) = b(0) + (b(1) - b(0)) * Percentage \ 100
   
    BlendColors = RGB(r(2), G(2), b(2))
End Function

Private Function SetBound(ByRef Num As Long, ByRef MinNum As Long, ByRef MaxNum As Long) As Long
    If Num < MinNum Then
        SetBound = MinNum
    ElseIf Num > MaxNum Then
        SetBound = MaxNum
    Else
        SetBound = Num
    End If
End Function

Public Sub GetRGB(r As Long, G As Long, b As Long, Color As Long)
Dim TempValue As Long
    TranslateColor Color, 0, TempValue
    r = TempValue And &HFF&
    G = (TempValue And &HFF00&) \ &H100&
    b = (TempValue And &HFF0000) \ &H10000
End Sub

Private Function HiWord(lDWord As Long) As Integer
  HiWord = (lDWord And &HFFFF0000) \ &H10000
End Function

Private Function LoWord(lDWord As Long) As Integer
  If lDWord And &H8000& Then
    LoWord = lDWord Or &HFFFF0000
  Else
    LoWord = lDWord And &HFFFF&
  End If
End Function
'Read the properties from the property bag - also, a good place to start the subclassing (if we're running)
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  Dim w As Long
  Dim h As Long
  Dim S As String
 
    With PropBag
        m_bEnabled = .ReadProperty("Enabled", True)
        Set UserControl.Font = .ReadProperty("Font", Ambient.Font)
        m_Caption = .ReadProperty("Caption", UserControl.Name)
        m_bCaptionHighLite = .ReadProperty("CaptionHighLite", False)
        m_lCaptionHighLiteColor = .ReadProperty("CaptionHighLiteColor", &HFF00&)
        m_bIconHighLite = .ReadProperty("IconHighLite", False)
        m_lIconHighLiteColor = .ReadProperty("IconHighLiteColor", &HFF00&)
        m_ForeColor = .ReadProperty("ForeColor", m_def_ForeColor)
        Set m_StdPicture = .ReadProperty("Picture", Nothing)
        m_PictureAlignment = .ReadProperty("PictureAlignment", m_def_PictureAlignment)
        m_Style = .ReadProperty("Style", 0)
        m_Checked = .ReadProperty("Checked", m_Checked)
        m_ColorButtonHover = .ReadProperty("ColorButtonHover", &HFFC090)
        m_ColorButtonUp = .ReadProperty("ColorButtonUp", &HE99950)
        m_ColorButtonDown = .ReadProperty("ColorButtonDown", &HE99950)
        m_ColorBright = .ReadProperty("ColorBright", &HFFEDB0)
        m_BorderBrightness = .ReadProperty("BorderBrightness", 0)
        m_DisplayHand = .ReadProperty("DisplayHand", False)
        m_ColorScheme = .ReadProperty("ColorScheme", 0)
    End With
    If m_DisplayHand Then UserControl.MousePointer = vbCustom Else UserControl.MousePointer = vbArrow
    UserControl.ForeColor = m_ForeColor
   
  If Ambient.UserMode Then                                                              'If we're not in design mode
    bTrack = True
    bTrackUser32 = IsFunctionExported("TrackMouseEvent", "User32")
 
    If Not bTrackUser32 Then
      If Not IsFunctionExported("_TrackMouseEvent", "Comctl32") Then
        bTrack = False
      End If
    End If
 
    If bTrack Then
      'OS supports mouse leave, so let's subclass for it
      With UserControl
        'Subclass the UserControl
        sc_Subclass .hwnd
        sc_AddMsg .hwnd, WM_PAINT, MSG_BEFORE
        sc_AddMsg .hwnd, WM_MOUSEMOVE
        sc_AddMsg .hwnd, WM_MOUSELEAVE
      End With
    End If
  End If
  m_InitCompleted = True
End Sub

'The control is terminating - a good place to stop the subclasser
Private Sub UserControl_Terminate()
  sc_Terminate                                                              'Terminate all subclassing
  If hButtonRegion Then DeleteObject hButtonRegion
End Sub

'Determine if the passed function is supported
Private Function IsFunctionExported(ByVal sFunction As String, ByVal sModule As String) As Boolean
  Dim hMod        As Long
  Dim bLibLoaded  As Boolean

  hMod = GetModuleHandleA(sModule)

  If hMod = 0 Then
    hMod = LoadLibraryA(sModule)
    If hMod Then
      bLibLoaded = True
    End If
  End If

  If hMod Then
    If GetProcAddress(hMod, sFunction) Then
      IsFunctionExported = True
    End If
  End If

  If bLibLoaded Then
    FreeLibrary hMod
  End If
End Function

'Track the mouse leaving the indicated window
Private Sub TrackMouseLeave(ByVal lng_hWnd As Long)
  Dim tme As TRACKMOUSEEVENT_STRUCT
 
  If bTrack Then
    With tme
      .cbSize = Len(tme)
      .dwFlags = TME_LEAVE
      .hwndTrack = lng_hWnd
    End With

    If bTrackUser32 Then
      TrackMouseEvent tme
    Else
      TrackMouseEventComCtl tme
    End If
  End If
End Sub

'-SelfSub code------------------------------------------------------------------------------------
Private Function sc_Subclass(ByVal lng_hWnd As Long, _
                    Optional ByVal lParamUser As Long = 0, _
                    Optional ByVal nOrdinal As Long = 1, _
                    Optional ByVal oCallback As Object = Nothing, _
                    Optional ByVal bIdeSafety As Boolean = True) As Boolean 'Subclass the specified window handle
'*************************************************************************************************
'* lng_hWnd   - Handle of the window to subclass
'* lParamUser - Optional, user-defined callback parameter
'* nOrdinal   - Optional, ordinal index of the callback procedure. 1 = last private method, 2 = second last private method, etc.
'* oCallback  - Optional, the object that will receive the callback. If undefined, callbacks are sent to this object's instance
'* bIdeSafety - Optional, enable/disable IDE safety measures. NB: you should really only disable IDE safety in a UserControl for design-time subclassing
'*************************************************************************************************
Const CODE_LEN      As Long = 260                                           'Thunk length in bytes
Const MEM_LEN       As Long = CODE_LEN + (8 * (MSG_ENTRIES + 1))            'Bytes to allocate per thunk, data + code + msg tables
Const PAGE_RWX      As Long = &H40&                                         'Allocate executable memory
Const MEM_COMMIT    As Long = &H1000&                                       'Commit allocated memory
Const MEM_RELEASE   As Long = &H8000&                                       'Release allocated memory flag
Const IDX_EBMODE    As Long = 3                                             'Thunk data index of the EbMode function address
Const IDX_CWP       As Long = 4                                             'Thunk data index of the CallWindowProc function address
Const IDX_SWL       As Long = 5                                             'Thunk data index of the SetWindowsLong function address
Const IDX_FREE      As Long = 6                                             'Thunk data index of the VirtualFree function address
Const IDX_BADPTR    As Long = 7                                             'Thunk data index of the IsBadCodePtr function address
Const IDX_OWNER     As Long = 8                                             'Thunk data index of the Owner object's vTable address
Const IDX_CALLBACK  As Long = 10                                            'Thunk data index of the callback method address
Const IDX_EBX       As Long = 16                                            'Thunk code patch index of the thunk data
Const SUB_NAME      As String = "sc_Subclass"                               'This routine's name
  Dim nAddr         As Long
  Dim nID           As Long
  Dim nMyID         As Long
 
  If IsWindow(lng_hWnd) = 0 Then                                            'Ensure the window handle is valid
    zError SUB_NAME, "Invalid window handle"
    Exit Function
  End If

  nMyID = GetCurrentProcessId                                               'Get this process's ID
  GetWindowThreadProcessId lng_hWnd, nID                                    'Get the process ID associated with the window handle
  If nID <> nMyID Then                                                      'Ensure that the window handle doesn't belong to another process
    zError SUB_NAME, "Window handle belongs to another process"
    Exit Function
  End If
 
  If oCallback Is Nothing Then                                              'If the user hasn't specified the callback owner
    Set oCallback = Me                                                      'Then it is me
  End If
 
  nAddr = zAddressOf(oCallback, nOrdinal)                                   'Get the address of the specified ordinal method
  If nAddr = 0 Then                                                         'Ensure that we've found the ordinal method
    zError SUB_NAME, "Callback method not found"
    Exit Function
  End If
   
  If z_Funk Is Nothing Then                                                 'If this is the first time through, do the one-time initialization
    Set z_Funk = New Collection                                             'Create the hWnd/thunk-address collection
    z_Sc(14) = &HD231C031: z_Sc(15) = &HBBE58960: z_Sc(17) = &H4339F631: z_Sc(18) = &H4A21750C: z_Sc(19) = &HE82C7B8B: z_Sc(20) = &H74&: z_Sc(21) = &H75147539: z_Sc(22) = &H21E80F: z_Sc(23) = &HD2310000: z_Sc(24) = &HE8307B8B: z_Sc(25) = &H60&: z_Sc(26) = &H10C261: z_Sc(27) = &H830C53FF: z_Sc(28) = &HD77401F8: z_Sc(29) = &H2874C085: z_Sc(30) = &H2E8&: z_Sc(31) = &HFFE9EB00: z_Sc(32) = &H75FF3075: z_Sc(33) = &H2875FF2C: z_Sc(34) = &HFF2475FF: z_Sc(35) = &H3FF2473: z_Sc(36) = &H891053FF: z_Sc(37) = &HBFF1C45: z_Sc(38) = &H73396775: z_Sc(39) = &H58627404
    z_Sc(40) = &H6A2473FF: z_Sc(41) = &H873FFFC: z_Sc(42) = &H891453FF: z_Sc(43) = &H7589285D: z_Sc(44) = &H3045C72C: z_Sc(45) = &H8000&: z_Sc(46) = &H8920458B: z_Sc(47) = &H4589145D: z_Sc(48) = &HC4836124: z_Sc(49) = &H1862FF04: z_Sc(50) = &H35E30F8B: z_Sc(51) = &HA78C985: z_Sc(52) = &H8B04C783: z_Sc(53) = &HAFF22845: z_Sc(54) = &H73FF2775: z_Sc(55) = &H1C53FF28: z_Sc(56) = &H438D1F75: z_Sc(57) = &H144D8D34: z_Sc(58) = &H1C458D50: z_Sc(59) = &HFF3075FF: z_Sc(60) = &H75FF2C75: z_Sc(61) = &H873FF28: z_Sc(62) = &HFF525150: z_Sc(63) = &H53FF2073: z_Sc(64) = &HC328&

    z_Sc(IDX_CWP) = zFnAddr("user32", "CallWindowProcA")                    'Store CallWindowProc function address in the thunk data
    z_Sc(IDX_SWL) = zFnAddr("user32", "SetWindowLongA")                     'Store the SetWindowLong function address in the thunk data
    z_Sc(IDX_FREE) = zFnAddr("kernel32", "VirtualFree")                     'Store the VirtualFree function address in the thunk data
    z_Sc(IDX_BADPTR) = zFnAddr("kernel32", "IsBadCodePtr")                  'Store the IsBadCodePtr function address in the thunk data
  End If
 
  z_ScMem = VirtualAlloc(0, MEM_LEN, MEM_COMMIT, PAGE_RWX)                  'Allocate executable memory

  If z_ScMem <> 0 Then                                                      'Ensure the allocation succeeded
    On Error GoTo CatchDoubleSub                                            'Catch double subclassing
      z_Funk.Add z_ScMem, "h" & lng_hWnd                                    'Add the hWnd/thunk-address to the collection
    On Error GoTo 0
 
    If bIdeSafety Then                                                      'If the user wants IDE protection
      z_Sc(IDX_EBMODE) = zFnAddr("vba6", "EbMode")                          'Store the EbMode function address in the thunk data
    End If
   
    z_Sc(IDX_EBX) = z_ScMem                                                 'Patch the thunk data address
    z_Sc(IDX_HWND) = lng_hWnd                                               'Store the window handle in the thunk data
    z_Sc(IDX_BTABLE) = z_ScMem + CODE_LEN                                   'Store the address of the before table in the thunk data
    z_Sc(IDX_ATABLE) = z_ScMem + CODE_LEN + ((MSG_ENTRIES + 1) * 4)         'Store the address of the after table in the thunk data
    z_Sc(IDX_OWNER) = ObjPtr(oCallback)                                     'Store the callback owner's object address in the thunk data
    z_Sc(IDX_CALLBACK) = nAddr                                              'Store the callback address in the thunk data
    z_Sc(IDX_PARM_USER) = lParamUser                                        'Store the lParamUser callback parameter in the thunk data
   
    nAddr = SetWindowLongA(lng_hWnd, GWL_WNDPROC, z_ScMem + WNDPROC_OFF)    'Set the new WndProc, return the address of the original WndProc
    If nAddr = 0 Then                                                       'Ensure the new WndProc was set correctly
      zError SUB_NAME, "SetWindowLong failed, error #" & Err.LastDllError
      GoTo ReleaseMemory
    End If
       
    z_Sc(IDX_WNDPROC) = nAddr                                               'Store the original WndProc address in the thunk data
    RtlMoveMemory z_ScMem, VarPtr(z_Sc(0)), CODE_LEN                        'Copy the thunk code/data to the allocated memory
    sc_Subclass = True                                                      'Indicate success
  Else
    zError SUB_NAME, "VirtualAlloc failed, error: " & Err.LastDllError
  End If
 
  Exit Function                                                             'Exit sc_Subclass

CatchDoubleSub:
  zError SUB_NAME, "Window handle is already subclassed"
 
ReleaseMemory:
  VirtualFree z_ScMem, 0, MEM_RELEASE                                       'sc_Subclass has failed after memory allocation, so release the memory
End Function

'Terminate all subclassing
Private Sub sc_Terminate()
  Dim i As Long

  If Not (z_Funk Is Nothing) Then                                           'Ensure that subclassing has been started
    With z_Funk
      For i = .Count To 1 Step -1                                           'Loop through the collection of window handles in reverse order
        z_ScMem = .Item(i)                                                  'Get the thunk address
        If IsBadCodePtr(z_ScMem) = 0 Then                                   'Ensure that the thunk hasn't already released its memory
          sc_UnSubclass zData(IDX_HWND)                                     'UnSubclass
        End If
      Next i                                                                'Next member of the collection
    End With
    Set z_Funk = Nothing                                                    'Destroy the hWnd/thunk-address collection
  End If
End Sub

'UnSubclass the specified window handle
Private Sub sc_UnSubclass(ByVal lng_hWnd As Long)
  If z_Funk Is Nothing Then                                                 'Ensure that subclassing has been started
    zError "sc_UnSubclass", "Window handle isn't subclassed"
  Else
    If IsBadCodePtr(zMap_hWnd(lng_hWnd)) = 0 Then                           'Ensure that the thunk hasn't already released its memory
      zData(IDX_SHUTDOWN) = -1                                              'Set the shutdown indicator
      zDelMsg ALL_MESSAGES, IDX_BTABLE                                      'Delete all before messages
      zDelMsg ALL_MESSAGES, IDX_ATABLE                                      'Delete all after messages
    End If
    z_Funk.Remove "h" & lng_hWnd                                            'Remove the specified window handle from the collection
  End If
End Sub

'Add the message value to the window handle's specified callback table
Private Sub sc_AddMsg(ByVal lng_hWnd As Long, ByVal uMsg As Long, Optional ByVal When As eMsgWhen = eMsgWhen.MSG_AFTER)
  If IsBadCodePtr(zMap_hWnd(lng_hWnd)) = 0 Then                             'Ensure that the thunk hasn't already released its memory
    If When And MSG_BEFORE Then                                             'If the message is to be added to the before original WndProc table...
      zAddMsg uMsg, IDX_BTABLE                                              'Add the message to the before table
    End If
    If When And MSG_AFTER Then                                              'If message is to be added to the after original WndProc table...
      zAddMsg uMsg, IDX_ATABLE                                              'Add the message to the after table
    End If
  End If
End Sub

'Delete the message value from the window handle's specified callback table
Private Sub sc_DelMsg(ByVal lng_hWnd As Long, ByVal uMsg As Long, Optional ByVal When As eMsgWhen = eMsgWhen.MSG_AFTER)
  If IsBadCodePtr(zMap_hWnd(lng_hWnd)) = 0 Then                             'Ensure that the thunk hasn't already released its memory
    If When And MSG_BEFORE Then                                             'If the message is to be deleted from the before original WndProc table...
      zDelMsg uMsg, IDX_BTABLE                                              'Delete the message from the before table
    End If
    If When And MSG_AFTER Then                                              'If the message is to be deleted from the after original WndProc table...
      zDelMsg uMsg, IDX_ATABLE                                              'Delete the message from the after table
    End If
  End If
End Sub

'Call the original WndProc
Private Function sc_CallOrigWndProc(ByVal lng_hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  If IsBadCodePtr(zMap_hWnd(lng_hWnd)) = 0 Then                             'Ensure that the thunk hasn't already released its memory
    sc_CallOrigWndProc = _
        CallWindowProcA(zData(IDX_WNDPROC), lng_hWnd, uMsg, wParam, lParam) 'Call the original WndProc of the passed window handle parameter
  End If
End Function

'Get the subclasser lParamUser callback parameter
Private Property Get sc_lParamUser(ByVal lng_hWnd As Long) As Long
  If IsBadCodePtr(zMap_hWnd(lng_hWnd)) = 0 Then                             'Ensure that the thunk hasn't already released its memory
    sc_lParamUser = zData(IDX_PARM_USER)                                    'Get the lParamUser callback parameter
  End If
End Property

'Let the subclasser lParamUser callback parameter
Private Property Let sc_lParamUser(ByVal lng_hWnd As Long, ByVal newValue As Long)
  If IsBadCodePtr(zMap_hWnd(lng_hWnd)) = 0 Then                             'Ensure that the thunk hasn't already released its memory
    zData(IDX_PARM_USER) = newValue                                         'Set the lParamUser callback parameter
  End If
End Property

'-The following routines are exclusively for the sc_ subclass routines----------------------------

'Add the message to the specified table of the window handle
Private Sub zAddMsg(ByVal uMsg As Long, ByVal nTable As Long)
  Dim nCount As Long                                                        'Table entry count
  Dim nBase  As Long                                                        'Remember z_ScMem
  Dim i      As Long                                                        'Loop index

  nBase = z_ScMem                                                            'Remember z_ScMem so that we can restore its value on exit
  z_ScMem = zData(nTable)                                                    'Map zData() to the specified table

  If uMsg = ALL_MESSAGES Then                                               'If ALL_MESSAGES are being added to the table...
    nCount = ALL_MESSAGES                                                   'Set the table entry count to ALL_MESSAGES
  Else
    nCount = zData(0)                                                       'Get the current table entry count
    If nCount >= MSG_ENTRIES Then                                           'Check for message table overflow
      zError "zAddMsg", "Message table overflow. Either increase the value of Const MSG_ENTRIES or use ALL_MESSAGES instead of specific message values"
      GoTo Bail
    End If

    For i = 1 To nCount                                                     'Loop through the table entries
      If zData(i) = 0 Then                                                  'If the element is free...
        zData(i) = uMsg                                                     'Use this element
        GoTo Bail                                                           'Bail
      ElseIf zData(i) = uMsg Then                                           'If the message is already in the table...
        GoTo Bail                                                           'Bail
      End If
    Next i                                                                  'Next message table entry

    nCount = i                                                              'On drop through: i = nCount + 1, the new table entry count
    zData(nCount) = uMsg                                                    'Store the message in the appended table entry
  End If

  zData(0) = nCount                                                         'Store the new table entry count
Bail:
  z_ScMem = nBase                                                           'Restore the value of z_ScMem
End Sub

'Delete the message from the specified table of the window handle
Private Sub zDelMsg(ByVal uMsg As Long, ByVal nTable As Long)
  Dim nCount As Long                                                        'Table entry count
  Dim nBase  As Long                                                        'Remember z_ScMem
  Dim i      As Long                                                        'Loop index

  nBase = z_ScMem                                                           'Remember z_ScMem so that we can restore its value on exit
  z_ScMem = zData(nTable)                                                   'Map zData() to the specified table

  If uMsg = ALL_MESSAGES Then                                               'If ALL_MESSAGES are being deleted from the table...
    zData(0) = 0                                                            'Zero the table entry count
  Else
    nCount = zData(0)                                                       'Get the table entry count
   
    For i = 1 To nCount                                                     'Loop through the table entries
      If zData(i) = uMsg Then                                               'If the message is found...
        zData(i) = 0                                                        'Null the msg value -- also frees the element for re-use
        GoTo Bail                                                           'Bail
      End If
    Next i                                                                  'Next message table entry
   
    zError "zDelMsg", "Message &H" & Hex$(uMsg) & " not found in table"
  End If
 
Bail:
  z_ScMem = nBase                                                           'Restore the value of z_ScMem
End Sub

'Error handler
Private Sub zError(ByVal sRoutine As String, ByVal sMsg As String)
  App.LogEvent TypeName(Me) & "." & sRoutine & ": " & sMsg, vbLogEventTypeError
  MsgBox sMsg & ".", vbExclamation + vbApplicationModal, "Error in " & TypeName(Me) & "." & sRoutine
End Sub

'Return the address of the specified DLL/procedure
Private Function zFnAddr(ByVal sDLL As String, ByVal sProc As String) As Long
  zFnAddr = GetProcAddress(GetModuleHandleA(sDLL), sProc)                   'Get the specified procedure address
  Debug.Assert zFnAddr                                                      'In the IDE, validate that the procedure address was located
End Function

'Map zData() to the thunk address for the specified window handle
Private Function zMap_hWnd(ByVal lng_hWnd As Long) As Long
  If z_Funk Is Nothing Then                                                 'Ensure that subclassing has been started
    zError "zMap_hWnd", "Subclassing hasn't been started"
  Else
    On Error GoTo Catch                                                     'Catch unsubclassed window handles
    z_ScMem = z_Funk("h" & lng_hWnd)                                        'Get the thunk address
    zMap_hWnd = z_ScMem
  End If
 
  Exit Function                                                             'Exit returning the thunk address

Catch:
  zError "zMap_hWnd", "Window handle isn't subclassed"
End Function

'Return the address of the specified ordinal method on the oCallback object, 1 = last private method, 2 = second last private method, etc
Private Function zAddressOf(ByVal oCallback As Object, ByVal nOrdinal As Long) As Long
  Dim bSub  As Byte                                                         'Value we expect to find pointed at by a vTable method entry
  Dim bVal  As Byte
  Dim nAddr As Long                                                         'Address of the vTable
  Dim i     As Long                                                         'Loop index
  Dim j     As Long                                                         'Loop limit
 
  RtlMoveMemory VarPtr(nAddr), ObjPtr(oCallback), 4                         'Get the address of the callback object's instance
  If Not zProbe(nAddr + &H1C, i, bSub) Then                                 'Probe for a Class method
    If Not zProbe(nAddr + &H6F8, i, bSub) Then                              'Probe for a Form method
      If Not zProbe(nAddr + &H7A4, i, bSub) Then                            'Probe for a UserControl method
        Exit Function                                                       'Bail...
      End If
    End If
  End If
 
  i = i + 4                                                                 'Bump to the next entry
  j = i + 1024                                                              'Set a reasonable limit, scan 256 vTable entries
  Do While i < j
    RtlMoveMemory VarPtr(nAddr), i, 4                                       'Get the address stored in this vTable entry
   
    If IsBadCodePtr(nAddr) Then                                             'Is the entry an invalid code address?
      RtlMoveMemory VarPtr(zAddressOf), i - (nOrdinal * 4), 4               'Return the specified vTable entry address
      Exit Do                                                               'Bad method signature, quit loop
    End If

    RtlMoveMemory VarPtr(bVal), nAddr, 1                                    'Get the byte pointed to by the vTable entry
    If bVal <> bSub Then                                                    'If the byte doesn't match the expected value...
      RtlMoveMemory VarPtr(zAddressOf), i - (nOrdinal * 4), 4               'Return the specified vTable entry address
      Exit Do                                                               'Bad method signature, quit loop
    End If
   
    i = i + 4                                                             'Next vTable entry
  Loop
End Function

'Probe at the specified start address for a method signature
Private Function zProbe(ByVal nStart As Long, ByRef nMethod As Long, ByRef bSub As Byte) As Boolean
  Dim bVal    As Byte
  Dim nAddr   As Long
  Dim nLimit  As Long
  Dim nEntry  As Long
 
  nAddr = nStart                                                            'Start address
  nLimit = nAddr + 32                                                       'Probe eight entries
  Do While nAddr < nLimit                                                   'While we've not reached our probe depth
    RtlMoveMemory VarPtr(nEntry), nAddr, 4                                  'Get the vTable entry
   
    If nEntry <> 0 Then                                                     'If not an implemented interface
      RtlMoveMemory VarPtr(bVal), nEntry, 1                                 'Get the value pointed at by the vTable entry
      If bVal = &H33 Or bVal = &HE9 Then                                    'Check for a native or pcode method signature
        nMethod = nAddr                                                     'Store the vTable entry
        bSub = bVal                                                         'Store the found method signature
        zProbe = True                                                       'Indicate success
        Exit Function                                                       'Return
      End If
    End If
   
    nAddr = nAddr + 4                                                       'Next vTable entry
  Loop
End Function

Private Property Get zData(ByVal nIndex As Long) As Long
  RtlMoveMemory VarPtr(zData), z_ScMem + (nIndex * 4), 4
End Property

Private Property Let zData(ByVal nIndex As Long, ByVal nValue As Long)
  RtlMoveMemory z_ScMem + (nIndex * 4), VarPtr(nValue), 4
End Property

'-Subclass callback, usually ordinal #1, the last method in this source file----------------------
Private Sub zWndProc1(ByVal bBefore As Boolean, _
                      ByRef bHandled As Boolean, _
                      ByRef lReturn As Long, _
                      ByVal lng_hWnd As Long, _
                      ByVal uMsg As Long, _
                      ByVal wParam As Long, _
                      ByVal lParam As Long, _
                      ByRef lParamUser As Long)
'*************************************************************************************************
'* bBefore    - Indicates whether the callback is before or after the original WndProc. Usually
'*              you will know unless the callback for the uMsg value is specified as
'*              MSG_BEFORE_AFTER (both before and after the original WndProc).
'* bHandled   - In a before original WndProc callback, setting bHandled to True will prevent the
'*              message being passed to the original WndProc and (if set to do so) the after
'*              original WndProc callback.
'* lReturn    - WndProc return value. Set as per the MSDN documentation for the message value,
'*              and/or, in an after the original WndProc callback, act on the return value as set
'*              by the original WndProc.
'* lng_hWnd   - Window handle.
'* uMsg       - Message value.
'* wParam     - Message related data.
'* lParam     - Message related data.
'* lParamUser - User-defined callback parameter
'*************************************************************************************************
Dim X As Long, Y As Long
  Select Case uMsg
    Case WM_PAINT
        Init_Style
    Case WM_MOUSEMOVE
        If wParam <> MK_LBUTTON And Not IsHover Then
            X = LoWord(lParam)
            Y = HiWord(lParam)
            If X > 0 And X < ScaleWidth And Y > 0 And Y < ScaleHeight Then
                IsHover = True
                TrackMouseLeave lng_hWnd
                RaiseEvent MouseEnter
                DrawButton (eHover)
            End If
        End If
  Case WM_MOUSELEAVE
        IsHover = False
        RaiseEvent MouseLeave
        If Not m_Checked Then If m_hasFocus Then DrawButton (eFocus) Else DrawButton (eNormal)
  End Select
End Sub