高考问答entourage韩剧百度云:天下真的没人会吗? 再问VB 里如何屏蔽flash控件右键
来源：百度文库 编辑：高考问答 时间：2024/05/01 12:51:52
请问高手们,VB里,如何用API截取flash的句柄,并彻底屏蔽了他的右键菜单?
我在Baidu搜索了好几个晚上,目前仅仅找到两个不成功的答案:
1.是把flash放在一个frame里,然后设置frame的Enabled为false
这样做确实可以屏蔽了flash右键,但是把flash内正常的交互效果全屏蔽了,所以不可取.
2.是有高手写了段代码,可以把整个工程的右键都屏蔽了,如果效果不错,倒也罢了,可惜我简单的测试了下就出现BUG,屏蔽后去右键窗口的标题栏,就导致死机,必须强行终止程序....
代码如下:
Sub EnableHook()
If hHook = 0 Then
hHook = SetWindowsHookEx(WH_MOUSE, AddressOf MouseHookProc, App.hInstance, 0)
End If
End Sub
Sub FreeHook()
Dim ret As Long
If hHook <> 0 Then
ret = UnhookWindowsHookEx(hHook)
hHook = 0
End If
End Sub
Function MouseHookProc(ByVal code As Long, ByVal wParam As Long, _
ByVal lParam As Long) As Long
If code < 0 Then
MouseHookProc = CallNextHookEx(hHook, code, wParam, lParam)
Exit Function
End If
If wParam = WM_RBUTTONDOWN Or wParam = WM_RBUTTONUP Then
MouseHookProc = 1 '表示不处理这个讯息
Exit Function
End If
'MouseHookProc = 0 '表示要处理这个讯息
Call CallNextHookEx(hHook, code, wParam, lParam)
End Function
请问高人们,,,谁能告诉我答案!!!!!!!!!!
.
谢谢三楼的朋友,我测试了一下
发现一个窗口里如果只有一个flash的话,还行,如果有两个以上,则只能屏蔽一个???
另外,如果flash放在了frame里,也不起作用了...
能不能帮我改改,只要是这个工程内的所有flash全都屏蔽了呢??
就是不能上传代码
我有一个完美的解决方案
就是屏蔽所有的右键
但是不会出现键窗口的标题栏任务拦死的现象
我发了
form1 的代码
........................................
Option Explicit
Private Sub Command1_Click()'开始屏蔽
EnableKBDHook
End Sub
Private Sub Command2_Click()' 解除屏蔽
UnHookKBD
End Sub
............................................
Module1.bas 的代码
Option Explicit
Public Const WH_CALLWNDPROC = 4
Public Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, ByVal lpvSource As Long, ByVal cbCopy As Long)
Public Const WH_MOUSE = 7
'鼠标消息
Public Const WM_MOUSEMOVE = &H200
Public Const WM_LBUTTONDOWN = &H201
Public Const WM_LBUTTONUP = &H202
Public Const WM_LBUTTONDBLCLK = &H203
Public Const WM_RBUTTONDOWN = &H204
Public Const WM_RBUTTONUP = &H205
Public Const WM_RBUTTONDBLCLK = &H206
Public Const WM_MBUTTONDOWN = &H207
Public Const WM_MBUTTONUP = &H208
Public Const WM_MBUTTONDBLCLK = &H209
Public Const WM_MOUSEACTIVATE = &H21
Public Const WM_MOUSEFIRST = &H200
Public Const WM_MOUSELAST = &H209
Public Const WM_MOUSEWHEEL = &H20A
Public Type MOUSEMSGS
X As Long
Y As Long
a As Long
b As Long
time As Long
End Type
Public Type POINTAPI
X As Long
Y As Long
End Type
Private Const MOUSEEVENTF_LEFTDOWN = &H2
Private Const MOUSEEVENTF_LEFTUP = &H4
Private Const MOUSEEVENTF_ABSOLUTE = &H8000
Public hHook As Long
Public Const HC_ACTION = 0
Public MouseMsg As MOUSEMSGS
Public Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" _
(ByVal idHook As Long, _
ByVal lpfn As Long, _
ByVal hmod As Long, _
ByVal dwThreadId As Long) As Long
Public Declare Function CallNextHookEx Lib "user32" _
(ByVal hHook As Long, _
ByVal ncode As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Public Declare Function UnhookWindowsHookEx Lib "user32" _
(ByVal hHook As Long) As Long
Public Function EnableKBDHook()
If hHook <> 0 Then
Exit Function
End If
hHook = SetWindowsHookEx(WH_MOUSE, AddressOf _
MyKBHFunc, App.hInstance, App.ThreadID)
End Function
Public Sub UnHookKBD()
UnhookWindowsHookEx hHook
hHook = 0
End Sub
Public Function MyKBHFunc(ByVal iCode As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Dim pt As POINTAPI
If iCode = HC_ACTION Then
CopyMemory MouseMsg, lParam, LenB(MouseMsg)
If wParam = WM_RBUTTONDOWN Then mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
MyKBHFunc = 1
End If
If wParam = WM_RBUTTONDOWN Then
mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
MyKBHFunc = 1
End If
End If
If iCode <> 0 Then
CallNextHookEx 0, iCode, wParam, lParam
End If
End Function
我现在也正在为编程的事学习呢
应该要用到API
不过代码太长了,头晕
死机了可以按Ctrl+Pause Break暂停 就不会造成损失了
告诉你一个好的学VB的网站 www.vbgood.com
Option Explicit
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Sub Form_Load()
Dim Handle As Long ' 窗口句柄
Dim ParentHandle As Long ' 父窗口句柄
ParentHandle = FindWindow("ThunderFormDC", "Form1") ' 获得父窗口句柄
Handle = FindWindowEx(ParentHandle, 0&, "MacromediaFlashPlayerActiveX", vbNullString) ' 获得窗口句柄
ret = SetWindowLong(Handle, GWL_WNDPROC, AddressOf WindowProc)
End Sub
' 标准模块
Option Explicit
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 SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private 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, ByVal lprc As Any) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Public Const GWL_WNDPROC = (-4)
Private Const TPM_LEFTALIGN = &H0&
Private Const WM_RBUTTONDOWN = &H204
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public ret As Long
' SetWindowLong 的回调函数, 利用 Msg 拦截消息
Function WindowProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If Msg = WM_RBUTTONDOWN Then
Dim pos As POINTAPI, hMenu As Long
GetCursorPos pos
hMenu = GetSubMenu(GetMenu(Form1.hwnd), 0)
TrackPopupMenu hMenu, TPM_LEFTALIGN, pos.x, pos.y, ByVal 0&, hwnd, ByVal 0&
Exit Function
End If
WindowProc = CallWindowProc(ret, hwnd, Msg, wParam, lParam)
End Function
用子类处理拦截，要加自定义菜单的话得先在窗体上用菜单编辑器做一个菜单或用API创建一个弹出式菜单，我帮你写了个代码。下面的代码得先用菜单编辑器在窗体上创建一个菜单。
powerbuilder
' 窗体模块
Option Explicit
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Sub Form_Load()
Dim Handle As Long ' 窗口句柄
Dim ParentHandle As Long ' 父窗口句柄
ParentHandle = FindWindow("ThunderFormDC", "Form1") ' 获得父窗口句柄
Handle = FindWindowEx(ParentHandle, 0&, "MacromediaFlashPlayerActiveX", vbNullString) ' 获得窗口句柄
ret = SetWindowLong(Handle, GWL_WNDPROC, AddressOf WindowProc)
End Sub
' 标准模块
Option Explicit
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 SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private 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, ByVal lprc As Any) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Public Const GWL_WNDPROC = (-4)
Private Const TPM_LEFTALIGN = &H0&
Private Const WM_RBUTTONDOWN = &H204
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public ret As Long
' SetWindowLong 的回调函数, 利用 Msg 拦截消息
Function WindowProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If Msg = WM_RBUTTONDOWN Then
Dim pos As POINTAPI, hMenu As Long
GetCursorPos pos
hMenu = GetSubMenu(GetMenu(Form1.hwnd), 0)
TrackPopupMenu hMenu, TPM_LEFTALIGN, pos.x, pos.y, ByVal 0&, hwnd, ByVal 0&
Exit Function
End If
WindowProc = CallWindowProc(ret, hwnd, Msg, wParam, lParam)
End Function
上面的代码我在Windows XP+VB6下调试通过。