Copier un dossier et tout son contenu

Soyez le premier à donner votre avis sur cette source.

Snippet vu 41 261 fois - Téléchargée 7 fois

Contenu du snippet

Private Const NOERROR As Long = 0&
Private Const FO_COPY As Long = &H2
Private Const FOF_ALLOWUNDO As Long = &H40
Private Const FOF_CONFIRMMOUSE As Long = &H2
Private Const FOF_FILESONLY As Long = &H80 '  on *.*, do only files
Private Const FOF_MULTIDESTFILES As Long = &H1
Private Const FOF_NOCONFIRMATION As Long = &H10 '  Don't prompt the user.
Private Const FOF_NOCONFIRMMKDIR As Long = &H200 ' don't confirm making any needed dirs
Private Const FOF_RENAMEONCOLLISION As Long  = &H8
Private Const FOF_SILENT As Long = &H4    ' don't create  progress/report
Private Const FOF_SIMPLEPROGRESS As Long = &H100 ' means don't show names of files
Private Const FOF_WANTMAPPINGHANDLE As Long  = &H20 ' Fill in SHFILEOPSTRUCT.hNameMappings
Private Type SHFILEOPSTRUCT
    hWnd As Long
    wFunc As Long
    pFrom As String
    pTo As String
    fFlags As Integer
    fAborted As Boolean
    hNameMaps As Long
    sProgress As String
End Type
Private Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As Any) As Long

Public Function CopyContentDirectory(ByVal sDirSrc As String, ByVal sDirDest As String, Optional ByVal lHandle As Long = 0,  Optional ByVal bIncludeSubFolders As Boolean  = True, Optional ByVal bShowWindowsProgressBox As Boolean  = False, Optional ByVal bRenameIfExists As Boolean = False,  Optional ByVal bShowWindowsAskActionBox As Boolean  = True) As Boolean
'sDirSrc                    -> répertoire  source
'sDirDest                   ->  répertoire destination
'lHandle                    -> handle appelant (peut rester à  0)
'bIncludeSubFolders         -> copie  récursive, donc avec les sous-dossiers et leur contenu
'bShowWindowsProgressBox    -> affiche la progressbox  windows
'bRenameIfExists            -> pas  d'écrasement, renomme directement les nouveaux fichiers du  dossier
'bShowWindowsAskActionBox   -> boite de  dialogue "renommer écraser oui tous etc...". NB : si FALSE, il n'y a pas non  plus de ProgressBox
    On Error GoTo Err_Handler
    Dim tFOS As SHFILEOPSTRUCT
    
'   formate  les chemins
    If bIncludeSubFolders Then
        If RightB$(sDirSrc, 2) = "\" Then sDirSrc = LeftB$(sDirSrc, LenB(sDirSrc) - 2)
    Else
        If Not (RightB$(sDirSrc, 2) = "\") Then sDirSrc = sDirSrc & "\"
        sDirSrc = sDirSrc & "*.*"
    End If
    If Not (RightB$(sDirDest, 2) = "\") Then sDirDest = sDirDest & "\"
    
'    structure
    With tFOS
        .hWnd = lHandle
        .wFunc = FO_COPY
        .pFrom = sDirSrc & vbNullChar
        .pTo = sDirDest & vbNullChar
        .fFlags = CInt(SetFOSFlag(bIncludeSubFolders, bShowWindowsProgressBox,  bRenameIfExists, bShowWindowsAskActionBox, False, True))
        .fAborted = False
        .hNameMaps = 0&
        .sProgress = vbNullChar
    End With
'   API /  retour
    CopyContentDirectory = (SHFileOperation(tFOS) =  NOERROR)
    
Err_Handler:
'   en IDE on peut avoir un message "Mémoire insuffisante" en fin  d'action malgré la réussite
    If Err.Number = 7 Then CopyContentDirectory =  True
End Function
Private Function SetFOSFlag(Optional ByVal bIncludeSubFolders As Boolean  = True, Optional ByVal bShowWindowsProgressBox As Boolean  = False, Optional ByVal bRenameIfExists As Boolean = False,  Optional ByVal bShowWindowsAskActionBox As Boolean  = False, Optional ByVal bAllowUndo As Boolean = False,  Optional ByVal bMulti  As Boolean = True) As  Long
    SetFOSFlag = FOF_WANTMAPPINGHANDLE Or  FOF_NOCONFIRMMKDIR
    If Not bIncludeSubFolders Then SetFOSFlag = SetFOSFlag  Or FOF_FILESONLY
    If Not bShowWindowsProgressBox Then SetFOSFlag = SetFOSFlag  Or FOF_SILENT
    If bRenameIfExists Then SetFOSFlag = SetFOSFlag Or FOF_RENAMEONCOLLISION
    If Not bShowWindowsAskActionBox Then SetFOSFlag = SetFOSFlag  Or FOF_NOCONFIRMATION
    If bAllowUndo Then SetFOSFlag = SetFOSFlag  Or FOF_ALLOWUNDO
    If bMulti Then SetFOSFlag = SetFOSFlag Or FOF_MULTIDESTFILES
End Function


Compatibilité : VB6, VBA

Disponible dans d'autres langages :

A voir également

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.