Win API works for all relevant versions of Access (97 ->)
--------------------------------
Option Compare Database
Option Explicit
Private Const CNull = 0&
'File Handling
Private Const FILE_CURRENT = 1
Private Const FILE_BEGIN = 0
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Private Const OPEN_EXISTING = 3
Private Const FILE_FLAG_RANDOM_ACCESS = &H10000000
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const FILE_ATTRIBUTE_ARCHIVE = &H20
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
Private Const FILE_ATTRIBUTE_HIDDEN = &H2
Private Const FILE_ATTRIBUTE_READONLY = &H1
Private Const FILE_ATTRIBUTE_SYSTEM = &H4
Private Const FILE_ATTRIBUTE_TEMPORARY = &H100
Private Const CREATE_ALWAYS = 2
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Private Type OVERLAPPED
Internal As Long
InternalHigh As Long
Offset As Long
OffsetHigh As Long
hEvent As Long
End Type
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As
Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As
Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long,
ByVal dwBytes As Long) As Long
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA"
(ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal
dwShareMode As Long, lpSecurityAttributes As SECURITY_ATTRIBUTES, ByVal
dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal
hTemplateFile As Long) As Long
Private Declare Function SetFilePointer Lib "kernel32" (ByVal hFile As Long,
ByVal lDistanceToMove As Long, lpDistanceToMoveHigh As Long, ByVal
dwMoveMethod As Long) As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long,
lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As
Long, lpOverlapped As OVERLAPPED) As Long
Private Declare Function LockFile Lib "kernel32" (ByVal hFile As Long, ByVal
dwFileOffsetLow As Long, ByVal dwFileOffsetHigh As Long, ByVal
nNumberOfBytesToLockLow As Long, ByVal nNumberOfBytesToLockHigh As Long) As
Long
Private Declare Function UnlockFile Lib "kernel32" (ByVal hFile As Long,
ByVal dwFileOffsetLow As Long, ByVal dwFileOffsetHigh As Long, ByVal
nNumberOfBytesToUnlockLow As Long, ByVal nNumberOfBytesToUnlockHigh As Long)
As Long
Private Declare Function CloseFile Lib "kernel32" Alias "CloseHandle" (ByVal
hFile As Long) As Long
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long,
lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten
As Long, lpOverlapped As Any) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long)
As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As
Long
Public Function CopyFile(ByVal Source$, ByVal destination$, Optional ByVal
HaltOnError As Boolean = False) As Long
Dim FileLength As Long, AmountCopied As Long
Dim retval As Variant, lpBuff As Long
Dim DestFile As Long, SourceFile As Long
Dim ApiErr As Integer, AmtRead As Integer
Dim lBytesRead As Long, lBytesWritten As Long
Dim hMem As Long
Dim SysRet As Variant
Dim SysCnt As Long
Const nBuff = &H7FFF '32768 - 1
Const wFlags = &H20
Dim uOverLapped As OVERLAPPED
Dim dOverLapped As OVERLAPPED
Dim sSec As SECURITY_ATTRIBUTES, dSec As SECURITY_ATTRIBUTES
On Error GoTo Err_CopyFile
SourceFile = CreateFile(Source, GENERIC_READ, FILE_SHARE_READ, sSec,
OPEN_EXISTING, _
FILE_FLAG_RANDOM_ACCESS Or
FILE_ATTRIBUTE_NORMAL, 0)
If SourceFile = -1 Then _
VBA.Err.Raise VBA.vbObjectError + 1051, "FromFile.CopyFile", "The file
'" & Source & "' is in use by another process"
With sSec
.nLength = Len(sSec)
.lpSecurityDescriptor = 0
.bInheritHandle = True
End With
DestFile = CreateFile(destination, GENERIC_WRITE, 0, dSec, CREATE_ALWAYS,
_
FILE_FLAG_RANDOM_ACCESS Or
FILE_ATTRIBUTE_NORMAL, 0)
If DestFile = -1 Then
VBA.Err.Raise vbObjectError + 1052, "ToFile.CopyFile", "Cannot Create
file '" & destination & "', it is in use by another process or the disk is
write protected"
End If
With dSec
.nLength = Len(dSec)
.lpSecurityDescriptor = 0
.bInheritHandle = True
End With
SysRet = Access.SysCmd(Access.acSysCmdInitMeter, "Copying: " &
VBA.Dir(Source$) & " to " & destination$, FileLen(Source))
hMem = GlobalAlloc(wFlags, nBuff)
lpBuff = GlobalLock(hMem)
AmtRead = ReadFile(SourceFile, ByVal lpBuff, nBuff, lBytesRead,
uOverLapped)
While lBytesRead <> 0
ApiErr = WriteFile(DestFile, ByVal lpBuff, lBytesRead, lBytesWritten,
ByVal CNull) ', dOverLapped)
If lBytesRead <> lBytesWritten Then
VBA.Err.Raise vbObjectError + 1053, "ToFile.CopyFile", "Cannot Copy to
file '" & destination & "', the Disk may be full"
End If
AmountCopied = AmountCopied + lBytesRead
SysRet = Access.SysCmd(Access.acSysCmdUpdateMeter, AmountCopied)
uOverLapped.Offset = AmountCopied
AmtRead = ReadFile(SourceFile, ByVal lpBuff, nBuff, lBytesRead,
uOverLapped)
Wend
CopyFile = AmountCopied
Bye_CopyFile:
On Error Resume Next
CloseHandle SourceFile
CloseHandle DestFile
lpBuff = GlobalUnlock(hMem)
hMem = GlobalFree(hMem)
SysRet = Access.SysCmd(Access.acSysCmdRemoveMeter)
Exit Function
Err_CopyFile:
'If HaltOnError Then ShowError
CopyFile = -VBA.Abs(VBA.Err.Number)
Resume Bye_CopyFile
End Function
-------------------------------
Usage CopyFile Source, Dest
HTH
Pieter
