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:\Media\Images\Happy.bmp"))
Call SelectObject(lButtonDownDC, LoadPicture("C:\Media\Images\HappyDN.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
Reply With Quote
2009 - 2016
