Snippet Library

'In a Module:

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

Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (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 SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

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 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 GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long

Private Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long

Private Const SRCCOPY = &HCC0020

Private Const GWL_WNDPROC = (-4)

Private Const WM_NCACTIVATE = &H86
Private Const WM_NCCALCSIZE = &H83
Private Const WM_NCCREATE = &H81
Private Const WM_NCDESTROY = &H82
Private Const WM_NCHITTEST = &H84
Private Const WM_NCLBUTTONDBLCLK = &HA3
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const WM_NCLBUTTONUP = &HA2
Private Const WM_NCMBUTTONDBLCLK = &HA9
Private Const WM_NCMBUTTONDOWN = &HA7
Private Const WM_NCMBUTTONUP = &HA8
Private Const WM_NCMOUSEMOVE = &HA0
Private Const WM_NCPAINT = &H85
Private Const WM_NCRBUTTONDBLCLK = &HA6
Private Const WM_NCRBUTTONDOWN = &HA4
Private Const WM_NCRBUTTONUP = &HA5
Private Const WM_COMMAND = &H111

Private Const HTBORDER = 18
Private Const HTBOTTOM = 15
Private Const HTBOTTOMLEFT = 16
Private Const HTCAPTION = 2
Private Const HTBOTTOMRIGHT = 17
Private Const HTCLIENT = 1
Private Const HTERROR = (-2)
Private Const HTGROWBOX = 4
Private Const HTHSCROLL = 6
Private Const HTLEFT = 10
Private Const HTMAXBUTTON = 9
Private Const HTMENU = 5
Private Const HTMINBUTTON = 8
Private Const HTNOWHERE = 0
Private Const HTREDUCE = HTMINBUTTON
Private Const HTRIGHT = 11
Private Const HTSIZE = HTGROWBOX
Private Const HTSIZEFIRST = HTLEFT
Private Const HTSIZELAST = HTBOTTOMRIGHT
Private Const HTSYSMENU = 3
Private Const HTTOP = 12
Private Const HTTOPLEFT = 13
Private Const HTTOPRIGHT = 14
Private Const HTTRANSPARENT = (-1)
Private Const HTVSCROLL = 7
Private Const HTZOOM = HTMAXBUTTON

Private lWindowProc As Long
Private lWindowHandle As Long
Private lButtonDC As Long
Private lButtonDownDC As Long

Private tRECT As RECT, lWidth, lHeight

Private bDrawnDown As Boolean

Public Sub SubclassWindow(ByVal hwnd As Long)
    Dim lDC As Long
    
    ' Get the Forms Device Context (DC)
    lDC = GetDC(hwnd)
    ' Create 2 compatible DC's for the Up and Down button images
    lButtonDC = CreateCompatibleDC(lDC)
    lButtonDownDC = CreateCompatibleDC(lDC)
    ' Load the Up and Down button images into each DC respectively
    ' Images are 16x14 16 colors
    Call SelectObject(lButtonDC, LoadPicture("C:MediaImagesHappy.bmp"))
    Call SelectObject(lButtonDownDC, LoadPicture("C:MediaImagesHappyDN.bmp"))
    ' Release the forms DC
    Call ReleaseDC(hwnd, lDC)
    ' Subclass the Form
    lWindowProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf SubWindowProc)
    ' Store the forms hWnd for processing later
    lWindowHandle = hwnd
End Sub

Public Sub StopSubclass()
    ' Remove the Forms subclassing
    Call SetWindowLong(lWindowHandle, GWL_WNDPROC, lWindowProc)
    ' Delete to 2 button image DC's
    Call DeleteDC(lButtonDC)
    Call DeleteDC(lButtonDownDC)
End Sub

