vbAccelerator - Contents of code file: frmCDBurn.frm

This file is part of the download VB5 Simple CD Burner, which is described in the article Simple Data CD Creation Using ICDBurn.

VERSION 5.00
Object = "{A3A35BDB-3B6A-46F3-B662-08B8F72ECD03}#11.1#0"; "vbalTreeView.ocx"
Begin VB.Form frmCDBurn 
   Caption         =   "Simple CD Burner"
   ClientHeight    =   6105
   ClientLeft      =   5415
   ClientTop       =   2205
   ClientWidth     =   6585
   BeginProperty Font 
      Name            =   "Tahoma"
      Size            =   8.25
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   Icon            =   "frmCDBurn.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   6105
   ScaleWidth      =   6585
   Begin VB.CommandButton cmdBurn 
      Caption         =   "&Burn..."
      Height          =   375
      Left            =   1620
      TabIndex        =   9
      Top             =   5640
      Width           =   1215
   End
   Begin VB.PictureBox picSimpleBurnInfo 
      BorderStyle     =   0  'None
      Height          =   5415
      Left            =   120
      ScaleHeight     =   5415
      ScaleWidth      =   6375
      TabIndex        =   0
      Top             =   120
      Width           =   6375
      Begin VB.CommandButton cmdRemove 
         Caption         =   "&Remove..."
         Height          =   375
         Left            =   2820
         TabIndex        =   11
         Top             =   4980
         Width           =   1275
      End
      Begin VB.CommandButton cmdAdd 
         Caption         =   "&Add..."
         Height          =   375
         Left            =   1500
         TabIndex        =   10
         Top             =   4980
         Width           =   1275
      End
      Begin VB.CommandButton cmdRefresh 
         Caption         =   "&Refresh"
         Height          =   375
         Left            =   4140
         TabIndex        =   7
         Top             =   4980
         Width           =   1275
      End
      Begin VB.TextBox txtStagingArea 
         Height          =   315
         Left            =   1500
         TabIndex        =   5
         Top             =   660
         Width           =   4815
      End
      Begin VB.TextBox txtDrive 
         Height          =   315
         Left            =   1500
         TabIndex        =   3
         Top             =   300
         Width           =   4815
      End
      Begin vbalTreeViewLib.vbalTreeView tvwFiles 
         Height          =   3855
         Left            =   1500
         TabIndex        =   6
         Top             =   1080
         Width           =   4815
         _ExtentX        =   8493
         _ExtentY        =   6800
         OLEDropMode     =   1
         DragAutoExpand  =   -1
         BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
            Name            =   "Tahoma"
            Size            =   8.25
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
      End
      Begin VB.Label lblFiles 
         Caption         =   "&Files:"
         Height          =   255
         Left            =   60
         TabIndex        =   8
         Top             =   1140
         Width           =   1395
      End
      Begin VB.Label lblStagingArea 
         Caption         =   "&Staging Area:"
         Height          =   255
         Left            =   60
         TabIndex        =   4
         Top             =   720
         Width           =   1395
      End
      Begin VB.Label lblDriveLetter 
         Caption         =   "&Recorder Drive:"
         Height          =   255
         Left            =   60
         TabIndex        =   2
         Top             =   360
         Width           =   1395
      End
      Begin VB.Label lblInformation 
         BackColor       =   &H80000010&
         Caption         =   " Simple CD Burn Details"
         ForeColor       =   &H80000014&
         Height          =   255
         Left            =   0
         TabIndex        =   1
         Top             =   0
         Width           =   6975
      End
   End
End
Attribute VB_Name = "frmCDBurn"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private m_cSimpleCDBurner As cSimpleCDBurner

Private m_cImlSmall As cVBALSysImageList
Private m_shl As New Shell
Private m_lId As Long

Private Sub enableControl(ctl As Control, ByVal bState As Boolean)
Dim oColor As OLE_COLOR
   oColor = IIf(bState, vbWindowBackground, vbButtonFace)
   ctl.Enabled = bState
   If TypeOf ctl Is TextBox Then
      ctl.BackColor = oColor
   ElseIf TypeOf ctl Is vbalTreeView Then
      ctl.BackColor = oColor
   End If
End Sub

