home *** CD-ROM | disk | FTP | other *** search
- VERSION 5.00
- Object = "{C1A8AF28-1257-101B-8FB0-0020AF039CA3}#1.1#0"; "MCI32.OCX"
- Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
- Begin VB.Form frmAudioPlayer
- BorderStyle = 1 'Fixed Single
- Caption = "Audio player"
- ClientHeight = 2775
- ClientLeft = 2040
- ClientTop = 1755
- ClientWidth = 4635
- LinkMode = 1 'Source
- LinkTopic = "Form2"
- LockControls = -1 'True
- MaxButton = 0 'False
- ScaleHeight = 2775
- ScaleWidth = 4635
- Begin VB.ComboBox cboTrack
- BeginProperty Font
- Name = "MS Sans Serif"
- Size = 8.25
- Charset = 0
- Weight = 700
- Underline = 0 'False
- Italic = 0 'False
- Strikethrough = 0 'False
- EndProperty
- Height = 315
- Left = 150
- TabIndex = 15
- Text = "Combo1"
- Top = 1740
- Width = 645
- End
- Begin VB.CommandButton cmdCDLoad
- BackColor = &H00C0C0FF&
- Caption = "~"
- BeginProperty Font
- Name = "MS Sans Serif"
- Size = 13.5
- Charset = 0
- Weight = 700
- Underline = 0 'False
- Italic = 0 'False
- Strikethrough = 0 'False
- EndProperty
- Height = 345
- Left = 3900
- Style = 1 'Graphical
- TabIndex = 13
- ToolTipText = "Load CD"
- Top = 2190
- Width = 525
- End
- Begin VB.CommandButton cmdVolInc
- Caption = "+"
- BeginProperty Font
- Name = "MS Sans Serif"
- Size = 12
- Charset = 0
- Weight = 700
- Underline = 0 'False
- Italic = 0 'False
- Strikethrough = 0 'False
- EndProperty
- Height = 345
- Left = 3900
- TabIndex = 11
- Top = 750
- Width = 495
- End
- Begin VB.CommandButton cmdVolDec
- Caption = "-"
- BeginProperty Font
- Name = "MS Sans Serif"
- Size = 13.5
- Charset = 0
- Weight = 700
- Underline = 0 'False
- Italic = 0 'False
- Strikethrough = 0 'False
- EndProperty
- Height = 345
- Left = 3360
- TabIndex = 10
- Top = 750
- Width = 525
- End
- Begin VB.CommandButton cmdCD
- BackColor = &H00C0C0FF&
- Caption = "CD"
- Height = 345
- Left = 180
- Style = 1 'Graphical
- TabIndex = 6
- Top = 150
- Width = 855
- End
- Begin VB.CommandButton cmdMidi
- BackColor = &H00FFFFC0&
- Caption = "Midi"
- Height = 345
- Left = 1920
- Style = 1 'Graphical
- TabIndex = 1
- Top = 150
- Width = 855
- End
- Begin VB.CommandButton cmdWave
- BackColor = &H00C0FFFF&
- Caption = "Wave"
- Height = 345
- Left = 1050
- Style = 1 'Graphical
- TabIndex = 0
- Top = 150
- Width = 855
- End
- Begin VB.CommandButton cmdExit
- Caption = "Exit"
- BeginProperty Font
- Name = "MS Sans Serif"
- Size = 8.25
- Charset = 0
- Weight = 700
- Underline = 0 'False
- Italic = 0 'False
- Strikethrough = 0 'False
- EndProperty
- Height = 345
- Left = 3630
- TabIndex = 2
- Top = 150
- Width = 825
- End
- Begin MCI.MMControl mmControl1
- Height = 375
- Left = 150
- TabIndex = 3
- ToolTipText = "1 Prev/2 Next/3 Play/4 Pause/5 Back/6 Step/7 Stop/8 Record/9 Eject"
- Top = 2160
- Width = 4290
- _ExtentX = 7567
- _ExtentY = 661
- _Version = 393216
- BorderStyle = 0
- DeviceType = ""
- FileName = ""
- End
- Begin VB.PictureBox picVolume
- Height = 405
- Left = 3330
- ScaleHeight = 345
- ScaleWidth = 1035
- TabIndex = 14
- Top = 720
- Width = 1095
- End
- Begin MSComDlg.CommonDialog CommonDialog1
- Left = 3660
- Top = 1380
- _ExtentX = 847
- _ExtentY = 847
- _Version = 393216
- CancelError = -1 'True
- DialogTitle = "HCL Applications"
- FromPage = 1
- Max = 1000
- Min = 1
- ToPage = 1
- End
- Begin VB.Label lblVolume
- Caption = "Volume:"
- Height = 285
- Left = 2730
- TabIndex = 12
- Top = 810
- Width = 585
- End
- Begin VB.Label lblDurationValue
- Caption = "lblDurationValue"
- Height = 285
- Left = 930
- TabIndex = 9
- Top = 1380
- Width = 1275
- End
- Begin VB.Label lblDuration
- BackColor = &H00C0C0C0&
- Caption = "Duration:"
- Height = 255
- Left = 150
- TabIndex = 8
- Top = 1380
- Width = 675
- End
- Begin VB.Label lblTotalTrack
- BackColor = &H00C0C0C0&
- Caption = "Total tracks:"
- Height = 255
- Left = 900
- TabIndex = 7
- Top = 1770
- Width = 1425
- End
- Begin VB.Label Label1
- BorderStyle = 1 'Fixed Single
- Height = 405
- Left = 150
- TabIndex = 5
- Top = 120
- Width = 4335
- End
- Begin VB.Label lblDevice
- Caption = "lblDevice"
- BeginProperty Font
- Name = "MS Sans Serif"
- Size = 8.25
- Charset = 0
- Weight = 700
- Underline = 0 'False
- Italic = 0 'False
- Strikethrough = 0 'False
- EndProperty
- Height = 255
- Left = 180
- TabIndex = 4
- Top = 810
- Width = 1365
- End
- Attribute VB_Name = "frmAudioPlayer"
- Attribute VB_GlobalNameSpace = False
- Attribute VB_Creatable = False
- Attribute VB_PredeclaredId = True
- Attribute VB_Exposed = False
- ' AudioPlayer.frm
- ' By Herman Liu
- ' An audio player with all essential functions; these include
- ' (1) adjustment of sound volumes of CD and WAVE; (2) direct
- ' selection of any CD track to play; (3) plays CD/WAVE/MIDI.
- ' For those who are frustrated for failing to a find a volume
- ' control for CD player on the sites and don't know how to
- ' make one, this source code shall definitely help).
- Private Const conCDInterval = 1000
- Private Const MMSYSERR_NOERROR = 0
- Private Const MAXPNAMELEN = 32
- Private Const MIXER_LONG_NAME_CHARS = 64
- Private Const MIXER_SHORT_NAME_CHARS = 16
- Private Const MIXER_GETLINEINFOF_COMPONENTTYPE = &H3&
- Private Const MIXER_GETCONTROLDETAILSF_VALUE = &H0&
- Private Const MIXER_GETLINECONTROLSF_ONEBYTYPE = &H2&
- Private Const MIXERLINE_COMPONENTTYPE_DST_FIRST = &H0&
- Private Const MIXERLINE_COMPONENTTYPE_SRC_FIRST = &H1000&
-
- Private Const MIXERLINE_COMPONENTTYPE_DST_SPEAKERS = _
- (MIXERLINE_COMPONENTTYPE_DST_FIRST + 4)
-
- Private Const MIXERLINE_COMPONENTTYPE_SRC_MICROPHONE = _
- (MIXERLINE_COMPONENTTYPE_SRC_FIRST + 3)
-
- Private Const MIXERLINE_COMPONENTTYPE_SRC_LINE = _
- (MIXERLINE_COMPONENTTYPE_SRC_FIRST + 2)
-
- Private Const MIXERCONTROL_CT_CLASS_FADER = &H50000000
- Private Const MIXERCONTROL_CT_UNITS_UNSIGNED = &H30000
- Private Const MIXERCONTROL_CONTROLTYPE_FADER = _
- (MIXERCONTROL_CT_CLASS_FADER Or MIXERCONTROL_CT_UNITS_UNSIGNED)
-
- Private Const MIXERCONTROL_CONTROLTYPE_VOLUME = (MIXERCONTROL_CONTROLTYPE_FADER + 1)
-
- Private Declare Function mixerClose Lib "WINMM.DLL" (ByVal hmx 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 Declare Function mixerGetLineInfo Lib "WINMM.DLL" Alias "mixerGetLineInfoA" _
- (ByVal hmxobj As Long, pmxl As MIXERLINE, ByVal fdwInfo As Long) 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 Sub CopyStructFromPtr Lib "kernel32" Alias "RtlMoveMemory" _
- (struct As Any, ByVal ptr As Long, ByVal cb As Long)
-
- Private Declare Sub CopyPtrFromStruct Lib "kernel32" Alias "RtlMoveMemory" _
- (ByVal ptr As Long, struct As Any, ByVal cb As Long)
-
- 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 Function waveOutGetVolume Lib "WINMM.DLL" (ByVal uDeviceID As Long, _
- lpdwVolume As Long) As Long
-
- Private Declare Function waveOutSetVolume Lib "WINMM.DLL" (ByVal uDeviceID As Long, _
- ByVal dwVolume As Long) As Long
-
- Private Type MIXERCAPS
- wMid As Integer ' manufacturer id
- wPid As Integer ' product id
- vDriverVersion As Long ' version of the driver
- szPname As String * MAXPNAMELEN ' product name
- fdwSupport As Long ' misc. support bits
- cDestinations As Long ' count of destinations
- End Type
-
- Private Type MIXERCONTROL
- cbStruct As Long ' size in Byte of MIXERCONTROL
- dwControlID As Long ' unique control id for mixer device
- dwControlType As Long ' MIXERCONTROL_CONTROLTYPE_xxx
- fdwControl As Long ' MIXERCONTROL_CONTROLF_xxx
- cMultipleItems As Long ' if MIXERCONTROL_CONTROLF_MULTIPLE set
- szShortName As String * MIXER_SHORT_NAME_CHARS ' short name of control
- szName As String * MIXER_LONG_NAME_CHARS ' long name of control
- lMinimum As Long ' Minimum value
- lMaximum As Long ' Maximum value
- reserved(10) As Long ' reserved structure space
- End Type
-
- Private Type MIXERCONTROLDETAILS
- cbStruct As Long ' size in Byte of MIXERCONTROLDETAILS
- dwControlID As Long ' control id to get/set details on
- cChannels As Long ' number of channels in paDetails array
- item As Long ' hwndOwner or cMultipleItems
- cbDetails As Long ' size of _one_ details_XX struct
- paDetails As Long ' pointer to array of details_XX structs
- End Type
-
- Private Type MIXERCONTROLDETAILS_UNSIGNED
- dwValue As Long ' value of the control
- End Type
-
- Private Type MIXERLINE
- cbStruct As Long ' size of MIXERLINE structure
- dwDestination As Long ' zero based destination index
- dwSource As Long ' zero based source index (if source)
- dwLineID As Long ' unique line id for mixer device
- fdwLine As Long ' state/information about line
- dwUser As Long ' driver specific information
- dwComponentType As Long ' component type line connects to
- cChannels As Long ' number of channels line supports
- cConnections As Long ' number of connections (possible)
- cControls As Long ' number of controls at this line
- 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 Type MIXERLINECONTROLS
- cbStruct As Long ' size in Byte of MIXERLINECONTROLS
- dwLineID As Long ' line id (from MIXERLINE.dwLineID)
- ' MIXER_GETLINECONTROLSF_ONEBYID or
- dwControl As Long ' MIXER_GETLINECONTROLSF_ONEBYTYPE
- cControls As Long ' count of controls pmxctrl points to
- cbmxctrl As Long ' size in Byte of _one_ MIXERCONTROL
- pamxctrl As Long ' pointer to first MIXERCONTROL array
- End Type
- Private Const conMCIErrInvalidDeviceID = 30257
- Private Const conMCIErrDeviceOpen = 30263
- Private Const conMCIErrCannotLoadDriver = 30266
- Private Const conMCIErrUnsupportedFunction = 30274
- Private Const conMCIErrInvalidFile = 30304
- Private Const conWAVEInterval = 50
- Private Const conWAVEIntervalPlus = 55
- Private Type VOLSETTINGTYPE
- LeftVol As Integer
- RightVol As Integer
- End Type
- Private Type VOLTYPE
- mWaveVol As Long
- End Type
- Const VolStelVal = 5000
- Const NegStepVal = 7000
- Dim mCD As Boolean
- Dim mWave As Boolean
- Dim mMidi As Boolean
- Dim mTracks As Integer
- Dim hmixer As Long
- Dim volCtrl As MIXERCONTROL ' waveout volume control
- Dim micCtrl As MIXERCONTROL ' microphone volume control
- Dim rc As Long
- Dim OK As Boolean
- Dim VolSetting As VOLSETTINGTYPE
- Dim mVol As VOLTYPE
- Dim LeftVol As Double, RightVol As Double
- Dim q As String, mSign As String
- Dim id As Long, mWaveVol As Long
- '-------
- Dim gmixervolume As Long
- Dim gfso As FileSystemObject
- Dim gcdg As Object
- Private Sub Form_Load()
- mCD = False
- mWave = False
- mMidi = False
- ButtonsOn True
- ' Tentatively set a reasonable starting volume level first
- gmixervolume = 30000
- Set gcdg = CommonDialog1
- Set gfso = New FileSystemObject
- End Sub
- Private Sub cmdExit_Click()
- On Error Resume Next
- mmControl1.Command = "pause"
- mmControl1.UpdateInterval = 0
- mmControl1.To = "1"
- mmControl1.Command = "Seek"
- mmControl1.Command = "close"
- Unload Me
- End Sub
- Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
- On Error Resume Next
- mmControl1.Command = "pause"
- mmControl1.UpdateInterval = 0
- mmControl1.To = "1"
- mmControl1.Command = "Seek"
- mmControl1.Command = "close"
- Set gcdg = Nothing
- Set gfso = Nothing
- End Sub
- Private Function CD_GetVolume(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
-
- ' Obtain a line corresponding to the component type
- rc = mixerGetLineInfo(hmixer, mxl, MIXER_GETLINEINFOF_COMPONENTTYPE)
-
- If (MMSYSERR_NOERROR = rc) Then
- mxlc.cbStruct = Len(mxlc)
- mxlc.dwLineID = mxl.dwLineID
- mxlc.dwControl = ctrlType
- mxlc.cControls = 1
- mxlc.cbmxctrl = Len(mxc)
-
- ' Allocate a buffer for the control
- hmem = GlobalAlloc(&H40, Len(mxc))
- mxlc.pamxctrl = GlobalLock(hmem)
- mxc.cbStruct = Len(mxc)
-
- ' Get the control
- rc = mixerGetLineControls(hmixer, mxlc, MIXER_GETLINECONTROLSF_ONEBYTYPE)
-
- If (MMSYSERR_NOERROR = rc) Then
- CD_GetVolume = True
-
- ' Copy the control into the destination structure
- CopyStructFromPtr mxc, mxlc.pamxctrl, Len(mxc)
- Else
- CD_GetVolume = False
- End If
- GlobalFree (hmem)
- Exit Function
- End If
- CD_GetVolume = False
- End Function
-
-
-
- Private Function CD_SetVolume(ByVal hmixer As Long, mxc As MIXERCONTROL, _
- ByVal volume As Long) As Boolean
-
- Dim mxcd As MIXERCONTROLDETAILS
- Dim vol As MIXERCONTROLDETAILS_UNSIGNED
-
- mxcd.item = 0
- mxcd.dwControlID = mxc.dwControlID
- mxcd.cbStruct = Len(mxcd)
- mxcd.cbDetails = Len(vol)
-
- ' Allocate a buffer for the control value buffer
- hmem = GlobalAlloc(&H40, Len(vol))
- mxcd.paDetails = GlobalLock(hmem)
- mxcd.cChannels = 1
- vol.dwValue = volume
-
- ' Copy the data into the control value buffer
- CopyPtrFromStruct mxcd.paDetails, vol, Len(vol)
-
- ' Set the control value
- rc = mixerSetControlDetails(hmixer, mxcd, MIXER_SETCONTROLDETAILSF_VALUE)
-
- GlobalFree (hmem)
- If (MMSYSERR_NOERROR = rc) Then
- CD_SetVolume = True
- Else
- CD_SetVolume = False
- End If
- End Function
- Sub WAVE_GetVolume()
- On Error Resume Next
- id = -0
- Dim i As Long
- i = waveOutGetVolume(id, mWaveVol)
- mVol.mWaveVol = mWaveVol
- LSet VolSetting = mVol
- LeftVol = VolSetting.LeftVol: RightVol = VolSetting.RightVol
- LeftVol = LeftVol - &HFFF
- RightVol = RightVol - &HFFF
- If LeftVol < -32768 Then LeftVol = 65535 + LeftVol
- If RightVol < -32768 Then RightVol = 65535 + RightVol
- VolSetting.LeftVol = LeftVol
- VolSetting.RightVol = RightVol
- LSet mVol = VolSetting
- mWaveVol = mVol.mWaveVol
- ghtr = Left(LeftVol, 1)
- If ghtr = "-" Then
- GoTo NegVal
- End If
- q = CStr(LeftVol / PosStepVal)
- If Val(q) < 1 Then q = "1"
- If Val(q) > 6 Then q = "6"
- Exit Sub
- NegVal:
- q = CStr((LeftVol * -1) / NegStepVal)
- If Val(q) < 7 Then q = "7"
- If Val(q) > 10 Then q = "10"
- End Sub
- Private Sub ButtonsOn(Onoff As Boolean)
- ' If the device is open, close it.
- If Not mmControl1.Mode = vbMCIModeNotOpen Then
- mmControl1.Command = "Close"
- End If
- cmdCDLoad.Visible = False ' Till if cmdCD is chosen
- cboTrack.Clear
- cboTrack.Enabled = False
- If Onoff Then
- mmControl1.Visible = False
-
- cmdCD.Enabled = True
- cmdWave.Enabled = True
- cmdMidi.Enabled = True
-
- ' Volume
- lblVolume.Visible = False
- picVolume.Visible = False
- cmdVolInc.Visible = False
- cmdVolDec.Visible = False
-
- lblDevice.Caption = ""
- picVolume.Visible = False
- lblTotalTrack.Visible = False
- cboTrack.Visible = False
-
- lblDuration.Visible = False
- lblDurationValue.Visible = False
-
- Else
- mmControl1.Visible = True
-
- cmdCD.Enabled = False
- cmdWave.Enabled = False
- cmdMidi.Enabled = False
-
- lblDuration.Visible = True
- lblDurationValue.Caption = ""
- lblDurationValue.Visible = True
-
- If mCD Then
- lblTotalTrack.Caption = "Total tracks:"
- lblTotalTrack.Visible = True
- cboTrack.Visible = True
- End If
- If mCD Or mWave Then
- lblVolume.Visible = True
- picVolume.Visible = True
- cmdVolInc.Visible = True
- cmdVolDec.Visible = True
- End If
- End If
- End Sub
- Private Sub cmdCD_Click()
- mCD = True
- mWave = False
- mMidi = False
- lblDevice.Caption = "CD Player"
- GoPlay1
- End Sub
- Private Sub cmdWave_Click()
- mCD = False
- mWave = True
- mMidi = False
- lblDevice.Caption = "WaveAudio"
- GoPlay2
- End Sub
- Private Sub cmdMidi_Click()
- mCD = False
- mWave = False
- mMidi = True
- lblDevice.Caption = "Sequencer"
- GoPlay2
- End Sub
- Private Sub GoPlay1()
- If CDOpenMixer Then
- ButtonsOn False
- cmdCDLoad.Visible = True ' Now let user see this button
- End If
- End Sub
- ' Triggered by user clicking cmdCDLoad
- Private Sub cmdCDLoad_Click()
- ' Open the CD device -- the disc must already be in the drive.
- On Error GoTo MCIerrhandler
- With mmControl1
- .DeviceType = "CDAudio"
- .UpdateInterval = 0
- .Wait = False
- End With
- cmdCDLoad.Visible = False ' User will see this again if eject CD
- mmControl1.TimeFormat = vbMCIFormatTmsf
- mmControl1.Command = "Open"
- mmControl1.Command = "pause"
- mTracks = mmControl1.Tracks
- mmControl1.To = "1"
- mmControl1.Command = "Seek"
- ' Fill list of track Nos.
- Dim i As Integer
- cboTrack.Clear
- For i = 1 To mTracks
- cboTrack.AddItem i
- Next i
- cboTrack.Text = cboTrack.List(0)
- DispTrackDuration
- mmControl1_PrevClick (0) ' Move to very start
-
-
- lblTotalTrack.Caption = "Total tracks: " & Str(mTracks)
- cboTrack.Enabled = True
- Exit Sub
- MCIerrhandler:
- ShowMCIerr
- Unload frmAudioPlayer
- End Sub
- Private Sub cbotrack_click()
- ' Set cboTrack value first
- cboTrack.ListIndex = Val(cboTrack.Text) - 1
- DispTrackDuration
- mmControl1.Command = "pause"
- mmControl1.TimeFormat = mciFormatTmsf
- mmControl1.To = Str$(cboTrack.ListIndex + 1)
- mmControl1.Command = "Seek"
- mmControl1.Track = Str$(cboTrack.ListIndex + 1)
- ' Once in play, disallow cboTrack, until cmdCDLoad is clicked again
- cboTrack.Enabled = False
- mmControl1.Command = "Play"
- End Sub
- Private Sub DispTrackDuration()
- On Error Resume Next
- If mCD Then
- ' Set correct Timefort to obtain milliseconds later
- mmControl1.TimeFormat = mciFormatMilliseconds
- ' Set track before calling to get tracklength
- If Val(mmControl1.Track) <= 1 Then
- mmControl1.Track = "1"
- End If
- mmControl1.Track = cboTrack.Text
- lblDurationValue.Caption = convertmmSec(mmControl1.TrackLength)
- mmControl1.TimeFormat = mciFormatTmsf
- End If
- End Sub
- Private Sub GoPlay2()
- On Error GoTo MCIerrhandler
- ButtonsOn False
- ' Obtain current Wave volume
- WAVE_GetVolume
- ' Set number of milliseconds between successive StatusUpdate events
- mmControl1.UpdateInterval = 0
- With gcdg
- .CancelError = True
- Select Case lblDevice.Caption
- Case "WaveAudio"
- .DialogTitle = "WaveAudio"
- .Filter = "(*.wav)|*.wav"
- Case "Sequencer"
- .DialogTitle = "Sequencer"
- .Filter = "(*.mid)|*.mid"
- End Select
-
- .FilterIndex = 1
- .Flags = vbOFNReadOnly Or vbOFNFileMustExist
- .FileName = ""
- End With
- FileNameRetry:
- gcdg.ShowOpen
- If Not gfso.FileExists(gcdg.FileName) Then
- GoTo FileNameRetry
- End If
- Select Case UCase(lblDevice.Caption)
- Case "Waveaudio"
- mmControl1.DeviceType = "WaveAudio"
- Case "SEQUENCER"
- mmControl1.DeviceType = "Sequencer"
- End Select
-
- With mmControl1
- .FileName = gcdg.FileName
- ' Allow the multimedia MCI control to stop before returning to application.
- .Wait = False
- .Command = "Open"
- .TimeFormat = vbMCIFormatMilliseconds
- End With
- On Error GoTo 0
- lblDurationValue.Caption = convertmmSec(mmControl1.Length)
- ' Exit to continue (to play)
- Exit Sub
- MCIerrhandler:
- ButtonsOn True
- If Err.Number <> 32755 Then
- ShowMCIerr
- Unload frmAudioPlayer
- End If
- End Sub
- Private Sub mmControl1_PlayClick(Cancel As Integer)
- ' Set the number of milliseconds between successive StatusUpdate events.
- If mCD Then
- If Val(mmControl1.Track) <= 1 Then
- mmControl1.Track = "1"
- End If
- cboTrack.Text = cboTrack.List(Val(mmControl1.Track) - 1)
- DispTrackDuration
- mmControl1.UpdateInterval = conCDInterval
- ' Once in play, disallow cboTrack, until cmdCDLoad is clicked again
- cboTrack.Enabled = False
- Else
- mmControl1.UpdateInterval = conWAVEInterval
- End If
- mmControl1.Command = "play"
- End Sub
- Private Sub mmControl1_PrevClick(Cancel As Integer)
- ' Set the number of milliseconds between successive
- ' StatusUpdate events.
- mmControl1.UpdateInterval = 0
- mmControl1.Command = "Prev"
- End Sub
- Private Sub mmControl1_EjectClick(Cancel As Integer)
- On Error GoTo MCIerrhandler
- ' Since user has ejected CD, may use LoadCD button again
- cmdCDLoad.Visible = True
- mmControl1.UpdateInterval = 0
- mmControl1.Command = "Eject"
- mmControl1.Command = "Close"
- On Error GoTo 0
- Exit Sub
- MCIerrhandler:
- ShowMCIerr
- End Sub
- Private Sub mmControl1_NextCompleted(ErrorCode As Long)
- cboTrack.Text = cboTrack.List(mmControl1.Track - 1)
- DispTrackDuration
- End Sub
- Private Sub mmControl1_PauseClick(Cancel As Integer)
- mmControl1.UpdateInterval = 0
- End Sub
- Private Sub mmControl1_PrevCompleted(ErrorCode As Long)
- ' By the time "completed", already in current track
- cboTrack.Text = cboTrack.List(mmControl1.Track - 1)
- DispTrackDuration
- End Sub
- Private Sub mmControl1_StopClick(Cancel As Integer)
- If mCD = True Then
- cboTrack.Text = cboTrack.List(0)
- lblDurationValue.Caption = ""
- mmControl1.Command = "pause"
- mmControl1.UpdateInterval = 0
- mmControl1.To = "1"
- mmControl1.Command = "Seek"
- mmControl1.Command = "close"
-
- cmdCDLoad.Visible = True
- End If
- End Sub
- Private Sub mmControl1_StatusUpdate()
- If mCD Then
- ' Set the track number to the current track.
- cboTrack.Text = cboTrack.List(mmControl1.Track - 1)
- DispTrackDuration
- Else
- ' If the device is not playing, reset to the beginning.
- If Not mmControl1.Mode = vbMCIModePlay Then
- mmControl1.UpdateInterval = 0
- End If
- End If
- End Sub
- Private Sub cmdVolDec_Click()
- If mCD Then
- CD_DecVolumeProc
- ElseIf mWave Then
- WAVE_DecVolumeProc
- End If
- End Sub
- Private Sub cmdVolInc_Click()
- If mCD Then
- CD_IncVolumeProc
- ElseIf mWave Then
- WAVE_IncVolumeProc
- End If
- End Sub
- Private Function CDOpenMixer() As Boolean
- CDOpenMixer = True
- ' Open the mixer with deviceID 0.
- rc = mixerOpen(hmixer, 0, 0, 0, 0)
- If ((MMSYSERR_NOERROR <> rc)) Then
- MsgBox "Couldn't open the mixer."
- CDOpenMixer = False
- Exit Function
- End If
-
- ' Get the waveout volume control
- OK = CD_GetVolume(hmixer, MIXERLINE_COMPONENTTYPE_DST_SPEAKERS, _
- MIXERCONTROL_CONTROLTYPE_VOLUME, volCtrl)
- If (OK = True) Then
- ' If the function successfully gets the volume control,
- ' the maximum and minimum values are specified by
- ' lMaximum and lMinimum
- Label1.Caption = volCtrl.lMinimum & " to " & volCtrl.lMaximum
- End If
-
- ' Get the microphone volume control
- OK = CD_GetVolume(hmixer, MIXERLINE_COMPONENTTYPE_SRC_MICROPHONE, _
- MIXERCONTROL_CONTROLTYPE_VOLUME, micCtrl)
- End Function
-
-
- Private Sub CD_DecVolumeProc()
- On Error Resume Next
- Dim cdvol As Long
- cdvol = gmixervolume - VolStelVal
- If cdvol < volCtrl.lMinimum Then
- cdvol = volCtrl.lMinimum
- End If
- CD_SetVolume hmixer, volCtrl, cdvol
- gmixervolume = cdvol
- End Sub
-
-
-
- Private Sub CD_IncVolumeProc()
- On Error Resume Next
- Dim cdvol As Long
- cdvol = gmixervolume + VolStelVal
- If cdvol > volCtrl.lMaximum Then
- cdvol = volCtrl.lMaximum
- End If
- CD_SetVolume hmixer, volCtrl, cdvol
- gmixervolume = cdvol
- End Sub
- Private Sub WAVE_DecVolumeProc()
- On Error Resume Next
- If q = "1" Then
- Exit Sub
- End If
- id = -0
- Dim i As Long
- i = waveOutGetVolume(id, mWaveVol)
- mVol.mWaveVol = mWaveVol
- LSet VolSetting = mVol
- LeftVol = VolSetting.LeftVol: RightVol = VolSetting.RightVol
- LeftVol = LeftVol - &HFFF
- RightVol = RightVol - &HFFF
- If LeftVol < -32768 Then LeftVol = 65535 + LeftVol
- If RightVol < -32768 Then RightVol = 65535 + RightVol
- VolSetting.LeftVol = LeftVol
- VolSetting.RightVol = RightVol
- LSet mVol = VolSetting
- mWaveVol = mVol.mWaveVol
- i = waveOutSetVolume(id, mWaveVol)
- WAVE_GetVolume
- End Sub
- Private Sub WAVE_IncVolumeProc()
- On Error Resume Next
- If q = "10" Then
- Exit Sub
- End If
- Dim dfre
- id = -0
- Dim i As Long
- i = waveOutGetVolume(id, mWaveVol)
- mVol.mWaveVol = mWaveVol
- LSet VolSetting = mVol
- LeftVol = VolSetting.LeftVol: RightVol = VolSetting.RightVol
- LeftVol = LeftVol + &HFFF
- RightVol = RightVol + &HFFF
- 'If LeftVol <= -30000 Then Exit Sub
- If LeftVol > 32767 Then LeftVol = LeftVol - 65536
- If RightVol > 32767 Then RightVol = RightVol - 65536
- VolSetting.LeftVol = LeftVol
- VolSetting.RightVol = RightVol
- LSet mVol = VolSetting
- mWaveVol = mVol.mWaveVol
- i = waveOutSetVolume(id, mWaveVol)
- WAVE_GetVolume
- End Sub
- Private Sub ShowMCIerr()
- Dim msg As String
- Select Case Err
- Case conMCIErrCannotLoadDriver
- msg = "Error load media device driver."
- Case conMCIErrDeviceOpen
- msg = "The device is not open or is not known."
- Case conMCIErrInvalidDeviceID
- msg = "Invalid device id."
- Case conMCIErrInvalidDeviceID
- msg = "Invalid filename."
- Case conMCIErrUnsupportedFunction
- msg = "Action not available for this device."
- Case Else
- msg = "Unknown error (" + Str$(Err) + ")."
- End Select
- MsgBox msg, 48, conMCIAppTIitle
- End Sub
- Private Function convertmmSec(ByVal TimeIn As Long) As String
- Dim intH As Integer, intM As Integer, intS As Integer
- Dim tmp As Long
- Dim strTime As String
- tmp = TimeIn / 1000
- intH = Int(tmp / 3600)
- tmp = tmp Mod 3600
- intM = Int(tmp / 60)
- tmp = tmp Mod 60
- intS = tmp
- If intH > 0 Then
- strTime = Trim(Str(intH)) & ":"
- Else
- strTime = ""
- End If
- If intM >= 10 Then
- strTime = strTime & Trim(Str(intM))
- ElseIf intM > 0 Then
- strTime = strTime & "0" & Trim(Str(intM))
- Else
- strTime = strTime & "00"
- End If
- strTime = strTime & ":"
- If intS >= 10 Then
- strTime = strTime & Trim(Str(intS))
- ElseIf intS > 0 Then
- strTime = strTime & "0" & Trim(Str(intS))
- Else
- strTime = strTime & "00"
- End If
- convertmmSec = strTime
- End Function
-