播放前景音乐和动画（WAB，MP3，MIDI，AVI）

发布: 2007-6-21 21:57 | 作者: | 来源: | 查看: 63次 | 进入软件测试论坛讨论

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

`     +                                                                                  +
`     +  属性——SpeakerVolume——读取/设置喇叭音量——取长整数                             +
`     +  属性——MicphoneVolume——读取/设置话筒音量——取长整数                            +
`     +  属性——Length——读取声音文件的播放长度——返回一个长整数                          +
`     +  属性——PlayFrom——设置开始播放的时间点——取值是长整数                            +
`     +  属性——PlayTo——设置播放结束的时间点——取值是长整数                              +
`     +  属性——Position——读取当前播放到的位置——返回长整数                              +
`     +  属性——Status——读取本对象的状态——返回值：CLOSED；PLAYING；PAUSED；STOPPED      +
`     +  过程——OpenMusic——打开一个声音文件——picCtl是播放AVI时用的载体                  +
`     +  过程PlayMusic——播放当前设备——无参数                                            +
`     +  过程PauseMusic()——暂停当前设备——无参数                                         +
`     +  过程CloseMusic()——关闭当前设备——无参数                                         +
`     +  过程Record()——开始录音——参数是要录音的秒数                                      +
`     +  过程PlayRecord()——播放已经录制的音乐——无参数                                    +
`     +  过程——WaitToFinish——等待到音乐停止或结束——无参数                              +
`     +                                                                                   +
`     +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

`***********************音量设置声明******************************************************************

Option Explicit
Const MMSYSERR_NOERROR = 0
Const MAXPNAMELEN = 32
Const MIXER_LONG_NAME_CHARS = 64
Const MIXER_SHORT_NAME_CHARS = 16
Const MIXER_GETLINEINFOF_COMPONENTTYPE = &H3&
Const MIXER_GETCONTROLDETAILSF_VALUE = &H0&
Const MIXER_SETCONTROLDETAILSF_VALUE = &H0&
Const MIXER_GETLINECONTROLSF_ONEBYTYPE = &H2&
Const MIXERLINE_COMPONENTTYPE_DST_FIRST = &H0&
Const MIXERLINE_COMPONENTTYPE_SRC_FIRST = &H1000&
Const MIXERLINE_COMPONENTTYPE_DST_SPEAKERS = (MIXERLINE_COMPONENTTYPE_DST_FIRST + 4)
Const MIXERLINE_COMPONENTTYPE_SRC_MICROPHONE = (MIXERLINE_COMPONENTTYPE_SRC_FIRST + 3)
Const MIXERLINE_COMPONENTTYPE_SRC_LINE = (MIXERLINE_COMPONENTTYPE_SRC_FIRST + 2)
Const MIXERCONTROL_CT_CLASS_FADER = &H50000000
Const MIXERCONTROL_CT_UNITS_UNSIGNED = &H30000
Const MIXERCONTROL_CONTROLTYPE_FADER = (MIXERCONTROL_CT_CLASS_FADER Or MIXERCONTROL_CT_UNITS_UNSIGNED)
Const MIXERCONTROL_CONTROLTYPE_VOLUME = (MIXERCONTROL_CONTROLTYPE_FADER + 1)

Private Type MIXERCONTROLDETAILS
    cbStruct    As Long
    dwControlID As Long
    cChannels   As Long
    Item        As Long
    cbDetails   As Long
    paDetails   As Long
End Type

Private Type MIXERCONTROLDETAILS_UNSIGNED
    dwValue As Long
End Type

Private Type MIXERCONTROL
    cbStruct       As Long
    dwControlID    As Long
    dwControlType  As Long
    fdwControl     As Long
    cMultipleItems As Long
    szShortName    As String * MIXER_SHORT_NAME_CHARS
    szName         As String * MIXER_LONG_NAME_CHARS
    lMinimum       As Long
    lMaximum       As Long
    Reserved(10)   As Long
