Friday, November 18, 2005
  
Option Explicit
Global gintcancel As Integer


Function DirFileCopy(strsource As String, strdest As String)
'Copies Files including Sub-Dirs from one location to another
'By Daniel Paull (c) Daniel Paull
On Error GoTo DirFileCopy_Error
Dim oldmatch As String
Dim strmatch As String
Dim lngattr As Long
Dim varreturn As Variant

strmatch = Dir(strsource, vbDirectory + vbHidden + vbArchive + vbSystem) ' Retrieve the first entry.
Do While strmatch <> "" And gintcancel = False ' Start the loop.
DoEvents
On Error GoTo DirFileCopy_Error
If strmatch <> "." And strmatch <> ".." Then
'It's not a link to previous dirs
lngattr = GetAttr(strsource) And vbNormal And vbReadOnly And vbHidden And vbSystem
oldmatch = strmatch
If (GetAttr(strsource & strmatch) And vbDirectory) = vbDirectory Then
'This is a subdir and so must also be copied
On Error Resume Next
'Mkdir the new dir
MkDir strdest & strmatch
On Error GoTo DirFileCopy_Error
'Relaunch the DirFileCopy using the SubDirs
DirFileCopy strsource & strmatch & "\", strdest & strmatch & "\"
'Restore file properties
SetAttr strdest & strmatch, GetAttr(strsource & strmatch)
'Continue loop
strmatch = Dir(strsource, vbDirectory + vbHidden + vbArchive + vbSystem)
Do While strmatch <> "" And strmatch <> oldmatch
strmatch = Dir
Loop
Else
'This is just a file
varreturn = CopyFile(strsource & strmatch, strdest & strmatch)
If varreturn =

Then
SetAttr strdest & strmatch, GetAttr(strsource & strmatch)
oldmatch = Dir(strsource, vbDirectory + vbHidden + vbArchive + vbSystem)
Do Until oldmatch = strmatch
oldmatch = Dir
Loop
Else
Error varreturn
End If
End If ' it represents a directory.
End If
strmatch = Dir ' Get next entry.
Loop
DirFileCopy =



DirFileCopy_Error:
Select Case Err
Case 0
Case 5
Resume Next
Case 76
DirFileCopy = 76
Case 61
MsgBox "The Destination Disk is Full", , "Disk Full"
DirFileCopy = Err
Case Else
MsgBox "An error has occurred " & " " & Err & " " & Err.Description, , "Error"
End Select
Exit Function
Resume
End Function
Public Function CopyFile(strlocation As String, strdestination As String) As Integer
'My Routine for copying files
On Error GoTo copyfile_error
If Len(Dir(strlocation, vbDirectory + vbHidden + vbArchive + vbSystem)) Then
DoEvents
FileCopy strlocation, strdestination
Else
MsgBox "The File " & strlocation & " can not be copied because it does not exits!"
End If
CopyFile =


Exit Function


copyfile_error:
Select Case Err
Case 53
MsgBox "The File " & strlocation & " can not be copied because it does not exits!"
Case 61
MsgBox "The file " & strlocation & " can not be copied to " & strdestination & " because the Disk is full!", , "Disk Full"
Case Else
MsgBox "An error has occurred copying needed install files to destination" & strdestination & " " & Err & " " & Err.Description, , "Error"
End Select
CopyFile = Err
Exit Function
Resume
End Function
Public Function DirFileKill(strsource As String)
'Kill Directories, not very nice but effective
On Error GoTo DirFileKill_Error
Dim oldmatch As String
Dim strmatch As String

On Error Resume Next
Kill strsource & "*.*"
On Error GoTo DirFileKill_Error

strmatch = Dir(strsource, vbDirectory + vbHidden + vbSystem + vbReadOnly) ' Retrieve the first entry.
Do While strmatch <> "" And gintcancel = False ' Start the loop.
DoEvents
On Error GoTo DirFileKill_Error
If strmatch <> "." And strmatch <> ".." Then
oldmatch = strmatch
SetAttr strsource & strmatch, vbNormal
If (GetAttr(strsource & strmatch) And vbDirectory) = vbDirectory Then
DirFileKill strsource & strmatch & "\"
RmDir strsource & strmatch & "\"
strmatch = Dir(strsource, vbDirectory)
Else
Kill strsource & "*.*"
End If ' it represents a directory.
End If
strmatch = Dir ' Get next entry.
Loop
RmDir strsource

DirFileKill_Error:
'Stop
Select Case Err

Case 0
Case 75
If (GetAttr(strsource & strmatch) And vbDirectory) = vbDirectory Then
DirFileKill strsource & strmatch & "\"
End If
Case 53
Resume Next
Case 5
' Stop
Resume Next
Case 76
Resume Next
Case Else
MsgBox "An error has occurred " & " " & Err & " " & Err.Description, , "Error"
End Select
Exit Function
Resume
End Function