Calculating the CDDB/CDID

Does anybody know of any freeware component or some windows API code (preferred) that collects the CD tracks' data and calculates the CDID of a CD?
LVL 1
zivfAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

watyCommented:
' #VBIDEUtils#************************************************************
' * Programmer Name  : Clem
' * Web Site         : http://www.planetsourcecode.com/vb/ftp/CODE_UPLOAD1285.zip
' * E-Mail           : waty.thierry@usa.net
' * Date             : 14/10/1999
' * Time             : 15:14
' **********************************************************************
' * Comments         : Connect and retrieve data about an audio CD through CDDB.com
' *
' *
' **********************************************************************
VERSION 1.0 CLASS
BEGIN
MultiUse = -1  'True
END
Attribute VB_Name = "CCd"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

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 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 MMSYSERR_NOERROR = 0

Private Const MCI_CLOSE = &H804
Private Const MCI_FORMAT_MSF = 2
Private Const MCI_OPEN = &H803
Private Const MCI_OPEN_ELEMENT = &H200&
Private Const MCI_OPEN_TYPE = &H2000&
Private Const MCI_SET = &H80D
Private Const MCI_SET_TIME_FORMAT = &H400&

Private Const MCI_STATUS_ITEM = &H100&
Private Const MCI_STATUS_LENGTH = &H1&
Private Const MCI_STATUS_NUMBER_OF_TRACKS = &H3&
Private Const MCI_STATUS_POSITION = &H2&
Private Const MCI_TRACK = &H10&
Private Const MCI_STATUS = &H814

Private mciOpenParms As MCI_OPEN_PARMS
Private mciSetParms As MCI_SET_PARMS
Private mciStatusParms As MCI_STATUS_PARMS

Private Type TTrackInfo
   Minutes As Long
   Seconds As Long
   Frames As Long
   FrameOffset As Long           ' Starting location in frames (used by QueryString)
End Type

Private m_Error As Long          ' Error code from API call
Private m_CID As String          ' Computed disc id
Private m_Drive As String        ' Drive letter
Private m_DeviceID As Long       ' Device Id
Private m_NTracks As Integer     ' Number of tracks in CD
Private m_Length As Long         ' Length of CD in seconds
Private m_Tracks() As TTrackInfo ' Track info for each and every track on the CD
' Zero based. Last index used for storing lead-out
' position information.

Private Sub Class_Initialize()
   m_CID = "(unavailable)"
   m_Drive = ""
   m_Error = 0
   m_DeviceID = -1
   m_NTracks = 0
End Sub

Public Property Get DiscID() As String
   DiscID = m_CID
End Property

Public Property Get ErrorCode() As Long
   Error = m_Error
End Property

Public Sub Init(sDrive As String)
   Dim p1 As Integer
   m_Error = MMSYSERR_NOERROR
   m_Drive = sDrive
   If OpenCD Then
      Call LoadCDInfo
      CloseCD
   End If

End Sub

Private Sub Class_Terminate()
   If m_DeviceID <> -1 Then
      CloseCD
   End If
End Sub

Private Function OpenCD() As Boolean
   Dim sCode As Long, wDeviceID As Long
   OpenCD = False
   mciOpenParms.lpstrDeviceType = "cdaudio"
   mciOpenParms.lpstrElementName = m_Drive
   sCode = mciSendCommand(0, MCI_OPEN, (MCI_OPEN_TYPE Or MCI_OPEN_ELEMENT), 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)  ' Dont forget to close it
      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

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
   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
   ReDim m_Tracks(m_NTracks + 1) As TTrackInfo
   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
      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
      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
   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
   dwLenM = (mciStatusParms.dwReturn) And &HFF
   dwLenS = (mciStatusParms.dwReturn  256) And &HFF
   dwLenF = ((mciStatusParms.dwReturn  65536) And &HFF) + 1
   dwPosM = m_Tracks(m_NTracks - 1).Minutes
   dwPosS = m_Tracks(m_NTracks - 1).Seconds
   dwPosF = m_Tracks(m_NTracks - 1).Frames
   dwpos = (dwPosM * 60 * 75) + (dwPosS * 75) + dwPosF + _
      (dwLenM * 60 * 75) + (dwLenS * 75) + dwLenF
   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
   m_Length = ((m_Tracks(m_NTracks).Minutes * 60) + (m_Tracks(m_NTracks).Seconds)) - _
      ((m_Tracks(0).Minutes * 60) + (m_Tracks(0).Seconds))
   sum = 0
   For p1 = 0 To m_NTracks - 1
      p2 = m_Tracks(p1).Minutes * 60 + m_Tracks(p1).Seconds
      Do While p2 > 0
         sum = sum + (p2 Mod 10)
         p2 = p2  10
      Loop
   Next p1
   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 QueryString() As String
   Dim p1 As Integer, s As String
   On Error GoTo CHK
   s = "cddb query " & m_CID & "+" & m_NTracks
   For p1 = 0 To m_NTracks - 1
      s = s & "+" & Format$(m_Tracks(p1).FrameOffset)
   Next
   QueryString = s & "+" & Format$(m_Tracks(m_NTracks).Minutes * 60) + (m_Tracks(m_NTracks).Seconds)
CHK:
   Select Case Err.Number
      Case 0
      Case 9
         MsgBox "Drive not ready. Try again."
         Exit Function
      Case Else
         MsgBox Err.Number & " " & Err.Description
         Exit Function
   End Select
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
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
zivfAuthor Commented:
First check seemed like exactly what I have looked for and a lot more.
I must check it more thoroughly but you have earned your points for now and more.

PLEASE: People! Don't paste those hugh amounts of code as answers! I hate it and it has no purpose. I have downloaded the project in a few seconds and it was all I needed. lots of code disturbs and prevents people in the experts-exchange site from having a clear view of their question and the answers they got to it and the evolution of answers.

Thanks.
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Visual Basic Classic

From novice to tech pro — start learning today.