I know this is an old thread but I suspect there are others that still need a better xcopy that includes subfolders, I had not been able to find one on the net so I ended up writting one. Calling a shell to dos works ok but has a few drawbacks, 1st, unless you have a function to wait till the shelled application is complete (search for Shell-N-Wait) before continuing, you have to hold any following commands with a message box and wait till the shelled application is complete before clicking to continue.
A more recent problem I found is that our office is moving to Windows 7 64bit while still using Office 32bit, the calls I make using shell-n-wait are using kernal32 functions to wail till the shelled process is complete, then thunking the 64 os into a 32bit function it got very very slow to do what is normally a very fast function. This fix is still a little slower than normal but there are fewer thunk delays using vba.
This version copies (or moves) files and subfolders - it does not adjust attributes.
to include all the subfolders it recursively calls itself.
'**************************************************************
'*
'* XCOPY - in vba
'* Recursively copies files from source folder and subfolders to destination folder and subfolders
'* Optional MoveFlag (true/false) if 'True' will delete source data after a copy is complete
'*
'* [sFolder] is the source folder path ie: ("C:\SourceFolderName\") - MUST END WITH "\"
'* [dFolder] is the destination folder path ie: ("C:\DestinationFolderName\") - MUST END WITH "\"
'* RETURNS integer, count of files copied
'*
'* EXAMPLE
'* CopiedFileCount = FSO_XCopy("C:\SourceFolderName\","C:\DestinationFolderName\")
'*
'**************************************************************
Function FSO_XCopy(sFolder As String, dFolder As String, Optional MoveFlag As Boolean) As Integer
Dim FSO
Dim objFile
Dim objFolder
Dim objSubFolder
Dim objSubFolders
Dim fCount As Integer
If Right(sFolder, 1) <> "\" Then sFolder = sFolder & "\" 'fix folder id
If Right(dFolder, 1) <> "\" Then dFolder = dFolder & "\" 'fix folder id
fCount = 0
If Len(Dir(Left(sFolder, Len(dFolder) - 1), vbDirectory)) = 0 Then
MsgBox "Source folder not found for function FSO_XCopy!"
GoTo FSO_XCOPY_Exit:
End If
Set FSO = CreateObject("Scripting.FileSystemObject") 'opens sys file scripts
If Len(Dir(Left(dFolder, Len(dFolder) - 1), vbDirectory)) = 0 Then MkDir dFolder 'if the path does not exist, create it
Set objFolder = FSO.GetFolder(sFolder)
Set objSubFolders = objFolder.SubFolders
For Each objSubFolder In objSubFolders
fCount = fCount + FSO_XCopy(sFolder & objSubFolder.Name & "/", dFolder & objSubFolder.Name & "/", MoveFlag) 'recursive call to self for subfolder found
Next objSubFolder
'Copy files from target folder
For Each objFile In objFolder.Files
objFile.Copy dFolder
If MoveFlag Then objFile.Delete
fCount = fCount + 1
Next objFile
If MoveFlag Then objFolder.Delete
'Clean up
Set objSubFolders = Nothing
Set objFolder = Nothing
Set FSO = Nothing
FSO_XCOPY_Exit:
FSO_XCopy = fCount
End Function