Long File Path Fails to Copy File to New Directory - vba

Question

I have this posted under my original post, but thought I would create a new question. I have the below code working that looks at my table in MS Access that has the path + file name and moves it to a new directory; I will also be looking at how to put Folders/Subfolders in the "new" directory based off of the original directory, but am unsure how to accomplish that. It currently works on my test table that has <259 characters in the path, but fails on long path/file names >259. Thoughts how how this can be addressed?
Appreciate the help.
Sub CopyFilesFromTable2()
On Error GoTo ErrorHandler
Dim source As String
Dim destination As String
Dim FSO As New FileSystemObject
Dim SQL As String
Dim RS As DAO.Recordset
Dim db As DAO.Database
'Test Table
SQL = "select * from file_test"
'Prod Table
'SQL = "select * from file"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set db = CurrentDb
Set RS = db.OpenRecordset(SQL)
source = RS!LocalFile
File = VBA.FileSystem.Dir(source)
destination = "D:\Temp\Test\"
With RS
If Not .BOF And Not .EOF Then
.MoveLast
.MoveFirst
While (Not .EOF)
FSO.CopyFile RS!LocalFile, destination
.MoveNext
Wend
End If
.Close
End With
ExitSub:
Set RS = Nothing
'set to nothing
MsgBox "Done!"
Exit Sub
ErrorHandler:
MsgBox Err, vbCritical
Resume ExitSub
End Sub

Answer 1

You've got a problem with long paths here, generally, these are best avoided.
However, with a tiny bit of WinAPI, you can easily avoid the issue.
Implement CopyFileExW:
Public Declare PtrSafe Function CopyFileExW Lib "Kernel32.DLL" (ByVal lpExistingFileName As LongPtr, ByVal lpNewFileName As LongPtr, ByVal lpProgressRoutine As LongPtr, ByVal lpData As LongPtr, ByRef pbCancel As Boolean, ByVal dwCopyFlags As Long) As Boolean
Declare consts:
Const COPY_FILE_FAIL_IF_EXISTS = 1&
Create a function that calls CopyFileExW, and prepends \\?\ to the path to allow for long paths:
Public Function CopyFile(strSource As String, strDestination As String, Optional Overwrite As Boolean = False)
strSource = "\\?\" & strSource
strDestination = "\\?\" & strDestination
Dim flags As Long
If Not Overwrite Then
flags = COPY_FILE_FAIL_IF_EXISTS
End If
Dim res As Boolean
res = CopyFileExW(StrPtr(strSource), StrPtr(strDestination), 0, 0, ByVal 0, flags)
If res = False Then
Err.Raise -5000, Description:="Copy file failed, error code " & Err.LastDllError
End If
End Function
And use that function, instead of RS!LocalFile, destination:
'CopyFile file needs the full path, so we append the filename
CopyFile RS!LocalFile, Destination & Right(RS!LocalFile, InStr(strReverse("RS!LocalFile"), "\") - 1)