CD |
Description: | |
This provides a few audio type functions via API. Basic play, stop, open, close, next and previous are here. Also, it can compute a unique CD ID based off track length, compatible with the CDDB (this part is based off code available on their webiste) 6/16/1999: Added Get_MCI_ID function that returns an ID compatible with CD Player. 7/30/1999: Added NumTracks, TrackLength and CDLength functions. Renamed Get_MCI_ID to MCI_ID. 11/17/1999: Added PlayRandomTrack | |
Code: | |
Option Explicit '--- Functions 'CDLength() As String 'CurrentTrack() As Long 'ID() As String 'CDDB compatible ID 'MCI_ID() As String 'CD Player compatible ID 'NumTracks() As Long 'Position() As String 'Status() As enumStatus 'TrackLength(nTrack As Long) As String '--- Subroutines 'CloseDrive() 'NextTrack() 'OpenDrive() 'PauseCD() 'PlayCD() 'PlayRandomTrack() 'PreviousTrack() 'SeekToBegining() 'StopCD() 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 Type MCI_OPEN_PARMS dwCallback As Long wDeviceID As Long lpstrDeviceType As String lpstrElementName As String lpstrAlias As String End Type Private Type MCI_SET_PARMS dwCallback As Long dwTimeFormat As Long dwAudio As Long End Type Private Type MCI_STATUS_PARMS dwCallback As Long dwReturn As Long dwItem As Long dwTrack As Integer End Type Private Type MCI_PLAY_PARMS dwCallback As Long dwFrom As Long dwTo As Long End Type Private Type MCI_INFO_PARMS dwCallback As Long lpstrReturn As String dwRetSize As Long End Type Private Declare Function mciSendCommand Lib "winmm.dll" Alias _ "mciSendCommandA" _ (ByVal wDeviceID As Long, ByVal uMessage As Long, ByVal dwParam1 As _ Long, ByRef dwParam2 As Any) As Long Private Const MCI_STRING_OFFSET = 512 Public Enum enumStatus statusNotReady = MCI_STRING_OFFSET + 12 statusPause = MCI_STRING_OFFSET + 13 statusPlay = MCI_STRING_OFFSET + 14 statusStop = MCI_STRING_OFFSET + 15 statusOpen = MCI_STRING_OFFSET + 16 statusRecord = MCI_STRING_OFFSET + 17 statusSeek = MCI_STRING_OFFSET + 18 End Enum Private Const MCI_FROM = &H4& Private Const MCI_STATUS_POSITION = &H2& Private Const MCI_STATUS_CURRENT_TRACK = &H8& Private Const MCI_STATUS_MODE = &H4& Private Const MCI_STOP = &H808 Private Const MCI_PAUSE = &H809 Private Const MCI_SEEK_TO_START = &H100& Private Const MMSYSERR_NOERROR = 0 Private Const MCI_CLOSE = &H804 Private Const MCI_FORMAT_MILLISECONDS = 0 Private Const MCI_FORMAT_MSF = 2 Private Const MCI_OPEN = &H803 Private Const MCI_OPEN_ELEMENT = &H200& Private Const MCI_OPEN_SHAREABLE = &H100& Private Const MCI_OPEN_TYPE = &H2000& Private Const MCI_SET = &H80D Private Const MCI_SET_TIME_FORMAT = &H400& Private Const MCI_SEEK = &H807 Private Const MCI_SEEK_TO_END = &H200& Private Const MCI_TO = &H8& Private Const MCI_WAIT = &H2& Private Const MCI_STATUS_ITEM = &H100& Private Const MCI_STATUS_LENGTH = &H1& Private Const MCI_STATUS_NUMBER_OF_TRACKS = &H3& Private Const MCI_TRACK = &H10& Private Const MCI_STATUS = &H814 Private Const MCI_SET_DOOR_OPEN = &H100& Private Const MCI_SET_DOOR_CLOSED = &H200& Private Const MCI_PLAY = &H806 Private Const MCI_INFO = &H80A Private Const MCI_INFO_MEDIA_IDENTITY = &H800& Private mciOpenParms As MCI_OPEN_PARMS Private mciSetParms As MCI_SET_PARMS Private mciStatusParms As MCI_STATUS_PARMS Private mciPlayParms As MCI_PLAY_PARMS Private mciInfoParms As MCI_INFO_PARMS Private Type TTrackInfo Minutes As Long Seconds As Long Frames As Long FrameOffset As Long End Type Private m_Error As Long Private m_CID As String Private m_DeviceID As Long Private m_NTracks As Integer Private m_Length As Long Private m_Tracks() As TTrackInfo Private m_LastPos As Long Private Sub Class_Initialize() m_CID = "(unavailable)" m_Error = 0 m_DeviceID = -1 m_NTracks = 0 OpenCD End Sub Private Sub Class_Terminate() If m_DeviceID <> -1 Then CloseCD End If End Sub Public Function Status() As enumStatus mciStatusParms.dwItem = MCI_STATUS_MODE mciSendCommand m_DeviceID, MCI_STATUS, MCI_WAIT Or MCI_STATUS_ITEM, _ mciStatusParms Status = mciStatusParms.dwReturn End Function Public Function CurrentTrack() As Long mciStatusParms.dwItem = MCI_STATUS_CURRENT_TRACK mciSendCommand m_DeviceID, MCI_STATUS, MCI_WAIT Or MCI_STATUS_ITEM, _ mciStatusParms CurrentTrack = mciStatusParms.dwReturn End Function Public Function Position() As String Dim nPos As Long Dim nTrackPos As Long Dim nIndex As Long Dim nF As Long Dim nS As Long Dim nM As Long mciStatusParms.dwItem = MCI_STATUS_POSITION mciSendCommand m_DeviceID, MCI_STATUS, MCI_WAIT Or MCI_STATUS_ITEM, _ mciStatusParms m_LastPos = mciStatusParms.dwReturn nF = (mciStatusParms.dwReturn \ 65536) And &HFF nS = (mciStatusParms.dwReturn \ 256) And &HFF nM = (mciStatusParms.dwReturn) And &HFF nPos = (nM * 60 * 75) + (nS * 75) + (nF) mciStatusParms.dwTrack = CurrentTrack mciStatusParms.dwItem = MCI_STATUS_POSITION mciSendCommand m_DeviceID, MCI_STATUS, MCI_STATUS_ITEM Or MCI_TRACK, _ mciStatusParms nF = (mciStatusParms.dwReturn \ 65536) And &HFF nS = (mciStatusParms.dwReturn \ 256) And &HFF nM = (mciStatusParms.dwReturn) And &HFF nTrackPos = (nM * 60 * 75) + (nS * 75) + (nF) nPos = nPos - nTrackPos nF = nPos Mod 75 nPos = nPos \ 75 nS = nPos Mod 60 nPos = nPos \ 60 nM = nPos Position = Format(nM, "0") & ":" & Format(nS, "00") End Function Public Function TrackLength(nTrack As Long) As String Dim nLength As Long Dim nF As Long Dim nS As Long Dim nM As Long mciStatusParms.dwItem = MCI_STATUS_LENGTH mciStatusParms.dwTrack = nTrack mciSendCommand m_DeviceID, MCI_STATUS, MCI_STATUS_ITEM Or _ MCI_TRACK, mciStatusParms nF = (mciStatusParms.dwReturn \ 65536) And &HFF nS = (mciStatusParms.dwReturn \ 256) And &HFF nM = (mciStatusParms.dwReturn) And &HFF TrackLength = Format(nM, "0") & ":" & Format(nS, "00") End Function Public Function CDLength() As String Dim dwPos As Long Dim dwPosS As Long Dim dwPosF As Long Dim dwPosM As Long Dim dwLenS As Long Dim dwLenF As Long Dim dwLenM As Long Dim nNumTracks As Long nNumTracks = NumTracks mciStatusParms.dwItem = MCI_STATUS_POSITION mciStatusParms.dwTrack = nNumTracks mciSendCommand m_DeviceID, MCI_STATUS, MCI_STATUS_ITEM Or _ MCI_TRACK, mciStatusParms dwPosF = (mciStatusParms.dwReturn \ 65536) And &HFF dwPosS = (mciStatusParms.dwReturn \ 256) And &HFF dwPosM = (mciStatusParms.dwReturn) And &HFF mciStatusParms.dwItem = MCI_STATUS_LENGTH mciStatusParms.dwTrack = nNumTracks mciSendCommand m_DeviceID, MCI_STATUS, MCI_STATUS_ITEM Or _ MCI_TRACK, mciStatusParms dwLenM = (mciStatusParms.dwReturn) And &HFF dwLenS = (mciStatusParms.dwReturn \ 256) And &HFF dwLenF = ((mciStatusParms.dwReturn \ 65536) And &HFF) + 1 dwPos = (dwPosM * 60 * 75) + (dwPosS * 75) + dwPosF + _ (dwLenM * 60 * 75) + (dwLenS * 75) + dwLenF dwLenF = dwPos Mod 75 dwPos = dwPos \ 75 dwLenS = dwPos Mod 60 dwPos = dwPos \ 60 dwLenM = dwPos CDLength = Format(dwLenM, "0") & ":" & Format(dwLenS, "00") End Function Public Sub NextTrack() Dim nTracks As Long mciStatusParms.dwItem = MCI_STATUS_NUMBER_OF_TRACKS mciSendCommand m_DeviceID, MCI_STATUS, MCI_STATUS_ITEM, mciStatusParms nTracks = mciStatusParms.dwReturn mciStatusParms.dwTrack = CurrentTrack + 1 If mciStatusParms.dwTrack > nTracks Then mciStatusParms.dwTrack = nTracks End If mciStatusParms.dwItem = MCI_STATUS_POSITION mciSendCommand m_DeviceID, MCI_STATUS, MCI_STATUS_ITEM Or MCI_TRACK, _ mciStatusParms m_LastPos = mciStatusParms.dwReturn PlayCD End Sub Public Sub PreviousTrack() mciStatusParms.dwTrack = CurrentTrack - 1 If mciStatusParms.dwTrack = 0 Then mciStatusParms.dwTrack = 1 End If mciStatusParms.dwItem = MCI_STATUS_POSITION mciSendCommand m_DeviceID, MCI_STATUS, MCI_STATUS_ITEM Or MCI_TRACK, _ mciStatusParms m_LastPos = mciStatusParms.dwReturn PlayCD End Sub Public Sub PlayCD() Dim n As Long CloseCD OpenCD mciPlayParms.dwFrom = m_LastPos If m_LastPos > 0 Then mciSendCommand m_DeviceID, MCI_PLAY, MCI_FROM, mciPlayParms Else mciSendCommand m_DeviceID, MCI_PLAY, 0, mciPlayParms End If End Sub Public Sub PlayRandomTrack() Dim n As Long Dim nTrack As Long nTrack = Int(Rnd * m_NTracks) CloseCD OpenCD LoadCDInfo Dim nTemp As Long Dim nTemp2 As Long nTemp = m_Tracks(nTrack).FrameOffset nTemp2 = (nTemp Mod 75) * 65536 nTemp2 = nTemp2 + ((nTemp \ 75) Mod 60) * 256 nTemp2 = nTemp2 + ((nTemp \ (75 * 60))) mciPlayParms.dwFrom = nTemp2 nTemp = m_Tracks(nTrack + 1).Frames + _ (m_Tracks(nTrack + 1).Seconds * 75) + _ (m_Tracks(nTrack + 1).Minutes * (75 * 60)) - 100 nTemp2 = (nTemp Mod 75) * 65536 nTemp2 = nTemp2 + ((nTemp \ 75) Mod 60) * 256 nTemp2 = nTemp2 + ((nTemp \ (75 * 60))) mciPlayParms.dwTo = nTemp2 mciSendCommand m_DeviceID, _ MCI_PLAY, MCI_FROM Or MCI_TO, mciPlayParms End Sub Public Sub StopCD() mciSendCommand m_DeviceID, MCI_STOP, 0, ByVal 0 m_LastPos = 0 End Sub Public Sub PauseCD() mciSendCommand m_DeviceID, MCI_PAUSE, 0, ByVal 0 End Sub Public Sub SeekToBegining() mciSendCommand m_DeviceID, MCI_SEEK Or MCI_WAIT, MCI_SEEK_TO_START, _ ByVal 0 m_LastPos = 0 End Sub Public Sub OpenDrive() mciSendCommand m_DeviceID, MCI_SET, MCI_SET_DOOR_OPEN, ByVal 0 End Sub Public Sub CloseDrive() m_LastPos = 0 mciSendCommand m_DeviceID, MCI_SET, MCI_SET_DOOR_CLOSED Or MCI_WAIT, _ ByVal 0 mciSendCommand m_DeviceID, MCI_SEEK, MCI_SEEK_TO_END, ByVal 0 End Sub Private Function OpenCD() As Boolean Dim scode As Long, wDeviceID As Long OpenCD = False mciOpenParms.lpstrDeviceType = "cdaudio" scode = mciSendCommand(0, MCI_OPEN, (MCI_OPEN_SHAREABLE Or _ MCI_OPEN_TYPE), mciOpenParms) If scode <> MMSYSERR_NOERROR Then m_Error = scode Exit Function End If m_DeviceID = mciOpenParms.wDeviceID mciSetParms.dwTimeFormat = MCI_FORMAT_MSF scode = mciSendCommand(m_DeviceID, MCI_SET, MCI_SET_TIME_FORMAT, _ mciSetParms) If scode <> MMSYSERR_NOERROR Then m_Error = scode scode = mciSendCommand(m_DeviceID, MCI_CLOSE, 0, 0) Exit Function End If OpenCD = True End Function Private Sub CloseCD() m_Error = mciSendCommand(m_DeviceID, MCI_CLOSE, 0, 0) m_DeviceID = -1 End Sub Public Function MCI_ID() As String mciInfoParms.dwCallback = 0 mciInfoParms.lpstrReturn = Space(32) mciInfoParms.dwRetSize = 32 mciSendCommand m_DeviceID, MCI_INFO, MCI_INFO_MEDIA_IDENTITY, mciInfoParms MCI_ID = Hex(mciInfoParms.lpstrReturn) End Function Public Function NumTracks() As Long mciStatusParms.dwItem = MCI_STATUS_NUMBER_OF_TRACKS mciSendCommand m_DeviceID, MCI_STATUS, MCI_STATUS_ITEM, _ mciStatusParms NumTracks = mciStatusParms.dwReturn End Function Private Function LoadCDInfo() As Boolean Dim scode As Long Dim p1 As Long, dwPosM As Long, dwPosS As Long, dwPosF As Long Dim dwLenM As Long, dwLenS As Long, dwLenF As Long, dwPos As Long Dim sum As Long, p2 As Long On Error Resume Next LoadCDInfo = False mciSetParms.dwTimeFormat = MCI_FORMAT_MSF scode = mciSendCommand(m_DeviceID, MCI_SET, MCI_SET_TIME_FORMAT, _ mciSetParms) ' First get number of tracks mciStatusParms.dwItem = MCI_STATUS_NUMBER_OF_TRACKS scode = mciSendCommand(m_DeviceID, MCI_STATUS, MCI_STATUS_ITEM, _ mciStatusParms) If scode <> MMSYSERR_NOERROR Then m_Error = scode Exit Function End If m_NTracks = mciStatusParms.dwReturn ' Allocate enough room for all the tracks, plus the extra info ' saved in the last element ReDim m_Tracks(m_NTracks + 1) As TTrackInfo ' Loop through all the tracks and get starting position For p1 = 1 To m_NTracks mciStatusParms.dwItem = MCI_STATUS_POSITION mciStatusParms.dwTrack = p1 scode = mciSendCommand(m_DeviceID, MCI_STATUS, MCI_STATUS_ITEM Or _ MCI_TRACK, mciStatusParms) If scode <> MMSYSERR_NOERROR Then m_Error = scode Exit Function End If ' We right shift the bits here, but I cheat and divide with some ' constants instead. ' ' Note that m_Tracks() is zero based! ' m_Tracks(p1 - 1).Frames = (mciStatusParms.dwReturn \ 65536) And &HFF m_Tracks(p1 - 1).Seconds = (mciStatusParms.dwReturn \ 256) And &HFF m_Tracks(p1 - 1).Minutes = (mciStatusParms.dwReturn) And &HFF ' I am saving the Frame Offset of the track for easy retrieval in _ ' the Query string function. m_Tracks(p1 - 1).FrameOffset = (m_Tracks(p1 - 1).Minutes * 60 * _ 75) + (m_Tracks(p1 - 1).Seconds * _ 75) + (m_Tracks(p1 - 1).Frames) Next p1 ' Get total length of CD in seconds mciStatusParms.dwItem = MCI_STATUS_LENGTH mciStatusParms.dwTrack = m_NTracks scode = mciSendCommand(m_DeviceID, MCI_STATUS, MCI_STATUS_ITEM Or _ MCI_TRACK, mciStatusParms) If scode <> MMSYSERR_NOERROR Then m_Error = scode Exit Function End If ' We now have the length of the last track dwLenM = (mciStatusParms.dwReturn) And &HFF dwLenS = (mciStatusParms.dwReturn \ 256) And &HFF dwLenF = ((mciStatusParms.dwReturn \ 65536) And &HFF) + 1 ' Get the starting position of the last track dwPosM = m_Tracks(m_NTracks - 1).Minutes dwPosS = m_Tracks(m_NTracks - 1).Seconds dwPosF = m_Tracks(m_NTracks - 1).Frames ' Add them together to get the total length of the CD dwPos = (dwPosM * 60 * 75) + (dwPosS * 75) + dwPosF + _ (dwLenM * 60 * 75) + (dwLenS * 75) + dwLenF ' Save it in the last element of m_Tracks() for later retrieval m_Tracks(m_NTracks).Frames = dwPos Mod 75 dwPos = dwPos \ 75 m_Tracks(m_NTracks).Seconds = dwPos Mod 60 dwPos = dwPos \ 60 m_Tracks(m_NTracks).Minutes = dwPos ' Now calculate the length by subtracting the starting position of _ the first ' track and the value calculated above m_Length = ((m_Tracks(m_NTracks).Minutes * 60) + _ (m_Tracks(m_NTracks).Seconds)) - _ ((m_Tracks(0).Minutes * 60) + (m_Tracks(0).Seconds)) ' Start calculating the CDDB Id. sum = 0 For p1 = 0 To m_NTracks - 1 ' Get current track position in seconds p2 = m_Tracks(p1).Minutes * 60 + m_Tracks(p1).Seconds ' Add each digit in P2 together and save in the "sum" Do While p2 > 0 sum = sum + (p2 Mod 10) p2 = p2 \ 10 Loop Next p1 ' Now, sum contains the sum of all digits calculated from the ' length in seconds of each and every track ' Finally put the figures together. Once again I cheat to avoid _ overflow ' and other awful things when dealing with VBs Signed longs. m_CID = LCase$(LeftZeroPad(Hex$(sum Mod &HFF), 2) & _ LeftZeroPad(Hex$(m_Length), 4) & LeftZeroPad(Hex$(m_NTracks), _ 2)) LoadCDInfo = True End Function Public Function ID() As String LoadCDInfo ID = m_CID End Function Private Function LeftZeroPad(s As String, n As Integer) As String If Len(s) < n Then LeftZeroPad = String$(n - Len(s), "0") & s Else LeftZeroPad = s End If End Function | |
Sample Usage: | |
Dim CD As New clsCD CD.Close CD.Play |