VB實現窗體注冊快捷鍵

在VB的菜單編輯器中，快捷鍵很少，如果想要實現Ctrl+Shift+O這樣的快捷鍵，都無法解決。後來利用API以及鉤子，實現了代碼，代碼如下

 

‘模塊代碼

Option Explicit
''
'' Copyright ?1997-1999 Brad Martinez, http://www.mvps.org
''
'' A general purpose subclassing module w/ debugging code
''
'' - Code was developed using, and is formatted for, 8pt. MS Sans Serif font
'' ==============================================

Public Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As Any) As Long
Public Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
Public Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long

Public Const WS_BORDER = &H800000
Public Const WS_CLIPCHILDREN = &H2000000

Public Enum GWL_nIndex
  GWL_WNDPROC = (-4)
''  GWL_HWNDPARENT = (-8)
  GWL_ID = (-12)
  GWL_STYLE = (-16)
  GWL_EXSTYLE = (-20)
''  GWL_USERDATA = (-21)
End Enum

Public Const WM_HOTKEY = &H312
Public Declare Function RegisterHotKey Lib "user32" (ByVal hwnd As Long, ByVal id As Long, ByVal fsModifIErs As Long, ByVal vk As Long) As Long
Public Declare Function UnregisterHotKey Lib "user32" (ByVal hwnd As Long, ByVal id As Long) As Long


Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As GWL_nIndex) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As GWL_nIndex, ByVal dwNewLong As Long) As Long

Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function DefWindowProc Lib "user32" Alias "DefWindowProcA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Private Const LMEM_FIXED = &H0
Private Const LMEM_ZEROINIT = &H40
Private Const LPTR = (LMEM_FIXED Or LMEM_ZEROINIT)
Private Declare Function LocalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal uBytes As Long) As Long
Private Declare Function LocalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function lstrcpyA Lib "kernel32" (lpString1 As Any, lpString2 As Any) As Long

Private Const OLDWNDPROC = "OldWndProc"
Private Const OBJECTPTR = "ObjectPtr"

'' Allocated string pointer filled with OLDWNDPROC string and used with all
'' CallWindowProc(GetProp(hwnd, m_lpszOldWndProc), ...) calls.
Private m_lpszOldWndProc As Long

#If DEBUGWINDOWPROC Then
  '' maintains a WindowProcHook reference for each subclassed window.
  '' the window''s handle is the collection item''s key string.
  Private m_colWPHooks As New Collection
#End If
''

'' On first window subclass, allocates a memory buffer and copIEs the
'' "OldWndProc" string to the buffer. On last unsubclass, frees and
'' zeros the allocated buffer. The pointer to the buffer is passed directly
'' to GetProp when retrIEing the subclassed window''s original window
'' procedure pointer, eliminating VB''s Unicode to ANSI string conversion
'' in our window procedures.

Private Sub SetWndProcPropertyBuffer(hwnd As Long, fAdd As Boolean)
  Static colhWnds As New Collection
  
  '' Collection holds the handles of all subclassed Windows,
  '' ensuring an accurate count of unique handles.
  On Error Resume Next
  If fAdd Then
    colhWnds.Add hwnd, CStr(hwnd)
  Else
    colhWnds.Remove CStr(hwnd)
  End If
  On Error GoTo 0
  
  '' If adding a window handle and the buffer is not yet
  '' allocated, allocate it.
  If fAdd Then
    If (m_lpszOldWndProc = 0) Then
      m_lpszOldWndProc = LocalAlloc(LPTR, Len(OLDWNDPROC))
      If m_lpszOldWndProc Then
        Call lstrcpyA(ByVal m_lpszOldWndProc, ByVal OLDWNDPROC)
''Debug.Print "wndproc buffer allocated"
      End If
    End If
  
  '' If removing a window handle, the collection count is zero, and the
  '' buffer is allocated, deallocate the buffer memory and zero the variable
  ElseIf (fAdd = False) And (colhWnds.Count = 0) Then
    If m_lpszOldWndProc Then
      Call LocalFree(m_lpszOldWndProc)
      m_lpszOldWndProc = 0
