无标题flash覆盖的窗体怎么移动

2012-12-19

无标题flash覆盖的窗体如何移动我有一个无标题VB窗体，里面放置一个一样大小的webbrowser控件。窗体启动后加

无标题flash覆盖的窗体如何移动
我有一个无标题VB窗体，里面放置一个一样大小的webbrowser控件。窗体启动后加载falsh动画。请问：这个窗体如何移动？请给出VB代码。
[最优解释]
只要在FLASH控件上拦截到鼠标按下消息,再捕捉鼠标就可以了.

'窗体上添加一个WebBrowser1.
'工程里添加一个子类化类模块,下载地址:http://blog.m5home.com/article.asp?id=370
Option Explicit

Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Long) As Long
Private Declare Function FindWindowEx Lib "user32.dll" Alias "FindWindowExA" ( _
     ByVal hwndParent As Long, _
     ByVal hwndChildAfter As Long, _
     ByVal lpszClass As String, _
     ByVal lpszWindow As String) As Long
Private Declare Sub Sleep Lib "kernel32.dll" ( _
     ByVal dwMilliseconds As Long)

Private Const HTCAPTION = 2&
Private Const WM_NCLBUTTONDOWN As Long = &HA1&
Private Const WM_LBUTTONDOWN As Long = &H201

Private Const IEClass1 As String = "Shell Embedding"
Private Const IEClass2 As String = "Shell DocObject View"
Private Const IEClass3 As String = "Internet Explorer_Server"
Private Const FlashClass As String = "MacromediaFlashPlayerActiveX"

Dim WithEvents oSC As cSubclass

Private Sub Form_Load()
    Dim FlashhWnd As Long

    WebBrowser1.Navigate "http://comic.qq.com/flash/2005/20050924aichu.swf"
    Me.Show

    Do
        DoEvents
        Sleep 100
        FlashhWnd = GetFlashhWnd
        If FlashhWnd <> 0 Then Exit Do
    Loop

    Set oSC = New cSubclass

    oSC.SetMsgHook FlashhWnd
End Sub

Private Function GetFlashhWnd() As Long
    '取WebBrewser控件中FLASH实例的句柄
    Dim lRet As Long, sL As Long

    lRet = FindWindowEx(Me.hWnd, ByVal 0&, IEClass1, vbNullString)
    lRet = FindWindowEx(lRet, ByVal 0&, IEClass2, vbNullString)
    lRet = FindWindowEx(lRet, ByVal 0&, IEClass3, vbNullString)
    GetFlashhWnd = FindWindowEx(lRet, ByVal 0&, FlashClass, vbNullString)
End Function

Private Sub Form_Unload(Cancel As Integer)
    oSC.SetMsgUnHook
    Set oSC = Nothing
End Sub

Private Sub oSC_GetWindowMessage(Result As Long, ByVal cHwnd As Long, ByVal Message As Long, ByVal wParam As Long, ByVal lParam As Long)
    If Message = WM_LBUTTONDOWN Then
        Call ReleaseCapture
        SendMessage Me.hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
    End If

    Result = oSC.CallDefaultWindowProc(cHwnd, Message, wParam, lParam)
End Sub

[其他解释]


Option Explicit
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
Private Sub Form_Load()
    Timer1.Interval = 500
    Timer1.Enabled = True
End Sub
'将代码放置到Timer中只是为了举例说明方法，实际使用中请考虑合适的地方添加以下代码
Private Sub Timer1_Timer()
    Dim lngP As Long
    lngP = GetForegroundWindow
    If lngP <> Me.hwnd Then lngP = MoveWindow(lngP, 100 * Rnd, 200 * Rnd, 100, 200, True)
End Sub

[其他解释]
我的要求是能用鼠标移动这个无标题窗体。
[其他解释]
看看这个：


Option Explicit
Private Const HWND_TOPMOST = -1
Private Const SWP_NOSIZE = &H1
Private Const WM_SYSCOMMAND = &H112&
Private Const SC_MOVE = &HF012&
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = vbLeftButton Then
        '为当前的应用程序释放鼠标捕获
        ReleaseCapture
        '移动窗体
        SendMessage Me.hwnd, WM_SYSCOMMAND, SC_MOVE, 0
    End If
End Sub

[其他解释]

他这个问题主要在于,鼠标只能点到那个FLASH控件.

那么点窗体移动的代码肯定是不行的,因为窗体完全在WEBBROWSER控件下面,而最上层还是一个FLASH控件.