End Type

Private Type MIXERLINECONTROLS
    cbStruct  As Long
    dwLineID  As Long
    dwControl As Long
    cControls As Long
    cbmxctrl  As Long
    pamxctrl  As Long
End Type

Private Type MIXERLINE
    cbStruct        As Long
    dwDestination   As Long
    dwSource        As Long
    dwLineID        As Long
    fdwLine         As Long
    dwUser          As Long
    dwComponentType As Long
    cChannels       As Long
    cConnections    As Long
    cControls       As Long
    szShortName     As String * MIXER_SHORT_NAME_CHARS
    szName          As String * MIXER_LONG_NAME_CHARS
    dwType          As Long
    dwDeviceID      As Long
    wMid            As Integer
    wPid            As Integer
    vDriverVersion  As Long
    szPname         As String * MAXPNAMELEN
End Type
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hmem As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hmem As Long) As Long
Private Declare Sub CopyPtrFromStruct Lib "kernel32" Alias "RtlMoveMemory" (ByVal ptr As Long, struct As Any, ByVal cb As Long)
Private Declare Sub CopyStructFromPtr Lib "kernel32" Alias "RtlMoveMemory" (struct As Any, ByVal ptr As Long, ByVal cb As Long)
Private Declare Function mixerOpen Lib "winmm.dll" (phmx As Long, ByVal uMxId As Long, ByVal dwCallback As Long, ByVal dwInstance As Long, ByVal fdwOpen As Long) As Long
Private Declare Function mixerSetControlDetails Lib "winmm.dll" (ByVal hmxobj As Long, pmxcd As MIXERCONTROLDETAILS, ByVal fdwDetails As Long) As Long
Private Declare Function mixerGetControlDetails Lib "winmm.dll" Alias "mixerGetControlDetailsA" (ByVal hmxobj As Long, pmxcd As MIXERCONTROLDETAILS, ByVal fdwDetails As Long) As Long
Private Declare Function mixerGetLineInfo Lib "winmm.dll" Alias "mixerGetLineInfoA" (ByVal hmxobj As Long, pmxl As MIXERLINE, ByVal fdwInfo As Long) As Long
Private Declare Function mixerGetLineControls Lib "winmm.dll" Alias "mixerGetLineControlsA" (ByVal hmxobj As Long, pmxlc As MIXERLINECONTROLS, ByVal fdwControls As Long) As Long
Private hmem As Long `
Private hmixer  As Long `
Private volCtrl As MIXERCONTROL
Private micCtrl As MIXERCONTROL
Private mlngMicVolume As Long
Private mlngMicMaxVolume As Long
Private mlngMicMinVolume As Long
Private mlngSpeakerVolume As Long
Private mlngSpeakerMaxVolume As Long
Private mlngSpeakerMinVolume As Long
Private mlngMixerErr As Long

`****************************************播放操作等声明***********************************************8
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 mciExecute Lib "winmm.dll" (ByVal lpstrCommand As String) As Long
Private Declare Function mciSendCommand Lib "winmm.dll" Alias "mciSendCommandA" (ByVal wDeviceID As Long, ByVal uMessage As Long, ByVal dwParam1 As Long, ByVal dwParam2 As Any) As Long
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private mstrPlayDevice As String `当前播放设备
Private mlngPlayFrom As Long `起始播放时间
Private mlngPlayTo As Long `结束播放时间
Private Const RECORDFILE = "c: est11.wav"

`===================================================================================================
`=========================================对象的属性=================================================
`===================================================================================================

`*******************喇叭音量的设置***************************************************************
Public Property Let SpeakerVolume(ByVal vData As Long)
    mlngSpeakerVolume = vData
    mlngSpeakerVolume = IIf(mlngSpeakerVolume > mlngSpeakerMaxVolume, mlngSpeakerMaxVolume, mlngSpeakerVolume)
    mlngSpeakerVolume = IIf(mlngSpeakerVolume < mlngSpeakerMinVolume, mlngSpeakerMinVolume, mlngSpeakerVolume)
    Call mSetVolumeValue(hmixer, volCtrl, mlngSpeakerVolume)
