MCI播放器在VB中实现

'用MCI命令来实现多媒体的播放功能
'下面的内容几乎有播放器软件的各种功能，你只是引用这些函数就能做出一个播放器来
'

Public Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long

Public Declare Function mciGetDeviceID Lib "winmm.dll" Alias "mciGetDeviceIDA" (ByVal lpstrName As String) As Long

Public Declare Function waveOutGetVolume Lib "winmm.dll" (ByVal uDeviceID As Long, lpdwVolume As Long) As Long

Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex 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 SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Public Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long

Enum PlayTypeName
    File = 1
    CDAudio = 2
    VCD = 3
    RealPlay = 4
End Enum
Dim PlayType As PlayTypeName
Enum AudioSource
    AudioStereo = 0 ' "stereo"
    AudioLeft = 1 '"left"
    AudioRight = 2 '"right"
End Enum
Dim hWndMusic As Long
Dim prevWndproc As Long

'=======================================================
'打开MCI设备，urlStr为网址,传值代表成功与否
'=======================================================
Public Function OpenURL(urlStr As String, Optional hwnd As Long) As Boolean
    OpenMusic = False
    Dim MciCommand As String
    Dim DriverID As String
   
    CloseMusic
     'MCI命令
    DriverID = GetDriverID(urlStr)
    If DriverID = "RealPlayer" Then
        PlayType = RealPlay
        Exit Function
    End If
    MciCommand = "open " & urlStr & " type " & DriverID & " alias NOWMUSIC"
   

    If DriverID = "AVIVideo" Or DriverID = "MPEGVideo" Or DriverID = "MPEGVideo2" Then
        If hwnd <> 0 Then
            MciCommand = MciCommand + " parent " & hwnd & " style child"
            hWndMusic = GetWindowHandle
            prevWndproc = GetWindowLong(hWndMusic, -4)
            SetWindowLong hWndMusic, -4, AddressOf WndProc
           
        Else
            MciCommand = MciCommand + " style overlapped "
        End If
    End If
   
    RefInt = mciSendString(MciCommand, vbNull, 0, 0)
    mciSendString "set NOWMUSIC time format milliseconds", vbNullString, 0, 0
    If RefInt = 0 Then OpenMusic = True

End Function
'=======================================================
'打开MCI设备，FILENAME为文件名,传值代表成功与否
'=======================================================
Public Function OpenMusic(FileName As String, Optional hwnd As Long) As Boolean
    OpenMusic = False
    Dim ShortPathName As String * 255
    Dim RefShortName As String
    Dim RefInt As Long
    Dim MciCommand As String
    Dim DriverID As String
   
    CloseMusic
    '获取短文件名
    GetShortPathName FileName, ShortPathName, 255
    RefShortName = Left(ShortPathName, InStr(1, ShortPathName, Chr(0)) - 1)
    'MCI命令
    DriverID = GetDriverID(RefShortName)
    If DriverID = "RealPlayer" Then
        PlayType = RealPlay
        Exit Function
    End If
    MciCommand = "open " & RefShortName & " type " & DriverID & " alias NOWMUSIC"
   

    If DriverID = "AVIVideo" Or DriverID = "MPEGVideo" Or DriverID = "MPEGVideo2" Then
        If hwnd <> 0 Then
            MciCommand = MciCommand + " parent " & hwnd & " style child"
            hWndMusic = GetWindowHandle
            prevWndproc = GetWindowLong(hWndMusic, -4)
            SetWindowLong hWndMusic, -4, AddressOf WndProc
           
        Else
            MciCommand = MciCommand + " style overlapped "
        End If
    End If
   
    RefInt = mciSendString(MciCommand, vbNull, 0, 0)
    mciSendString "set NOWMUSIC time format milliseconds", vbNullString, 0, 0
    If RefInt = 0 Then OpenMusic = True

End Function
Function WndProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    If Msg = &H202 Then
    MsgBox "OK"
    End If
    WndProc = CallWindowProc(prevWndproc, hwnd, Msg, wParam, lParam)
End Function
'=======================================================
'根据文件名，确定设备
'=======================================================
Public Function GetDriverID(ff As String) As String
    Select Case UCase(Right(ff, 3))
     Case "MID", "RMI", "IDI"
        GetDriverID = "Sequencer"
     Case "WAV"
        GetDriverID = "Waveaudio"
     Case "ASF", "ASX", "IVF", "LSF", "LSX", "P2V", "WAX", "WVX", ".WM", "WMA", "WMX", "WMP"
        GetDriverID = "MPEGVideo2"
     Case ".RM", "RAM", ".RA"
        GetDriverID = "RealPlayer"
     Case Else
        GetDriverID = "MPEGVideo"
     End Select
End Function

'======================================================
'播放文件
'======================================================
Public Function PlayMusic() As Boolean
    Dim RefInt As Long
    PlayMusic = False
    RefInt = mciSendString("play NOWMUSIC", vbNull, 0, 0)
    If RefInt = 0 Then PlayMusic = True
