Change this Program

Tech-Archive recommends: Fix windows errors by optimizing your registry

Hi
I need some help please, can I delete the Button Options and code the file
to Burn into the program somewhere, it will always be the same. I have tried
all options I can think of without any success, at the moment I do not fully
understand all of the program.



Option Explicit

Private m_cSimpleCDBurner As cSimpleCDBurner

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

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 sPathFrom 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
' sPathFrom = "Copy of OurData.mdb"
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

' If tvwFiles = True Then sPathFrom = "Copy of OurData.mdb"

sPathFrom = "Copy of OurData.mdb"
' Call tvwFiles_DragDropRequest

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 + 10
txtStagingArea.Width = txtDrive.Width + 10
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 vbalTreeViewLib6.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
vbalTreeViewLib6.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
'here?
' sPathFrom = "C:\Addressbook\AccessFile\Copy of OurData.mdb"
'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


.

Quantcast