'模块 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 LongPublic Declare Function mciGetDeviceID Lib "winmm.dll" Alias "mciGetDeviceIDA" (ByVal lpstrName As String) As LongPublic Declare Function waveOutGetVolume Lib "winmm.dll" (ByVal uDeviceID As Long, lpdwVolume As Long) As LongPublic Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As LongPublic 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 LongPublic Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPublic Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As LongEnum 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 OpenURL = 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 OpenURL = TrueEnd 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 = TrueEnd 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
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 LongPublic Declare Function mciGetDeviceID Lib "winmm.dll" Alias "mciGetDeviceIDA" (ByVal lpstrName As String) As LongPublic Declare Function waveOutGetVolume Lib "winmm.dll" (ByVal uDeviceID As Long, lpdwVolume As Long) As LongPublic Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As LongPublic 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 LongPublic Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPublic Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As LongEnum 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
OpenURL = 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 OpenURL = TrueEnd 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 = TrueEnd 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