by asmatt (1 Submission)
Category: Sound/MP3
Compatability: Visual Basic 5.0
Difficulty: Unknown Difficulty
Originally Published: Thu 7th December 2000
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
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
VBcoders
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
