'declarations section
Option Explicit
Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Private Const CREATE_NEW = 1
Private Const OPEN_EXISTING = 3
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const FILE_ATTRIBUTE_ARCHIVE = &H20
'create file handle
Private Declare Function CreateFile Lib "kernel32.dll" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
'allow return of errors encountered while writing destination file
Private Declare Function GetLastError Lib "kernel32.dll" () As Long
'closes file handles
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
'reads the file
Private Declare Function ReadFile Lib "kernel32.dll" (ByVal hSource As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As Any) As Long
'gets file size
Private Declare Function GetFileSize Lib "kernel32.dll" (ByVal hSource As Long, lpFileSizeHigh As Long) As Long
'writes the file
Private Declare Function WriteFile Lib "kernel32.dll" (ByVal hSource As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped As Any) As Long
Public Function CopyAFile(progress As Object, sourceFile As String, destFile As String) As String
Dim hSource As Long 'file handle to source file
Dim hDest As Long 'file handle to destination file
Dim retVal As Long 'holder for returned values from the above api calls
Dim numBytesRead As Long 'bytes read on each ReadFile call
Dim numBytesWritten As Long 'bytes written on read WriteFile call
Dim numBytesWrittenTotal As Long 'bytes written total as of current
Dim loworder As Long 'filesize related
Dim highorder As Long 'filesize related
Dim donereading As Boolean 'indicates no more bytes to read, exit loop
Dim byte1() As Byte ' the Long value to write to the file
Dim f As Long ' size of byte1()
'initialize variables
donereading = False
progress.Value = 0
'create a handle to source file
hSource = CreateFile(sourceFile, GENERIC_READ, FILE_SHARE_READ, ByVal CLng(0), OPEN_EXISTING, FILE_ATTRIBUTE_ARCHIVE, ByVal CLng(0))
If hSource = -1 Then ' the file could not be opened
Debug.Print "Unable to open the file - it may not exist, or improper flags"
CopyAFile = "Source file may not exist"
Exit Function ' abort
End If
'create a handle to destination file
hDest = CreateFile(destFile, GENERIC_WRITE, FILE_SHARE_READ, ByVal CLng(0), CREATE_NEW, FILE_ATTRIBUTE_ARCHIVE, ByVal CLng(0))
If hDest = -1 Then ' the file could not be opened
Debug.Print "Unable to open the file - it may exist, or improper flags"
retVal = CloseHandle(hSource)
CopyAFile = "Destination file exists, or improper flags"
Exit Function ' abort
End If
[b]
'following code needs to be addressed for files >2gigabytes
'retrieve file size in bytes to store as MAX parameter for progressbar
loworder = GetFileSize(hSource, highorder) ' read the file's size
If loworder > 2000000000 Then 'this code cannot handle files > 2gb
retVal = CloseHandle(hDest)
retVal = CloseHandle(hSource)
CopyAFile = "File too large"
Exit Function
[/b]
If loworder > 3000 Then highorder = (loworder / 1000)
Else
highorder = (loworder / 10)
End If
ReDim byte1(highorder)
f = UBound(byte1)
'the maximum size of file to be transfered reflected in max size of progressbar
progress.Max = loworder / highorder '.Max only takes integer values to 32,7Xx..
'an error may occur if filesize > 2gb
'*********************************begin loop
Do While (donereading = False)
'read in bytes from the source file
retVal = ReadFile(hSource, byte1(0), f, numBytesRead, ByVal CLng(0))
If numBytesRead < f Then 'we have read less than byte array bounds (near end of file)
ReDim Preserve byte1(numBytesRead) 'change the byte array to reflect
f = UBound(byte1) 'only the amount of bytes read
donereading = True 'signify done reading to loop
End If
' Write out bytes to the destination file
retVal = WriteFile(hDest, byte1(0), f, numBytesWritten, ByVal CLng(0))
If retVal = 0 Then
retVal = GetLastError
Debug.Print "Error: " & retVal
CopyAFile = "Error writing destination file: " & retVal
retVal = CloseHandle(hDest)
retVal = CloseHandle(hSource)
Exit Function
End If
' force the OS to write the data NOW
'retVal = FlushFileBuffers(hDest)'not necessary as such
numBytesWrittenTotal = numBytesWrittenTotal + numBytesWritten
'update the progress value
progress.Value = CInt(numBytesWrittenTotal / highorder)
Loop
'**********************************end loop
' Close the file handles.
ReDim byte1(0)
progress.Value = 0
retVal = CloseHandle(hDest)
retVal = CloseHandle(hSource)
CopyAFile = "Success"
End Function
