Solved

cd player

Posted on 1999-01-06
3
306 Views
Last Modified: 2010-05-03
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?
0
Comment
Question by:c98af
3 Comments
 

Author Comment

by:c98af
ID: 1454197
could you post any replies to
c98af@whitchurch.cardiff.sch.uk

0
 
LVL 14

Accepted Solution

by:
waty earned 100 total points
ID: 1454198
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
 
LVL 13

Expert Comment

by:Mirkwood
ID: 1454199
0

Featured Post

How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

Join & Write a Comment

Suggested Solutions

Introduction While answering a recent question (http://www.experts-exchange.com/Q_27402310.html) in the VB classic zone, I wrote some VB code in the (Office) VBA environment, rather than fire up my older PC.  I didn't post completely correct code o…
You can of course define an array to hold data that is of a particular type like an array of Strings to hold customer names or an array of Doubles to hold customer sales, but what do you do if you want to coordinate that data? This article describes…
Get people started with the process of using Access VBA to control Outlook using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Microsoft Outlook. Using automation, an Access applic…
This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…

708 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

12 Experts available now in Live!

Get 1:1 Help Now