''Debug.Print "wndproc buffer freed"
    End If
  End If   '' fAdd

End Sub

Public Function SubClass(hwnd As Long, _
                                         lpfnNew As Long, _
                                         Optional objNotify As Object = Nothing) As Boolean
  Dim lpfnOld As Long
  Dim fSuccess As Boolean
  On Error GoTo Out

  If GetProp(hwnd, OLDWNDPROC) Then
    SubClass = True
    Exit Function
  End If
  
  Call SetWndProcPropertyBuffer(hwnd, True)
  
#If (DEBUGWINDOWPROC = 0) Then
    lpfnOld = SetWindowLong(hwnd, GWL_WNDPROC, lpfnNew)

#Else
    Dim objWPHook As WindowProcHook
    
    Set objWPHook = CreateWindowProcHook
    m_colWPHooks.Add objWPHook, CStr(hwnd)
    
    With objWPHook
      Call .SetMainProc(lpfnNew)
      lpfnOld = SetWindowLong(hwnd, GWL_WNDPROC, .ProcAddress)
      Call .SetDebugProc(lpfnOld)
    End With

#End If
  
  If lpfnOld Then
    fSuccess = SetProp(hwnd, OLDWNDPROC, lpfnOld)
    If (objNotify Is Nothing) = False Then
      fSuccess = fSuccess And SetProp(hwnd,OBJECTPTR, ObjPtr(objNotify))
    End If
  End If
  
Out:
  If fSuccess Then
    SubClass = True
  
  Else
    If lpfnOld Then Call SetWindowLong(hwnd, GWL_WNDPROC, lpfnOld)
    MsgBox "Error subclassing window &H" & Hex(hwnd) & vbCrLf & vbCrLf & _
                  "Err# " & Err.Number & ": " & Err.Description, vbExclamation
  End If
  
End Function

Public Function UnSubClass(hwnd As Long) As Boolean
  Dim lpfnOld As Long
  
  lpfnOld = GetProp(hwnd, OLDWNDPROC)
  If lpfnOld Then
    
    If SetWindowLong(hwnd, GWL_WNDPROC, lpfnOld) Then
      Call RemoveProp(hwnd, OLDWNDPROC)
      Call RemoveProp(hwnd, OBJECTPTR)

#If DEBUGWINDOWPROC Then
      '' remove the WindowProcHook reference from the collection
      m_colWPHooks.Remove CStr(hwnd)
#End If
      
      Call SetWndProcPropertyBuffer(hwnd, False)
      UnSubClass = True
    
    End If   '' SetWindowLong
  End If   '' lpfnOld

End Function

Public Function WndProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

    Select Case uMsg
        Case WM_HOTKEY
            Select Case wParam
                Case 100
                    Form1.ExecuteMenuCommand 100
                    Exit Function
            End Select
    
    End Select
    
    WndProc = CallWindowProc(GetProp(hwnd, m_lpszOldWndProc), hwnd, uMsg, wParam, lParam)

End Function

 

''窗體代碼
Private Const MOD_ALT = &H1
Private Const MOD_CONTROL = &H2
Private Const MOD_SHIFT = &H4

Private Sub Form_Load()
    Me.mnuFile_Open.Caption = "打開(&O)" & vbTab & "Ctrl+Shift+O"
    
    RegisterHotKey Me.hwnd, 100, MOD_CONTROL + MOD_SHIFT, vbKeyO
    
    SubClass Me.hwnd, AddressOf WndProc
    
    
End Sub

Private Sub Form_Unload(Cancel As Integer)
    UnregisterHotKey Me.hwnd, 100
    UnSubClass Me.hwnd
    
End Sub

Public Sub ExecuteMenuCommand(ByVal id As Long)
    Select Case id
        Case 100
            mnuFile_Open_Click
    End Select
    
End Sub

Private Sub mnuFile_Open_Click()
    MsgBox mnuFile_Open.Caption
    
End Sub

Private Sub mnuFile_Save_Click()
    MsgBox mnuFile_Save.Caption
    
End Sub

 

所顯示的菜單圖片：