播放背景音乐的类

领测软件测试网

　　 
　　`     ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

`     +                                                                                  +
`     +  属性——Directory——设置背景音乐所在目录——一个完整目录路径                       +
`     +  属性——IsLoop——读取/设置是否循环播放所有音乐——取布尔值                         +
`     +  过程PlayMusic——播放当前设备——无参数                                            +
`     +  过程PauseMusic()——暂停当前设备——无参数                                         +
`     +  过程CloseMusic()——关闭当前设备——无参数                                         +
`     +  过程RandomList()——随机播放音乐——无参数                                         +
`     +  过程SequenceList()——顺序播放音乐——无参数                                       +
`     +                                                                                   +
`     +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Option Explicit
`===========================================================================================
`===========================声明部分========================================================
`===========================================================================================
Private 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
Private Declare Function mciGetErrorString Lib "winmm.dll" Alias "mciGetErrorStringA" (ByVal dwError As Long, ByVal lpstrBuffer As String, ByVal uLength As Long) As Long
Private Declare Function GetTickCount Lib "kernel32" () As Long

Private mstrSeqMusicList() As String `顺序播放数组
Private mstrPlayMusicList() As String `播放歌曲的数组
Private mstrMusicDevice As String `当前音乐设备

Private mlngMaxMusicNum As Long `最大的歌曲数目
Private mlngCurrentMusic As Long `当前播放的歌曲在播放数组中的序号
Private mlngCurrentPlayTime As Long `当前播放的时间
Private mblnIsLoop As Boolean `是否循环播放

`===========================================================================================
`===========================公有属性部分========================================================
`===========================================================================================

`
Public Property Let Directory(filePath As String)
    ReturnList filePath, "*.*", mstrPlayMusicList()
    mlngMaxMusicNum = UBound(mstrPlayMusicList())
End Property

`是否循环播放当前音乐数组
Public Property Let IsLoop(blnLoop As Boolean)
    mblnIsLoop = blnLoop
End Property
Public Property Get IsLoop() As Boolean
    IsLoop = mblnIsLoop
End Property

`===========================================================================================
`===========================公有方法部分========================================================
`===========================================================================================

`******************************播放歌曲*******************************************************
Public Sub PlayMusic()
Dim tmp As Long, errorCode As Long, tickCount As Long
    mPlayMusic mstrPlayMusicList(mlngCurrentMusic), mstrMusicDevice, mlngCurrentPlayTime
    While (1)
        Select Case mGetPlayStatus(mstrMusicDevice)
            Case "STOPPED":
                If mlngCurrentMusic >= mlngMaxMusicNum Then `歌曲结束
                    mlngCurrentMusic = 0
                    If mblnIsLoop Then `用户使用了循环播放
                        mCloseMusic mstrMusicDevice, mlngCurrentPlayTime
                        mPlayMusic mstrPlayMusicList(mlngCurrentMusic), mstrMusicDevice, mlngCurrentPlayTime
                    Else
                        CloseMusic
                        Exit Sub
                    End If
                Else `歌曲并没有到达最后一曲
                    mlngCurrentMusic = mlngCurrentMusic + 1
                    mCloseMusic mstrMusicDevice, mlngCurrentPlayTime
                    mPlayMusic mstrPlayMusicList(mlngCurrentMusic), mstrMusicDevice, mlngCurrentPlayTime
                End If
            Case "PAUSED"
                Exit Sub
            Case "CLOSED"
                Exit Sub
            
        End Select
        
        tickCount = GetTickCount()
        While GetTickCount() - tickCount < 1000
            tmp = DoEvents
        Wend
    Wend
End Sub

`***********************************************暂停当前曲目************************************
Public Sub PauseMusic()
    mPauseMusic mstrMusicDevice, mlngCurrentPlayTime
End Sub

`*******************************停止播放*******************************************************
Public Sub CloseMusic()
    mCloseMusic mstrMusicDevice, mlngCurrentPlayTime
    mlngCurrentMusic = 0
End Sub

`***************************************随机播放数组*********************************************
Public Sub RandomList()
    CopyArray mstrPlayMusicList(), mstrSeqMusicList()
    ReturnRndList mstrSeqMusicList(), mstrPlayMusicList(), mlngCurrentMusic
End Sub

`***********************************`顺序播放音乐数组**********************************************
Public Sub SequenceList()
    ReturnSeqList mstrSeqMusicList(), mstrPlayMusicList(), mlngCurrentMusic
End Sub

`===========================================================================================
`===========================私有过程和函数部分================================================
`===========================================================================================

`*********************播放文件；设备名；起始播放时间*********************************************
Private Sub mPlayMusic(currentMusicName As String, musicDevice As String, Optional startTime As Long = 0)  `播放当前曲目
Dim errorCode As Long
Dim ErrorString As String * 128
    If musicDevice <> " BACKDEVICE" Then
        musicDevice = " BACKDEVICE"
        errorCode = mciSendString("open  " & currentMusicName & " alias " & musicDevice, 0, 0, 0)
        If errorCode <> 0 Then `出现错误
               errorCode = mciGetErrorString(errorCode, ErrorString, 128)
               Debug.Print Left(ErrorString, InStr(1, ErrorString, Chr(0), vbTextCompare) - 1)
               Exit Sub
        End If
    End If
    errorCode = mciSendString("play " + musicDevice + " from " + Str(startTime), 0, 0, 0)  `播放
    If errorCode <> 0 Then `出现错误
           errorCode = mciGetErrorString(errorCode, ErrorString, 128)
           Debug.Print Left(ErrorString, InStr(1, ErrorString, Chr(0), vbTextCompare) - 1)
           Exit Sub
    End If
End Sub

