Copie de fichiers avec CreateObject("Shell.Application")

Version imprimable

28/05/2024, 18h46
bernardrustrel

Copie de fichiers avec CreateObject("Shell.Application")

Bonjour

Je vous sollicite afin de trouver une solution quant à la copie de fichier avec VBA.
Je sélectionne plusieurs fichiers dont les noms alimentent un Tableau, or je n'arrive pas à prendre en considération tous les fichiers en une fois mais les copie l'un après l'autre en utilisant:
For N=0 to Ubound(TbloCheminFichier)
CreateObject("Shell.Application").Namespace(DossDest).CopyHere (TbloCheminFichier(N))
Next N

Comment pourrais je copier tous les fichiers sans utilser la boucle FOR, NEXT

Merci à vous, pour votre aide
Cordialment, Bernardrustrel
29/05/2024, 09h37
deedolith

Salut,

D'après la documentation, CopyHere copie un dossier, ce n'est pas l'instruction qu'il te faut.

tu n'as pas 36 solutions, au choix:
- Construire une ligne de commande, passer par ShellExecute, et exécuter la commande robocopy (https://learn.microsoft.com/fr-fr/wi...mands/robocopy).
- Copier les fichiers 1 par 1, dans ce cas, l'objet Shell n'est pas recommandé, mais plutôt FSO (File System Object).

Bonjour,

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
Function CopierFichiers(sourceDir As String, destDir As String, overwrite As Boolean) As Variant
    On Error GoTo ErrorHandler
 
    With CreateObject("Scripting.FileSystemObject")
        ' Vérifier l'existence du répertoire source
        If Not .FolderExists(sourceDir) Then
            CopierFichiers = "Le répertoire source n'existe pas."
            Exit Function
        End If
 
        ' Créer le répertoire de destination s'il n'existe pas
        If Not .FolderExists(destDir) Then
            .CreateFolder destDir
        End If
 
        ' Copier chaque fichier du répertoire source vers le répertoire de destination
        Dim sourceFolder As Object
        Dim file As Object
 
        Set sourceFolder = .GetFolder(sourceDir)
 
        For Each file In sourceFolder.Files
            If Not .FileExists(destDir & "\" & file.Name) Or overwrite Then
                file.Copy destDir & "\" & file.Name, overwrite
            End If
        Next file
    End With
 
    ' Si tout s'est bien passé
    CopierFichiers = True
    Exit Function
 
ErrorHandler:
    CopierFichiers = "Erreur: " & Err.Description
End Function

Tu peux utiliser cette fonction de cette manière :

Code:

1
2
3
4
5
6
7
8
9
10
Sub TestCopierFichiers()
    Dim resultat As Variant
    resultat = CopierFichiers("C:\Source", "C:\Destination", True)
 
    If resultat = True Then
        Debug.Print "La copie des fichiers a réussi."
    Else
        Debug.Print "Erreur lors de la copie des fichiers : " & resultat
    End If
End Sub

Pour afficher le dialogue de transfère des fichiers essaye avec SHFileOperation, il existe pleins d'exemples sur le net sur cette fonction

https://learn.microsoft.com/fr-fr/wi...hfileopstructa

Citation:

pFrom...
Bien que ce membre soit déclaré comme une seule chaîne terminée par null, il s’agit en fait d’une mémoire tampon qui peut contenir plusieurs noms de fichiers délimités par des valeurs Null. Chaque nom de fichier est terminé par un seul caractère NULL . Le nom du dernier fichier se termine par un double caractère NULL (« \0\0 ») pour indiquer la fin de la mémoire tampon.

Regarder dans le code la fonction TransfereFichiers

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
Private Declare PtrSafe Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationW" (lpFileOp As SHFILEOPSTRUCT) As Long
Private Type SHFILEOPSTRUCT
    hwnd                            As LongPtr
    wFunc                           As Long
    pFrom                           As LongPtr
    pTo                             As LongPtr
    fFlags                          As Integer
    fAnyOperationsAborted           As Long
    hNameMappings                   As LongPtr
    lpszProgressTitle               As LongPtr
End Type
 
Private Const FO_COPY = 2
Private Const FOF_MULTIDESTFILES = &H1
'Private Const FOF_NOCONFIRMATION = &H10
'Private Const FOF_SIMPLEPROGRESS = &H100
 
Public Sub TransfereFichiers(ByVal aSrc As Collection, ByVal Dest As String)
  Dim fso As Object
  Dim DstPath As String, elem
  Dim SrcList As String, DstList As String
  Set fso = CreateObject("Scripting.FileSystemObject")
 
  If aSrc.Count = 0 Then: Exit Sub
 
  For Each elem In aSrc
    SrcList = SrcList & elem & vbNullChar
    DstPath = fso.BuildPath(Dest, fso.GetFileName(elem))
    DstList = DstList & DstPath & vbNullChar
  Next
  SrcList = SrcList & vbNullChar
  DstList = DstList & vbNullChar
 
  Dim lpFileOp As SHFILEOPSTRUCT
  lpFileOp.pFrom = StrPtr(SrcList)
  lpFileOp.pTo = StrPtr(DstList)
  lpFileOp.wFunc = FO_COPY
  lpFileOp.fFlags = FOF_MULTIDESTFILES
 
  SHFileOperation lpFileOp
 
End Sub