Private Function validateDragLocation(nodDrag As cTreeViewNode, nodInsert As
 cTreeViewNode) As Boolean
   
   ' only ok if (a) nodInsert is a folder
   ' and (b) nodDrag's path is not a wholly
   ' contained child of nodInsert
   Dim sPathDrag As String
   Dim sPathInsert As String
   Dim iPos As Long
   Dim bOk As Boolean
   
   If nodInsert.ItemData = 0 Then
   
      If Not nodDrag Is Nothing Then
         sPathDrag = nodDrag.Key
         iPos = InStr(sPathDrag, ":")
         sPathDrag = Mid(sPathDrag, iPos + 1)
      Else
         ' TODO: confirm for the files in the data
      End If
      
      sPathInsert = nodInsert.Key
      iPos = InStr(sPathInsert, ":")
      sPathInsert = Mid(sPathInsert, iPos + 1)
      
      bOk = Not (InStr(sPathInsert, sPathDrag) = 1)
      
   End If
   validateDragLocation = bOk

End Function


Private Sub configureTreeView()
   
   ' Set up the Image List
   Set m_cImlSmall = New cVBALSysImageList
   With m_cImlSmall
      .IconSizeX = 16
      .IconSizeY = 16
      .Create
   End With
   tvwFiles.ImageList = m_cImlSmall.hIml
   tvwFiles.DragStyle = etvwDropHighlight

End Sub

Private Function IsReallyAFolder(itm As FolderItem) As Boolean
Dim bIsFolder As Boolean
Dim sExt As String
   If (itm.IsFolder) Then
      bIsFolder = True
      If Len(itm.Path) > 4 Then
         sExt = LCase(Right(itm.Path, 4))
         If (sExt = ".zip") Then
            bIsFolder = False
         End If
      End If
   End If
   IsReallyAFolder = bIsFolder
End Function

Private Sub showStagingFiles()
Dim fdr As Folder
Dim itm As FolderItem

   Set fdr = m_shl.NameSpace(m_cSimpleCDBurner.BurnStagingAreaFolder)
   For Each itm In fdr.items
      If (itm.IsFileSystem) And Not (itm.IsLink) Then
         addFileOrFolder tvwFiles.nodes, itm.Name, itm.Path,
          IsReallyAFolder(itm)
      End If
   Next
   
End Sub

Private Sub addFileOrFolder(nodes As cTreeViewNodes, ByVal sName As String,
 ByVal sPath As String, ByVal bIsFolder As Boolean)
Dim sKey As String
Dim nod As cTreeViewNode

   If (bIsFolder) Then
      m_lId = m_lId + 1
      sKey = m_lId & ":" & sPath
      Set nod = nodes.Add(, , sKey, sName, _
         m_cImlSmall.ItemIndex(sPath, True))
      nod.ItemData = 0
      m_lId = m_lId + 1
      nod.Children.Add , , "TODO:" & m_lId, "Unexpanded"
   Else
      m_lId = m_lId + 1
      sKey = m_lId & ":" & sPath
      Set nod = nodes.Add(, , sKey, sName, _
         m_cImlSmall.ItemIndex(sPath, True))
      nod.ItemData = 1
   End If
   
End Sub

Private Sub createCDBurner()
   
   Set m_cSimpleCDBurner = New cSimpleCDBurner
   On Error GoTo errorHandler
   m_cSimpleCDBurner.Initialise Me.hwnd
   
   If (m_cSimpleCDBurner.HasRecordableDrive) Then
      txtDrive.Text = m_cSimpleCDBurner.RecorderDriveLetter
      txtStagingArea.Text = m_cSimpleCDBurner.BurnStagingAreaFolder
      showStagingFiles
      
      enableControl txtStagingArea, True
      enableControl txtDrive, True
      enableControl tvwFiles, True
      enableControl cmdAdd, True
      enableControl cmdRemove, True
      enableControl cmdRefresh, True
      enableControl cmdBurn, True
      
   Else
      txtDrive.Text = "No Recordable Drive found."
      txtStagingArea.Text = "N/A"
   End If
   Exit Sub