所以只能拦截鼠标能点到的对象的鼠标消息.
[其他解释]
全局鼠标钩子，拦截左键点下消息，然后判断自己的窗口是不是激活状态，并且坐标是不是在窗口范畴催
[其他解释]
老马的可以，但调试退出时，报错1了。
[其他解释]

引用:

老马的可以，但调试退出时，报错1了。

哈哈,我这只是个简单的思路实现,没考虑多的问题.

反正思路是OK的,实现是他自己的事啦!
[其他解释]
子类化就是了。
[其他解释]
原来我实现了右击弹出退出菜单，在大家的启发下，增加了左键按下移动窗体。请大家比较一下，哪种方法好。
Option Explicit

Private Declare Function EnumChildWindows Lib "user32" (ByVal hWndParent As Long, ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private 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
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetTickCount Lib "kernel32" () As Long
'=================================
Private Const GWL_WNDPROC = (-4)      '为窗口过程设置新地址

Private Const WM_KEYDOWN As Long = &H100
Private Const WM_RBUTTONDBLCLK As Long = &H206
Private Const WM_RBUTTONDOWN As Long = &H204
Private Const WM_RBUTTONUP As Long = &H205
Private Const WM_LBUTTONDOWN As Long = &H201

Private FHW As Long
Private glPrevWndProc As Long

'禁止右键菜单
Private Function EnumChildProc(ByVal lhWnd As Long, ByVal lParam As Long) As Long
  Dim RetVal As Long, Pos As Integer
  Dim WinClassBuf As String * 255
  Dim WinClass As String

  On Error Resume Next
  RetVal = GetClassName(lhWnd, WinClassBuf, 255)
  Pos = InStr(WinClassBuf, Chr(0))
  If Pos > 0 Then
      WinClass = Left(WinClassBuf, Pos - 1)
  End If

  If WinClass = "MacromediaFlashPlayerActiveX" Then
     FHW = lhWnd
     EnumChildProc = False
  ElseIf Left(WinClass, 4) = "ATL:" Then
      FHW = lhWnd
      EnumChildProc = False

  Else
      EnumChildProc = True
  End If
  If Err.Number <> 0 Then Err.Clear
End Function

Private Sub UnSubClass()
  If FHW <> 0 And glPrevWndProc <> 0 Then
    Call SetWindowLong(FHW, GWL_WNDPROC, glPrevWndProc)
    FHW = 0
  End If
End Sub

Private Function MyWindowProc(ByVal HW As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  Select Case uMsg
    Case WM_RBUTTONDOWN
      '// "鼠标右键按下"
      Exit Function
    Case WM_RBUTTONUP
      '"鼠标右键抬起"
      Form1.PopupMenu Form1.m_munu
      Exit Function
    Case WM_LBUTTONDOWN
      Form1.moveForm
       '// "按键按下"
  End Select
  MyWindowProc = CallWindowProc(glPrevWndProc, HW, uMsg, wParam, lParam)
End Function

Private Function SubClass() As Long
  SubClass = SetWindowLong(FHW, GWL_WNDPROC, AddressOf MyWindowProc)
End Function

Public Sub RemoveMenu(ByVal Wnd As Long)
  Dim lRet As Long, lParam As Long

  Call UnSubClass
  lRet = EnumChildWindows(Wnd, AddressOf EnumChildProc, lParam)
  If FHW <> 0 Then
     glPrevWndProc = SubClass()
  End If
End Sub

Public Sub StopRemoveMenu()
  Call UnSubClass
End Sub
[其他解释]
窗体1中代码
Option Explicit

Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Long) As Long
Private Const HTCAPTION = 2&
Private Const WM_NCLBUTTONDOWN As Long = &HA1&
Private Const WM_LBUTTONDOWN As Long = &H201

Public Sub moveForm()
  Call ReleaseCapture
  SendMessage Me.hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
End Sub

Private Sub Form_Load()
  WBFlash.Navigate "about:blank"
  DoEvents
  WBFlash.Navigate App.Path & "\黄金矿工.swf"

End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
  StopRemoveMenu
End Sub

Private Sub m_quit_Click()
  Unload Me
End Sub

Private Sub Timer1_Timer()
RemoveMenu (Me.hWnd)
Timer1.Enabled = False
End Sub

[其他解释]
在模块中调用窗体，感觉很不爽，如何修改和封装？

热点排行