play.frm

OpenPlayer代码

VERSION 5.00
Object = "{D27CDB6B-AE6D-11CF-96B8-444553540000}#1.0#0"; "SWFLASH.OCX"
Begin VB.Form Play 
   Appearance      =   0  'Flat
   BackColor       =   &H80000000&
   BorderStyle     =   0  'None
   Caption         =   "SuperPlayer播放区"
   ClientHeight    =   1785
   ClientLeft      =   4500
   ClientTop       =   2040
   ClientWidth     =   2580
   Icon            =   "Play.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   1785
   ScaleWidth      =   2580
   ShowInTaskbar   =   0   'False
   Begin ShockwaveFlashObjectsCtl.ShockwaveFlash ShockwaveFlash1 
      Height          =   375
      Left            =   360
      TabIndex        =   0
      Top             =   150
      Width           =   480
      _cx             =   4195151
      _cy             =   4194965
      Movie           =   ""
      Src             =   ""
      WMode           =   "Window"
      Play            =   -1  'True
      Loop            =   -1  'True
      Quality         =   "High"
      SAlign          =   ""
      Menu            =   -1  'True
      Base            =   ""
      Scale           =   "ShowAll"
      DeviceFont      =   0   'False
      EmbedMovie      =   0   'False
      BGColor         =   ""
      SWRemote        =   ""
   End
   Begin VB.Timer ResizeTimer 
      Interval        =   50
      Left            =   1380
      Top             =   780
   End
   Begin VB.Shape FlashBorder 
      BorderColor     =   &H00800000&
      Height          =   555
      Index           =   0
      Left            =   225
      Top             =   90
      Visible         =   0   'False
      Width           =   855
   End
   Begin VB.Shape FlashBorder 
      BorderColor     =   &H00FFFFFF&
      Height          =   675
      Index           =   1
      Left            =   60
      Top             =   30
      Visible         =   0   'False
      Width           =   1035
   End
   Begin VB.Shape FlashBorder 
      BorderColor     =   &H00800000&
      Height          =   765
      Index           =   2
      Left            =   0
      Top             =   0
      Visible         =   0   'False
      Width           =   1305
   End
End
Attribute VB_Name = "Play"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

'取得窗口位置的函数
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long

Const WM_SYSCOMMAND = &H112
Const SC_MOVE = &HF012
'窗口位置变量
Private Type RECT
   Left As Long
   Top As Long
   Right As Long
   Bottom As Long
End Type

Dim Mouse As POINTAPI
Dim MyMouse As POINTAPI
Dim MyRect As RECT



Dim Action As String                             '所要执行的动作变量，是移动还是改变大小及从哪个方向改变大小

