|
|
|
|
|
|
|
|
|
|
|
 |
|
|||||||||||||||||||||||||||||||||||||||||||||||||||||||
|
||||||||||||||||||||||||||||||||||||||||||||||||||||||||
 |
||||||||||||||||||||||||||||||||||||||||||||||||||||||||
Visual Basic Callbacks CopyFileEx: Create a File Backup App with a Progress Callback |
|
| Posted: | Saturday September 18, 1999 |
| Updated: | Monday December 26, 2011 |
| Applies to: | VB5, VB6 |
| Developed with: | VB6, Windows NT4 |
| OS restrictions: | Windows NT4, Windows 2000, Windows XP |
| Author: | VBnet - Randy Birch, MSDN |
|
Related: |
CopyFileEx: Create a File Backup App |
| Prerequisites |
| Windows NT4 or greater. |
|
|
 "So
that's how you do it!" This demo shows how to add a callback to the CopyFileEx API that returns the progress of a copying routine.
But there is a catch ... CopyFileEx is only available on real operating systems - AKA Windows NT.
This demo uses the same basic logic and methodologies as shown in CopyFileEx: Create a File Backup App, but adds the code to utilize the CopyProgressRoutine to display each file's copying progress in a standard VB ProgressBar. CopyFileEx: Create a File Backup Appexplained pretty well what the logic is behind these demos so I'll concentrate here on explaining the callback members. The CopyProgressRoutine is defined in the MSDN as taking ULARGE integers for its first four parameters. Since VB does not yet support ULARGE, I have declared those parameters using the Currency data type which is conveniently the same size as a ULARGE integer (8 bytes). But since a currency is returned with three decimals, it is necessary to multiply the returned value by 10000 to get the actual number. The MSDN defines the members of the CopyFileEx API and its callback as: CopyFileEx members
CopyProgressRoutine Callback members
When CopyFileEx is invoked, and passed the AddressOf a CopyProgressRoutine callback, for every file CopyFileEx handles it sends one CALLBACK_STREAM_SWITCH message in the dwCallbackReason member. This message signifies that a new file is about to be copied, and its TotalFileSize member contains not surprisingly the size of the file about to be copied. In the callback, this is the place to define the maximum value for the progressbar, and to reset its current value to 0 in preparation for the copying. During the copy process, the callback will receive at least one CALLBACK_CHUNK_FINISHED message as dwCallbackReason. The TotalBytesTransferred member will contain a value representing the bytes copied thus far, providing an easy method to calculate the file's copy progress. In my test the dwStreamNumber was always 1. This demo has a couple of changes making it sufficiently different from the "CopyFileEx: Create a File Backup App" demo that it would be best to construct this project form from scratch. |
| BAS Module Code |
|
| Place the following code into the general declarations area of a bas module: |
|
|
Option Explicit '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Copyright ©1996-2011 VBnet/Randy Birch, All Rights Reserved. ' Some pages may also contain other copyrights by the author. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Distribution: You can freely use this code in your own ' applications, but you may not reproduce ' or publish this code on any web site, ' online service, or distribute as source ' on any media without express permission. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Public Const MAXDWORD As Long = &HFFFFFFFF
Public Const MAX_PATH As Long = 260
Public Const INVALID_HANDLE_VALUE As Long = -1
Public Const FILE_ATTRIBUTE_DIRECTORY As Long = &H10
'Define possible return codes from the CopyFileEx callback routine
Public Const PROGRESS_CONTINUE As Long = 0
Public Const PROGRESS_CANCEL As Long = 1
Public Const PROGRESS_STOP As Long = 2
Public Const PROGRESS_QUIET As Long = 3
'CopyFileEx callback routine state change values
Public Const CALLBACK_CHUNK_FINISHED As Long = &H0
Public Const CALLBACK_STREAM_SWITCH As Long = &H1
'CopyFileEx option flags
Public Const COPY_FILE_FAIL_IF_EXISTS As Long = &H1
Public Const COPY_FILE_RESTARTABLE As Long = &H2
Public Const COPY_FILE_OPEN_SOURCE_FOR_WRITE As Long = &H4
Public Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Public Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
Public Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Public Declare Function FindFirstFile Lib "kernel32" _
Alias "FindFirstFileA" _
(ByVal lpFileName As String, _
lpFindFileData As WIN32_FIND_DATA) As Long
Public Declare Function FindNextFile Lib "kernel32" _
Alias "FindNextFileA" _
(ByVal hFindFile As Long, _
lpFindFileData As WIN32_FIND_DATA) As Long
Public Declare Function FindClose Lib "kernel32" _
(ByVal hFindFile As Long) As Long
Public Declare Function CompareFileTime Lib "kernel32" _
(lpFileTime1 As FILETIME, _
lpFileTime2 As FILETIME) As Long
Public Declare Function CopyFile Lib "kernel32" _
Alias "CopyFileA" _
(ByVal lpExistingFileName As String, _
ByVal lpNewFileName As String, _
ByVal bFailIfExists As Long) As Long
Public Declare Function CreateDirectory Lib "kernel32" _
Alias "CreateDirectoryA" _
(ByVal lpPathName As String, _
lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long
Public Declare Function CopyFileEx Lib "kernel32" _
Alias "CopyFileExA" _
(ByVal lpExistingFileName As String, _
ByVal lpNewFileName As String, _
ByVal lpProgressRoutine As Long, _
lpData As Any, _
pbCancel As Long, _
ByVal dwCopyFlags As Long) As Long
Public Function FARPROC(ByVal pfn As Long) As Long
'A dummy procedure that receives and returns
'the value of the AddressOf operator.
'Obtain and set the address of the callback
'This workaround is needed as you can't assign
'AddressOf directly to a member of a user-
'defined type, but you can assign it to another
'long and use that (as returned here)
FARPROC = pfn
End Function
Public Function CopyProgressCallback(ByVal TotalFileSize As Currency, _
ByVal TotalBytesTransferred As Currency, _
ByVal StreamSize As Currency, _
ByVal StreamBytesTransferred As Currency, _
ByVal dwStreamNumber As Long, _
ByVal dwCallbackReason As Long, _
ByVal hSourceFile As Long, _
ByVal hDestinationFile As Long, _
lpData As Long) As Long
Select Case dwCallbackReason
Case CALLBACK_STREAM_SWITCH:
'this value is passed whenever the
'callback is initialized for each file.
Form1.ProgressBar1.Value = 0
Form1.ProgressBar1.Min = 0
Form1.ProgressBar1.Max = (TotalFileSize * 10000)
Form1.ProgressBar1.Refresh
CopyProgressCallback = PROGRESS_CONTINUE
Case CALLBACK_CHUNK_FINISHED
'called when a block has been copied
Form1.ProgressBar1.Value = (TotalBytesTransferred * 10000)
'optional. While the app is copying it
'will not respond to input for canceling.
DoEvents
CopyProgressCallback = PROGRESS_CONTINUE
End Select
End Function
|
| Form Code |
|
| Create a new project, and add to the form: two text boxes
(Text1 & Text2), one list (List1), two command buttons, (Command1 and Command2) and a checkbox (Check1). Label as desired.
Unlike the CopyFile demo, this only lists the target file actions, so the code handling the messages displayed was changed. Once constructed, add the following code: |
|
|
Option Explicit
'passing True for bCancelBackup will
'terminate the copy procedure
Dim bCancelBackup As Long
Private Sub BackupBegin(bUseCallback As Boolean)
Dim WFDSource As WIN32_FIND_DATA
Dim WFDTarget As WIN32_FIND_DATA
Dim sSourceFolder As String
Dim sTargetFolder As String
Dim hFileSource As Long
Dim hFileTarget As Long
'Assure both source and target
'paths are fully qualified
sSourceFolder = QualifyPath(Text1.Text)
sTargetFolder = QualifyPath(Text2.Text)
'Check for existence of source folder
'by obtaining a handle to the source
hFileSource = FileGetFileHandle(sSourceFolder, WFDSource)
'If source folder not available, perform
'action (ie abort, map a drive etc)
If hFileSource = INVALID_HANDLE_VALUE Then
MsgBox "Backup source folder " & sSourceFolder & " not found."
Exit Sub
End If
'Check for existence of target folder
'by obtaining a handle to the target
hFileTarget = FileGetFileHandle(sTargetFolder, WFDTarget)
If hFileTarget = INVALID_HANDLE_VALUE Then
'If target folder not available, perform
'action (ie abort, create folder(s) etc).
'Here, we'll create the folder(s)
MsgBox "Backup target folder " & sTargetFolder & " not found. Creating the target."
'remember ... hFileTarget has been closed in
'the CreateNestedFolders call ... do
'not attempt to use this handle!
hFileTarget = CreateNestedFolders(sTargetFolder)
End If
'If source and target handles are valid
If (hFileSource <> INVALID_HANDLE_VALUE) And _
(hFileTarget <> INVALID_HANDLE_VALUE) Then
'clear the cancel backup flag
bCancelBackup = False
'perform the backup
Call BackupSourceFolder(hFileSource, sSourceFolder, _
WFDSource, sTargetFolder, bUseCallback)
End If
'clean up by closing the source handle. The target
'handle is closed in the BackupSourceFolder sub.
Call FindClose(hFileSource)
End Sub
Private Function FileCompareFileDates(WFDSource As WIN32_FIND_DATA, _
WFDTarget As WIN32_FIND_DATA) As Long
Dim CTSource As FILETIME
Dim CTTarget As FILETIME
CTSource.dwHighDateTime = WFDSource.ftLastWriteTime.dwHighDateTime
CTSource.dwLowDateTime = WFDSource.ftLastWriteTime.dwLowDateTime
CTTarget.dwHighDateTime = WFDTarget.ftLastWriteTime.dwHighDateTime
CTTarget.dwLowDateTime = WFDTarget.ftLastWriteTime.dwLowDateTime
FileCompareFileDates = CompareFileTime(CTSource, CTTarget)
End Function
Private Function UnQualifyPath(ByVal sFolder As String) As String
'remove any trailing slash
sFolder = Trim$(sFolder)
If Right$(sFolder, 1) = "\" Then
UnQualifyPath = Left$(sFolder, Len(sFolder) - 1)
Else
UnQualifyPath = sFolder
End If
End Function
Private Function BackupSourceFolder(ByVal hFileSource As Long, _
ByVal sSourceFolder As String, _
WFDSource As WIN32_FIND_DATA, _
ByVal sTargetFolder As String, _
bUseCallback As Boolean) As Long
'common local working variables
Dim sPath As String
Dim sRootSource As String
Dim sTmp As String
Dim sTargetMsg As String
Dim backupMsg As String
Dim diff As Long
Dim backupSuccess As Boolean
'variables used for the source files and folders
Dim dwSourceFileSize As Long
'variables used for the target files and folders
Dim WFDTarget As WIN32_FIND_DATA
Dim hTargetFile As Long
Dim dwTargetFileSize As Long
sRootSource = QualifyPath(sSourceFolder)
sPath = sRootSource & "*.*"
'last check!
If hFileSource <> INVALID_HANDLE_VALUE Then
Do
'remove trailing nulls from the first retrieved object
sTmp = TrimNull(WFDSource.cFileName)
'if the object is not a folder..
If (WFDSource.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) <> _
FILE_ATTRIBUTE_DIRECTORY Then
'check for the corresponding file
'in the target folder by using the API
'to locate that specific file
hTargetFile = FindFirstFile(sTargetFolder & sTmp, WFDTarget)
'if the file is not in the target folder..
If hTargetFile <> INVALID_HANDLE_VALUE Then
'get the file size for the source and target files
dwSourceFileSize = FileGetFileSize(WFDSource)
dwTargetFileSize = FileGetFileSize(WFDTarget)
'compare the dates.
'If diff = 0 source and target are the same
'If diff = 1 source is newer than target
'If diff = -1 source is older than target
diff = FileCompareFileDates(WFDSource, WFDTarget)
'if the dates, attributes and file times
'are the same...
If (dwSourceFileSize = dwTargetFileSize) And _
WFDSource.dwFileAttributes = WFDTarget.dwFileAttributes And _
diff = 0 Then
'...the files are the same, so take
'appropriate action (here, this is
'to simply list the files for info)
List1.AddItem sTmp & vbTab & _
"exists; same" & vbTab & _
dwTargetFileSize & vbTab & _
WFDTarget.dwFileAttributes & vbTab & _
"not required"
Else
'files are not the same
If diff = 1 Then
'perform the preferred copy method ONLY if
'diff indicated that the source was newer!
backupSuccess = FileCopyProgress(sSourceFolder & sTmp, _
sTargetFolder & sTmp, _
bUseCallback)
sTargetMsg = "source newer"
If (bCancelBackup = False) Then
If backupSuccess = True Then
backupMsg = "file copied"
Else: backupMsg = "*not copied*"
End If
Else: backupMsg = "user cancelled"
End If
ElseIf diff = -1 Then
'source is older
sTargetMsg = "source older"
backupMsg = "not overwritten"
ElseIf diff = 0 Then
'the dates are the same but the file attributes
'are different. Since the date didn't change,
'replacing the file is a judgement call for
'the developer.
sTargetMsg = "attr different"
backupMsg = "not overwritten"
'backupSuccess = FileCopyProgress(...)
End If
'info only: add the files to the
'list with the appropriate message
List1.AddItem sTmp & vbTab & _
sTargetMsg & vbTab & _
dwTargetFileSize & vbTab & _
WFDTarget.dwFileAttributes & vbTab & _
backupMsg
End If 'If dwSourceFileSize
'since the target file was found,
'close the handle
Call FindClose(hTargetFile)
Else:
'the target file was not found so
'copy the file to the target directory
Label2.Caption = "backing up " & sSourceFolder & sTmp
Label2.Refresh
backupSuccess = FileCopyProgress(sSourceFolder & sTmp, _
sTargetFolder & sTmp, _
bUseCallback)
If (bCancelBackup = False) Then
If backupSuccess = True Then
backupMsg = "file copied"
Else: backupMsg = "*not copied*"
End If
Else: backupMsg = "user cancelled"
End If
'info only: add the files to the list
List1.AddItem sTmp & vbTab & _
"backup needed" & vbTab & _
dwTargetFileSize & vbTab & _
WFDTarget.dwFileAttributes & vbTab & _
backupMsg
End If 'If hTargetFile
End If 'If WFDSource.dwFileAttributes
'clear the local variables
dwSourceFileSize = 0
dwTargetFileSize = 0
'optional. While the app is copying it
'will not respond to input for canceling.
DoEvents
Loop While FindNextFile(hFileSource, WFDSource)
End If
End Function
Private Function FileGetFileSize(WFD As WIN32_FIND_DATA) As Long
FileGetFileSize = (WFD.nFileSizeHigh * (MAXDWORD + 1)) + WFD.nFileSizeLow
End Function
Private Function FileGetFileHandle(sPathToFiles As String, WFD As WIN32_FIND_DATA) As Long
Dim sPath As String
Dim sRoot As String
sRoot = QualifyPath(sPathToFiles)
sPath = sRoot & "*.*"
'obtain handle to the first match
'in the target folder
FileGetFileHandle = FindFirstFile(sPath, WFD)
End Function
Private Function QualifyPath(sPath As String) As String
'assures that a passed path ends in a slash
If Right$(sPath, 1) <> "\" Then
QualifyPath = sPath & "\"
Else
QualifyPath = sPath
End If
End Function
Public Function TrimNull(startstr As String) As String
'returns the string up to the first
'null, if present, or the passed string
Dim pos As Integer
pos = InStr(startstr, Chr$(0))
If pos Then
TrimNull = Left$(startstr, pos - 1)
Exit Function
End If
TrimNull = startstr
End Function
Private Sub Command1_Click()
List1.AddItem "--- new backup ---"
Dim bUseCallback As Boolean
'if the checks are checked, pass true to the flags
bUseCallback = Check1.Value = 1
'prevent a recursive entry by
'disabling the command button
Command1.Enabled = False
BackupBegin bUseCallback
Command1.Enabled = True
End Sub
Private Function CreateNestedFolders(ByVal sCompletePath As String) As Long
'creates nested directories on the drive
'included in the path by parsing the passed
'directory string and looping through each
'folder listed to create the final path.
Dim SA As SECURITY_ATTRIBUTES
Dim WFD As WIN32_FIND_DATA
Dim drivePart As String
Dim newDirectory As String
Dim item As String
Dim pos As Long
Dim cnt As Long
Dim hPath As Long
sCompletePath = QualifyPath(sCompletePath)
pos = InStr(sCompletePath, ":\")
If pos Then
drivePart = StripDelimitedItem(sCompletePath, "\")
Else: drivePart = StripDelimitedItem(CurDir(), "\")
End If
Do
cnt = cnt + 1
item = StripDelimitedItem(sCompletePath, "\")
If cnt = 1 Then
newDirectory = drivePart & item
Else
newDirectory = newDirectory & item
End If
SA.nLength = LenB(SA)
Call CreateDirectory(newDirectory, SA)
Loop Until sCompletePath = ""
hPath = FileGetFileHandle(sCompletePath, WFD)
CreateNestedFolders = hPath
Call FindClose(hPath)
End Function
Private Function StripDelimitedItem(startStrg As String, delimiter As String) As String
'take a string separated by nulls,
'split off 1 item, and shorten the string
'so the next item is ready for removal.
Dim pos As Long
Dim item As String
pos = InStr(1, startStrg, delimiter)
If pos Then
StripDelimitedItem = Mid$(startStrg, 1, pos)
startStrg = Mid$(startStrg, pos + 1, Len(startStrg))
End If
End Function
Private Sub Command2_Click()
'passing True for bCancelBackup will
'terminate the copy procedure
bCancelBackup = True
End Sub
Private Function FileCopyProgress(sSourceFile As String, _
sTargetFile As String, _
bUseCallback As Boolean) As Boolean
Dim lpCallback As Long
'if callback/progressbar specified, pass the
'addressof the callback procedure to the
'CopyFileEx lpCallback member. Because AddressOf
'can not be assigned directly, use a roundabout
'means by passing the address to a function
'that returns the same.
If bUseCallback Then
lpCallback = FARPROC(AddressOf CopyProgressCallback)
Else
lpCallback = 0& End If
'if CopyFileEx succeeds, the return
'value is 1. A failure returns 0.
FileCopyProgress = CopyFileEx(sSourceFile, _
sTargetFile, _
lpCallback, _
0&, _
bCancelBackup, _
COPY_FILE_RESTARTABLE) = 1
End Function
|
| Comments |
| Save the project, and before running, set the correct paths in both text boxes. Toss some files into the source folder and run. Note that if you error during the run, you may be unable to delete the target files for a second test. This is due to CopyFile leaving the file opened; the only recourse is to save the work, exit the project and restart it. You can then delete the target folders and/or files and retest. |
|
|
|
|
|
|||||
|
|||||
|
|
|||||
|
Copyright ©1996-2011 VBnet and Randy Birch. All Rights Reserved. |
 |
