一个关于WINDOWS消息的问题!!!

HOWTO: Hook Into a Window's Messages Using AddressOf
Step-by-Step Example
Start a new Visual Basic Standard EXE project. Form1 is created by default.
Add two CommandButtons and a Standard Module to the form.
Add the following code to the Declarations section of Module1:      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      Declare Function SetWindowLong Lib "user32" Alias _
      "SetWindowLongA" (ByVal hwnd As Long, _
      ByVal nIndex As Long, ByVal dwNewLong As Long) As Long      Public Const GWL_WNDPROC = -4
      Public IsHooked As Boolean
      Global lpPrevWndProc As Long
      Global gHW As Long      Public Sub Hook()
          If IsHooked Then
          MsgBox "Don't hook it twice without " & _
            "unhooking, or you will be unable to unhook it."
          Else
          lpPrevWndProc = SetWindowLong(gHW, GWL_WNDPROC, _
          AddressOf WindowProc)
          IsHooked = True
          End If
      End Sub      Public Sub Unhook()
          Dim temp As Long
          temp = SetWindowLong(gHW, GWL_WNDPROC,lpPrevWndProc)
          IsHooked = False
      End Sub      Function WindowProc(ByVal hw As Long, ByVal uMsg As _
      Long, ByVal wParam As Long, ByVal lParam As Long) As Long
          Debug.Print "Message: "; hw, uMsg, wParam, lParam
          WindowProc = CallWindowProc(lpPrevWndProc, hw, _
          uMsg, wParam, lParam)
      End Function
Add the following code to the Declarations section of Form1:      Private Sub Form_Load()
          gHW = Me.hwnd
          Command1.Caption = "Hook"
          Command2.Caption = "Unhook"
      End Sub      Private Sub Command1_Click()
          Hook
      End Sub      Private Sub Command2_Click()
          Unhook
      End Sub      Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode  _
          As Integer)
          If IsHooked Then
          Cancel = 1
          MsgBox "Unhook before closing, or the IDE will crash."
          End If
      End Sub Before running this sample, save your project.
Press the F5 key to run the program, and click Hook. The Immediate window starts filling with the messages the form is receiving, hooked through to your new WindowProc function and then passed on to the Form's own handler.
These two Hook and Unhook procedures enable the code to hook into the stream of messages.
In the first procedure "Hook" you make use of the SetWindowLong function. The SetWindowLong function changes an attribute of a specified window. It takes the following parameters:
hwnd: The handle of the Window you are going to change.
nIndex: The action you are going to do to the window.
dwNewLong: The new value you change to.
In this example, you use the Form's hwnd property as the targeted window to change. You then use the GWL_WNDPROC constant to tell the SetWindowLong function that you want to change the address of the target window's WindowProc function. Finally you set dwNewLong to the address of a new WindowProc function (see next step). Notice that you store the previous WindowProc address in the lpPrevWndProc variable.
The second procedure "UnHook" simply reverses what you have done and puts the address of the original window procedure back.
Here WindowProc is the function that you are routing the window messages to when you "Hook" the form's WindowProc function. Note that you make use of the CallWindowProc function; using the lpPrevWndProc variable to send any unprocessed messages to the original handler. Hence, you are allowing a chain of window procedures to process all messages.

我这有个 subclassing BUTTON 的例子：
=====================================
'frmTest.frmPrivate Sub cmdDemo_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = 2 Then PopupMenu mnuButton, , cmdDemo.Left, cmdDemo.Top + cmdDemo.Height
End SubPrivate Sub cmdPick_Click()
    frmPalette.Show
End SubPrivate Sub cmdQuit_Click()
    End
End SubPrivate Sub Command1_Click()
    MsgBox "Hi!" & vbNewLine & "I am Khrys (Chris, but I'm weird...), a person who writes VB programs. And I wrote this one *yay*." & vbNewLine & "This program is just a demo of one of the many subclassing things I have written, and probably one of the more useful. I like subclassing stuff because it gives you effects that cannot be produced in other ways. However, i have killed VB many times with unsuccessful attempts, so I save my work every few lines of code :)" & vbNewLine & "Thanks for using my code!", vbInformation, "About"
    MsgBox "Ooh...warning. There is a little problem with the UnRegisterButton sub. That's why I haven't implemented it in this program. When you do subclass in your programs that you will compile, though, it will be fine. Usage: 'UnRegisterButton cmdWhatEver'. Simple. Thank You.", vbCritical, "Warning"
