Suppression d'un dossier et de son contenu

Commenter

Contenu du snippet 

Private Const NOERROR As Long = 0&
Private Const FO_DELETE As Long = &H3
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 DeleteContentDirectory(ByVal  sDirSrc As  String, Optional ByVal  lHandle As Long  = 0, Optional ByVal bDeleteContainerFolder As Boolean  = True, Optional ByVal bIncludeSubFolders As Boolean  = True, Optional ByVal bShowWindowsProgressBox As Boolean  = False, Optional ByVal bSendToRecycleBin As Boolean  = False, Optional ByVal bShowWindowsAskActionBox As Boolean  = False) As Boolean
'sDirSrc                    -> répertoire à  supprimer
'lHandle                    -> handle  appelant (peut rester à 0)
'bDeleteContainerFolder     -> supprimer le contenu ou  également le dossier
'bIncludeSubFolders          -> suppression récursive? ne peut être à faux si on doit supprimer le dossier  parent
'bShowWindowsProgressBox    -> affiche  la progressbox windows
'bSendToRecycleBin          -> suppression vers la corbeille,  sinon définitive
'bShowWindowsAskActionBox   ->  boite de dialogue "confirmation de suppression" (ou d'envoi vers corbeille). NB  : si FALSE, il n'y a pas non plus de ProgressBox
    On Error GoTo Err_Handler
    Dim tFOS As SHFILEOPSTRUCT
'   on ne peut  pas supprimer le dossier parent si on ne supprime pas TOUT le  contenu
    If (bDeleteContainerFolder = True) And  (bIncludeSubFolders = False) Then  Exit Function
    
'   formate le  chemin
    If bIncludeSubFolders And bDeleteContainerFolder 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
'   structure
    With tFOS
        .hWnd = lHandle
        .wFunc = FO_DELETE
        .pFrom = sDirSrc & vbNullChar
        .pTo = vbNullChar
        .fFlags = CInt(SetFOSFlag(bIncludeSubFolders, bShowWindowsProgressBox,  False,  bShowWindowsAskActionBox, bSendToRecycleBin, False))
        .fAborted = False
        .hNameMaps = 0&
        .sProgress = vbNullChar
    End With
        
'    API
    DeleteContentDirectory = (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 DeleteContentDirectory =  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

S'inscrire maintenant

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.

Du même auteur (Renfield)