modwndproc.bas

一个俄罗斯方块游戏

Attribute VB_Name = "modWndProc"
Option Explicit

Private Const WM_KEYDOWN = &H100
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 SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Const GWL_WNDPROC = (-4)
Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long

Public Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
   Dim nOldProc As Long
   nOldProc = GetProp(hwnd, "BTT_OLDPROC")
   Select Case uMsg
   Case WM_KEYDOWN
      Debug.Print Hex(wParam), Hex(lParam)
   End Select
   WindowProc = CallWindowProc(nOldProc, hwnd, uMsg, wParam, lParam)
End Function


Public Function SetWindowProc(ByVal hwnd As Long) As Long
   Dim nOldProc As Long
   nOldProc = GetProp(hwnd, "BTT_OLDPROC")
   If nOldProc <> 0 Then
      Debug.Assert False
      Exit Function
   End If

   nOldProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WindowProc)
   If nOldProc <> 0 Then
      SetProp hwnd, "BTT_OLDPROC", nOldProc
   End If
   SetWindowProc = nOldProc
End Function


Public Function RestoreWindowProc(ByVal hwnd As Long) As Long
   Dim nOldProc As Long
   nOldProc = GetProp(hwnd, "BTT_OLDPROC")
   If nOldProc = 0 Then
      Debug.Assert False
      Exit Function
   End If
   
   Dim nRet As Long
   nRet = SetWindowLong(hwnd, GWL_WNDPROC, nOldProc)
   Debug.Assert nRet <> 0
   RemoveProp hwnd, "BTT_OLDPROC"
   RestoreWindowProc = nRet
End Function