End SubPrivate Sub Form_Load()
    Dim RunMeNow As Boolean
    RunMeNow = MsgBox("The program you are about to run uses subclassing. Once a control is subclassed, it must be un-subclassed correctly. It is always advisable to SAVE YOUR WORK before running a subclassing project. Also, do not, UNDER ANY CIRCUMSTANCES, end this program through VB's Stop Button. Click Quit, or the ?button. If you wish to close now, and save this project first, click Cancel. Clicking OK will proceed with the running of the program. Thank You.", vbCritical + vbOKCancel, "Warning") = vbOK
    If RunMeNow = False Then End
    RegisterButton cmdDemo, RGB(255, 0, 0)
    DoEvents
End SubPrivate Sub optColour_Click(Index As Integer)    Select Case Index

            Case 0
                ButtonColour = RGB(255, 0, 0)
                cmdPick.Enabled = False
                DoEvents
                RegisterButton cmdDemo, ButtonColour
                DoEvents
            Case 1
                ButtonColour = RGB(0, 0, 255)
                cmdPick.Enabled = False
                DoEvents
                RegisterButton cmdDemo, ButtonColour
                DoEvents
            Case 2
                ButtonColour = RGB(0, 255, 0)
                cmdPick.Enabled = False
                DoEvents
                RegisterButton cmdDemo, ButtonColour
                DoEvents
            Case 3
                ButtonColour = RGB(255, 255, 0)
                cmdPick.Enabled = False
                DoEvents
                RegisterButton cmdDemo, ButtonColour
                DoEvents
            Case 4
                ButtonColour = RGB(255, 0, 255)
                cmdPick.Enabled = False
                DoEvents
                RegisterButton cmdDemo, ButtonColour
                DoEvents
            Case 5
                ButtonColour = RGB(255, 255, 255)
                cmdPick.Enabled = False
                DoEvents
                RegisterButton cmdDemo, ButtonColour
                DoEvents
            Case 6
                ButtonColour = RGB(0, 0, 0)
                cmdPick.Enabled = False
                DoEvents
                RegisterButton cmdDemo, ButtonColour
                DoEvents
            Case 7
                cmdPick.Enabled = True
        End Select
End SubPrivate Sub pmnuDisable_Click()
    cmdDemo.Enabled = False
End SubPrivate Sub pmnuEnable_Click()
    cmdDemo.Enabled = True
End Sub
===================================

=========================================
'frmPalette.frm
Public OriginalButtonColour As StringPrivate Sub cmdOK_Click()
    ButtonColour = picColour.BackColor
    RegisterButton frmTest.cmdDemo, ButtonColour
    Me.Hide
End SubPrivate Sub Form_Load()
    OriginalButtonColour = picColour.BackColor
End SubPrivate Sub sldRGB_Scroll(Index As Integer)
    ButtonColour = RGB(sldRGB(0).Value, sldRGB(1).Value, sldRGB(2).Value)
    picColour.BackColor = ButtonColour
    lblColour.Caption = "Current Colour: " & ButtonColour
End Sub

========================================
'modSubClass.bas
Private colButtons  As New Collection
Private Const KeyConst = "K"
Private Const PROP_COLOR = "SMDColor"
Private Const PROP_HWNDPARENT = "SMDhWndParent"
Private Const PROP_LPWNDPROC = "SMDlpWndProc"
Private Const GWL_WNDPROC As Long = (-4)
Private Const ODA_SELECT As Long = &H2
Private Const ODS_SELECTED As Long = &H1
Private Const ODS_FOCUS As Long = &H10
Private Const ODS_BUTTONDOWN As Long = ODS_FOCUS Or ODS_SELECTED
Private Const WM_DESTROY As Long = &H2
Private Const WM_DRAWITEM As Long = &H2BPrivate Type RECT
   Left        As Long
   Top         As Long
   Right       As Long
   Bottom      As Long
End TypePrivate Type Size
   cx          As Long
   cy          As Long
End TypePrivate Type DRAWITEMSTRUCT
   CtlType     As Long
   CtlID       As Long
   itemID      As Long
   itemAction  As Long
   itemState   As Long
   hWndItem    As Long
   hDC         As Long
   rcItem      As RECT
   itemData    As Long
