Copy Large File by Chunk with Progress Notification

[anhn]

When using FileCopy() to copy large file (particular over network), your project may looks like "Not Responding" or hang.

This single function can be used to copy file by chunk with progress notification between chunk. It can be used anywhere for VB6/VBA projects.

If required, a cancel feature of the copy process can be built-in with a Public Boolean flag.

Function CopyFileByChunk(sSource As String, sDestination As String, _
                   Optional ByVal ChunkSize As Long) As Long
   Dim FileSize As Long, OddSize As Long, SoFar As Long
   Dim Buffer() As Byte, f1 As Integer, f2 As Integer
   Const MaxChunkSize As Long = 2 * 2 ^ 20 '-- 2MB

   On Error GoTo CopyFileByChunk_Error
   f1 = FreeFile: Open sSource For Binary Access Read As #f1
    '-- create a blank file, existing file will be overitten
   f2 = FreeFile: Open sDestination For Output As #f2: Close #f2
   FileSize = LOF(f1)
   If FileSize = 0 Then GoTo Exit_CopyFileByChunk ' -- done!
   f2 = FreeFile: Open sDestination For Binary Access Write As #f2
   If ChunkSize <= 0 Then ChunkSize = FileSize \ 100 '-- approx 1%
   If ChunkSize = 0 Then
      OddSize = FileSize
   Else
      If ChunkSize > MaxChunkSize Then ChunkSize = MaxChunkSize
      OddSize = FileSize Mod ChunkSize
   End If
   If OddSize Then
      ReDim Buffer(1 To OddSize)
      Get #f1, , Buffer
      Put #f2, , Buffer
      SoFar = OddSize
      '-- replace with your way of progess notification such as
      'Label1.Caption = SoFar & " bytes out of " & FileSize & " bytes: " & _
                   Format(SoFar / FileSize, "0.0%")
      Debug.Print SoFar, Format(SoFar / FileSize, "0.0%")
      DoEvents '-- if required
   End If
   If ChunkSize Then
      ReDim Buffer(1 To ChunkSize)
      Do While SoFar < FileSize
         Get #f1, , Buffer
         Put #f2, , Buffer
         SoFar = SoFar + ChunkSize
         '-- replace with your way of progess notification such as
         'Label1.Caption = SoFar & " bytes out of " & FileSize & " bytes: " & _
                      Format(SoFar / FileSize, "0.0%")
         Debug.Print SoFar, Format(SoFar / FileSize, "0.0%")
         DoEvents '-- if required
      Loop
   End If
   
   CopyFileByChunk = LOF(f2)
   If CopyFileByChunk <> FileSize Then
      CopyFileByChunk = -CopyFileByChunk '-- negative denotes error
   End If
   
Exit_CopyFileByChunk:
   Close #f1
   Close #f2
   Exit Function
   
CopyFileByChunk_Error:
   MsgBox "Runtime error " & Err.Number & ":" & vbCrLf & Err.Description, _
          vbCritical, "CopyFileByChunk"
   CopyFileByChunk = -1 '-- negative denotes error
   Resume Exit_CopyFileByChunk
End Function

Sub Usage_CopyFileByChunk()
    Dim sFileName As String, sSource As String, sDest As String
    
    sFileName = "UNBILL.CSV"
    sSource = "\\XyzServer\global\" & sFileName
    sDest = "C:\MyFolder\" & sFileName

    'Dim t As Single
    't = Timer
    '-- specify chunk size as 512KB:
    Debug.Print CopyFileByChunk(sSource, sDest, 512 * 1024&)
    '-- or use default chunk size of 1% file size:
    'Debug.Print CopyFileByChunk(sSource, sDest)
    'Debug.Print Timer - t
End Sub