VB5 Simple CD Burner (70K)
VB6 Simple CD Burner (67K)
2 Jun 2004
First Posted
vbAccelerator TreeView Control
VB IMAPI (CD Burning) Interfaces (IVBIMAPI.tlb)
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
 |