module1.bas

OpenPlayer代码

Attribute VB_Name = "Module1"
Option Explicit
   '结束进程
Public Declare Function TerminateProcess Lib "Kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Public Declare Function GetCurrentThreadId Lib "Kernel32" () As Long
'TerminateProcess GetCurrentProcessId ,0

'==============================
'设置窗体总在最前面用到
' SetWindowPos Me.hwnd, -1, 0, 0, 0, 0, 3   '设置
' SetWindowPos Me.hwnd, -2, 0, 0, 0, 0, 3   '取消
'==============================
Public 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

'==============================
'移动窗体
'ReleaseCapture
'SendMessage hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
'==============================
Public Declare Function ReleaseCapture Lib "user32" () As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Const HTCAPTION = 2
Public Const WM_NCLBUTTONDOWN = &HA1

'=============================
'shell 打开
'=============================
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long

'以下为创建无边框窗体
Public Type RECT
   Left As Long
   Top As Long
   Right As Long
   Bottom As Long
End Type
Public Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Public Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Public Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As POINTAPI, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long
Public Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Public Declare Function ScreenToClient Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long


'==============================
'取得鼠标的当前位置
'及取得鼠标当前位置下窗体名柄
'getcursorpos(mouse)
'==============================
Public Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Public Type POINTAPI
   X As Long
   Y As Long
End Type



'==============================
'查找父、子窗口的名柄
'==============================
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public 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

