Function 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 AppPath, Text1.Text ' en text1 pones el path de destino (con este codigo incluis subcarpetas y sobreescribis)
End Sub