VB5 Audio Burner (81K)
VB6 Audio Burner (78K)
2 Jun 2004
First Posted
Image Mastering API (IMAPI) Library for VB
VB IMAPI (CD Burning) Interfaces (IVBIMAPI.tlb)
Using WinAmp In Plugins From VB
vbAccelerator - Contents of code file: frmAudioBurner.frm
This file is part of the download VB5 Audio Burner, which is described in the article Writing Audio CDs.
VERSION 5.00
Begin VB.Form frmAudioBurner
Caption = "vbAccelerator Audio CD Burner"
ClientHeight = 6360
ClientLeft = 3540
ClientTop = 2550
ClientWidth = 6570
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Icon = "frmAudioBurner.frx":0000
LinkTopic = "Form1"
ScaleHeight = 6360
ScaleWidth = 6570
Begin VB.PictureBox picStatus
Align = 2 'Align Bottom
BorderStyle = 0 'None
Height = 735
Left = 0
ScaleHeight = 735
ScaleWidth = 6570
TabIndex = 13
Top = 5625
Width = 6570
Begin VB.PictureBox picProgress
BorderStyle = 0 'None
Height = 315
Left = 60
ScaleHeight = 315
ScaleWidth = 6315
TabIndex = 14
Top = 0
Width = 6315
End
Begin VB.Label lblStatus
Height = 255
Left = 60
TabIndex = 15
Top = 420
Width = 6315
End
End
Begin VB.PictureBox picBurn
BorderStyle = 0 'None
Height = 735
Left = 60
ScaleHeight = 735
ScaleWidth = 6315
TabIndex = 9
Top = 4680
Width = 6315
Begin VB.CommandButton cmdBurn
Caption = "&Burn"
Height = 435
Left = 1560
TabIndex = 12
Top = 120
Width = 1335
End
Begin VB.CheckBox chkSimulate
Caption = "&Simulate Burn"
Height = 255
Left = 3060
TabIndex = 11
Top = 120
Value = 1 'Checked
Width = 2775
End
Begin VB.CheckBox chkEject
Caption = "&Eject when Done"
Height = 255
Left = 3060
TabIndex = 10
Top = 420
Value = 1 'Checked
Width = 2775
End
End
Begin VB.PictureBox picFiles
BorderStyle = 0 'None
ClipControls = 0 'False
Height = 4155
Left = 60
ScaleHeight = 4155
ScaleWidth = 6315
TabIndex = 2
Top = 480
Width = 6315
Begin VB.ListBox lstFiles
Height = 3570
Left = 1560
TabIndex = 7
Top = 0
Width = 4275
End
Begin VB.CommandButton cmdAdd
Caption = "&Add..."
Height = 435
Left = 1560
TabIndex = 6
Top = 3660
Width = 1335
End
Begin VB.CommandButton cmdRemove
Caption = "&Remove..."
Height = 435
Left = 2940
TabIndex = 5
Top = 3660
Width = 1335
End
Begin VB.CommandButton cmdMoveUp
Caption = ""
BeginProperty Font
Name = "Wingdings"
Size = 8.25
Charset = 2
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 315
Left = 5880
TabIndex = 4
Top = 1500
Width = 375
End
Begin VB.CommandButton cmdMoveDown
Caption = ""
BeginProperty Font
Name = "Wingdings"
Size = 8.25
Charset = 2
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 315
Left = 5880
TabIndex = 3
Top = 1860
Width = 375
End
Begin VB.Label lblFiles
Caption = "&Files:"
Height = 255
Left = 0
TabIndex = 8
Top = 60
Width = 1515
End
End
Begin VB.ComboBox cboRecorder
Height = 315
Left = 1620
Style = 2 'Dropdown List
TabIndex = 1
Top = 60
Width = 4815
End
Begin VB.Label lblRecorder
Caption = "&Recorder:"
Height = 255
Left = 60
TabIndex = 0
Top = 120
Width = 1515
End
End
Attribute VB_Name = "frmAudioBurner"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Enum EApplicationMode
eIdle
eBurning
End Enum
Private WithEvents m_cDiscMaster As cDiscMaster
Attribute m_cDiscMaster.VB_VarHelpID = -1
Private m_cRedbook As cRedbookDiscMaster
Private m_bCancel As Boolean
Private m_eMode As EApplicationMode
Private m_cProgress As pcProgressBar
Private Sub createCD()
Dim lFreeBlocks As Long
Dim lTotalBlocks As Long
Dim lBlockSize As Long
Dim iFile As Long
Dim iRecorder As Long
Dim cRecorder As cDiscRecorder
Dim bCloseExclusive As Boolean
Dim cInfo As cMediaInfo
Dim cProps As cDiscRecorderProperties
Dim cProp As cProperty
Dim iProp As Long
setApplicationMode eBurning
Set m_cProgress = New pcProgressBar
m_cProgress.XpStyle = True
m_cProgress.DrawObject = picProgress
m_cProgress.BarColor = vbHighlight
picProgress.Visible = True
showStatus "Opening Recorder for burning.."
Set m_cRedbook = m_cDiscMaster.RedbookDiscMaster
iRecorder = cboRecorder.ItemData(cboRecorder.ListIndex)
m_cDiscMaster.Recorders(iRecorder).SetAsActive
Set cRecorder = m_cDiscMaster.Recorders.ActiveRecorder
showStatus "Checking media type.."
cRecorder.OpenExclusive
bCloseExclusive = True
Set cInfo = cRecorder.MediaInfo
If (cInfo.MediaPresent) And _
((cInfo.mediaflags And MEDIA_WRITABLE) = MEDIA_WRITABLE) Then
cRecorder.CloseExclusive
bCloseExclusive = False
If Not (m_bCancel) Then
If (cInfo Is Nothing) Then
MsgBox "Please insert writable CD media into the " &
cboRecorder.List(cboRecorder.ListIndex) & " recorder.",
vbExclamation
Else
lFreeBlocks = cInfo.FreeBlocks
' Generate the progress info
lBlockSize = m_cRedbook.AudioBlockSize
For iFile = 1 To lstFiles.ListCount
lTotalBlocks = lTotalBlocks + lstFiles.ItemData(iFile - 1) \
lBlockSize
Next iFile
m_cProgress.Value = 0
m_cProgress.Max = lTotalBlocks
If (lTotalBlocks <= lFreeBlocks) Then
' First, create the CD Image
showStatus "Creating the CD Image..."
createCDImage
If Not (m_bCancel) Then
Dim lErr As Long
On Error Resume Next
m_cDiscMaster.RecordDisc (chkSimulate.Value = vbChecked),
(chkEject.Value = vbChecked)
lErr = Err.Number
On Error GoTo 0
If Not (lErr = 0) Then
MsgBox "An error occurred whilst recording the disc: " &
DecodeIMAPIError(lErr), vbExclamation
End If
End If
Else
MsgBox "The compilation is too long to burn onto the selected
media.", vbExclamation
End If
End If
End If
Else
MsgBox "Please insert writable media into the " &
cboRecorder.List(cboRecorder.ListIndex) & " recorder.", vbExclamation
End If
If (m_bCancel) Then
On Error Resume Next
m_cDiscMaster.ClearFormatContent
On Error GoTo 0
End If
If (bCloseExclusive) Then
cRecorder.CloseExclusive
End If
setApplicationMode eIdle
End Sub
Private Sub createCDImage()
Dim iFile As Long
Dim sFile As String
For iFile = 1 To lstFiles.ListCount
sFile = lstFiles.List(iFile - 1)
showStatus "Adding track " & sFile & "..."
addTrack sFile
If m_bCancel Then
Exit For
End If
Next iFile
End Sub
Private Function addTrack(ByVal sFile As String) As Long
Dim lBlockSize As Long
Dim cWav As cWavReader
Dim lTrackSize As Long
Dim lTrackBlocks As Long
Dim bMore As Boolean
Dim lReadSize As Long
Dim lWrittenSize As Long
Dim lWrittenBlocks As Long
lBlockSize = m_cRedbook.AudioBlockSize
Set cWav = New cWavReader
cWav.ReadBufferSize = lBlockSize \ 4
cWav.OpenFile sFile
lTrackSize = cWav.AudioLength * 4
lTrackBlocks = lTrackSize \ lBlockSize
If (lTrackSize Mod lBlockSize) > 0 Then
lTrackBlocks = lTrackBlocks + 1
End If
m_cRedbook.CreateAudioTrack lTrackBlocks
Do
bMore = cWav.Read
If (bMore) Then
lReadSize = cWav.ReadSize * 4
cWav.ZeroUnusedBufferBytes
m_cRedbook.AddAudioTrackBlocks cWav.ReadBufferPtr, lBlockSize
lWrittenSize = lWrittenSize + lReadSize
lWrittenBlocks = lWrittenBlocks + 1
m_cProgress.Value = m_cProgress.Value + 1
DoEvents
End If
Loop While (bMore) And Not (m_bCancel)
If Not (m_bCancel) Then
m_cRedbook.CloseAudioTrack
End If
cWav.CloseFile
addTrack = lWrittenBlocks
'
End Function
Private Sub setApplicationMode(ByVal eMode As EApplicationMode)
m_eMode = eMode
If (eMode = eBurning) Then
m_bCancel = False
cmdBurn.Caption = "Cancel"
enableControl cboRecorder, False
enableControl lstFiles, False
enableControl cmdMoveUp, False
enableControl cmdMoveDown, False
enableControl cmdAdd, False
enableControl cmdRemove, False
enableControl chkSimulate, False
enableControl chkEject, False
Else
cmdBurn.Caption = "&Burn"
enableControl cboRecorder, (cboRecorder.ListCount > 0)
enableControl cmdAdd, True
enableControl lstFiles, True
lstFiles_Click
picProgress.Visible = False
showStatus "Ready"
End If
End Sub
Private Sub enableControl(ctl As Control, ByVal bState As Boolean)
Dim oBackColor As OLE_COLOR
oBackColor = IIf(bState, vbWindowBackground, vbButtonFace)
ctl.Enabled = bState
If TypeOf ctl Is ListBox Then
ctl.BackColor = oBackColor
ElseIf TypeOf ctl Is ComboBox Then
ctl.BackColor = oBackColor
End If
End Sub
Private Sub showRecorders()
Dim iRecorder As Long
Set m_cDiscMaster = New cDiscMaster
m_cDiscMaster.Initialise
With m_cDiscMaster.Recorders
For iRecorder = 1 To .Count
With .Recorder(iRecorder)
If (.SupportsRedbook) Then
cboRecorder.AddItem .VendorId & " " & .ProductId & " " &
.RevisionId
cboRecorder.ItemData(cboRecorder.NewIndex) = iRecorder
End If
End With
Next iRecorder
End With
If (cboRecorder.ListCount > 0) Then
enableControl cboRecorder, True
cboRecorder.ListIndex = 0
End If
showStatus "Ready."
End Sub
Private Sub showStatus(ByVal sStatus As String)
lblStatus.Caption = sStatus
lblStatus.Refresh
End Sub
Private Sub addFile(ByVal sFile As String)
' Check not already there
Dim iFile As Long
For iFile = 1 To lstFiles.ListCount
If (lstFiles.List(iFile - 1) = sFile) Then
MsgBox "This file already exists in your compilation.", vbInformation
Exit Sub
End If
Next iFile
' Confirm valid wave file
Dim lErr As Long
Dim bR As Boolean
Dim cWav As New cWavReader
On Error Resume Next
bR = cWav.OpenFile(sFile)
lErr = Err.Number
On Error GoTo 0
If (bR And (lErr = 0)) Then
lstFiles.AddItem sFile
lstFiles.ItemData(lstFiles.NewIndex) = cWav.AudioLength * 4
If (lstFiles.ListIndex <> lstFiles.NewIndex) Then
lstFiles.ListIndex = lstFiles.NewIndex
Else
lstFiles_Click
End If
Else
MsgBox "'" & sFile & "' is not a 16bit stereo 44.1kHz Wave File.",
vbInformation
End If
End Sub
Private Sub cboRecorder_Click()
Dim iRecorder As Long
If (cboRecorder.ListIndex > -1) Then
iRecorder = cboRecorder.ItemData(cboRecorder.ListIndex)
enableControl lstFiles, True
enableControl cmdAdd, True
enableControl cmdRemove, (lstFiles.ListIndex > -1)
Else
enableControl lstFiles, False
enableControl cmdAdd, False
enableControl cmdRemove, False
End If
End Sub
Private Sub cmdAdd_Click()
Dim cD As New pcCommonDialog
Dim sFile As String
Dim vFile As Variant
If (cD.VBGetOpenFileName(sFile, _
MultiSelect:=True, _
Filter:="Wave Files (*.WAV)|*.WAV|All Files (*.*)|*.*", _
DefaultExt:="WAV", _
Owner:=Me.hWnd, flags:=OFN_EXPLORER)) Then
For Each vFile In cD.GetMultiSelectFileNames(sFile)
addFile vFile
Next
End If
End Sub
Private Sub cmdBurn_Click()
'
If (m_eMode = eIdle) Then
createCD
Else
m_bCancel = True
End If
'
End Sub
Private Sub cmdMoveDown_Click()
Dim iIndexNow As Long
Dim sFile As String
Dim iSize As Long
iIndexNow = lstFiles.ListIndex
If (iIndexNow < lstFiles.ListCount - 1) And (lstFiles.ListCount > 1) Then
sFile = lstFiles.List(iIndexNow)
iSize = lstFiles.ItemData(iIndexNow)
lstFiles.RemoveItem iIndexNow
lstFiles.AddItem sFile, iIndexNow + 1
lstFiles.ItemData(iIndexNow + 1) = iSize
lstFiles.ListIndex = iIndexNow + 1
End If
End Sub
Private Sub cmdMoveUp_Click()
Dim iIndexNow As Long
Dim sFile As String
Dim iSize As Long
iIndexNow = lstFiles.ListIndex
If (iIndexNow > 0) And (lstFiles.ListCount > 1) Then
sFile = lstFiles.List(iIndexNow)
iSize = lstFiles.ItemData(iIndexNow)
lstFiles.RemoveItem iIndexNow
lstFiles.AddItem sFile, iIndexNow - 1
lstFiles.ItemData(iIndexNow - 1) = iSize
lstFiles.ListIndex = iIndexNow - 1
End If
End Sub
Private Sub cmdRemove_Click()
Dim sFile As String
Dim iIndex As Long
If (lstFiles.ListIndex > -1) Then
iIndex = lstFiles.ListIndex
sFile = lstFiles.List(iIndex)
If (vbYes = MsgBox("Are you sure you want to remove '" & sFile & "' from
the compilation?", vbQuestion Or vbYesNo)) Then
lstFiles.RemoveItem iIndex
If (lstFiles.ListCount > 0) Then
If (iIndex < lstFiles.ListCount) Then
lstFiles.ListIndex = iIndex
Else
lstFiles.ListIndex = lstFiles.ListCount - 1
End If
Else
enableControl cmdBurn, False
enableControl chkSimulate, False
enableControl chkEject, False
End If
End If
End If
End Sub
Private Sub Form_Load()
enableControl cboRecorder, False
enableControl lstFiles, False
enableControl cmdAdd, False
enableControl cmdRemove, False
enableControl cmdMoveUp, False
enableControl cmdMoveDown, False
enableControl cmdBurn, False
enableControl chkSimulate, False
enableControl chkEject, False
picProgress.Visible = False
showStatus "Examining available disc recorders..."
Me.Show
Me.Refresh
Screen.MousePointer = vbHourglass
showRecorders
Screen.MousePointer = vbDefault
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
showStatus "Shutting down, please wait..."
enableControl cboRecorder, False
enableControl lstFiles, False
enableControl cmdAdd, False
enableControl cmdRemove, False
enableControl cmdMoveUp, False
enableControl cmdMoveDown, False
enableControl cmdBurn, False
Me.Enabled = False
Me.Refresh
Screen.MousePointer = vbHourglass
Set m_cRedbook = Nothing
m_cDiscMaster.ClearUp
Set m_cDiscMaster = Nothing
Screen.MousePointer = vbDefault
End Sub
Private Sub Form_Resize()
On Error Resume Next
cboRecorder.Width = Me.ScaleWidth - cboRecorder.Left - picFiles.Left
picFiles.Width = Me.ScaleWidth - picFiles.Left * 2
picFiles.Height = Me.ScaleHeight - picFiles.TOp - picStatus.Height -
picBurn.Height
picBurn.TOp = picFiles.TOp + picFiles.Height
picBurn.Width = Me.ScaleWidth - picFiles.Left * 2
End Sub
Private Sub lstFiles_Click()
enableControl cmdRemove, (lstFiles.ListIndex > -1)
enableControl cmdMoveUp, (lstFiles.ListIndex > 0)
enableControl cmdMoveDown, (lstFiles.ListIndex < lstFiles.ListCount - 1)
enableControl cmdBurn, (lstFiles.ListCount > 0)
enableControl chkSimulate, (lstFiles.ListCount > 0)
enableControl chkEject, (lstFiles.ListCount > 0)
End Sub
Private Sub m_cDiscMaster_AddProgress(ByVal nCompleted As Long, ByVal nTotal As
Long)
'
' Raised as items are added to the stash.
' Not used in this example.
'
End Sub
Private Sub m_cDiscMaster_BlockProgress(ByVal nCurrentBlock As Long, ByVal
nTotalBlocks As Long)
'
DoEvents
m_cProgress.Value = nCurrentBlock
m_cProgress.Max = nTotalBlocks
'
End Sub
Private Sub m_cDiscMaster_BurnComplete(ByVal status As Long)
'
showStatus "Burn Complete"
picProgress.Visible = False
'
End Sub
Private Sub m_cDiscMaster_ClosingDisc(ByVal nEstimatedSeconds As Long)
'
showStatus "Closing Disc: Estimated time left: " & nEstimatedSeconds
'
End Sub
Private Sub m_cDiscMaster_EraseComplete(ByVal status As Long)
'
showStatus "Disc erase complete."
'
End Sub
Private Sub m_cDiscMaster_PnPActivity()
'
Debug.Print "PnPActivity"
'
End Sub
Private Sub m_cDiscMaster_PreparingBurn(ByVal nEstimatedSeconds As Long)
'
showStatus "Preparing to burn disc: Estimated time: " & nEstimatedSeconds
'
End Sub
Private Sub m_cDiscMaster_QueryCancel(bCancel As Boolean)
'
DoEvents
bCancel = m_bCancel
'
End Sub
Private Sub m_cDiscMaster_TrackProgress(ByVal nCurrentTrack As Long, ByVal
nTotalTracks As Long)
'
If (nCurrentTrack = nTotalTracks) Then
showStatus "Completed burning tracks."
Else
showStatus "Burning track " & nCurrentTrack + 1 & " of " & nTotalTracks
End If
'
End Sub
Private Sub picBurn_Resize()
'
End Sub
Private Sub picFiles_Resize()
Dim lW As Long
Dim lH As Long
On Error Resume Next
'
lW = picFiles.ScaleWidth - lstFiles.Left - cmdMoveUp.Width - 4 *
Screen.TwipsPerPixelX
lH = picFiles.ScaleHeight - cmdAdd.Height - 4 * Screen.TwipsPerPixelY
lstFiles.Width = lW
lstFiles.Height = lH
cmdMoveUp.Left = lstFiles.Left + lW + 2 * Screen.TwipsPerPixelX
cmdMoveUp.TOp = lstFiles.TOp + (lstFiles.Height - (cmdMoveUp.Height +
Screen.TwipsPerPixelY) * 2) \ 2
cmdMoveDown.Left = cmdMoveUp.Left
cmdMoveDown.TOp = cmdMoveUp.TOp + cmdMoveUp.Height + 2 *
Screen.TwipsPerPixelY
cmdAdd.TOp = lstFiles.TOp + lH + 2 * Screen.TwipsPerPixelY
cmdRemove.TOp = cmdAdd.TOp
'
End Sub
Private Sub picProgress_Paint()
If Not m_cProgress Is Nothing Then
m_cProgress.Draw
End If
End Sub
Private Sub picStatus_Resize()
'
On Error Resume Next
picProgress.Width = picStatus.ScaleWidth - picProgress.Left * 2
lblStatus.Width = picProgress.Width
'
End Sub
 |