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

Dim CD As New clsCD

CD.Close
CD.Play