Access VBA to Copy File (rather than move it) 1

[swtrader]

The following code is copied from the web and attributed to: FMS Development Team -- and it works great for what I am trying to accomplish...using Access to rename and move files...with one exception... It deletes the 'old' file once it has renamed and moved it. I need to leave the old file in its original place with its original name.

I tried replacing "Name" with "FileCopy" but that did not work. Can someone help?

Thanks

------------

Option Compare Database

Public Function TestNameStatement()
Dim fOK As Boolean

' Folders must exist for Source, but do not need to exist _
' for destination
'fOK = RenameFileOrDir("C:\TestFolder\test.txt", _
"C:\TestFolder\test_NEWNAME.txt")
fOK = RenameFileOrDir("C:\TestFolder\test.txt", _
"G:\TestFolder\test_NEWNAME.txt")

' Folder must exist for source
'fOK = RenameFileOrDir("C:\TestFolder", _
'"C:\TestFolder_NEWNAME")

' Folders only will fail across drives
'fOK = RenameFileOrDir("C:\TestFolder", "D:\TestFolder")
End Function

Public Function RenameFileOrDir( _
ByVal strSource As String, _
ByVal strTarget As String, _
Optional fOverwriteTarget As Boolean = False) As Boolean

On Error GoTo PROC_ERR

Dim fRenameOK As Boolean
Dim fRemoveTarget As Boolean
Dim strFirstDrive As String
Dim strSecondDrive As String
Dim fOK As Boolean

If Not ((Len(strSource) = 0) Or _
(Len(strTarget) = 0) Or _
(Not (FileOrDirExists(strSource)))) Then

' Check if the target exists
If FileOrDirExists(strTarget) Then

If fOverwriteTarget Then
fRemoveTarget = True
Else
If vbYes = MsgBox("Do you wish to overwrite the " & _
"target file?", vbExclamation + vbYesNo, _
"Overwrite confirmation") Then
fRemoveTarget = False 'True
End If
End If

If fRemoveTarget Then
' Check that it's not a directory
If ((GetAttr(strTarget) And vbDirectory)) <> _
vbDirectory Then
Kill strTarget
fRenameOK = True
Else
MsgBox "Cannot overwrite a directory", vbOKOnly, _
"Cannot perform operation"
'FUTURE CODE FOR DIRECTORIES
End If
End If
Else
' The target does not exist
' Check if source is a directory
If ((GetAttr(strSource) And vbDirectory) = _
vbDirectory) Then
' Source is a directory, see if drives are the same
strFirstDrive = Left(strSource, InStr(strSource, ":\"))
strSecondDrive = Left(strTarget, InStr(strTarget, ":\"))
If strFirstDrive = strSecondDrive Then
fRenameOK = True
Else
MsgBox "Cannot rename directories across drives", _
vbOKOnly, "Cannot perform operation"
'FUTURE CODE FOR DIRECTORIES ON DIFFERENT DRIVES
End If
Else
'It's a file, ok to proceed
fRenameOK = True
End If
End If

If fRenameOK Then
Name strSource As strTarget 'replaced Name with Copy
fOK = True
End If
End If

RenameFileOrDir = fOK

PROC_EXIT:
Exit Function

PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"RenameFileOrDir"
Resume PROC_EXIT
End Function


Public Function FileOrDirExists(strDest As String) As Boolean
Dim intLen As Integer
Dim fReturn As Boolean

fReturn = False

If strDest <> vbNullString Then
On Error Resume Next
intLen = Len(Dir$(strDest, vbDirectory + vbNormal))
On Error GoTo PROC_ERR
fReturn = (Not Err And intLen > 0)
End If

PROC_EXIT:
FileOrDirExists = fReturn
Exit Function

PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"FileOrDirExists"
Resume PROC_EXIT
End Function

 

[PHV]

Did youy try to replace this:
Name strSource As strTarget
with this ?
FileCopy strSource, strTarget

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886

 

[swtrader]

That did it...and just below it...

FileCopy = fOK

Thanks for your help.