Just paste create a new class module and then paste this source code into it. You can name the module CDController.
'----------------------------------------------------------------------
'
' Module Name: CDController
' Written By: C&D Programming Corp.
' Create Date: 1/99
' Copyright: Copyright 1999 by C&D Programming Corp. Source
' code may not be reproduced except for use in a
' compiled executable. All rights reserved. If
' you would like to reprint any or all of this
' code please email us at info@codeoftheweek.com
'----------------------------------------------------------------------
Option Explicit
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 mciSendString Lib "winmm.dll" Alias "mciSendStringA" _
(ByVal lpstrCommand As String, ByVal lpstrReturnString As String, _
ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
Public Enum enumTimeFormat
tf_tmsf ' track/minute/second/frame
tf_milliseconds
End Enum
'
' Removes the trailing null from a string
'
Private Function RemoveNull(sData As String) As String
sData = Trim(sData)
If Len(sData) > 0 Then
If Right(sData, 1) = vbNullChar Then
sData = Left(sData, Len(sData) - 1)
End If
End If
RemoveNull = sData
End Function
'
' Retrieves the error string as defined in the multimedia library winmm.dll
'
Private Function ErrorString(lError As Long) As String
Dim sBuf As String
Dim lRet As Long
' pad out buffer
sBuf = String(129, " ")
lRet = mciGetErrorString(lError, sBuf, Len(sBuf))
sBuf = Trim(sBuf)
' remove null terminator
ErrorString = Left(sBuf, Len(sBuf) - 1)
End Function
'
' Initializes the cd audio player
'
Public Sub InitializeDevice()
CloseAll
SetupCDPlayer
SetTimeFormat tf_tmsf
End Sub
'
' sets up an alias that is used in the other functions and routines in this class
'
Private Sub SetupCDPlayer()
Dim lRet As Long
lRet = mciSendString("open cdaudio alias cd wait shareable", 0, 0, 0)
If lRet <> 0 Then
Err.Raise 5, "SetupCDPlayer", ErrorString(lRet)
End If
End Sub
'
' closes all channels this class opened
'
Public Sub CloseAll()
Dim lRet As Long
lRet = mciSendString("close all", 0, 0, 0)
If lRet <> 0 Then
Err.Raise 5, "CloseAll", ErrorString(lRet)
End If
End Sub
'
' sets the appropriate time format for the cd audio device. This routine will
' determine how functions like Position return the information to the calling
' routines.
'
Public Sub SetTimeFormat(eTimeFormat As enumTimeFormat)
Dim lRet As Long
Select Case eTimeFormat
Case tf_tmsf
lRet = mciSendString("set cd time format tmsf wait", 0, 0, 0)
Case tf_milliseconds
lRet = mciSendString("set cd time format milliseconds", 0, 0, 0)
End Select
If lRet <> 0 Then
Err.Raise 5, "SetTimeFormat", ErrorString(lRet)
End If
End Sub
'
' Starts playing an audio CD. You can optionally specify the start and finish track.
' If no track numbers are specified it will play the entire cd.
'
Public Sub Play(Optional lStartTrack As Long = 0, Optional lFinishTrack As Long = 0)
Dim lRet As Long
If lStartTrack = 0 And lFinishTrack = 0 Then
lRet = mciSendString("play cd", 0, 0, 0)
Else
If lStartTrack <> 0 And lFinishTrack = 0 Then
lRet = mciSendString("play cd from " & lStartTrack & " to " & TrackCount, 0, 0, 0)
Else
lRet = mciSendString("play cd from " & lStartTrack & " to " & lFinishTrack, 0, 0, 0)
End If
End If
If lRet <> 0 Then
Err.Raise 5, "Play", ErrorString(lRet)
End If
End Sub
'
' Stops playing the CD. We could not determine what exactly is different
' between stop cd and pause cd (at least in our configuration).
'
Public Sub StopNow() ' Stop is a reserved word so we used StopNow instead
Dim lRet As Long
lRet = mciSendString("stop cd wait", 0, 0, 0)
If lRet <> 0 Then
Err.Raise 5, "StopNow", ErrorString(lRet)
End If
End Sub
'
' Pauses playing the CD. We could not determine what exactly is different
' between stop cd and pause cd (at least in our configuration).
'
Public Sub Pause()
Dim lRet As Long
lRet = mciSendString("pause cd", 0, 0, 0)
If lRet <> 0 Then
Err.Raise 5, "Pause", ErrorString(lRet)
End If
End Sub
'
' Determines if there is any cd media present in the cd device.
' Returns True or False
'
Public Function IsMediaPresent() As Boolean
Dim sRet As String
Dim lRet As Long
sRet = String(50, " ")
lRet = mciSendString("status cd media present", sRet, Len(sRet), 0)
If lRet <> 0 Then
Err.Raise 5, "IsMediaPresent", ErrorString(lRet)
End If
IsMediaPresent = Trim(Left(sRet, 5))
End Function
'
' Returns the number of tracks on the cd media. Data cd's usually
' return 1 track and audio cd's will return the number of tracks defined
' by the manufacturer.
'
Public Function TrackCount() As Long
Dim sRet As String
Dim lRet As Long
sRet = String(50, " ")
mciSendString "status cd number of tracks wait", sRet, Len(sRet), 0
If lRet <> 0 Then
Err.Raise 5, "TrackCount", ErrorString(lRet)
End If
TrackCount = CLng(Trim(sRet))
End Function
'
' Retrieves the track number the cd device is currently playing or cued to
' play.
'
Public Property Get TrackNumber() As Long
Dim sRet As String
Dim lRet As Long
sRet = String(50, " ")
mciSendString "status cd current track wait", sRet, Len(sRet), 0
If lRet <> 0 Then
Err.Raise 5, "CurrentTrack", ErrorString(lRet)
End If
TrackNumber = CLng(RemoveNull(sRet))
End Property
'
' Sets the track number that the cd device is playing or cued to play.
' If the cd was playing at the start of this call it will be playing at
' the end of this call unless an error occurs.
'
Public Property Let TrackNumber(lTrack As Long)
Dim lRet As Long
Dim bWasPlaying As Boolean
bWasPlaying = IsPlaying
If bWasPlaying Then
Pause
End If
lRet = mciSendString("seek cd to " & lTrack & " wait", 0, 0, 0)
If lRet <> 0 And lRet <> 282 Then ' attempt to seek byond end of CD
Err.Raise 5, "TrackNumber", ErrorString(lRet)
End If
If bWasPlaying Then
Play
End If
End Property
'
' All devices can return the "not ready", "paused", "playing", and "stopped" values.
' Some devices can return the additional "open", "parked", "recording", and
' "seeking" values.
'
Public Function Mode() As String
Dim sRet As String
Dim lRet As Long
sRet = String(50, " ")
lRet = mciSendString("status cd mode wait", sRet, Len(sRet), 0)
If lRet <> 0 Then
Err.Raise 5, "Mode", ErrorString(lRet)
End If
Mode = RemoveNull(sRet)
End Function
'
' Returns the current position of the cd device as set in SetTimeFormat
'
Public Property Get Position() As String
Dim sRet As String
Dim lRet As Long
sRet = String(50, " ")
lRet = mciSendString("status cd position wait", sRet, Len(sRet), 0)
If lRet <> 0 Then
Err.Raise 5, "Position", ErrorString(lRet)
End If
Position = RemoveNull(sRet)
End Property
'
' Sets the position of the cd device using the time format specified in
' SetTimeFormat
'
Public Property Let Position(sPosition As String)
Dim lRet As Long
lRet = mciSendString("seek cd to " & sPosition, 0, 0, 0)
If lRet <> 0 Then
Err.Raise 5, "Position", ErrorString(lRet)
End If
End Property
'
' Takes an tmsf format position string and converts it to the track number and
' position into that track number. A future version of this class will include
' additional features to perform various mathematical functions on tmsf strings
'
Public Sub SplitPosition(sPos As String, lTrack As Long, sTimeInto As String)
If InStr(sPos, ":") <> 0 Then
lTrack = CLng(Left(sPos, 2))
sTimeInto = Mid$(sPos, 4)
Else
sTimeInto = sPos
End If
End Sub
'
' Retrieves the length of the cd disc currently loaded in the time format
' specified by SetTimeFormat
'
Public Property Get LengthOfDisc() As String
Dim sRet As String
Dim lRet As Long
sRet = String(50, " ")
lRet = mciSendString("status cd length wait", sRet, Len(sRet), 0)
If lRet <> 0 Then
Err.Raise 5, "LengthOfDisc", ErrorString(lRet)
End If
LengthOfDisc = RemoveNull(sRet)
End Property
'
' Retrieves the length of the track specified by lTrack in the time format
' specified by SetTimeFormat
'
Public Function LengthOfTrack(lTrack As Long) As String
Dim sRet As String
Dim lRet As Long
sRet = String(50, " ")
lRet = mciSendString("status cd length track " & lTrack & " wait", sRet, Len(sRet), 0)
If lRet <> 0 Then
Err.Raise 5, "LengthOfTrack", ErrorString(lRet)
End If
LengthOfTrack = RemoveNull(sRet)
End Function
'
' Returns true if the cd is currently playing
'
Public Function IsPlaying() As Boolean
IsPlaying = (Mode = "playing")
End Function
'
' Begin playing the current track at the beginning
'
Public Sub RewindTrack()
Dim lTrack As Long
lTrack = TrackNumber
If IsPlaying Then
TrackNumber = lTrack
Play
Else
TrackNumber = lTrack
End If
End Sub
'
' Loads a listbox with a listing of the available track on the currently
' loaded cd. This can be easily modified to work load information from a
' database to show track names and stuff like that. It might even be useful
' to see this as a small user control that you can paste into your project.
' If anybody wants to write that for publication, let us know at
' publish@codeoftheweek.com
'
Public Sub FillTrackList(lst As ListBox)
Dim lTracks As Long
Dim lTrack As Long
lTracks = TrackCount
For lTrack = 1 To lTracks
lst.AddItem lTrack & " - " & LengthOfTrack(lTrack)
Next
End Sub