• Home
 · 
• Sound/MP3
 · 
• CD Player

CD Player

CD Player

API Declarations



Dim fastForwardSpeed As Long ' seconds to seek for ff/rew
Dim fPlaying As Boolean ' true if CD is currently playing
Dim fCDLoaded As Boolean ' true if CD is the the player
Dim numTracks As Integer ' number of tracks on audio CD
Dim trackLength() As String ' array containing length of each track
Dim track As Integer ' current track
Dim min As Integer ' current minute on track
Dim sec As Integer ' current second on track
Dim cmd As String ' string to hold mci command strings

Dim hWndStatus As Long
Const ID_STATUS = 201

Dim SBHeight As Long

Dim PanelText() As String
Dim PanelColor() As Long





Rate CD Player

• 1
• 2
• 3
• 4
• 5

(2(2 Vote))

CODE:

Friend Function WndProc(ByVal hWnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long, bUseRetVal As Boolean) As Long

    Dim di As DRAWITEMSTRUCT
    Dim sTemp As String

    If wMsg = WM_DRAWITEM Then
        'Which panel to draw?
        CopyMemory di, ByVal lParam, Len(di)
        'Get the text we stored for this panel
        sTemp = PanelText(di.itemID)
        'Prepare the device context
        SetBkMode di.hDC, TRANSPARENT
        SetTextColor di.hDC, PanelColor(di.itemID)
        'Draw our text
        DrawText di.hDC, sTemp, Len(sTemp), di.rcItem, _
            DT_SINGLELINE + DT_RIGHT + DT_VCENTER
        'Don't pass on to VB
        WndProc = 1
        bUseRetVal = True

    End If

End Function


' Send a MCI command string
' If fShowError is true, display a message box on error
Private Function SendMCIString(cmd As String, fShowError As Boolean) As Boolean
Static rc As Long
Static errStr As String * 200

rc = mciSendString(cmd, 0, 0, hWnd)
If (fShowError And rc <> 0) Then
    mciGetErrorString rc, errStr, Len(errStr)
    MsgBox errStr
End If
SendMCIString = (rc = 0)
End Function

Private Sub Form_Load()
    Dim rct As RECT
    'Initialize the information we'll use
    'for the owner-drawn panels
    ReDim PanelText(0 To 2) As String
    ReDim PanelColor(0 To 2) As Long
    PanelText(0) = "Owner-draw #1"
    PanelColor(0) = vbBlack
    PanelText(1) = "Owner-draw #2"
    PanelColor(1) = vbBlue
    PanelText(2) = "Owner-draw #3"
    PanelColor(2) = vbRed
    'Initialize the Common Controls library
    InitCommonControls

    'Create our StatusBar!
    hWndStatus = CreateStatusWindow(WS_CHILD + WS_VISIBLE + _
        WS_CLIPCHILDREN + WS_CLIPSIBLINGS + SBARS_SIZEGRIP, _
        "Visual Basic Thunder... the power to crack Windows!", _
        Me.hWnd, ID_STATUS)
    'Store the height of the StatusBar in a variable
    GetWindowRect hWndStatus, rct
    SBHeight = rct.Bottom - rct.Top

    SubclassForm



    Const nParts As Long = 3
    Dim wParts(0 To 2) As Long
    'Set panel widths
    wParts(0) = 100
    wParts(1) = 200
    wParts(2) = -1
    'Tell the StatusBar how many panels we want
    'and get it out of simple mode
    SendMessage hWndStatus, SB_SIMPLE, 0, ByVal 0&
    SendMessage hWndStatus, SB_SETPARTS, nParts, wParts(0)
    'Set first panel properties
    SendMessage hWndStatus, SB_SETICON, _
        0, ByVal pic.Picture.Handle
    SendMessage hWndStatus, SB_SETTEXT, _
        0, ByVal "Idle"
    'Second panel
    SendMessage hWndStatus, SB_SETTEXT, _
        1 + SBT_POPOUT, ByVal totalplay.Caption
    'Third panel
    SendMessage hWndStatus, SB_SETTEXT, _
        2 + SBT_POPOUT, ByVal tracktime.Caption


' If we're already running, then quit
If (App.PrevInstance = True) Then
    End
End If

' Initialize variables
Timer1.Enabled = False
fastForwardSpeed = 5
fCDLoaded = False

' If the cd is being used, then quit
If (SendMCIString("open cdaudio alias cd wait shareable", True) = False) Then
    End
End If

SendMCIString "set cd time format tmsf wait", True
Timer1.Enabled = True

End Sub

Private Sub Form_Unload(Cancel As Integer)
'Close all MCI devices opened by this program
SendMCIString "close all", False
End Sub

' Play the CD
Private Sub play_Click()
SendMCIString "play cd", True
fPlaying = True
    SendMessage hWndStatus, SB_SETTEXT, _
        0, ByVal "Playing..."
End Sub
' Stop the CD play
Private Sub stopbtn_Click()
SendMCIString "stop cd wait", True
cmd = "seek cd to " & track
SendMCIString cmd, True
fPlaying = False
Update
    SendMessage hWndStatus, SB_SETTEXT, _
        0, ByVal "Idle"
