---Soumis par Ken Getz---
VBA Developer's Handbook - Code de remplacement pour certaines fonctions du chapitre 12.
Dans VBA Developer's Handbook, au chapitre 12, la procédure dhDelTree
possède un sérieux problème si vous lui fournissez le chemin d'un disque
autre que le disque actuel. Dans un tel cas, la procédure efface les fichiers
du disque courant, non du disque spécifié. Cela peut entraîner de sérieuse
perte de données.
La fonction de replacement suivante effectue le changement de disque et de
répertoire à ceux spécifiés, de sorte que l'effacement s'effectue
correctement. N'utilisez pas la fonction dhDelTree
publiée dans le bouquin -- assurez vous de remplacer toutes les copies par
cette nouvelle version, pour éviter de perdre des données.
Aucune fonction ne fonctionnera proprement si vous ne possédez pas les
autres procédures du chapitre 12, il est donc inutile de télécharger ces
correctifs si vous ne possédez pas le bouquin.
'************ Code Start **************
' Add this at the top of the module.
Private Declare Function SetCurrentDirectory _
Lib "kernel32" Alias "SetCurrentDirectoryA" _
(ByVal lpPathName As String) As Long
Function dhDelTree(ByVal Directory As String, _
Optional RemoveRoot As Boolean = True, _
Optional ByVal Level As Integer = 1) As Boolean
' Deletes an entire directory tree (including all
' files and subdirectories). Calls itself recursively.
' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.
' In:
' Directory
' Directory to delete.
' RemoveRoot
' True if you want to remove the top-level folder.
' False if you want to remove contents, but leave
' the top-level folder intact.
' Level
' Used by the procedure. Do not specify a value.
' Out:
' Return Value:
' True if successful, False if not.
' Example:
' Call dhDelTree("C:\") ' Ha! Ha! Just kidding
' Call dhDelTree("C:\DATA\MYDIR")
On Error GoTo HandleErrors
Dim strFilename As String
Dim strDirectory As String
strDirectory = dhFixPath(Directory)
' Check to make sure the directory actually exists.
' If not, we don't have to do a thing.
If Len(Dir(strDirectory, vbDirectory)) = 0 Then
GoTo ExitHere
End If
If dhFixPath(CurDir) = strDirectory Then
MsgBox "Unable to delete the current directory. " & _
"Move to a different directory, and try again."
GoTo ExitHere
End If
' Delete all the files in the current directory
strFilename = Dir(strDirectory & "*.*")
Do Until strFilename = ""
Kill strDirectory & strFilename
strFilename = Dir
Loop
' Now build a list of subdirectories
Do
strFilename = Dir(strDirectory & "*.*", vbDirectory)
' Skip "." and ".."
Do While strFilename = "." Or strFilename = ".."
strFilename = Dir
Loop
' If there are no more files, exit the loop.
' Otherwise call dhDelTree again to wipe
' out the subdirectory.
If strFilename = "" Then
Exit Do
Else
' Call dhDelTree recursively. Pass True for RemoveRoot,
' because you'll always want to remove subfolders.
' Indicate the level by passing Level + 1.
If Not dhDelTree(strDirectory & strFilename, True, Level + 1) Then
GoTo ExitHere
End If
End If
Loop
' Finally, remove the target directory
' The following expression returns True unless
' the first factor is True and the
' second factor is False -- that is,
' it always removes the folder unless
' you're at level 1 (the root level) and you've
' been told not to remove the root.
If Level = 1 Imp RemoveRoot Then
RmDir strDirectory
End If
dhDelTree = True
ExitHere:
Exit Function
HandleErrors:
Select Case Err.Number
Case 75 ' Path or file access
' If a file or folder can't be deleted,
' just keep going.
Resume Next
Case Else
dhDelTree = False
MsgBox Err.Description, vbExclamation, _
"Error " & Err.Number & " in dhDelTree"
Resume ExitHere
End Select
End Function
'************ Code End **************
Dans VBA Developer's Handbook, au chapitre 12, si vous utilisez la fonction dhDir pour parcourir les dossiers, la fonction ne libère pas correctement une ressource référant à ce dossier et vous ne serez pas capable d'effacer ce dossier à moins de quitter VBA (en quittant l'application hôtesse). La fonction de remplacement qui suit résoudra ce problème.
'************ Code Start **************
Function dhDir(Optional ByVal strPath As String = "", _
Optional lngAttributes As Long = vbNormal, _
Optional fExclusive As Boolean = True) As String
' Replacement for the VBA Dir function which lets you
' specify file attributes for a restrictive search.
' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.
' In:
' strPath (Optional, default = "")
' Path and/or file specification to search.
' lngAttributes (Optional, default = vbNormal)
' File attributes.
' fExclusive (Optional, default = True)
' If True, only those files with the matching
' file attributes are returned.
' Out:
' Return Value:
' If called with a file specification, the first
' matching filename is returned. If called without
' a file specification, the next matching filename
' is returned. When no additional matching filenames
' are found, an empty string is returned.
' Example:
' Dim strDir As String
'
' strDir = dhDir("C:\", vbDirectory)
' Do Until strDir = ""
' Debug.Print strDir
' strDir = dhDir()
' Loop
Dim fd As WIN32_FIND_DATA
Static hFind As Long
Static lngAttr As Long
Static fEx As Boolean
Dim strOut As String
' If no path was passed, try to find the next file
If strPath = "" Then
If hFind > 0 Then
If CBool(FindNextFile(hFind, fd)) Then
strOut = dhFindByAttr(hFind, fd, lngAttr, fEx)
End If
End If
' Otherwise, start a new search
Else
' Store the attributes and exclusive settings
lngAttr = lngAttributes
fEx = fExclusive
' If the path ends in a backslash, assume
' all files and append "*.*"
If Right(strPath, 1) = "\" Then
strPath = strPath & "*.*"
End If
' Find the first file
hFind = FindFirstFile(strPath, fd)
If hFind > 0 Then
strOut = dhFindByAttr(hFind, fd, lngAttr, fEx)
End If
End If
' If the search failed, close the Find handle.
If Len(strOut) = 0 Then
If hFind > 0 Then
Call FindClose(hFind)
End If
End If
dhDir = strOut
End Function
'************ Code End **************