End Property

`*******************喇叭音量的读取置***************************************************************
Public Property Get SpeakerVolume() As Long
    SpeakerVolume = mlngSpeakerVolume
End Property

`*******************************话筒音量的设置*********************
Public Property Let MicVolume(ByVal vData As Long)
    mlngMicVolume = vData
    mlngMicVolume = IIf(mlngMicVolume > mlngMicMaxVolume, mlngSpeakerMaxVolume, mlngMicVolume)
    mlngMicVolume = IIf(mlngMicVolume < mlngMicMinVolume, mlngSpeakerMinVolume, mlngMicVolume)
    Call fSetVolumeControl(hmixer, micCtrl, mlngMicVolume)
End Property

`*******************************话筒音量的读取*********************
Public Property Get MicVolume() As Long
    MicVolume = mlngMicVolume
End Property

`****************************起始播放时间******************************************************
Public Property Let playFrom(lngTime As Long)
    mlngPlayFrom = lngTime
End Property

`***************************结束播放时间********************************************************
Public Property Let playTo(lngTime As Long)
    mlngPlayTo = lngTime
End Property

`****************************取得当前播放时间*****************************************************
Public Property Get Position() As Long
    Position = mGetMusicPosition(mstrPlayDevice)
End Property

`***************************取得当前播放状态******************************************************
Public Property Get Length() As String
    Length = mGetMusicLength(mstrPlayDevice)
End Property

`****************************取得当前播放状态******************************************************
Public Property Get Status() As String
    Status = mGetPlayStatus(mstrPlayDevice)
End Property

`====================================================================================================
`=========================================对象的方法==================================================
`=====================================================================================================

`********************打开****************************************************************************
Public Sub OpenMusic(FileName As String, Optional picCtl As PictureBox)

    mOpenMusic FileName, mstrPlayDevice, picCtl
End Sub

`********************播放***************************************************************************
Public Sub PlayMusic(Optional picCtl As PictureBox)
Dim tmp, tickCount As Long
    mPlayMusic mstrPlayDevice, mlngPlayFrom, mlngPlayTo
End Sub

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

`*****************************关闭当前音乐设备*******************************************************
Public Sub CloseMusic()
    mCloseMusic mstrPlayDevice, mlngPlayFrom
End Sub

`*******************************录音*************************************************************
Public Sub Record(timeLength As Integer)
Dim errorCode As Long, tickCount As Long
Dim ReturnString As String * 128
Dim strRecord As String
Dim tmpFile As String
    strRecord = " record"
    errorCode = mciSendString("open new type waveaudio alias " & strRecord, 0, 0, 0)
    errorCode = mciSendString("record " & strRecord, 0, 0, 0)
    tickCount = GetTickCount()
    While GetTickCount() - tickCount < 1000 * timeLength
        DoEvents
    Wend
    errorCode = mciSendString("stop " & strRecord, 0, 0, 0)
    errorCode = mciSendString("save " & strRecord & " " & RECORDFILE, 0, 0, 0)
    errorCode = mciSendString("close " & strRecord, 0, 0, 0)
End Sub

`*******************************播放录音*************************************************************
Public Sub PlayRecord()
Dim errorCode As Long
Dim strRecord As String
    strRecord = " record"
    errorCode = mciSendString("open " & RECORDFILE & " alias " & strRecord, 0, 0, 0)
    errorCode = mciSendString("play " & strRecord & " wait", 0, 0, 0)
    errorCode = mciSendString("close " & strRecord, 0, 0, 0)
    Kill (RECORDFILE)
End Sub

