Private Const NOERROR As Long = 0&
Private Const FO_MOVE As Long = &H1
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 MoveContentDirectory(ByVal sDirSrc As String, ByVal sDirDest As String, Optional ByVal lHandle As Long = 0, Optional ByVal bMoveContainerFolder As Boolean = True, 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)
'bMoveContainerFolder -> déplacer le contenu ou également le dossier. ne peux être TRUE si on ne déplace pas aussi les sous-dossiers
'bIncludeSubFolders -> déplacement récursif, 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
' on ne peut pas supprimer le dossier parent si on ne déplace pas TOUT le contenu
If (bMoveContainerFolder = True) And (bIncludeSubFolders = False) Then Exit Function
' formate les chemins
If bIncludeSubFolders And bMoveContainerFolder 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_MOVE
.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
MoveContentDirectory = (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 MoveContentDirectory = 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