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