End TypePrivate Declare Function CallWindowProc Lib "user32" _
    Alias "CallWindowProcA" _
   (ByVal lpPrevWndFunc As Long, _
    ByVal hWnd As Long, _
    ByVal msg As Long, _
    ByVal wParam As Long, _
    lParam As DRAWITEMSTRUCT) As LongPrivate Declare Function GetParent Lib "user32" _
    (ByVal hWnd As Long) As LongPrivate Declare Function GetProp Lib "user32" _
    Alias "GetPropA" _
   (ByVal hWnd As Long, _
    ByVal lpString As String) As LongPrivate Declare Function GetTextExtentPoint32 Lib "gdi32" _
    Alias "GetTextExtentPoint32A" _
   (ByVal hDC As Long, _
    ByVal lpSz As String, _
    ByVal cbString As Long, _
    lpSize As Size) As LongPrivate Declare Function RemoveProp Lib "user32" _
    Alias "RemovePropA" _
   (ByVal hWnd As Long, _
    ByVal lpString As String) As LongPrivate Declare Function SetProp Lib "user32" _
    Alias "SetPropA" _
   (ByVal hWnd As Long, _
    ByVal lpString As String, _
    ByVal hData As Long) As LongPrivate Declare Function SetTextColor Lib "gdi32" _
    (ByVal hDC As Long, _
    ByVal crColor As Long) As LongPrivate Declare Function SetWindowLong Lib "user32" _
    Alias "SetWindowLongA" _
   (ByVal hWnd As Long, _
    ByVal nIndex As Long, _
    ByVal dwNewLong As Long) As LongPrivate Declare Function TextOut Lib "gdi32" _
    Alias "TextOutA" _
   (ByVal hDC As Long, _
    ByVal x As Long, _
    ByVal y As Long, _
    ByVal lpString As String, _
    ByVal nCount As Long) As Long
Private Function FindButton(sKey As String) As Boolean   Dim cmdButton As CommandButton

   On Error Resume Next
   Set cmdButton = colButtons.Item(sKey)
   FindButton = (Err.Number = 0)End Function
Private Function GetKey(hWnd As Long) As String
   GetKey = KeyConst & hWnd
End Function
Private Function ProcessButton(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, lParam As DRAWITEMSTRUCT, sKey As String) As Long   Dim cmdButton       As CommandButton
   Dim bRC             As Boolean
   Dim lRC             As Long
   Dim x               As Long
   Dim y               As Long
   Dim lpWndProC       As Long
   Dim lButtonWidth    As Long
   Dim lButtonHeight   As Long
   Dim lPrevColor      As Long
   Dim lColor          As Long
   Dim TextSize        As Size
   Dim sCaption        As String

   Const PushOffset = 2

   Set cmdButton = colButtons.Item(sKey)
   sCaption = cmdButton.Caption

   lColor = GetProp(cmdButton.hWnd, PROP_COLOR)
   lPrevColor = SetTextColor(lParam.hDC, lColor)

  'In Pixels
   lRC = GetTextExtentPoint32(lParam.hDC, _
   sCaption, Len(sCaption), TextSize)

  'In Pixels
   lButtonHeight = lParam.rcItem.Bottom - lParam.rcItem.Top
   lButtonWidth = lParam.rcItem.Right - lParam.rcItem.Left

  'The button is pressed! Offset the text
  'so it looks like the button is pushed
   If (lParam.itemAction = ODA_SELECT) And (lParam.itemState = ODS_BUTTONDOWN) Then
      cmdButton.SetFocus
      DoEvents

      x = (lButtonWidth - TextSize.cx + PushOffset) \ 2
      y = (lButtonHeight - TextSize.cy + PushOffset) \ 2
   Else
      x = (lButtonWidth - TextSize.cx) \ 2
      y = (lButtonHeight - TextSize.cy) \ 2
   End If

  'Get the default WndProd address
   lpWndProC = GetProp(hWnd, PROP_LPWNDPROC)

  'Do the default button processing
   ProcessButton = CallWindowProc(lpWndProC, hWnd, uMsg, wParam, lParam)

  'Put our text on the button
   bRC = TextOut(lParam.hDC, x, y, sCaption, Len(sCaption))

  'Restore the device context to the original color
   lRC = SetTextColor(lParam.hDC, lPrevColor)

ProcessButton_Exit:
   Set cmdButton = NothingEnd Function
