Informace o adresáři

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ů

Zpět

Autor: The Bozena