乐筑天下

搜索
欢迎各位开发者和用户入驻本平台 尊重版权,从我做起,拒绝盗版,拒绝倒卖 签到、发布资源、邀请好友注册,可以获得银币 请注意保管好自己的密码,避免账户资金被盗
查看: 16|回复: 0

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

[复制链接]

13

主题

396

帖子

5

银币

后起之秀

Rank: 20Rank: 20Rank: 20Rank: 20

铜币
448
发表于 2005-7-6 11:48:00 | 显示全部楼层 |阅读模式
在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

本帖以下内容被隐藏保护;需要你回复后,才能看到!

游客,如果您要查看本帖隐藏内容请回复
回复

使用道具 举报

发表回复

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

  • 微信公众平台

  • 扫描访问手机版

  • 点击图片下载手机App

QQ|关于我们|小黑屋|乐筑天下 繁体中文

GMT+8, 2025-7-4 00:19 , Processed in 2.054836 second(s), 59 queries .

© 2020-2025 乐筑天下

联系客服 关注微信 帮助中心 下载APP 返回顶部 返回列表