by Waty Thierry (60 Submissions)
Category: Sound/MP3
Compatability: Visual Basic 4.0 (32-bit)
Difficulty: Unknown Difficulty
Originally Published: Tue 13th April 1999
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
Interact with CD's without using the Microsoft Multimedia Control.
VBcoders
' * Programmer Name : Waty Thierry
' * Web Site : www.geocities.com/ResearchTriangle/6311/
' * E-Mail : [email protected]
' * Date : 29/10/98
' * Time : 14:31
' * Module Name : class_CDAudio
' * Module Filename : CDAudio.cls
' **********************************************************************
' * Comments : This class allows you to interact with CD's
' * without using the Microsoft Multimedia Control.
' *
' **********************************************************************
' Windows API Declarations
Private Type MCI_OPEN_PARMS
dwCallback As Long
wDeviceID As Long
lpstrDeviceType As String
lpstrElementName As String
lpstrAlias As String
End Type
Private Type MCI_GENERIC_PARMS
dwCallback As Long
End Type
Private Type MCI_SET_PARMS
dwCallback As Long
dwTimeFormat As Long
dwAudio As Long
End Type
Private Type MCI_PLAY_PARMS
dwCallback As Long
dwFrom As Long
dwTo As Long
End Type
Private Type MCI_STATUS_PARMS
dwCallback As Long
dwReturn As Long
dwItem As Long
dwTrack As Integer
End Type
Private mOpenParams As MCI_OPEN_PARMS
Private Const MCI_STATUS_NUMBER_OF_TRACKS = &H3&
Private Const MCI_CLOSE = &H804
Private Const MCI_WAIT = &H2&
Private Const MCI_OPEN = &H803
Private Const MCI_FORMAT_MILLISECONDS = 0
Private Const MCI_SET = &H80D
Private Const MCI_OPEN_ELEMENT = &H200&
Private Const MCI_SET_TIME_FORMAT = &H400&
Private Const MCI_STOP = &H808
Private Const MCI_SEEK = &H807
Private Const MCI_SEEK_TO_START = &H100&
Private Const MCI_PLAY = &H806
Private Const MCI_NOTIFY = &H1&
Private Const MCI_STATUS_POSITION = &H2&
Private Const MCI_STATUS = &H814
Private Const MCI_STATUS_ITEM = &H100&
Private Const MCI_OPEN_SHAREABLE = &H100&
Private Const MCI_OPEN_TYPE = &H2000&
Private Const MCI_SET_DOOR_OPEN = &H100&
Private Const MCI_FORMAT_TMSF = 10
Private Const MCI_STATUS_LENGTH = &H1&
Private Const MCI_TRACK = &H10&
Private Const MCI_TO = &H8
Private Const MCI_FROM = &H4
Private Declare Function mciSendCommand _
Lib "winmm.dll" _
Alias "mciSendCommandA" _
(ByVal wDeviceID As Long, _
ByVal uMessage As Long, _
ByVal dwParam1 As Long, _
dwParam2 As Any) _
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 mcolTracks As Collection
Private m_fPlaying As Boolean
Private Const cintErrorStringLen As Integer = 100
Private Sub Class_Initialize()
' Set initial values
' Source: Total VB SourceBook 5
On Error GoTo PROC_ERR
mOpenParams.dwCallback = 0
mOpenParams.wDeviceID = 0
mOpenParams.lpstrDeviceType = "cdaudio"
mOpenParams.lpstrElementName = 0
mOpenParams.lpstrAlias = 0
PROC_EXIT:
Exit Sub
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"Class_Initialize"
Resume PROC_EXIT
End Sub
Private Sub Class_Terminate()
' Make sure the CD resource is closed
' Source: Total VB SourceBook 5
On Error GoTo PROC_ERR
CloseCD
PROC_EXIT:
Exit Sub
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"Class_Terminate"
Resume PROC_EXIT
End Sub
Public Property Get Minutes() As Integer
' Returns: the current minute position
' Source: Total VB SourceBook 5
Minutes = MCI_TMSF_MINUTE(GetPosition)
End Property
Public Property Let Minutes(ByVal intValue As Integer)
' intValue: Set the current minute position
' Source: Total VB SourceBook 5
SetPosition Track, intValue, Seconds
End Property
Public Property Let Seconds(ByVal intValue As Integer)
' intValue: Set the current second position
' Source: Total VB SourceBook 5
SetPosition Track, Minutes, intValue
End Property
Public Property Get Seconds() As Integer
' Returns: the current seconds position
' Source: Total VB SourceBook 5
Seconds = MCI_TMSF_SECOND(GetPosition)
End Property
Public Property Let Track(ByVal intValue As Integer)
' intValue: Set the current track position
' Source: Total VB SourceBook 5
SetPosition intValue, Minutes, Seconds
End Property
Public Property Get Track() As Integer
' Returns: the current track
' Source: Total VB SourceBook 5
Track = MCI_TMSF_TRACK(GetPosition)
End Property
Public Property Get Tracks() As Collection
' Returns: the tracks collection
' Source: Total VB SourceBook 5
On Error GoTo PROC_ERR
Set Tracks = mcolTracks
PROC_EXIT:
Exit Property
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"Tracks"
Resume PROC_EXIT
End Property
Public Sub CloseCD()
' Comments : Closes the CD resource
' Parameters: None
' Returns : Nothing
' Source : Total VB SourceBook 5
'
Dim gp As MCI_GENERIC_PARMS
Dim lngResult As Long
On Error GoTo PROC_ERR
If mOpenParams.wDeviceID <> 0 Then
' The CD is open
' Stop it if it is playing
StopCD
' close the CD device
lngResult = mciSendCommand(mOpenParams.wDeviceID, MCI_CLOSE, MCI_WAIT, gp)
mOpenParams.wDeviceID = 0
End If
PROC_EXIT:
Exit Sub
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"CloseCd"
Resume PROC_EXIT
End Sub
Public Sub Eject()
' Comments : Ejects the CD from the drive
' Parameters: None
' Returns : Nothing
' Source : Total VB SourceBook 5
'
Dim mciSet As MCI_SET_PARMS
Dim lngFlags As Long
Dim lngResult As Long
Dim strErrorDescription As String
On Error GoTo PROC_ERR
' Open the cd door
lngFlags = MCI_SET_DOOR_OPEN
lngResult = mciSendCommand(mOpenParams.wDeviceID, MCI_SET, lngFlags, mciSet)
' Throw an error if one occured
If lngResult <> 0 Then
strErrorDescription = Space$(cintErrorStringLen)
mciGetErrorString lngResult, strErrorDescription, cintErrorStringLen
Err.Raise lngResult, , strErrorDescription
End If
PROC_EXIT:
Exit Sub
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"Eject"
Resume PROC_EXIT
End Sub
Public Sub OpenCD()
' Comments : Opens the CD resource
' Parameters: None
' Returns : Nothing
' Source : Total VB SourceBook 5
'
Const cstrDeviceName As String = "cdaudio"
Dim lngResult As Long
Dim strErrorDescription As String
Dim mciSet As MCI_SET_PARMS
On Error GoTo PROC_ERR
' Close the CD if it is open
If mOpenParams.wDeviceID <> 0 Then
CloseCD
End If
mOpenParams.lpstrDeviceType = cstrDeviceName
lngResult = mciSendCommand(0, MCI_OPEN, MCI_WAIT Or MCI_OPEN_SHAREABLE Or _
MCI_OPEN_TYPE, mOpenParams)
' Throw an error if one occured
If lngResult <> 0 Then
strErrorDescription = Space$(cintErrorStringLen)
mciGetErrorString lngResult, strErrorDescription, cintErrorStringLen
Err.Raise lngResult, , strErrorDescription
End If
' Set the time format
mciSet.dwTimeFormat = MCI_FORMAT_TMSF
lngResult = mciSendCommand(mOpenParams.wDeviceID, MCI_SET, MCI_WAIT Or _
MCI_SET_TIME_FORMAT, mciSet)
' Throw an error if one occured
If lngResult <> 0 Then
strErrorDescription = Space$(cintErrorStringLen)
mciGetErrorString lngResult, strErrorDescription, cintErrorStringLen
Err.Raise lngResult, , strErrorDescription
End If
' Enumerate the tracks on the CD
EnumTracks
PROC_EXIT:
Exit Sub
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"OpenCD"
Resume PROC_EXIT
End Sub
Public Sub Pause()
' Comments : Pauses CD Play
' Parameters: None
' Returns : Nothing
' Source : Total VB SourceBook 5
'
Dim lngResult As Long
On Error GoTo PROC_ERR
' Tell the CD device to pause
lngResult = mciSendCommand(mOpenParams.wDeviceID, MCI_STOP, MCI_WAIT, 0)
m_fPlaying = False
PROC_EXIT:
Exit Sub
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"Pause"
Resume PROC_EXIT
End Sub
Public Sub Play()
' Comments : Plays the CD
' Parameters: None
' Returns : Nothing
' Source : Total VB SourceBook 5
'
Dim lngResult As Long
Dim strErrorDescription As String
Dim mciPlay As MCI_PLAY_PARMS
On Error GoTo PROC_ERR
' Tell the CD device to begin playing
lngResult = mciSendCommand(mOpenParams.wDeviceID, MCI_PLAY, MCI_NOTIFY, _
mciPlay)
' Throw an error if one occured
If lngResult <> 0 Then
strErrorDescription = Space$(cintErrorStringLen)
mciGetErrorString lngResult, strErrorDescription, cintErrorStringLen
Err.Raise lngResult, , strErrorDescription
End If
'Set the playing flag to True
m_fPlaying = True
PROC_EXIT:
Exit Sub
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"Play"
Resume PROC_EXIT
End Sub
Public Sub StopCD()
' Comments : Stops the CD
' Parameters: None
' Returns : Nothing
' Source : Total VB SourceBook 5
'
Dim lngResult As Long
On Error GoTo PROC_ERR
' Tell the cd device to stop
lngResult = mciSendCommand(mOpenParams.wDeviceID, MCI_STOP, MCI_WAIT, 0)
' Reset play position
m_fPlaying = False
SetPosition 1, 0, 0
PROC_EXIT:
Exit Sub
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"StopCD"
Resume PROC_EXIT
End Sub
Private Function dblToLong(ByVal dblNumber As Double) As Long
' Comments : This routine does an unsigned conversion from a double Value
' to a long Value. This procedure correctly handles any double
' value
' Parameters: dblNumber - the double value to convert to a long
' Returns : long
' Source : Total VB SourceBook 5
'
Dim dblDivisor As Double
Dim dblTemp As Double
On Error GoTo PROC_ERR
' Visual basic does not allow you enter the value &H100000000 directly,
' so we enter &H7FFFFFFF, double it and add two to create it.
dblDivisor = &H7FFFFFFF
dblDivisor = (dblDivisor * 2) + 2
'if the number is larger than a long can store, then truncate it
If dblNumber > dblDivisor Or dblNumber < 0 Then
dblTemp = dblNumber - (Int(dblNumber / dblDivisor) * dblDivisor)
Else
dblTemp = dblNumber
End If
' if the number is greater than a signed long, convert it to a
' negative
If dblTemp > &H7FFFFFFF Then
dblToLong = dblTemp - dblDivisor
ElseIf dblTemp < 0 Then
' If the number is negative
dblToLong = dblDivisor + dblTemp
Else
dblToLong = dblTemp
End If
PROC_EXIT:
Exit Function
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"dblToLong"
Resume PROC_EXIT
End Function
Private Sub EnumTracks()
' Comments : Enumerates the tracks on a cd
' Parameters: None
' Returns : Nothing
' Source : Total VB SourceBook 5
'
Dim status As MCI_STATUS_PARMS
Dim mciSet As MCI_SET_PARMS
Dim lngFlags As Long
Dim strErrorDescription As String
Dim lngResult As Long
Dim intCounter As Integer
Dim intTrackCount As Integer
On Error GoTo PROC_ERR
' Set the time format
mciSet.dwTimeFormat = MCI_FORMAT_TMSF
lngFlags = MCI_SET_TIME_FORMAT
lngResult = mciSendCommand(mOpenParams.wDeviceID, MCI_SET, lngFlags, mciSet)
' Throw an error if one occured
If lngResult <> 0 Then
strErrorDescription = Space$(cintErrorStringLen)
mciGetErrorString lngResult, strErrorDescription, cintErrorStringLen
Err.Raise lngResult, , strErrorDescription
End If
' Get the number of tracks
lngFlags = MCI_STATUS_ITEM
status.dwItem = MCI_STATUS_NUMBER_OF_TRACKS
lngResult = mciSendCommand(mOpenParams.wDeviceID, MCI_STATUS, lngFlags, _
status)
' Throw an error if one occured
If lngResult <> 0 Then
strErrorDescription = Space$(cintErrorStringLen)
mciGetErrorString lngResult, strErrorDescription, cintErrorStringLen
Err.Raise lngResult, , strErrorDescription
End If
' Set up the tracks collection
intTrackCount = status.dwReturn
Set mcolTracks = New Collection
For intCounter = 0 To intTrackCount - 1
status.dwItem = MCI_STATUS_LENGTH
status.dwTrack = intCounter + 1
mciSendCommand mOpenParams.wDeviceID, MCI_STATUS, MCI_TRACK Or _
MCI_STATUS_ITEM, status
' Convert from the length returned from MCI to the length in seconds,
' then add it to the collection
mcolTracks.Add (60 * (((status.dwReturn And &H7FFF)) And 255)) + _
(((status.dwReturn And &H7FFF) / 256) And 255)
Next intCounter
PROC_EXIT:
Exit Sub
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"EnumTracks"
Resume PROC_EXIT
End Sub
Private Function GetPosition() As Long
' Comments : This function returns the current of the playback of the MCI
' device
' Parameters: None
' Returns : The current position in Track/Minute/Second format
' Source : Total VB SourceBook 5
'
Dim status As MCI_STATUS_PARMS
Dim mciSet As MCI_SET_PARMS
Dim lngFlags As Long
Dim lngResult As Long
Dim strErrorDescription As String
On Error GoTo PROC_ERR
' Set the time format
mciSet.dwTimeFormat = MCI_FORMAT_TMSF
lngFlags = MCI_SET_TIME_FORMAT
lngResult = mciSendCommand(mOpenParams.wDeviceID, MCI_SET, lngFlags, mciSet)
' Throw an error if one occured
If lngResult <> 0 Then
strErrorDescription = Space$(cintErrorStringLen)
mciGetErrorString lngResult, strErrorDescription, cintErrorStringLen
Err.Raise lngResult, , strErrorDescription
End If
' Get the position
lngFlags = MCI_STATUS_ITEM
status.dwItem = MCI_STATUS_POSITION
lngResult = mciSendCommand(mOpenParams.wDeviceID, MCI_STATUS, lngFlags, _
status)
' Throw an error if one occured
If lngResult <> 0 Then
strErrorDescription = Space$(cintErrorStringLen)
mciGetErrorString lngResult, strErrorDescription, cintErrorStringLen
Err.Raise lngResult, , strErrorDescription
End If
' Return the position
GetPosition = status.dwReturn
PROC_EXIT:
Exit Function
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"GetPosition"
Resume PROC_EXIT
End Function
Private Function IntToByte(ByVal intNumber As Integer) As Byte
' Comments : This routine does an unsigned conversion from an integer value
' to a byte value. This procedure correctly handles any integer
' value
' Parameters: intNumber - the integer value to convert to a byte
' Returns : Byte
' Source : Total VB SourceBook 5
'
On Error GoTo PROC_ERR
IntToByte = intNumber And &HFF&
PROC_EXIT:
Exit Function
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"IntToByte"
Resume PROC_EXIT
End Function
Private Function IntToLong(ByVal intNumber As Integer) As Long
' Comments : This routine converts an integer value to a long value,
' treating the integer as unsigned
' Parameters: intNumber - the integer to convert to long
' Returns : long
' Source : Total VB SourceBook 5
'
On Error GoTo PROC_ERR
' This routine converts an integer value to a long value
If intNumber < 0 Then
IntToLong = intNumber + &H10000
Else
IntToLong = intNumber
End If
PROC_EXIT:
Exit Function
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"IntToLong"
Resume PROC_EXIT
End Function
Private Function LongToDbl(ByVal lngNumber As Long) As Double
' Comments : This routine converts a long Value to a double Value,
' treating the long as unsigned
' Parameters: lngNumber - the long to convert to double
' Returns : double
' Source : Total VB SourceBook 5
'
Dim dblDivisor As Double
On Error GoTo PROC_ERR
' Visual basic does not allow you enter the value &H100000000 directly,
' so we enter &H7FFFFFFF, double it and add two to create it.
dblDivisor = &H7FFFFFFF
dblDivisor = (dblDivisor * 2) + 2
If lngNumber < 0 Then
LongToDbl = lngNumber + dblDivisor
Else
LongToDbl = lngNumber
End If
PROC_EXIT:
Exit Function
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"LongToDbl"
Resume PROC_EXIT
End Function
Private Function LongToInt(ByVal lngNumber As Long) As Integer
' Comments : This routine does an unsigned conversion from a long value
' to an integer value. This procedure correctly handles any
' long value
' Parameters: lngNumber - the long value to convert to an integer
' Returns : Integer
' Source : Total VB SourceBook 5
'
On Error GoTo PROC_ERR
' This routine converts a long value to an integer
lngNumber = lngNumber And &HFFFF&
If lngNumber > &H7FFF Then
LongToInt = lngNumber - &H10000
Else
LongToInt = lngNumber
End If
PROC_EXIT:
Exit Function
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"LongToInt"
Resume PROC_EXIT
End Function
Private Function MCI_MAKE_TMSF( _
intTrack As Integer, _
intMinute As Integer, _
intSecond As Integer) _
As Long
' Comments : This function converts from Tracks/Minute/Seconds to a position
' usable by MCI
' Parameters: intTrack - The track position
' intMinute - The minute position
' intSecond - The seconds position
' Returns : The converted position
' Source : Total VB SourceBook 5
'
On Error GoTo PROC_ERR
MCI_MAKE_TMSF = CLng(intTrack) Or CLng(Shli(intMinute, 8)) Or _
CLng(Shll(intSecond, 16))
PROC_EXIT:
Exit Function
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"MCI_MAKE_TMSF"
Resume PROC_EXIT
End Function
Private Function MCI_TMSF_MINUTE(lngTime As Long) As Byte
' Comments : This function converts a position returned from MCI to
' a minute values
' Parameters: lngTime - The position value returned from MCI
' Returns : The minute
' Source : Total VB SourceBook 5
'
On Error GoTo PROC_ERR
MCI_TMSF_MINUTE = IntToByte(Shri(LongToInt(lngTime), 8))
PROC_EXIT:
Exit Function
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"MCI_TMSF_MINUTE"
Resume PROC_EXIT
End Function
Private Function MCI_TMSF_SECOND(lngTime As Long) As Byte
' Comments : This function converts a position returned from MCI to
' a seconds values
' Parameters: lngTime - The position value returned from MCI
' Returns : The seconds
' Source : Total VB SourceBook 5
'
On Error GoTo PROC_ERR
MCI_TMSF_SECOND = IntToByte(LongToInt(Shrl(lngTime, 16)))
PROC_EXIT:
Exit Function
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"MCI_TMSF_SECOND"
Resume PROC_EXIT
End Function
Private Function MCI_TMSF_TRACK(lngTime As Long) As Byte
' Comments : This function converts a position returned from MCI to
' a track values
' Parameters: lngTime - The position value returned from MCI
' Returns : The track
' Source : Total VB SourceBook 5
'
On Error GoTo PROC_ERR
MCI_TMSF_TRACK = IntToByte(LongToInt(lngTime))
PROC_EXIT:
Exit Function
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"MCI_TMSF_TRACK"
Resume PROC_EXIT
End Function
Private Sub SetPosition( _
intTrack As Integer, _
intMinute As Integer, _
intSecond As Integer)
' Comments : This procedure set the current position of the MCI playback
' Parameters: intTrack - The track position
' intMinute - The minute position
' intSecond - The seconds position
' Returns : Nothing
' Source : Total VB SourceBook 5
'
Dim mciPlay As MCI_PLAY_PARMS
Dim mciSet As MCI_SET_PARMS
Dim lngFlags As Long
Dim lngResult As Long
Dim strErrorDescription As String
On Error GoTo PROC_ERR
' Set the time format
mciSet.dwTimeFormat = MCI_FORMAT_TMSF
lngFlags = MCI_SET_TIME_FORMAT
lngResult = mciSendCommand(mOpenParams.wDeviceID, MCI_SET, lngFlags, mciSet)
' Throw an error if one occured
If lngResult <> 0 Then
strErrorDescription = Space$(cintErrorStringLen)
mciGetErrorString lngResult, strErrorDescription, cintErrorStringLen
Err.Raise lngResult, , strErrorDescription
End If
lngFlags = MCI_TO Or MCI_WAIT
If (m_fPlaying) Then
' If we are already playing, tell the cd to play from the new position
mciPlay.dwFrom = MCI_MAKE_TMSF(intTrack, intMinute, intSecond)
lngResult = mciSendCommand(mOpenParams.wDeviceID, MCI_PLAY, MCI_FROM, _
mciPlay)
Else
' If the cd is stopped or paused, set the play from and to parameters to
' the same value. This will keep the cd from playing
mciPlay.dwTo = MCI_MAKE_TMSF(intTrack, intMinute, intSecond)
mciPlay.dwFrom = MCI_MAKE_TMSF(intTrack, intMinute, intSecond)
lngResult = mciSendCommand(mOpenParams.wDeviceID, MCI_PLAY, MCI_FROM Or _
MCI_TO, mciPlay)
End If
' Throw an error if one occured
If lngResult <> 0 Then
strErrorDescription = Space$(cintErrorStringLen)
mciGetErrorString lngResult, strErrorDescription, cintErrorStringLen
Err.Raise lngResult, , strErrorDescription
End If
PROC_EXIT:
Exit Sub
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"SetPosition"
No comments have been posted about Interact with CD's without using the Microsoft Multimedia Control.. Why not be the first to post a comment about Interact with CD's without using the Microsoft Multimedia Control..