Public Declare Function EnumChildWindows Lib "user32" (ByVal hWndParent As Long, ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long


'==============================
'HOOK 钩！
'回调函数
'==============================
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
'Public Const GWL_WNDPROC = -4


'Public Const WM_RBUTTONUP = 516   'Flash右键菜单常数
'Public Const WM_CLICK = 514       'Flash单击
'Public Const WM_LBUTTONDOWN = &H201

Public Const WM_USER = &H400
Public Const WM_LBUTTONUP = &H202
Public Const WM_MBUTTONUP = &H208
Public Const WM_RBUTTONUP = &H205
Public Const TRAY_CALLBACK = (WM_USER + 1001&)
Public Const GWL_WNDPROC = (-4)
Public Const GWL_USERDATA = (-21)

Global Zoom As Integer
Global isFullScreen As Boolean
Global netWidth, netHeight As Long
Global Filename As String
Global isHOOK As Boolean

'=================================
'SWF文件头部信息
'=================================
Global colorR As Byte, colorB As Byte, colorG As Byte, MFPS As Byte
Global MWidth As Integer, MHeight As Integer, MTotalFrames As Integer
Global fso As New FileSystemObject
Global hFlashhwnd1 As Long
Global typeFLASHNOTE As FLASHNOTE
Global bEXE As Boolean


Public lpPrevWndProc As Long
Public lngHWnd As Long
'=============================================
'以下为ShockWaveFlash钩子
'=============================================
Public Sub Hook(hWnd As Long)
    lngHWnd = hWnd
    lpPrevWndProc = SetWindowLong(lngHWnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub

'钩 子 函 数 撤 消：

Public Sub UnHook()
    Dim lngReturnValue As Long
    lngReturnValue = SetWindowLong(lngHWnd, GWL_WNDPROC, lpPrevWndProc)
End Sub

Function WindowProc(ByVal hw As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

    Select Case uMsg
    ' 检 测 鼠 标 击 键 消 息， 如 果 是 单 击 右 键
        Case 516  '右键
           Popupme
        Case 123  '键盘菜单键
           Popupme
        Case 513 'LeftMouseDown
             If (Zoom = 0 And (Not isFullScreen)) And Form2.MEnabelMove.Checked Then
               ReleaseCapture
               SendMessage Form1.hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
             End If
             WindowProc = CallWindowProc(lpPrevWndProc, hw, uMsg, wParam, lParam)
        Case 522                    '滑轮调整播放窗口的大小,滑轮滚动 wParam大于0为下，小于0为向上
            If Form1.ShockwaveFlash1.Movie <> "" Then
                If wParam < 0 And (Form1.Width < (Screen.Width - 500) And Form1.Height < (Screen.Height - 500)) Then
                    Form1.Height = Form1.Height + 500
                    Form1.Width = Form1.Width + 500
                Else
                    If Form1.Width > 700 And Form1.Height > 700 Then
                        Form1.Height = Form1.Height - 500
                        Form1.Width = Form1.Width - 500
                    End If
               End If
            End If
        Case Else
             WindowProc = CallWindowProc(lpPrevWndProc, hw, uMsg, wParam, lParam)
    End Select
End Function

'================================
'弹出自定义菜单
'================================

Function Popupme()
    Dim OPEXE As String
    
    OPEXE = App.Path & IIf(Len(App.Path) < 4, "OpenPlayer.exe", "\OpenPlayer.exe")
     '================================
     '初始化菜单
     '================================
    If fso.FileExists(OPEXE) Then
        Form2.SuperPlayer.Enabled = True
    Else
        Form2.SuperPlayer.Enabled = False
    End If
      '初始化[放大]
     If Zoom > 6 Then
        Form2.ZoomIn.Enabled = False
     Else
        Form2.ZoomIn.Enabled = True
     End If
     '初始化[缩小]
     If Zoom = 0 Then
         Form2.ZoomOut.Enabled = False
     Else
         Form2.ZoomOut.Enabled = True
     End If
      '初始化[全屏]
     If isFullScreen = True Then
        'Form2.FullScreen.Caption = "返回(&R)"
        Form2.FullScreen.Checked = True
     Else
        'Form2.FullScreen.Caption = "全屏(&F)"
        Form2.FullScreen.Checked = False
     End If
     If CLng(MTotalFrames) < 2 Then
        Form2.Ctrl.Visible = False
        Form2.s7.Visible = False
        Form2.MEnabelMove1.Visible = True
     Else
        Form2.Ctrl.Visible = True
        Form2.s7.Visible = True
        Form2.MEnabelMove1.Visible = False
     End If
     If bEXE Then
        Form2.CreateSwf.Visible = True
     Else
        Form2.CreateSwf.Visible = False
     End If
           
     '初始化[循环]
     If Form1.ShockwaveFlash1.Loop = True Then
        Form2.Loop1.Checked = True
     Else
        Form2.Loop1.Checked = False
     End If
     '初始化[播放]
     If Form1.ShockwaveFlash1.Playing = True Then
      Form2.play.Caption = "停止(&S)"
     Else
       Form2.play.Caption = "播放(&S)"
     End If
     
     Form1.PopupMenu Form2.popup '弹出菜单

End Function



'建立错误文件报告
Public Sub CreateErrorReport(FunctionName)
    Dim logFile As String
    Dim lfnNum As Long
    logFile = App.Path & IIf(Len(App.Path) > 4, "\OpenPlayer.log", "OpenPlayer.log")
    lfnNum = FreeFile
    Open logFile For Append As #lfnNum
        Print #lfnNum, Date & FunctionName & " 发生错误： " & vbCrLf & vbTab & Err.Number & Err.Description
        Err.Clear
    Close #lfnNum
End Sub

'=======================================================
'        以下两个由：
'        制作：王鑫
'        MSN：[e-mail]
'        制作，非常感谢王鑫
'    由于我学VB不久，基础不好，用的方法太笨了
'    我以后一定要学好基础
'=======================================================

Public Function EnumChildProc(ByVal hWnd As Long, _
                                        ByVal lParam As Long) As Long
                                    
    '这个回调函数通过过滤所有的子窗口的类名，来判断是不是 Flash 控件，
    '如果 Form 里的控件（子窗口）太多的话一定会影响启动速度的。我发现
    '这个函数是从 TabIndex 最大的控件开始过滤的，也就是说，如果在设计
    '窗体界面的时候最后才放置 Flash 控件的话，你就会第一个找到它的句柄
    '了。而且 Flash 控件的类名会随着它的版本的不同而不同，所以我就用了
    '一个 Like 语句。
  
    'If GetClsName(hwnd) = "ATL:100536D0" Then
    'If GetClsName(hwnd) = "ATL:582236D0" Then
    Dim hFlash As String
    hFlash = GetClsName(hWnd)
    If (hFlash Like "ATL:????????") Or (hFlash = "MacromediaFlashPlayerActiveX") Then
        hFlashhwnd1 = hWnd
        Hook hFlashhwnd1
        EnumChildProc = 0
    Else
        EnumChildProc = 1
    End If
End Function
Public Function GetClsName(ByVal hWnd As Long) As String
    Dim xLen As Long
    Dim sBuffer As String
    sBuffer = String(255, 0)
    xLen = GetClassName(hWnd, sBuffer, 255)
    If xLen = 0 Then
        GetClsName = ""
    Else
        GetClsName = Left(sBuffer, xLen)
    End If
End Function