社区 › VBA/VB/ActiveX/API 编程技术 › [求助]请版主们帮我调试一下该快捷菜单的程序

wyj7485 发表于 2005-7-6 11:48:00

[求助]请版主们帮我调试一下该快捷菜单的程序

在VB下是可以完全执行的,我转成VBA时,连续执行就会退出cad,


请版主们帮我调试一下该快捷菜单的程序,感谢!





相应vb程序代码:


＇模块<BR>Option Explicit


Public Const mFileId1 = &amp;H1&amp;<BR>Public Const mFileId2 = &amp;H2&amp;


Public Const TPM_LEFTALIGN = &amp;H0&amp;<BR>Public Const TPM_LEFTBUTTON = &amp;H0&amp;<BR>Public Const MF_STRING = &amp;H0&amp;<BR>Public Const GWL_WNDPROC = (-4)<BR>Public Const WM_COMMAND = &amp;H111


Public OldWinProc As Long


Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long<BR>Public 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<BR>Public Declare Function CreatePopupMenu Lib "user32" () As Long<BR>Public Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As String) As Long<BR>Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long<BR>Public Declare Function GetActiveWindow Lib "user32" () As Long<BR>Public Declare Function TrackPopupMenu Lib "user32" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal x As Long, ByVal y As Long, ByVal nReserved As Long, ByVal hwnd As Long, lprc As Any) As Long<BR>Public Type POINTAPI<BR>                                x As Long<BR>                                y As Long<BR>End Type


Public Function NewWindowProc(ByVal inHWND As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long<BR>                                If Msg = WM_COMMAND Then<BR>                                                                If wParam = mFileId1 Then<BR>                                                                                                MsgBox "菜单1"<BR>                                                                                                Exit Function<BR>                                                                End If<BR>                                                                If wParam = mFileId2 Then<BR>                                                                                                MsgBox "菜单2"<BR>                                                                                                Exit Function<BR>                                                                End If<BR>                                End If<BR>                                NewWindowProc = CallWindowProc(OldWinProc, inHWND, Msg, wParam, lParam)<BR>End Function


<BR>＇窗体<BR>Option Explicit<BR>Private Sub Form_Load()<BR>                                OldWinProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf NewWindowProc)<BR>End Sub


Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)<BR>Dim lResult As Long, hPopupMenu As Long<BR>                                <BR>                                If Button = 2 Then<BR>                                <BR>                               hPopupMenu = CreatePopupMenu()<BR>                                                               <BR>                               lResult = AppendMenu(hPopupMenu, MF_STRING, mFileId1, "菜单1")<BR>                               lResult = AppendMenu(hPopupMenu, MF_STRING, mFileId2, "菜单2")<BR>                                                                <BR>                               Dim Pt As POINTAPI<BR>                                                               <BR>                               GetCursorPos Pt<BR>                               lResult = TrackPopupMenu(hPopupMenu, TPM_LEFTALIGN Or TPM_LEFTBUTTON, Pt.x, Pt.y, 0, GetActiveWindow, 0&amp;)                                                               <BR>                                End If<BR>End Sub<BR>

查看完整版本: [求助]请版主们帮我调试一下该快捷菜单的程序