End Function

'======================================================
'获取媒体的长度
'======================================================
Public Function GetMusicLength() As Long
    Dim RefStr As String * 80
    mciSendString "status NOWMUSIC length", RefStr, 80, 0
    GetMusicLength = Val(RefStr)
End Function

'======================================================
'获取当前播放进度
'======================================================
Public Function GetMusicPos() As Long
    Dim RefStr As String * 80
    mciSendString "status NOWMUSIC position", RefStr, 80, 0
    GetMusicPos = Val(RefStr)
End Function

'======================================================
'获取媒体的当前进度
'======================================================
Public Function SetMusicPos(Position As Long) As Boolean
    Dim RefInt As Long
    SetMusicPos = False
    RefInt = mciSendString("seek NOWMUSIC to " & Position, vbNull, 0, 0)
    If RefInt = 0 Then SetMusicPos = True
End Function

'======================================================
'暂停播放
'======================================================
Public Function PauseMusic() As Boolean
    Dim RefInt As Long
    PauseMusic = False
    RefInt = mciSendString("pause NOWMUSIC", vbNull, 0, 0)
    If RefInt = 0 Then PauseMusic = True
End Function
'======================================================
'关闭媒体
'======================================================
Public Function CloseMusic() As Boolean
    Dim RefInt As Long
    CloseMusic = False
    RefInt = mciSendString("close NOWMUSIC", vbNull, 0, 0)
    If RefInt = 0 Then CloseMusic = True
End Function
'======================================================
'设置声道
'======================================================
Public Function SetAudioSource(sAudioSource As AudioSource) As Boolean
    Dim RefInt As Long
    Dim strSource As String
    Select Case sAudioSource
        Case 1: strSource = "left"
        Case 2: strSource = "right"
        Case 0: strSource = "stereo"
    End Select
    SetAudioSource = False
    RefInt = mciSendString("setaudio  NOWMUSIC source to " & strSource, vbNull, 0, 0)
    If RefInt = 0 Then SetAudioSource = True
End Function

'======================================================
'全屏播放
'======================================================
Public Function PlayFullScreen() As Boolean
    Dim RefInt As Long
    PlayFullScreen = False
    RefInt = mciSendString("play NOWMUSIC fullscreen", vbNull, 0, 0)
    If RefInt = 0 Then PlayFullScreen = True
End Function

'=====================================================
'设置声音大小
'=====================================================
Public Function SetVolume(Volume As Long) As Boolean
    Dim RefInt As Long
    SetVolume = False
    RefInt = mciSendString("setaudio NOWMUSIC volume to " & Volume, vbNull, 0, 0)
    If RefInt = 0 Then SetVolume = True
End Function

'=====================================================
'设置播放速度
'=====================================================
Public Function SetSpeed(Speed As Long) As Boolean
    Dim RefInt As Long
    SetSpeed = False
    RefInt = mciSendString("set NOWMUSIC speed " & Speed, vbNull, 0, 0)
    If RefInt = 0 Then SetSpeed = True
End Function

'====================================================
'静音True为静音，FALSE为取消静音
'====================================================
Public Function SetAudioOnOff(AudioOff As Boolean) As Boolean
    Dim RefInt As Long
    Dim OnOff As String
    SetAudioOff = False
    If AudioOff Then OnOff = "off" Else OnOff = "on"
    RefInt = mciSendString("setaudio NOWMUSIC " & OnOff, vbNull, 0, 0)
    If RefInt = 0 Then SetAudioOff = True
End Function

'====================================================
'是否有画面True为有，FALSE为取消
'====================================================
Public Function SetWindowShow(WindowOff As Boolean) As Boolean
    Dim RefInt As Long
    Dim OnOff As String
    SetWindowShow = False
    If WindowOff Then OnOff = "show" Else OnOff = "hide"
    RefInt = mciSendString("window NOWMUSIC  state " & OnOff, vbNull, 0, 0)
    If RefInt = 0 Then SetWindowShow = True
End Function

'====================================================
'获得当前媒体的状态是不是在播放
'====================================================
Public Function IsPlaying() As Boolean
    Dim sl As String * 255
    mciSendString "status NOWMUSIC mode", sl, Len(sl), 0
    If Left(sl, 7) = "playing" Or Left(sl, 2) = "播放" Then
        IsPlaying = True
    Else
        IsPlaying = False
    End If
End Function

'====================================================
'获得播放窗口的handle
'====================================================
Public Function GetWindowHandle() As Long
    Dim RefStr As String * 160
    mciSendString "status NOWMUSIC window handle", RefStr, 80, 0
    GetWindowHandle = Val(RefStr)
End Function

'====================================================
'获取DeviceID
'====================================================
Public Function GetDeviceID() As Long
    GetDeviceID = mciGetDeviceID("NOWMUSIC")
End Function