Sub OpenFlash(fn As String)
Dim oFSO As New FileSystemObject
Dim oF As file
Dim tFN As FLASHNOTE
Dim i As Long
Dim LsIndex As Long

    '请参考getFlashHeader(fn) 函数
    FH = getFlashHeader(fn)
    If FH.intIsFlashMovie = -1 Then
        MsgBox "找不到文件   " & vbCrLf & fn, vbOKOnly + vbCritical, "小鱼儿工作室"
        If ShockwaveFlash1.Movie = "" Then
            Me.Visible = False
        End If
        Exit Sub
    End If
   
    If FH.intIsFlashMovie = 0 Then
        MsgBox "文件不是Flash Movie 格式！      ", vbOKOnly + vbCritical, "小鱼儿工作室"
        If ShockwaveFlash1.Movie = "" Then
            Me.Visible = False
        End If
        Exit Sub
    End If
   
    If FH.intIsFlashMovie = 2 Then
        MsgBox "未知错误！  ", vbOKOnly + vbCritical, "小鱼儿工作室"
        If ShockwaveFlash1.Movie = "" Then
            Me.Visible = False
        End If
        Exit Sub
    End If
    
    '有一些动画隐藏了鼠标,ShowMouse.spf 是一个显示鼠标的文件,这样做是为了显示鼠标.
    ShockwaveFlash1.Movie = App.Path & IIf(Len(App.Path) >= 4, "\ShowMouse.spf", "ShowMouse.spf")
    
    ShockwaveFlash1.Play
    ControlForm.SpeedTimer.Enabled = False
   
    '当窗口最小化时，不能调整大小
    Me.WindowState = 0
   
    SetWindowPos Me.hwnd, -1, 0, 0, 0, 0, 3   '设置总在最前面,好像有一个API可以实现使一个窗口置于所有窗口之前,但不是"总在最前面",我还没有弄懂
    SetWindowPos Me.hwnd, -2, 0, 0, 0, 0, 3   '取消
  
  
   
    With ShockwaveFlash1
        .Visible = True
        .BackgroundColor = RGB(FH.bColorB, FH.bColorG, FH.bColorR)      '设置背景色
        .Movie = fn                                                     '动画的路径
        .Play                                                           '播放
    End With
   
    With Me
        .Visible = True
        .WindowState = 0
        .Height = FH.lMHeight * 15 + 120                                '设置窗口大小
        .Width = FH.lMWidth * 15 + 120
        .Top = (Screen.Height - .Height) / 3                            '位置
        If .Width < ControlForm.Left Then
           Me.Left = (ControlForm.Left - Me.Width) / 2
        Else
           Me.Left = 15
        End If
    End With
   

   '查找重复的项
   LsIndex = SendMessage(ControlForm.ComboAddr.hwnd, CB_FINDSTRING, -1, ByVal fn)
   If LsIndex = -1 Then
        ControlForm.ComboAddr.AddItem fn, 0
   End If
   ControlForm.ComboAddr.Text = fn
   
   LsIndex = SendMessage(ControlForm.List(1).hwnd, LB_FINDSTRING, -1, ByVal fn)
   If LsIndex = -1 Then
        ControlForm.List(0).AddItem ("[" & ControlForm.List(0).ListCount + 1 & "]" & getBaseName(fn))
        ControlForm.List(1).AddItem fn
   End If
  
    '菜单
    ControlForm.speed.Caption = "速度:" & FH.intMRate & "帧/秒"
    ControlForm.total.Caption = "共：" & FH.intMTotalFrames & "帧"
      
    '作者和作品名
    tFN = getNote(fn)
    ControlForm.MovieLabel.Caption = tFN.strMovieName
    ControlForm.MovieLabel.ToolTipText = tFN.strMovieName
    ControlForm.AuthorLabel.Caption = "作者：" & tFN.strAuthor
    ControlForm.AuthorLabel.ToolTipText = "作者：" & tFN.strAuthor
       
    '设置播放窗口的标题
    Me.Caption = "OpenPlayer播放区—" & tFN.strMovieName & "(" & fn & ")"
       
    '全局的总帧数,Swflash.ocx 中的ShockwaveFlash1.TotalFrames 在一些版本中不能用
    TotalFrames = FH.intMTotalFrames
    
    Th = Hour(Time())
    Tm = Minute(Time())
    Ts = Second(Time())
    
    '属性
    ControlForm.PropertiyLabel(0).Caption = "文件名 ：" & Right(fn, Len(fn) - InStrRev(fn, "\"))
    ControlForm.PropertiyLabel(1).Caption = "大    小：" & FormatNumber(FH.lMSize, 0) & "字节"
    ControlForm.PropertiyLabel(2).Caption = "版    本：Flash " & FH.bMVersion
    ControlForm.PropertiyLabel(3).Caption = "完成日期：" & FormatDateTime(FileDateTime(fn), vbLongDate) & FormatDateTime(FileDateTime(fn), vbLongTime)
    ControlForm.PropertiyLabel(4).Caption = "帧    数：" & FormatNumber(FH.intMTotalFrames, 0) & "帧"
    ControlForm.PropertiyLabel(5).Caption = "速    度：" & FH.intMRate & "帧/秒"
    ControlForm.PropertiyLabel(6).Caption = "高 × 宽：" & FH.lMHeight & " × " & FH.lMWidth & " 像素"
    ControlForm.PropertiyLabel(7).Caption = "估计时间：" & FormatNumber(FH.intMTotalFrames / FH.intMRate, 2) & "秒"
      
   
    
    Set oFSO = Nothing
   
End Sub

Sub FixWindows()
    '调整控件在窗口中的大小
    ShockwaveFlash1.Height = Me.Height - 120
    ShockwaveFlash1.Width = Me.Width - 120
End Sub

Sub DrawBorder()
'画边框
    FlashBorder(0).Top = 15
    FlashBorder(0).Left = 15
    FlashBorder(0).Height = Me.Height - 30
    FlashBorder(0).Width = Me.Width - 30
    FlashBorder(0).Visible = True
    FlashBorder(1).Top = 30
    FlashBorder(1).Left = 30
    FlashBorder(1).Height = Me.Height - 60
    FlashBorder(1).Width = Me.Width - 60
    FlashBorder(1).Visible = True
    FlashBorder(2).Top = 45
    FlashBorder(2).Left = 45
    FlashBorder(2).Height = Me.Height - 90
    FlashBorder(2).Width = Me.Width - 90
    FlashBorder(2).Visible = True
End Sub


Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
   '与Form_MouseMove结合,通过鼠标调整窗口的大小
   '按下鼠标左键
    If Button = vbLeftButton Then
        '为当前的应用程序释放鼠标捕获
        ReleaseCapture
        Select Case Action
               Case "Left"
                    SendMessage Me.hwnd, WM_SYSCOMMAND, &HF001, 0
               Case "Right"
                    SendMessage Me.hwnd, WM_SYSCOMMAND, &HF002, 0
               Case "Up"
                    SendMessage Me.hwnd, WM_SYSCOMMAND, &HF003, 0
               Case "LeftUp"
                    SendMessage Me.hwnd, WM_SYSCOMMAND, &HF004, 0
               Case "RightUp"
                    SendMessage Me.hwnd, WM_SYSCOMMAND, &HF005, 0
               Case "Down"
                    SendMessage Me.hwnd, WM_SYSCOMMAND, &HF006, 0
               Case "LeftDown"
                    SendMessage Me.hwnd, WM_SYSCOMMAND, &HF007, 0
               Case "RightDown"
                    SendMessage Me.hwnd, WM_SYSCOMMAND, &HF008, 0
               Case "Move"
                    ReleaseCapture
                    SendMessage hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
        End Select
        
        If Me.Width < 200 Then Me.Width = 200
        If Me.Height < 200 Then Me.Height = 200
        ShockwaveFlash1.Width = Me.Width - 120
        ShockwaveFlash1.Height = Me.Height - 120
        Call DrawBorder
    End If


End Sub

Private Sub Form_Resize()
    FixWindows                              '调整窗口的大小
    DrawBorder                              '画边框
End Sub



Private Sub ResizeTimer_Timer()

Dim MyPoint As POINTAPI

    ' MyRect返回当前窗口位置
    Call GetWindowRect(Me.hwnd, MyRect)
    
    ' MyPoint返回当前鼠标位置
    Call GetCursorPos(MyPoint)
    
    If WindowFromPoint(MyPoint.X, MyPoint.Y) = Me.hwnd Then
        Select Case True
              '鼠标位于窗口左上方
             Case MyPoint.X < MyRect.Left + 5 And MyPoint.Y < MyRect.Top + 5
                  Screen.MousePointer = vbSizeNWSE
                  Action = "LeftUp"
             '鼠标位于窗口右下方
             Case MyPoint.X > MyRect.Right - 5 And MyPoint.Y > MyRect.Bottom - 5
                  Screen.MousePointer = vbSizeNWSE
                  Action = "RightDown"
             '鼠标位于窗口右上方
             Case MyPoint.X > MyRect.Right - 5 And MyPoint.Y < MyRect.Top + 5
             '45度双向鼠标指针
                  Screen.MousePointer = vbSizeNESW
                  Action = "RightUp"
             '鼠标位于窗口左下方
             Case MyPoint.X < MyRect.Left + 5 And MyPoint.Y > MyRect.Bottom - 5
                  Screen.MousePointer = vbSizeNESW
                  Action = "LeftDown"
             '鼠标位于窗口左边
             Case MyPoint.X < MyRect.Left + 5
                  Screen.MousePointer = vbSizeWE
                  Action = "Left"
             '鼠标位于窗口右边
             Case MyPoint.X > MyRect.Right - 5
                  Screen.MousePointer = vbSizeWE
                  Action = "Right"
             '鼠标位于窗口上方
             Case MyPoint.Y < MyRect.Top + 5
             '垂直双向鼠标指针
                  Screen.MousePointer = vbSizeNS
                  Action = "Up"
             '鼠标位于窗口下方
             Case MyPoint.Y > MyRect.Bottom - 5
                  Screen.MousePointer = vbSizeNS
                  Action = "Down"
             '鼠标位于窗口其他位置
             Case Else
             '默认鼠标指针
                  Action = "Move"
                  Screen.MousePointer = 0
        End Select
    Else
        Action = "Move"
        Screen.MousePointer = 0
    End If

End Sub


Private Sub Form_Load()
    Dim ret As Long
    
    ShockwaveFlash1.Top = 60
    ShockwaveFlash1.Left = 60
    ret = EnumChildWindows(Me.hwnd, AddressOf EnumChildProc, ByVal 0&)

    Call DrawBorder
    Call FixWindows
End Sub

Private Sub ShockwaveFlash1_FSCommand(ByVal command As String, ByVal args As String)
Dim isExec As Integer
Dim oFSO As New FileSystemObject
    Select Case UCase(command)
   
       '======================================
       '全屏显示
       'FSCommand 用法：
       'fscommand ("fullscreen","true/false")
       '======================================
         Case UCase("FullScreen")  '全屏显示
             If UCase(args) = UCase("False") Or args = "0" Then
                  isFullScreen = True
                  Call ControlForm.doFullScreen
             Else
                  isFullScreen = False
                  Call ControlForm.doFullScreen
             End If
       '======================================
       '退出当前电影
       'FSCommand 用法：
       'fscommand ("Quit")
       '======================================
        Case UCase("quit")
            ShockwaveFlash1.Movie = ""
            Unload Me
         '=====================================
         '执行程序：
         'FSCommand 用法：
         'fscommand ("exec",FileName)
         '
         '=====================================
        Case UCase("exec")
        On Error Resume Next
             If MsgBox("电影要求执行程序：" & vbCrLf & vbCrLf & args & vbCrLf & vbCrLf & "是否执行？", vbYesNo + vbInformation, "FSCommand") = vbYes Then
                If oFSO.FileExists(args) = False Then
                   MsgBox vbCrLf & "          找不到程序：     " & vbCrLf & "        " & args, vbOKOnly + vbCritical, "找不到程序..."
                Else
                   Shell args, vbNormalFocus
                End If
                End If
         '=====================================
         '总在最前面
         'FSCommand 用法：
         'fscommand ("onTop","true/false")
         '=====================================
        Case UCase("onTop")
            If UCase(args) = UCase("False") Or args = "0" Then
                SetWindowPos Play.hwnd, -2, 0, 0, 0, 0, 3   '取消
                ControlForm.onTop.Checked = False
             Else
                SetWindowPos Play.hwnd, -1, 0, 0, 0, 0, 3   '设置
                ControlForm.onTop.Checked = True
             End If
        
  End Select
 Set oFSO = Nothing
End Sub