cd player

I want to design a new cd player for personal use in windows.  I have seen some built in VB, and I would like to use that.  Is there any activeX controls I can d/l to interface between the cd and VB?  If so, which is the best?
c98afAsked:
Who is Participating?
 
watyConnect With a Mentor Commented:
Here is a class to control a cd :

' #VBIDEUtils#************************************************************
' * Programmer Name  : Waty Thierry
' * Web Site         : www.geocities.com/ResearchTriangle/6311/
' * E-Mail           : waty.thierry@usa.net
' * 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.
' *
' **********************************************************************

'' Example code for the CCD class
''
'' To use this example:
'' 1. Create a new form.
'' 2. Create a command button called 'cmdPlay'
'' 3. Create a command button called 'cmdPause'
'' 4. Create a command button called 'cmdStop'
'' 5. Create a command button called 'cmdBackTrack'
'' 6. Create a command button called 'cmdBack'
'' 7. Create a command button called 'cmdForward'
'' 8. Create a command button called 'cmdForwardTrack'
'' 9. Create a command button called 'cmdEject'
'' 10. Create a command button called 'cmdPower'
'' 11. Create a label called 'lblTime'
'' 12. Create a combo box called 'cboTracks'
'' 13. Create a timer control called 'Timer1'
'' 14. Paste the entire contents of this module into the
''    new form's module.
''
'
'Private mcd As CCD
'
'Private Sub Form_Load()
'  ' arrange the controls and set their captions
'  Me.Width = 3885
'  Me.Height = 2475
'  Me.Caption = "CD Player Demo"
'
'  With lblTime
'    .Caption = "[01] 00:00"
'    .Move 0, 210, 1710, 375
'    .FontName = "Courier New"
'    .ForeColor = vbCyan
'    .BackColor = vbBlack
'    .FontSize = 12
'  End With
'
'  With cmdPlay
'    .Move 1785, 225, 825, 270
'    .Caption = "Play"
'    .ToolTipText = "Play"
'  End With
'
'  With cmdPause
'    .Move 2640, 225, 270, 270
'    .Caption = "||"
'    .ToolTipText = "Pause"
'  End With
'
'  With cmdStop
'    .Move 2910, 225, 270, 270
'    .Caption = "X"
'    .ToolTipText = "Stop"
'  End With
'
'  With cmdBackTrack
'    .Move 1785, 510, 270, 270
'    .Caption = "Ü"
'    .Font.name = "Symbol"
'    .ToolTipText = "Back one Track"
'  End With
'
'  With cmdBack
'    .Move 2055, 510, 270, 270
'    .Caption = "¬"
'    .Font.name = "Symbol"
'    .ToolTipText = "Go backwards in track"
'  End With
'
'  With cmdForward
'    .Move 2340, 510, 270, 270
'    .Caption = "®"
'    .Font.name = "Symbol"
'    .ToolTipText = "Go forwards in track"
'  End With
'
'  With cmdForwardTrack
'    .Move 2640, 510, 270, 270
'    .Caption = "Þ"
'    .Font.name = "Symbol"
'    .ToolTipText = "Forward one track"
'  End With
'
'  With cmdEject
'    .Move 2910, 510, 270, 270
'    .Caption = "Ý"
'    .Font.name = "Symbol"
'    .ToolTipText = "Eject"
'  End With
'
'  With cmdPower
'    .Move 2475, 900, 705, 360
'    .Caption = "Power"
'    .ToolTipText = "Power"
'  End With
'
'  With cboTracks
'    .Move 75, 1020, 1635
'    .ToolTipText = "Track"
'  End With
'
'  With Timer1
'    .Interval = 1000
'    .Enabled = False
'  End With
'
'  ' Instantiate the CCD object
'  Set mcd = New CCD
'
'End Sub
'
'Private Sub cboTracks_Click()
'  mcd.Track = cboTracks.ListIndex + 1
'  mcd.Minutes = 0
'  mcd.Seconds = 0
'End Sub
'
'Private Sub cmdBack_Click()
'  mcd.Seconds = mcd.Seconds - 1
'End Sub
'
'Private Sub cmdBackTrack_Click()
'  If mcd.Track > 0 Then
'    mcd.Track = mcd.Track - 1
'    mcd.Minutes = 0
'    mcd.Seconds = 0
'  End If
'End Sub
'
'Private Sub cmdEject_Click()
'  mcd.Eject
'End Sub
'
'Private Sub cmdForward_Click()
'  mcd.Seconds = mcd.Seconds + 1
'End Sub
'
'Private Sub cmdForwardTrack_Click()
'  If mcd.Track < mcd.Tracks.count Then
'    mcd.Track = mcd.Track + 1
'    mcd.Minutes = 0
'    mcd.Seconds = 0
'  End If
'
'End Sub
'
'Private Sub cmdPause_Click()
'  mcd.Pause
'End Sub
'
'Private Sub cmdPlay_Click()
'  mcd.Play
'End Sub
'
'Private Sub cmdPower_Click()
'  Dim intTrackCounter As Integer
'
'  mcd.OpenCD
'
'  cboTracks.Clear
'
'  For intTrackCounter = 1 To mcd.Tracks.count
'    cboTracks.AddItem "Track " & intTrackCounter
'  Next intTrackCounter
'
'  cboTracks.ListIndex = 0
'
'  Timer1.Enabled = True
'End Sub
'
'Private Sub cmdStop_Click()
'  mcd.StopCD
'End Sub
'
'Private Sub Form_Unload(Cancel As Integer)
'  ' Destroy the object, which will stop the Cd from playing
'  Set mcd = Nothing
'End Sub
'
'Private Sub Timer1_Timer()
'
'  lblTime = "[" & Format(mcd.Track, "00") & "] " & _
'            Format(mcd.Minutes, "00") & _
'            ":" & Format(mcd.Seconds, "00")
'
'End Sub