errorHandler:
   txtDrive.Text = "CD Burner Interface not initialised"
   txtStagingArea.Text = "N/A"
   MsgBox "Failed to initialise the CD Burner", vbExclamation
   Exit Sub

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:="All Files (*.*)|*.*", _
      Owner:=Me.hwnd)) Then
      
      Dim sPathTo As String
      Dim nodSel As cTreeViewNode
      Set nodSel = tvwFiles.SelectedItem
      sPathTo = txtStagingArea.Text
      If Not (nodSel Is Nothing) Then
         If (nodSel.ItemData = 0) Then
            sPathTo = ExtractPathFromKey(nodSel.Key)
         ElseIf Not (nodSel.Parent Is Nothing) Then
            Set nodSel = nodSel.Parent
            sPathTo = ExtractPathFromKey(nodSel.Key)
         Else
            Set nodSel = Nothing
         End If
      End If
      
      For Each vFile In cD.GetMultiSelectFileNames(sFile)
         copyOrMoveFileOrFolder nodSel, vFile, AddFileToDirectory(sPathTo,
          GetFileName(vFile)), True
      Next
      
   End If
End Sub

Private Sub cmdBurn_Click()
   On Error Resume Next
   m_cSimpleCDBurner.Burn
   If Not (Err.Number = 0) Then
      MsgBox "An error occurred whilst trying to burn the files." & vbCrLf &
       vbCrLf & Err.Description, vbExclamation
   End If
End Sub

Private Sub cmdRefresh_Click()
   
   tvwFiles.nodes.Clear
   
   showStagingFiles
   
End Sub

Private Sub cmdRemove_Click()
Dim nodSel As cTreeViewNode
Dim sQuestion As String
Dim sPath As String
   Set nodSel = tvwFiles.SelectedItem
   If Not (nodSel Is Nothing) Then
      sPath = ExtractPathFromKey(nodSel.Key)
      If (nodSel.ItemData = 0) Then
         sQuestion = "Are you sure you want to remove the folder '" & sPath &
          "' and any subdirectories?"
      Else
         sQuestion = "Are you sure you want to remove the file '" & sPath & "'?"
      End If
      If (vbYes = MsgBox(sQuestion, vbYesNo Or vbQuestion)) Then
         removeFileOrFolder sPath, (nodSel.ItemData = 0)
         nodSel.Delete
      End If
   End If
End Sub

Private Sub removeFileOrFolder(ByVal sPath As String, ByVal bIsFolder As
 Boolean)
Dim fdr As Folder
Dim itm As FolderItem
   If (bIsFolder) Then
      Set fdr = m_shl.NameSpace(sPath)
      For Each itm In fdr.items
         removeFileOrFolder itm.Path, IsReallyAFolder(itm)
      Next
      RmDir sPath
   Else
      Kill sPath
   End If
End Sub

Private Sub Form_Load()
   
   enableControl txtStagingArea, False
   enableControl txtDrive, False
   enableControl tvwFiles, False
   enableControl cmdAdd, False
   enableControl cmdRemove, False
   enableControl cmdRefresh, False
   enableControl cmdBurn, False
   
   Me.Show
   Me.Refresh
   
   configureTreeView
   
   createCDBurner
           
End Sub


Private Sub Form_Resize()
   On Error Resume Next
   picSimpleBurnInfo.Move picSimpleBurnInfo.Left, picSimpleBurnInfo.TOp, _
      Me.ScaleWidth - picSimpleBurnInfo.Left * 2, _
      Me.ScaleHeight - picSimpleBurnInfo.TOp * 3 - cmdBurn.Height
   cmdBurn.Move cmdBurn.Left, picSimpleBurnInfo.TOp + picSimpleBurnInfo.Height
End Sub

Private Sub picSimpleBurnInfo_Resize()
   '
   On Error Resume Next
   lblInformation.Width = picSimpleBurnInfo.ScaleWidth
   txtDrive.Width = picSimpleBurnInfo.ScaleWidth - txtDrive.Left
   txtStagingArea.Width = txtDrive.Width
   tvwFiles.Move tvwFiles.Left, tvwFiles.TOp, txtDrive.Width, _
      picSimpleBurnInfo.ScaleHeight - tvwFiles.TOp - cmdAdd.Height - 4 *
       Screen.TwipsPerPixelY
   cmdAdd.TOp = tvwFiles.TOp + tvwFiles.Height + 2 * Screen.TwipsPerPixelY
   cmdRemove.TOp = cmdAdd.TOp
   cmdRefresh.TOp = cmdAdd.TOp
   '
End Sub

