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

  • lpExistingFileName - STRING - name of an existing file
  • lpNewFileName - STRING  - name of new file
  • lpProgressRoutine - LONG  - address of callback function
  • lpData - LONG   - data passed to and from the callback function
  • pbCancel -   LONG  - used to cancel the operation
  • dwCopyFlags - LONG   - specifies how the file is copied

CopyProgressRoutine Callback members

  • TotalFileSize   - ULONG  - total file size, in bytes
  • TotalBytesTransferred   - ULONG  - total number of bytes transferred
  • StreamSize  - ULONG  - total number of bytes for this stream
  • StreamBytesTransferred   - ULONG  - total number of bytes transferred for this stream
  • dwStreamNumber   - LONG  - the current stream
  • dwCallbackReason - LONG  - reason for callback
  • hSourceFile  - LONG  - handle to the source file
  • hDestinationFile   - LONG  - handle to the destination file
  • lpData  - LONG   - passed by CopyFileEx

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.

 
 

PayPal Link
Make payments with PayPal - it's fast, free and secure!

 
 
 
 

Copyright 1996-2011 VBnet and Randy Birch. All Rights Reserved.
Terms of Use  |  Your Privacy

 

Hit Counter