[求助]请版主们帮我调试一下该快捷菜单的程序
在VB下是可以完全执行的,我转成VBA时,连续执行就会退出cad,请版主们帮我调试一下该快捷菜单的程序,感谢!
相应vb程序代码:
＇模块
Option Explicit
Public Const mFileId1 = &H1&
Public Const mFileId2 = &H2&
Public Const TPM_LEFTALIGN = &H0&
Public Const TPM_LEFTBUTTON = &H0&
Public Const MF_STRING = &H0&
Public Const GWL_WNDPROC = (-4)
Public Const WM_COMMAND = &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
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
Public Declare Function CreatePopupMenu Lib "user32" () As Long
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
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Public Declare Function GetActiveWindow Lib "user32" () As Long
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
Public Type POINTAPI
x As Long
y As Long
End Type
Public Function NewWindowProc(ByVal inHWND As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If Msg = WM_COMMAND Then
If wParam = mFileId1 Then
MsgBox "菜单1"
Exit Function
End If
If wParam = mFileId2 Then
MsgBox "菜单2"
Exit Function
End If
End If
NewWindowProc = CallWindowProc(OldWinProc, inHWND, Msg, wParam, lParam)
End Function
＇窗体
Option Explicit
Private Sub Form_Load()
OldWinProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf NewWindowProc)
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim lResult As Long, hPopupMenu As Long
If Button = 2 Then
hPopupMenu = CreatePopupMenu()
lResult = AppendMenu(hPopupMenu, MF_STRING, mFileId1, "菜单1")
lResult = AppendMenu(hPopupMenu, MF_STRING, mFileId2, "菜单2")
Dim Pt As POINTAPI
GetCursorPos Pt
lResult = TrackPopupMenu(hPopupMenu, TPM_LEFTALIGN Or TPM_LEFTBUTTON, Pt.x, Pt.y, 0, GetActiveWindow, 0&)
End If
End Sub
**** Hidden Message *****
页:
[1]