Private Sub tvwFiles_BeforeExpand(node As vbalTreeViewLib.cTreeViewNode, cancel
 As Boolean)
   '
   If InStr(node.FirstChild.Key, "TODO:") = 1 Then
      
      Screen.MousePointer = vbHourglass
      
      node.Children.Remove 1

      Dim items As Folder
      Dim itm As FolderItem
      Dim sPath As String
      Dim nodes As cTreeViewNodes
      Set nodes = node.Children
      
      sPath = ExtractPathFromKey(node.Key)
      Set items = m_shl.NameSpace(sPath)
      If Not items Is Nothing Then
         For Each itm In items.items
            If (itm.IsFileSystem) And Not (itm.IsLink) Then
               addFileOrFolder nodes, itm.Name, itm.Path, IsReallyAFolder(itm)
            End If
         Next
      End If
      
      node.Sort etvwItemDataThenAlphabetic
      
      Screen.MousePointer = vbDefault
      
   End If
   '
End Sub

Private Function ExtractPathFromKey(ByVal sKey As String) As String
Dim iPos As Long
   iPos = InStr(sKey, ":")
   ExtractPathFromKey = Mid(sKey, iPos + 1)
End Function

Private Function AddFileToDirectory(ByVal sDir As String, ByVal sFile As
 String) As String
   If (Right(sDir, 1) <> "\") Then
      sDir = sDir & "\"
   End If
   ' Note: note dealing with .. or .
   AddFileToDirectory = sDir & sFile
End Function

Private Function GetDirectory(ByVal sPath As String) As String
Dim iPos As Long
Dim sDir As String
   sDir = sPath
   For iPos = Len(sPath) To 1 Step -1
      If (Mid(sPath, iPos, 1) = "\") Then
         sDir = Left(sPath, iPos - 1)
         Exit For
      End If
   Next iPos
   GetDirectory = sDir
End Function

Private Function GetFileName(ByVal sPath As String) As String
Dim iPos As Long
Dim sFile As String
   sFile = sPath
   For iPos = Len(sPath) To 1 Step -1
      If (Mid(sPath, iPos, 1) = "\") Then
         sFile = Mid(sPath, iPos + 1)
         Exit For
      End If
   Next iPos
   GetFileName = sFile
End Function

Private Sub tvwFiles_DragDropRequest(Data As DataObject, nodeOver As
 vbalTreeViewLib.cTreeViewNode, ByVal bAbove As Boolean, ByVal hitTest As Long)
Dim nodDrag As cTreeViewNode
Dim sPathFrom As String
Dim sPathTo As String
Dim sDirTo As String
Dim sText As String
   
   Set nodDrag = tvwFiles.NodeFromDragData(Data)
   
   If Not (nodDrag Is Nothing) Then ' not a treeview node
      
      If validateDragLocation(nodDrag, nodeOver) Then
                  
         sPathFrom = ExtractPathFromKey(nodDrag.Key)
         sPathTo = ExtractPathFromKey(nodeOver.Key)
         sPathTo = AddFileToDirectory(sPathTo, nodDrag.Text)
         sText = nodDrag.Text
         
         ' Delete the source drag node:
         nodDrag.Delete
         
         copyOrMoveFileOrFolder nodeOver, sPathFrom, sPathTo, False

      End If
            
   Else
      
      Dim iFileCount As Long
      Dim iFile As Long
      
      ' Dropping some files:
      On Error Resume Next
      iFileCount = Data.Files.Count
      On Error GoTo 0
      
      If (iFileCount > 0) Then
         
         If nodeOver Is Nothing Then
            sDirTo = txtStagingArea.Text
         Else
            sDirTo = ExtractPathFromKey(nodeOver.Key)
         End If
      
         For iFile = 1 To iFileCount
            sPathFrom = Data.Files(iFile)
            sText = GetFileName(sPathFrom)
            sPathTo = AddFileToDirectory(sDirTo, sText)
            
            copyOrMoveFileOrFolder nodeOver, sPathFrom, sPathTo, True
            
         Next iFile
         
      End If
      
   End If
   
   '
End Sub

Private Sub copyOrMoveFileOrFolder( _
      nodParent As cTreeViewNode, _
      ByVal sPathFrom As String, _
      ByVal sPathTo As String, _
      ByVal bCopy As Boolean)
Dim iAttr As Integer
   
   If (sPathFrom = sPathTo) Then
      ' Null
      Exit Sub
   End If
   
   iAttr = GetAttr(sPathFrom)
   If (iAttr And vbDirectory) = vbDirectory Then
      ' Create the new directory
      MkDir sPathTo
      If (nodParent Is Nothing) Then
         addFileOrFolder tvwFiles.nodes, GetFileName(sPathTo), sPathTo, True
      Else
         addFileOrFolder nodParent.Children, GetFileName(sPathTo), sPathTo, True
      End If
      '
      ' Now move or copy all of the underlying files
      moveOrCopyFolder sPathFrom, sPathTo, bCopy, True
      '
   Else
      ' Simply moving or copying a file
      FileCopy sPathFrom, sPathTo
      If Not (bCopy) Then
         Kill sPathFrom
      End If
      If (nodParent Is Nothing) Then
         addFileOrFolder tvwFiles.nodes, GetFileName(sPathTo), sPathTo, False
      Else
         addFileOrFolder nodParent.Children, GetFileName(sPathTo), sPathTo,
          False
      End If
   End If
            
End Sub

Private Sub moveOrCopyFolder(ByVal sPathFrom As String, ByVal sPathTo As
 String, ByVal bCopy As Boolean, ByVal bTopFolder As Boolean)
Dim itm As FolderItem
Dim fdr As Folder

   If Not (bTopFolder) Then
      MkDir sPathTo
   End If
   Set fdr = m_shl.NameSpace(sPathFrom)
   For Each itm In fdr.items
      If (itm.IsFileSystem) And (itm.IsBrowsable) And Not (itm.IsLink) Then
         If (IsReallyAFolder(itm)) Then
            ' Recurse
            moveOrCopyFolder itm.Path, AddFileToDirectory(sPathTo, itm.Name),
             bCopy, False
         Else
            ' Move or copy the file
            FileCopy itm.Path, AddFileToDirectory(sPathTo, itm.Name)
            If Not (bCopy) Then
               Kill itm.Path
            End If
         End If
      End If
   Next
   
   If Not (bCopy) Then
      RmDir sPathFrom
   End If
   
End Sub

Private Sub tvwFiles_OLEDragOver(Data As DataObject, Effect As Long, Button As
 Integer, Shift As Integer, x As Single, y As Single, State As Integer)
   
   ' Check if we're attempting to make something a child of
   ' itself:
   Dim nodDrag As cTreeViewNode
   Dim bOk As Boolean
   Dim nodInsert As cTreeViewNode
   Dim iFileCount As Long
   
   bOk = False
   
   ' Get drag node:
   Set nodDrag = tvwFiles.NodeFromDragData(Data)
   If Not (nodDrag Is Nothing) Then ' It isn't a treeview node
   
      ' Get drag insert point
      Set nodInsert = tvwFiles.DragInsertNode()
      If Not (nodInsert Is Nothing) Then ' there is no current insert point
      
         bOk = validateDragLocation(nodDrag, nodInsert)
         
      End If
      
   Else
      On Error Resume Next
      iFileCount = Data.Files.Count
      On Error GoTo 0
      If (iFileCount > 0) Then
         
         ' Get drag insert point
         Set nodInsert = tvwFiles.DragInsertNode()
         If (nodInsert Is Nothing) Then
            ' there is no current insert point
            bOk = True
         Else
            bOk = validateDragLocation(Nothing, nodInsert)
            
         End If
         
      End If
   End If
   
   Effect = IIf(bOk, vbDropEffectMove, vbDropEffectNone)
   
End Sub

Private Sub tvwFiles_OLEStartDrag(Data As DataObject, AllowedEffects As Long)
   '
   ' Check if this is a root node:
   Dim nodDrag As cTreeViewNode
   Dim iFileCount As Long
   
   Set nodDrag = tvwFiles.NodeFromDragData(Data)
   If (nodDrag Is Nothing) Then
      On Error Resume Next
      iFileCount = Data.Files.Count
      On Error GoTo 0
      If (iFileCount > 0) Then
         AllowedEffects = vbDropEffectCopy
      Else
         AllowedEffects = vbDropEffectNone
      End If
   Else
      AllowedEffects = vbDropEffectMove
   End If
   '
End Sub

Private Sub tvwFiles_SelectedNodeChanged()
Dim sKey As String
Dim iPos As Long
Dim sPath As String
   sKey = tvwFiles.SelectedItem.Key
   iPos = InStr(sKey, ":")
   sPath = Mid(sKey, iPos + 1)
   'txtSelected.Text = tvwDirs.SelectedItem.Text & " (" & sPath & ")"
End Sub