Not a Member Yet,
Click here to Register
How do you like the new design?
It's cool, great job
[tally: 70%] 70%
It's okay
[tally: 20%] 20%
Its OK but I liked the old layout better
[tally: 0%] 0%
Please bring the old one back
[tally: 10%] 10%

votes: 10

ID: 251
Viewed: 2310
Added: Jul 26, 2002
Snippet uploaded by: snippet
Written By: Aaron Young
Demo: Sorry, no demo

User Rated at: 0 Stars
Rate This:

Thank you for your vote. Please wait...

It appears you already voted for this snippet

It appears your vote value was empty

Adds custom title buttons to your form.

Highlight all by clicking in box
'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_NCLBUTTONUP = &HA2
Private Const WM_NCMBUTTONUP = &HA8
Private Const WM_NCMOUSEMOVE = &HA0
Private Const WM_NCPAINT = &H85
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 HTRIGHT = 11
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 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
' 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

' 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

' 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
' Tell the default handler, we've processed this message
SubWindowProc = 0
' Trigger our Click event
End If

' 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
' Otherwise, if the image is currently sunken, raise it
If bDrawnDown Then
PaintButton lButtonDC
End If
' and release capture
End If

' 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

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

Private Sub Form_Unload(Cancel As Integer)
End Sub

No Comments to show

Please completely fill out the form below if you want to review this snippet. All reviews are subject to validation.

Replying to a Comment...

Adding your comment. Please wait...

Thanks for adding your comment!. After further review it will be added.

There was a problem adding your comment. Please try again.

Please complete all the fields in the form before sending.

© 2002 - 2017 All Rights Reserved. Conditions