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 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145
| Option Compare Database
Option Explicit
'Déclaration des API
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
'Constantes pour les API
Const MAX_PATH = 260
Const MAXDWORD = &HFFFF
Const INVALID_HANDLE_VALUE = -1
Const FILE_ATTRIBUTE_ARCHIVE = &H20
Const FILE_ATTRIBUTE_DIRECTORY = &H10
Const FILE_ATTRIBUTE_HIDDEN = &H2
Const FILE_ATTRIBUTE_NORMAL = &H80
Const FILE_ATTRIBUTE_READONLY = &H1
Const FILE_ATTRIBUTE_SYSTEM = &H4
Const FILE_ATTRIBUTE_TEMPORARY = &H100
'Type pour les API
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
Function StripNulls(OriginalStr As String) As String
'Cette fonction permet de supprimer le caractère de fin de chaine d'une chaine quelconque
'Si on trouve le chr$(0) on rentre dans la boucle
If (InStr(OriginalStr, Chr(0)) > 0) Then
'On prend les données à gauche de la chaine.
OriginalStr = Left(OriginalStr, InStr(OriginalStr, Chr(0)) - 1)
End If
'on affecte la nouvelle chaine à l'argument de sortie.
StripNulls = OriginalStr
End Function
Function CopyFilesAPI(path As String, SearchStr As String, filecount As Long, dircount As Long, path_dest As String)
'déclaration des variables
Dim filename As String
Dim DirName As String
Dim dirNames() As String
Dim nDir As Integer
Dim i As Integer
Dim hSearch As Long
Dim WFD As WIN32_FIND_DATA
Dim Cont As Integer
Dim rs As DAO.Recordset
'si le chemin passé en argument n'a pas un \ on le rajoute
If Right(path, 1) <> "\" Then
path = path & "\"
End If
' Recherche des sous répertoires
nDir = 0
'redimensionne ndir
ReDim dirNames(nDir)
Cont = True
'on cherche le premier fichier
hSearch = FindFirstFile(path & "*", WFD)
If hSearch <> INVALID_HANDLE_VALUE Then
'on boucle tant que la structure renvoi un nouveau repertoire (vérification avec cont)
Do While Cont
DirName = StripNulls(WFD.cFileName)
If (DirName <> ".") And (DirName <> "..") Then
If GetFileAttributes(path & DirName) And FILE_ATTRIBUTE_DIRECTORY Then
dirNames(nDir) = DirName
dircount = dircount + 1
nDir = nDir + 1
ReDim Preserve dirNames(nDir)
'on creer le repertoire destination si il n'existe pas
If Dir(path_dest & DirName, vbDirectory) = "" Then
MkDir (path_dest & DirName)
End If
End If
End If
Cont = FindNextFile(hSearch, WFD)
Loop
Cont = FindClose(hSearch)
End If
'fin de recherche des sous repertoire
'on attaque les fichiers
hSearch = FindFirstFile(path & SearchStr, WFD)
Cont = True
If hSearch <> INVALID_HANDLE_VALUE Then
While Cont
filename = StripNulls(WFD.cFileName)
If (filename <> ".") And (filename <> "..") And GetAttr(path & filename) <> vbDirectory Then
CopyFilesAPI = CopyFilesAPI + (WFD.nFileSizeHigh * MAXDWORD) + WFD.nFileSizeLow
filecount = filecount + 1
'on ajoute le fichier dans la liste
FileCopy path & filename, path_dest & filename
End If
Cont = FindNextFile(hSearch, WFD)
Wend
Cont = FindClose(hSearch)
End If
If nDir > 0 Then
For i = 0 To nDir - 1
'si on accepte les sous repertoire on s'appelle recursivement
CopyFilesAPI = CopyFilesAPI + CopyFilesAPI(path & dirNames(i) & "\", SearchStr, filecount, dircount, path_dest & dirNames(i) & "\")
Next i
End If
End Function
Public Sub test()
'i renvoi le nombre de fichier
Dim i As Long
'j renvoi le nombre de repertoire
Dim j As Long
'la fonction renvoi le nombre d'octet copié
CopyFilesAPI "C:\source\", "*.*", i, j, "c:\destination\"
End Sub |
Partager