Private Function SubWindowProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    ' Capture ALL messages going to the Form before they are processed
    Static bDepressed As Boolean
    
    Dim lDC As Long
        
    ' Call the default behaviour as normally we'll want to adjust it after the fact
    SubWindowProc = CallWindowProc(lWindowProc, hwnd, Msg, wParam, lParam)
    
    ' Get the Forms current dimensions
    Call GetWindowRect(hwnd, tRECT)
    
    ' Calculate the Forms Width and Height
    lWidth = tRECT.Right - tRECT.Left
    lHeight = tRECT.Bottom - tRECT.Top
            
    Select Case Msg
    Case WM_NCHITTEST
        ' See if the cursor is over our custom button
        If IsOverButton(lParam) Then
            ' If it is, set the Capture to this window, allowing us to receive
            ' Input events as they happen instead of "after the fact"
            SetCapture hwnd
            ' Tell the form our button is just the Caption bar (I don't know of a custom button HT Const)
            SubWindowProc = HTCAPTION
        End If
        
    Case WM_NCLBUTTONDOWN
        ' If the left mouse button is pressed over our button, show a sunken image
        If IsOverButton(lParam) Then
            ' Keep a flag so we know it's being pressed, (lets us to the fancy raise and sink
            ' as the mouse moves in and out of the button without letting the mouse button up.)
            bDepressed = True
            ' Draw the sunken image of our button
            PaintButton lButtonDownDC
            ' Tell the default Window handler we've processed this message
            SubWindowProc = 0
        End If

    Case WM_NCLBUTTONUP
        ' If the left button is up, our button can no longer be being pressed
        ' so flag it and no longer depressed.
        bDepressed = False
        ' If the mouse is over our button...
        If IsOverButton(lParam) Then
            ' Draw the raised image
            PaintButton lButtonDC
            ' Release sole capture of the Input messages
            ReleaseCapture
            ' Tell the default handler, we've processed this message
            SubWindowProc = 0
            ' Trigger our Click event
            ButtonClickEvent
        End If
        
    Case WM_NCMOUSEMOVE
        ' If the mouse moves over our button and the left button is pressed..
        If IsOverButton(lParam) And bDepressed Then
            ' Draw the sunken button image
            PaintButton lButtonDownDC
        Else
            ' Otherwise, if the image is currently sunken, raise it
            If bDrawnDown Then
                PaintButton lButtonDC
            End If
            ' and release capture
            ReleaseCapture
        End If
        
    Case WM_NCPAINT, WM_NCACTIVATE
        ' Redraw the button on PAINT and ACTIVATE events
        PaintButton lButtonDC
        
    End Select
        
End Function

Private Function LoWord(ByVal lValue As Long) As Long
    LoWord = lValue And &HFFFF&
End Function

Private Function HiWord(ByVal lValue As Long) As Long
    HiWord = (lValue / &H10000) And &HFFFF&
End Function

Private Function IsOverButton(ByVal lPos As Long)
    ' Determine if the specified Coords are within our custom button
    Dim lX As Long, lY As Long
    lX = (LoWord(lPos) - tRECT.Left)
    lY = (HiWord(lPos) - tRECT.Top)
    IsOverButton = (lX >= (lWidth - 75)) And (lX <= (lWidth - 61)) And (lY >= 6 And lY <= 22)
End Function

Private Function PaintButton(ByVal lImageDC As Long)
    ' Draw the specified image
    Dim lDC As Long
    ' Track whether the button is currently drawn up or down.
    bDrawnDown = (lImageDC = lButtonDownDC)
    lDC = GetWindowDC(lWindowHandle)
    BitBlt lDC, lWidth - 75, 6, 16, 14, lImageDC, 0, 0, SRCCOPY
    Call ReleaseDC(lWindowHandle, lDC)
End Function

Private Sub ButtonClickEvent()
    ' Custom Button Event Code goes Here!
    MsgBox "Smile!!"
End Sub

'In a Form:
Private Sub Form_Initialize()
    SubclassWindow hwnd
End Sub

Private Sub Form_Unload(Cancel As Integer)
    StopSubclass
End Sub
;