Private Sub RemoveForm(hWndParent As Long)   Dim hWndButton As Long
   Dim i As Integer

   UnsubclassForm hWndParent

   On Error GoTo RemoveForm_Exit

   For i = colButtons.Count - 1 To 0 Step -1

      hWndButton = colButtons(i).hWnd

      If GetProp(hWndButton, PROP_HWNDPARENT) = hWndParent Then
         RemoveProp hWndButton, PROP_COLOR
         RemoveProp hWndButton, PROP_HWNDPARENT
         colButtons.Remove i
      End If

   Next i

RemoveForm_Exit:
   Exit SubEnd Sub
Private Function UnsubclassForm(hWnd As Long) As Boolean   Dim lpWndProC As Long

   lpWndProC = GetProp(hWnd, PROP_LPWNDPROC)

   If lpWndProC = 0 Then

      UnsubclassForm = False

   Else

      Call SetWindowLong(hWnd, GWL_WNDPROC, lpWndProC)
      RemoveProp hWnd, PROP_LPWNDPROC
      UnsubclassForm = True

   End IfEnd Function

DateTimePicker好像不是windows内置的标准控件
只有标准控件才有自己的预定义的消息

’（接上）
Private Function ButtonColorProc(ByVal hWnd As Long, _
                            ByVal uMsg As Long, _
                            ByVal wParam As Long, _
                            lParam As DRAWITEMSTRUCT) As Long   Dim lpWndProC       As Long
   Dim bProcessButton  As Boolean
   Dim sButtonKey      As String   bProcessButton = False      'Assume default processing   If (uMsg = WM_DRAWITEM) Then

     'Have we got this button? To find out,
     'try to reference the item in the collection.
     'If it's there, we have got it.  If it's
     'not there, we'll get an error.
      sButtonKey = GetKey(lParam.hWndItem)
      bProcessButton = FindButton(sButtonKey)

   End If


   If bProcessButton Then

      ProcessButton hWnd, uMsg, wParam, lParam, sButtonKey

   Else

      lpWndProC = GetProp(hWnd, PROP_LPWNDPROC)
      ButtonColorProc = CallWindowProc(lpWndProC, hWnd, uMsg, wParam, lParam)      If uMsg = WM_DESTROY Then RemoveForm hWnd

   End IfEnd Function
Public Function RegisterButton(Button As CommandButton, Forecolor As Long) As Boolean   Dim hWndParent      As Long
   Dim lpWndProC       As Long
   Dim sButtonKey      As String  'Make the colButtons key for the button
   sButtonKey = GetKey(Button.hWnd)

  'If we already own the button, just change the
  'colour otherwise we need to process the whole thing.
   If FindButton(sButtonKey) Then

      SetProp Button.hWnd, PROP_COLOR, Forecolor
      Button.Refresh

   Else

     'Get the handle to the buttons parent form.
      hWndParent = GetParent(Button.hWnd)

     'If we can't find a parent form, report a
     'problem and get out.
      If (hWndParent = 0) Then
         RegisterButton = False
         Exit Function
      End If

     'found the parent, gather all of the necessary
     'button values and add it to the collection.
      colButtons.Add Button, sButtonKey
      SetProp Button.hWnd, PROP_COLOR, Forecolor
      SetProp Button.hWnd, PROP_HWNDPARENT, hWndParent

     'Determine if we've already subclassed this form.
      lpWndProC = GetProp(hWndParent, PROP_LPWNDPROC)

     'It's a new form.  Subclass it and add the
     'Window proc address to the collection.
      If (lpWndProC = 0) Then
         lpWndProC = SetWindowLong(hWndParent, _
         GWL_WNDPROC, AddressOf ButtonColorProc)
         SetProp hWndParent, PROP_LPWNDPROC, lpWndProC
      End If

   End If

   RegisterButton = TrueEnd Function
Public Function UnregisterButton(btnButton As CommandButton) As Boolean   Dim hWndParent As Long
   Dim sKeyButton As String   sKeyButton = GetKey(btnButton.hWnd)   If (FindButton(sKeyButton) = False) Then
      UnregisterButton = False
      Exit Function
   End If   hWndParent = GetProp(btnButton.hWnd, PROP_HWNDPARENT)
   UnregisterButton = UnsubclassForm(hWndParent)   colButtons.Remove sKeyButton
   RemoveProp btnButton.hWnd, PROP_COLOR
   RemoveProp btnButton.hWnd, PROP_HWNDPARENT

End Function
=======================================================以上全部代码是改变 Button 颜色的。希望对你有启发。

调试易

一个关于WINDOWS消息的问题!!!

解决方案 »