End Sub
' Pause the CD
Private Sub pause_Click()
SendMCIString "pause cd", True
fPlaying = False
Update
    SendMessage hWndStatus, SB_SETTEXT, _
        0, ByVal "Paused"
End Sub
' Eject the CD
Private Sub eject_Click()
SendMCIString "set cd door open", True
Update
End Sub
' Fast forward
Private Sub ff_Click()
Dim s As String * 40

SendMCIString "set cd time format milliseconds", True
mciSendString "status cd position wait", s, Len(s), 0
If (fPlaying) Then
    cmd = "play cd from " & CStr(CLng(s) + fastForwardSpeed * 1000)
Else
    cmd = "seek cd to " & CStr(CLng(s) + fastForwardSpeed * 1000)
End If
mciSendString cmd, 0, 0, 0
SendMCIString "set cd time format tmsf", True
Update
End Sub
' Rewind the CD
Private Sub rew_Click()
Dim s As String * 40

SendMCIString "set cd time format milliseconds", True
mciSendString "status cd position wait", s, Len(s), 0
If (fPlaying) Then
    cmd = "play cd from " & CStr(CLng(s) - fastForwardSpeed * 1000)
Else
    cmd = "seek cd to " & CStr(CLng(s) - fastForwardSpeed * 1000)
End If
mciSendString cmd, 0, 0, 0
SendMCIString "set cd time format tmsf", True
Update
End Sub
' Forward track
Private Sub ftrack_Click()
If (track < numTracks) Then
    If (fPlaying) Then
        cmd = "play cd from " & track + 1
        SendMCIString cmd, True
    Else
        cmd = "seek cd to " & track + 1
        SendMCIString cmd, True
    End If
Else
    SendMCIString "seek cd to 1", True
End If
Update
End Sub
' Go to previous track
Private Sub btrack_Click()
Dim from As String
If (min = 0 And sec = 0) Then
    If (track > 1) Then
        from = CStr(track - 1)
    Else
        from = CStr(numTracks)
    End If
Else
    from = CStr(track)
End If
If (fPlaying) Then
    cmd = "play cd from " & from
    SendMCIString cmd, True
Else
    cmd = "seek cd to " & from
    SendMCIString cmd, True
End If
Update
End Sub
' Update the display and state variables
Private Sub Update()
Static s As String * 30

' Check if CD is in the player
mciSendString "status cd media present", s, Len(s), 0
If (CBool(s)) Then
    ' Enable all the controls, get CD information
    If (fCDLoaded = False) Then
        mciSendString "status cd number of tracks wait", s, Len(s), 0
        numTracks = CInt(Mid$(s, 1, 2))
        eject.Enabled = True
        
        ' If CD only has 1 track, then it's probably a data CD
        If (numTracks = 1) Then
            Exit Sub
        End If
        
        mciSendString "status cd length wait", s, Len(s), 0
        totalplay.Caption = "Tracks: " & numTracks & "  Total time: " & s
        ReDim trackLength(1 To numTracks)
        Dim i As Integer
        For i = 1 To numTracks
            cmd = "status cd length track " & i
            mciSendString cmd, s, Len(s), 0
            trackLength(i) = s
        Next
        play.Enabled = True
        pause.Enabled = True
        ff.Enabled = True
        rew.Enabled = True
        ftrack.Enabled = True
        btrack.Enabled = True
        stopbtn.Enabled = True
        fCDLoaded = True
        SendMCIString "seek cd to 1", True
    End If

    ' Update the track time display
    mciSendString "status cd position", s, Len(s), 0
    track = CInt(Mid$(s, 1, 2))
    min = CInt(Mid$(s, 4, 2))
    sec = CInt(Mid$(s, 7, 2))
    timeWindow.Text = "[" & Format(track, "00") & "] " & Format(min, "00") _
            & ":" & Format(sec, "00")
    tracktime.Caption = "Track time: " & trackLength(track)
    
    ' Check if CD is playing
    mciSendString "status cd mode", s, Len(s), 0
    fPlaying = (Mid$(s, 1, 7) = "playing")
Else
    eject.Enabled = False
    ' Disable all the controls, clear the display
    If (fCDLoaded = True) Then
        play.Enabled = False
        pause.Enabled = False
        ff.Enabled = False
        rew.Enabled = False
        ftrack.Enabled = False
        btrack.Enabled = False
        stopbtn.Enabled = False
        fCDLoaded = False
        fPlaying = False
        totalplay.Caption = ""
        tracktime.Caption = ""
        timeWindow.Text = ""
    End If
End If
End Sub
' Set the fast-forward speed
Private Sub ffspeed_Click()
Dim s As String
s = InputBox("Enter the new speed in seconds", "Fast Forward Speed", CStr(fastForwardSpeed))
If IsNumeric(s) Then
    fastForwardSpeed = CLng(s)
End If
End Sub

Private Sub Timer1_Timer()
Update
End Sub

Private Sub Timer2_Timer()
    SendMessage hWndStatus, SB_SETTEXT, _
        1 + SBT_POPOUT, ByVal totalplay.Caption
    'Third panel
    SendMessage hWndStatus, SB_SETTEXT, _
        2 + SBT_POPOUT, ByVal tracktime.Caption
End Sub