' 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"
   Resume PROC_EXIT

End Sub

Private Function Shli( _
         ByVal intValue As Integer, _
         ByVal bytPlaces As Byte) _
         As Integer
   ' Comments  : Shifts a numeric value left the specified number of bits.
   '             Left shifting can be defined as a multiplication operation.
   '             For the number of bits we want to shift a value to the
   '             left, we need to raise two to that power, then multiply the
   '             result by our original value.
   ' Parameters: intValue - integer value to shift
   '             bytPlaces - number of places to shift
   ' Returns   : Shifted value
   ' Source    : Total VB SourceBook 5
   '
   Dim lngMultiplier As Long

   On Error GoTo PROC_ERR

   ' if we are shifting 16 or more bits, then the result is always zero
   If bytPlaces >= 16 Then
      Shli = 0
   Else
      lngMultiplier = 2 ^ bytPlaces
      Shli = LongToInt(intValue * lngMultiplier)
   End If

PROC_EXIT:
   Exit Function

PROC_ERR:
   MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
         "Shli"
   Resume PROC_EXIT

End Function

Private Function Shll(ByVal lngNumber As Long, ByVal bytPlaces As Byte) As Long
   ' Comments  : Shifts a numeric Value left the specified number of bits.
   ' Parameters: lngNumber - long Value to shift
   '             bytPlaces - number of places to shift
   ' Returns   : Shifted Value
   ' Source    : Total VB SourceBook 5
   '
   Dim dblMultiplier As Double

   On Error GoTo PROC_ERR

   ' if we are shifting 32 or more bits, then the result is always zero
   If bytPlaces >= 32 Then
      Shll = 0
   Else
      dblMultiplier = 2 ^ bytPlaces
      Shll = dblToLong(lngNumber * dblMultiplier)
   End If

PROC_EXIT:
   Exit Function

PROC_ERR:
   MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
         "Shll"
   Resume PROC_EXIT

End Function

Private Function Shri( _
         ByVal lngValue As Long, _
         ByVal bytPlaces As Byte) _
         As Integer
   ' Comments  : Shifts a long Value right the selected number of places
   ' Parameters: lngValue - integer Value to shift
   '             bytPlaces - number of places to shift
   ' Returns   : Shifted value
   ' Source    : Total VB SourceBook 5
   '
   Dim lngDivisor As Long

   On Error GoTo PROC_ERR

   ' if we are shifting 16 or more bits, then the result is always zero
   If bytPlaces >= 16 Then
      Shri = 0
   Else
      lngDivisor = 2 ^ bytPlaces
      Shri = Int(IntToLong(lngValue) / lngDivisor)
   End If

PROC_EXIT:
   Exit Function

PROC_ERR:
   MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
         "Shri"
   Resume PROC_EXIT

End Function

Private Function Shrl(ByVal lngNumber As Long, ByVal bytPlaces As Byte) As Long
   ' Comments  : Shifts a long Value right the selected number of places
   ' Parameters: lngNumber - long Value to shift
   '             bytPlaces - number of places to shift
   ' Returns   : Shifted Value
   ' Source    : Total VB SourceBook 5
   '
   Dim lngDivisor As Long

   On Error GoTo PROC_ERR

   ' if we are shifting 32 or more bits, then the result is always zero
   If bytPlaces >= 32 Then
      Shrl = 0
   Else
      lngDivisor = 2 ^ bytPlaces
      Shrl = Int(LongToDbl(lngNumber) / lngDivisor)
   End If

PROC_EXIT:
   Exit Function

PROC_ERR:
   MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
         "Shrl"
   Resume PROC_EXIT

End Function


0
 
c98afAuthor Commented:
could you post any replies to
c98af@whitchurch.cardiff.sch.uk

0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.