Tips&Tricks

'In the Form:

'-------------------------------------------------------

Private Sub Form_Initialize()

    SubclassWindow hwnd

End Sub

Private Sub Form_Unload(Cancel As Integer)

    ' >>> WARNING if this isn't called before the application terminates VB WILL rash!!! <<<

    StopSubclass

End Sub

'-------------------------------------------------------

това е кода на модула:

'-------------------------------------------------------

' Example of how to Add a button to the forms caption bar.

' Written by Aaron Young ([email protected])

' June 2001

'

'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:\Happy.bmp"))

    Call SelectObject(lButtonDownDC, LoadPicture("C:\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

'-------------------------------------------------------