`***********************暂停设备******************************************************************
Private Sub mPauseMusic(musicDevice As String, currentPlayTime As Long)
Dim ErrorString As String * 128
Dim errorCode As Long
Dim strCommand As String
    strCommand = "pause " & musicDevice
    errorCode = mciSendString(strCommand, 0, 0, 0)
    If errorCode <> 0 Then `出现错误
           errorCode = mciGetErrorString(errorCode, ErrorString, 128)
           Debug.Print Left(ErrorString, InStr(1, ErrorString, Chr(0), vbTextCompare) - 1)
           Exit Sub
    End If
    currentPlayTime = mGetMusicPosition(musicDevice)
End Sub

`*********************关闭设备*********************************************************************
Private Sub mCloseMusic(musicDevice As String, currentPlayTime As Long)
Dim errorCode As Long
    errorCode = mciSendString("capability " & musicDevice & " device type", 0, 0, 0)
    If errorCode = 0 Then
         errorCode = mciSendString("close " & musicDevice & " wait", 0, 0, 0)
         currentPlayTime = 0
         musicDevice = ""
    Else
        Debug.Print "设备已经关闭！"
    End If
End Sub
`************************取得当前设备状态**********************************************************
Private Function mGetPlayStatus(musicDevice As String) As String
Dim ErrorString As String * 128, ReturnString As String * 128
Dim errorCode As Long
Dim strCommand As String
    strCommand = "status " & musicDevice & " mode"
    errorCode = mciSendString(strCommand, ReturnString, 128, 0)
    If errorCode <> 0 Then `出现错误
        errorCode = mciGetErrorString(errorCode, ErrorString, 128)
        mGetPlayStatus = "CLOSED"
        Exit Function
    Else `检查播放状态
        mGetPlayStatus = UCase(Left(ReturnString, InStr(1, ReturnString, Chr(0), vbTextCompare) - 1))
    End If
End Function
`************************取得当前播放位置*********************************************************
Private Function mGetMusicPosition(musicDevice As String) As Long
Dim ErrorString As String * 128, ReturnString As String * 128
Dim errorCode As Long
Dim strCommand As String
    strCommand = "status " & musicDevice & " position"
    errorCode = mciSendString(strCommand, ReturnString, 128, 0)
    If errorCode <> 0 Then `出现错误
           errorCode = mciGetErrorString(errorCode, ErrorString, 128)
           Debug.Print Left(ErrorString, InStr(1, ErrorString, Chr(0), vbTextCompare) - 1)
           Exit Function
    End If
    mGetMusicPosition = CLng(ReturnString)
End Function

`*************************************拷贝数组***************************************************
Private Sub CopyArray(arrayCopy() As String, arrayPaste() As String)
    Dim i As Integer
    ReDim arrayPaste(LBound(arrayCopy()) To UBound(arrayCopy()))
    For i = LBound(arrayCopy()) To UBound(arrayCopy())
        arrayPaste(i) = arrayCopy(i)
    Next
End Sub

`*********************输入目录名和文件限制，返回所有符合条件的一个文本数组***************************
Private Function ReturnList(filePath As String, fileFilter As String, fileNames() As String) As Boolean
Dim filePathAndFilter As String
Dim i As Long
    filePathAndFilter = filePath + fileFilter
    i = 0
    ReDim fileNames(i)
    fileNames(i) = filePath + Dir(filePathAndFilter)
    Do While fileNames(i) <> filePath
        i = i + 1
        ReDim Preserve fileNames(i)
        fileNames(i) = filePath + Dir()
        
    Loop
    i = i - 1 `因为最后得到的是一个空字符串所以去掉
    If i < 0 Or fileNames(i) = "" Then
        MsgBox "该目录没有符合条件的文件，请重新定位！", , "KingsunSoft"
        ReturnList = False
    Else
        ReDim Preserve fileNames(i)
        ReturnList = True
    End If
End Function

`*******随机排列字符串数组，不改变原来的数组，并且返回当前所用的字符串的新位置************************
Private Sub ReturnRndList(SequenceList() As String, playList() As String, currentMusic As Long)
    Dim tmpString As String
    Dim flags() As Boolean `别选择数组中的元素是否已经被选过
    Dim i As Long, low As Long, up As Long, tmp As Long
    tmpString = SequenceList(currentMusic)
    low = LBound(SequenceList())
    up = UBound(SequenceList())
    For i = low To up
        ReDim Preserve playList(i)
        ReDim Preserve flags(i)
        playList(i) = SequenceList(i)
        flags(i) = True
    Next
    For i = low To up
tryAgain:
        Randomize
        tmp = CInt(Rnd * up)
        If flags(tmp) = True Then
            playList(i) = SequenceList(tmp)
            flags(tmp) = False
        Else:
            GoTo tryAgain
        End If
        If tmpString = playList(i) Then currentMusic = i
    Next i
End Sub

`*************************************随机排列字符串数组*****************************************
Private Sub ReturnSeqList(SequenceList() As String, playList() As String, currentMusic As Long)
Dim tmpString As String
Dim i As Long, low As Long, up As Long
    tmpString = playList(currentMusic)
    CopyArray SequenceList(), playList()
    low = LBound(SequenceList())
    up = UBound(SequenceList())
    For i = low To up
        If tmpString = playList(i) Then currentMusic = i
    Next
End Sub

`===========================================================================================
`===========================类事件部分========================================================
`===========================================================================================

Private Sub Class_Initialize()
    mlngCurrentMusic = 0
End Sub

Private Sub Class_Terminate()
    CloseMusic
End Sub
`     刘立志 整理于2001-4-20

文章来源于领测软件测试网 https://www.ltesting.net/