`*************************WaitToFinish等待到音乐停止或结束*******************************************
Public Sub WaitToFinish()
Dim Flag As String
    While 1
        Flag = mGetPlayStatus(mstrPlayDevice)
        Select Case Flag
            Case "STOPPED", "CLOSED", "PAUSED": Exit Sub
            Case Else: DoEvents
        End Select
    Wend
End Sub
`=====================================================================================================
`========================================私有过程和函数================================================
`=====================================================================================================

`************************打开设备******************************************************************
Private Sub mOpenMusic(ByVal currentMusicName As String, musicDevice As String, Optional picCtl As PictureBox)      `播放当前曲目
Dim errorCode As Long
Dim strFrom As String, strTo As String
Dim ErrorString As String * 128
    musicDevice = " PLAYDEVICE"
    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)
    End If
    errorCode = mciSendString("set  " & musicDevice & " time format milliseconds", 0, 0, 0)
    If Not (picCtl Is Nothing) Then  `专门为了播放AVI文件
        errorCode = mciSendString("window " & musicDevice & " handle " & Str$(picCtl.hwnd), 0, 0, 0)
        errorCode = mciSendString("put " & musicDevice & " destination  at 0 0  " & Str$(picCtl.Width) & " " & Str$(picCtl.Height), 0, 0, 0)
        If Not picCtl.Visible Then picCtl.Visible = True
        errorCode = mciSendString("cue " & musicDevice & " to 1", 0, 0, 0)
        errorCode = mciSendString("update " & musicDevice, 0, 0, 0)
    End If
End Sub

`************************播放设备*****************************************************************
Private Sub mPlayMusic(musicDevice As String, ByVal playFrom As Long, ByVal playTo As Long)
Dim errorCode As Long
Dim strFrom As String, strTo As String
Dim ErrorString As String * 128
    strFrom = " from " & Str$(playFrom)
    strTo = IIf(playFrom >= playTo, "", " to " & Str(playTo))
    errorCode = mciSendString("play " + musicDevice + strFrom + strTo, 0, 0, 0)
    If errorCode <> 0 Then `出现错误
           errorCode = mciGetErrorString(errorCode, ErrorString, 128)
           Debug.Print Left(ErrorString, InStr(1, ErrorString, Chr(0), vbTextCompare) - 1)
    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
    Else
        Debug.Print "设备已经关闭！"
    End If
End Sub

`************************取得设备总长度*************************************************************
Private Function mGetMusicLength(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 & " length"
    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
    Else
        mGetMusicLength = CLng(ReturnString)
    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 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 mGetVolumeControl(ByVal hmixer As Long, ByVal componentType As Long, ByVal ctrlType As Long, ByRef mxc As MIXERCONTROL) As Boolean
Dim mxlc As MIXERLINECONTROLS
Dim mxl  As MIXERLINE
Dim hmem As Long
Dim rc   As Long
    mxl.cbStruct = Len(mxl)
    mxl.dwComponentType = componentType
    rc = mixerGetLineInfo(hmixer, mxl, MIXER_GETLINEINFOF_COMPONENTTYPE)
    If MMSYSERR_NOERROR = rc Then
        With mxlc
            .cbStruct = Len(mxlc)
            .dwLineID = mxl.dwLineID
            .dwControl = ctrlType
            .cControls = 1
            .cbmxctrl = Len(mxc)
        End With
        hmem = GlobalAlloc(&H40, Len(mxc))
        mxlc.pamxctrl = GlobalLock(hmem)
        mxc.cbStruct = Len(mxc)
        rc = mixerGetLineControls(hmixer, mxlc, MIXER_GETLINECONTROLSF_ONEBYTYPE)
        If MMSYSERR_NOERROR = rc Then
            mGetVolumeControl = True
            Call CopyStructFromPtr(mxc, mxlc.pamxctrl, Len(mxc))
        Else
            mGetVolumeControl = False
        End If
        Call GlobalFree(hmem)
        Exit Function
    End If
    mGetVolumeControl = False
End Function
`*************************取得当前音量设置值************************************************************
Private Function mGetVolumeValue(ByVal hmixer As Long, mxc As MIXERCONTROL) As Long
Dim rc   As Long
Dim mxcd As MIXERCONTROLDETAILS
Dim vol  As MIXERCONTROLDETAILS_UNSIGNED
    With mxcd
        .Item = 0
        .dwControlID = mxc.dwControlID
        .cbStruct = Len(mxcd)
        .cbDetails = Len(vol)
    End With
    hmem = GlobalAlloc(&H40, Len(vol))
    mxcd.paDetails = GlobalLock(hmem)
    mxcd.cChannels = 1
    rc = mixerGetControlDetails(hmixer, mxcd, MIXER_GETCONTROLDETAILSF_VALUE)
    Call CopyStructFromPtr(vol, mxcd.paDetails, Len(mxcd.paDetails))
    Call GlobalFree(hmem)

    If MMSYSERR_NOERROR = rc Then
        mGetVolumeValue = vol.dwValue
    Else
        mGetVolumeValue = -1
    End If
End Function

`*************************设置音量**********************************************************************
Private Function mSetVolumeValue(ByVal hmixer As Long, mxc As MIXERCONTROL, ByVal volume As Long) As Boolean
Dim rc   As Long
Dim mxcd As MIXERCONTROLDETAILS
Dim vol  As MIXERCONTROLDETAILS_UNSIGNED
    With mxcd
        .Item = 0
        .dwControlID = mxc.dwControlID
        .cbStruct = Len(mxcd)
        .cbDetails = Len(vol)
    End With
    hmem = GlobalAlloc(&H40, Len(vol))
    mxcd.paDetails = GlobalLock(hmem)
    mxcd.cChannels = 1
    vol.dwValue = volume
    Call CopyPtrFromStruct(mxcd.paDetails, vol, Len(vol))
    rc = mixerSetControlDetails(hmixer, mxcd, MIXER_SETCONTROLDETAILSF_VALUE)
    Call GlobalFree(hmem)

    If MMSYSERR_NOERROR = rc Then
        mSetVolumeValue = True
    Else
        mSetVolumeValue = False
    End If
End Function

`*************打开混音器设备，取得喇叭和MIC的最大和最小的音量及当前值***************************************
Private Function OpenMixer() As Long
Dim rc  As Long
Dim bOK As Boolean
    rc = mixerOpen(hmixer, 0, 0, 0, 0)
    mlngMixerErr = rc
    If MMSYSERR_NOERROR <> rc Then
        MsgBox "Could not open the mixer.", vbCritical, "Volume Control"
        Exit Function
    End If
    bOK = mGetVolumeControl(hmixer, MIXERLINE_COMPONENTTYPE_DST_SPEAKERS, MIXERCONTROL_CONTROLTYPE_VOLUME, volCtrl)
    If bOK Then
            mlngSpeakerMaxVolume = volCtrl.lMaximum
            mlngSpeakerMinVolume = volCtrl.lMinimum
    End If
    bOK = mGetVolumeControl(hmixer, MIXERLINE_COMPONENTTYPE_SRC_MICROPHONE, MIXERCONTROL_CONTROLTYPE_VOLUME, micCtrl)
    If bOK Then
            mlngMicMaxVolume = micCtrl.lMaximum
            mlngMicMinVolume = micCtrl.lMinimum
    End If
    mlngSpeakerVolume = mGetVolumeValue(hmixer, volCtrl)
    mlngMicVolume = mGetVolumeValue(hmixer, micCtrl)
End Function

`*******************************初始化**************************************************************
Private Sub Class_Initialize()
    OpenMixer
End Sub
Private Sub Class_Terminate()
    CloseMusic
End Sub

`     刘立志整理于2001-4-19