Postup:
V projektu založte nový modul.
Do tohoto modulu vložte následující kód:
Const MAX_PATH = 260
Const INVALID_HANDLE_VALUE = -1
Const FILE_ATTRIBUTE_DIRECTORY = &H10
Type FILETIME
dwLowDateTime As
Long
dwHighDateTime As Long
End Type
Type FOLDER_INFO
curSize As Currency
lngNumFiles As Long
lngNumSubFolders As
Long
End Type
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
Declare Function
FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal
lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA"
(ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long)
As Long
*Každá deklarace
musí být celá na samostatném řádku
Public Function
GetFolderInfo(strFolder As String) As FOLDER_INFO
Dim lngFileNum As
Long, lngFolderNum As Long
Dim curSize As
Currency, FolderQueue As New Collection
If
Right$(strFolder, 1) <> "\" Then strFolder = strFolder &
"\"
'Přidání
do řady
FolderQueue.Add
strFolder
Call EnumFolder(FolderQueue,
lngFileNum, curSize)
FolderQueue.Remove 1
Do While FolderQueue.Count > 0
lngFolderNum
= lngFolderNum + 1
Call
EnumFolder(FolderQueue, lngFileNum, curSize)
FolderQueue.Remove
1
DoEvents
Loop
'Návratové
hodnoty
GetFolderInfo.curSize = curSize
GetFolderInfo.lngNumFiles = lngFileNum
GetFolderInfo.lngNumSubFolders
= lngFolderNum
End Function
Private Sub EnumFolder(FolderQueue
As Collection, lngFileNum, lngSize As Currency)
Dim strTemp As
String, strFolder As String
Dim lRetVal As Long,
FFdata As WIN32_FIND_DATA
Dim lngSearchHandle As Long
strFolder
= FolderQueue.Item(1)
'Zjištění podadresářů
lngSearchHandle
= FindFirstFile(strFolder & "*.*", FFdata)
'Kontrola správného handlu
If
lngSearchHandle = INVALID_HANDLE_VALUE Then Exit Sub
'Zjištění jména souboru
strTemp =
TrimNulls(FFdata.cFileName)
Do While strTemp <> ""
If (FFdata.dwFileAttributes And
FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY Then
'Je to adresář - ujistěme se, že to není . nebo ..
If strTemp <> "." And strTemp <> ".." Then
'Ok, přidat do fronty
If Right$(strTemp, 1) <> "\" Then strTemp = strTemp &
"\"
FolderQueue.Add strFolder & strTemp
End If
Else
'Je to soubor, zjistíme velikost
lngSize = lngSize + FFdata.nFileSizeLow
'Zvednutí počtu souborů
lngFileNum = lngFileNum + 1
End If
'Další soubor / adresář
lRetVal = FindNextFile(lngSearchHandle, FFdata)
'Vyčištění strTemp
strTemp = ""
'Jméno souboru, pokud byla funkce úspěšná
If lRetVal <> 0 Then strTemp = TrimNulls(FFdata.cFileName)
Loop
'Zavření vyhledávacího handlu
lRetVal = FindClose(lngSearchHandle)
End Sub
Private Function
TrimNulls(strString As String) As String
Dim l As Long
l = InStr(1,
strString, Chr(0))
If l = 1 Then
TrimNulls = ""
ElseIf l > 0
Then
TrimNulls
= Left$(strString, l - 1)
Else
TrimNulls = strString
End If
End Function
Funkci voláte následovně:
Dim
udtFolderInfo As FOLDER_INFO
udtFolderInfo = GetFolderInfo("C:\Windows\System")
Návratové hodnoty:
udtFolderInfo.curSize
'velikost
udtFolderInfo.lngNumSubFolders
'počet podadresářů
udtFolderInfo.lngNumFiles
'počet souborů
|