EDITADO
Como es algo que tambien a mi me interesaba he buscado un poco más y he modificado otro código para crear una función parecida al XCopy de MS-DOS:
Código vb:
Ver originalFunction XCopy(srcPath As String, dstPath As String, Optional FilePat As String = "*.*", Optional IncludeSubDirs As Boolean = True, Optional Sobreescribir As Boolean = True) As Integer
' Ejmp:
' XCopy "c:\p1", "d:\p1"
' funciona tambien en red:
' XCopy "//PC001/C/p1", "//PC002/C/p1"
Const ATTR_DIRECTORY = 16
Dim DirOK As Integer, i As Integer
Dim DirReturn As String
ReDim d(1) As String
Dim dCount As Integer
Dim CurrFile$
Dim CurrDir$
Dim dstPathBackup As String
Dim f%
On Error Resume Next
MkDir dstPath
If InStr(1, srcPath, "\") Or InStr(1, srcPath, ":") Then
If Right(srcPath, 1) <> "\" Then srcPath = srcPath & "\"
ElseIf InStr(1, srcPath, "/") Then
If Right(srcPath, 1) <> "/" Then srcPath = srcPath & "/"
End If
If InStr(1, dstPath, "\") Or InStr(1, dstPath, ":") Then
If Right(dstPath, 1) <> "\" Then dstPath = dstPath & "\"
ElseIf InStr(1, dstPath, "/") Then
If Right(dstPath, 1) <> "/" Then dstPath = dstPath & "/"
End If
On Error GoTo DirErr
CurrDir$ = CurDir$ ' directorio actual de trabajo
srcPath = UCase$(srcPath)
dstPath = UCase$(dstPath)
dstPathBackup = dstPath ' guardamos el directorio destino
' Iniciamos variables para mantener los nombres de archivos
DirReturn = Dir(srcPath & "*.*", ATTR_DIRECTORY)
' Buscamos todos los Subdirectorios
Do While DirReturn <> ""
' aseguramos que no se haga nada con "." y ".."
If DirReturn <> "." And DirReturn <> ".." Then
If (GetAttr(srcPath & DirReturn) And ATTR_DIRECTORY) = ATTR_DIRECTORY Then
' agregamos a la lista de directorios
dCount = dCount + 1
ReDim Preserve d(dCount)
d(dCount) = srcPath & DirReturn
End If
End If
DirReturn = Dir
Loop
' ahora hacemos que los archivos que coicidan
DirReturn = Dir(srcPath & FilePat, 0)
' Buscamos todos los archivos
Do While DirReturn <> ""
' aseguramos que no es directorio
If Not ((GetAttr(srcPath & DirReturn) And ATTR_DIRECTORY) = ATTR_DIRECTORY) Then
' es un archivo y se copia
'Si existe miramos si se sobre-escribe
On Error Resume Next
f% = FreeFile
Open dstPath & DirReturn For Input As #f%
Close #f%
If Err <> 0 Or Sobreescribir = True Then
FileCopy srcPath & DirReturn, dstPath & DirReturn
End If
End If
DirReturn = Dir
Loop
' Ahora hacemos los subdirectorios
For i = 1 To dCount
If IncludeSubDirs Then
On Error GoTo PathErr
dstPath = dstPath & Right$(d(i), Len(d(i)) - Len(srcPath))
' si el path no existe lo creamos
ChDir dstPath
On Error GoTo DirErr
Else
XCopy = True
GoTo ExitFunc
End If
DirOK = XCopy(d(i), dstPath, FilePat, IncludeSubDirs, Sobreescribir)
' Reiniciamos dstPath al valor asignado
dstPath = dstPathBackup
Next
XCopy = True
ExitFunc:
ChDir CurrDir$
Exit Function
DirErr:
MsgBox "Error: " & Error$(Err)
XCopy = False
Resume ExitFunc
PathErr:
If Err = 75 Or Err = 76 Then ' si no encontramos el path
MkDir dstPath
Resume Next
End If
GoTo DirErr
End Function
Private Sub Command1_Click()
XCopy "//PC001/C/reporte diario", "//PC002/C/reporte diario"
End Sub
Saludos