Größe (MB) eines Dateiordners - die 2.

Sub dir_1() erg = 0 pfad = "C:\" pfad1 = Dir(pfad, 16) Do Until pfad1 = "" If (GetAttr(pfad & pfad1) And vbDirectory) = vbDirectory Then dir_2 (pfad & pfad1 & "\") Else erg = erg + FileLen(pfad & pfad1) End If pfad1 = Dir Loop MsgBox erg End Sub Sub dir_2(pfad_2 As String) pfad2 = Dir(pfad_2, 16) Do Until pfad2 = "" If Not pfad2 = "." And Not pfad2 = ".." Then If (GetAttr(pfad_2 & pfad2) And vbDirectory) = vbDirectory Then 'dir_3 (pfad_2 & pfad2 & "\") Else erg = erg + FileLen(pfad_2 & pfad2) End If End If pfad2 = Dir Loop End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo RALF,
VBA - Profi ? Und schlägt sich mit DIR herum, kann keine rekursive Prozedur schreiben und versteht nicht, dass die Variable Pfad2 als Referenz übergeben wird und der geänderte Wert nicht in die Parameter des Calls passen, da muss ich mich über nichts mehr wundern. :-)
Code in Modul1:
Option Explicit
Option Private Module

Private Declare Function MoveWindow Lib "user32.dll" ( _
    ByVal hwnd As Long, _
    ByVal x As Long, _
    ByVal y As Long, _
    ByVal nWidth As Long, _
    ByVal nHeight As Long, _
    ByVal bRepaint As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32.dll" ( _
    ByVal nIndex As Long) As Long
Private Declare Function GetWindowRect Lib "user32.dll" ( _
    ByVal hwnd As Long, _
    ByRef lpRect As RECT) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" ( _
    lpbi As InfoT) As Long
Private Declare Function CoTaskMemFree Lib "ole32" ( _
    ByVal hMem As Long) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" ( _
    ByVal lpStr1 As String, _
    ByVal lpStr2 As String) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" ( _
    ByVal pList As Long, _
    ByVal lpBuffer As String) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
    ByVal lpClassname As String, _
    ByVal lpWindowName As String) As Long
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" ( _
    ByVal hwnd As Long, _
    ByVal Msg As Long, _
    wParam As Any, _
    lParam As Any) As Long

Private Type InfoT
    hwnd As Long
    Root As Long
    DisplayName As Long
    Title As Long
    Flags As Long
    FName As Long
    lParam As Long
    Image As Long
End Type

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Public Enum BIF_Flag
    BIF_RETURNONLYFSDIRS = &H1
    BIF_DONTGOBELOWDOMAIN = &H2
    BIF_STATUSTEXT = &H4
    BIF_RETURNFSANCESTORS = &H8
    BIF_EDITBOX = &H10
    BIF_VALIDATE = &H20
    BIF_NEWDIALOGSTYLE = &H40
    BIF_BROWSEINCLUDEURLS = &H80
    BIF_BROWSEFORCOMPUTER = &H1000
    BIF_BROWSEFORPRINTER = &H2000
    BIF_BROWSEINCLUDEFILES = &H4000
    BIF_SHAREABLE = &H8000
End Enum

Private Const SM_CXFULLSCREEN = &H10
Private Const SM_CYFULLSCREEN = &H11

Private Const BFFM_SETSELECTION = &H466
Private Const BFFM_INITIALIZED = &H1

Private s_BrowseInitDir As String

Public Function fncGetFolder( _
        Optional ByVal sMsg As String = "Bitte wählen Sie ein Verzeichnis", _
        Optional ByVal lFlag As BIF_Flag = BIF_RETURNONLYFSDIRS, _
        Optional ByVal sPath As String = "C:\") As String
    Dim xl As InfoT, IDList As Long, RVal As Long, FolderName As String
    s_BrowseInitDir = sPath
    With xl
        .hwnd = FindWindow("XLMAIN", vbNullString)
        .Root = 0
        .Title = lstrcat(sMsg, "")
        .Flags = lFlag
        .FName = FuncCallback(AddressOf BrowseCallback)
    End With
    IDList = SHBrowseForFolder(xl)
    If IDList <> 0 Then
        FolderName = Space(256)
        RVal = SHGetPathFromIDList(IDList, FolderName)
        CoTaskMemFree (IDList)
        FolderName = Trim$(FolderName)
        FolderName = Left$(FolderName, Len(FolderName) - 1)
    End If
    fncGetFolder = FolderName
End Function

Private Function BrowseCallback( _
        ByVal hwnd As Long, _
        ByVal uMsg As Long, _
        ByVal wParam As Long, _
        ByVal lParam As Long) As Long
    If uMsg = BFFM_INITIALIZED Then
        Call SendMessage(hwnd, BFFM_SETSELECTION, ByVal 1&, ByVal s_BrowseInitDir)
        Call CenterDialog(hwnd)
    End If
    BrowseCallback = 0
End Function

Private Function FuncCallback(ByVal nParam As Long) As Long
    FuncCallback = nParam
End Function

Private Sub CenterDialog(ByVal hwnd As Long)
    Dim WinRect As RECT, ScrWidth As Integer, ScrHeight As Integer
    Dim DlgWidth As Integer, DlgHeight As Integer
    GetWindowRect hwnd, WinRect
    DlgWidth = WinRect.Right - WinRect.Left
    DlgHeight = WinRect.Bottom - WinRect.Top
    ScrWidth = GetSystemMetrics(SM_CXFULLSCREEN)
    ScrHeight = GetSystemMetrics(SM_CYFULLSCREEN)
    MoveWindow hwnd, (ScrWidth - DlgWidth) / 2, _
        (ScrHeight - DlgHeight) / 2, DlgWidth, DlgHeight, 1
End Sub

Code in Modul2:
Option Explicit

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 FindClose Lib "kernel32" ( _
    ByVal hFindFile As Long) As Long

Private Enum FILE_ATTRIBUTE
    INVALID_HANDLE_VALUE = -1
    FILE_ATTRIBUTE_ARCHIVE = &H20
    FILE_ATTRIBUTE_DIRECTORY = &H10
    FILE_ATTRIBUTE_HIDDEN = &H2
    FILE_ATTRIBUTE_NORMAL = &H80
    FILE_ATTRIBUTE_READONLY = &H1
    FILE_ATTRIBUTE_SYSTEM = &H4
    FILE_ATTRIBUTE_TEMPORARY = &H100
End Enum

Private Const MAX_PATH = 260

Private Const OF_READ = &H0

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

Private lngFilecount As Long
Private lngFoldercount As Long
Private varBytes As Variant

Public Sub start()
    Dim lngIndex As Long
    Dim strFolder As String
    strFolder = Trim$(fncGetFolder(sPath:="C:\Programme\"))
    If strFolder <> "" Then
        lngFilecount = 0
        lngFoldercount = 0
        varBytes = 0
        FindFiles strFolder, "*.*"
        MsgBox "Ordner: " & CStr(lngFoldercount) & vbLf & _
            "Dateien: " & CStr(lngFilecount) & vbLf & _
            "Größe: " & Format(CDec(varBytes), "#,##0") & " Byte", 64, "Info"
    End If
End Sub

Private Sub FindFiles(ByVal strFolderPath As String, ByVal strSearch As String)
    Dim udtWFD As WIN32_FIND_DATA, lngSearch As Long, strDirName As String
    If Right$(strFolderPath, 1) <> "\" Then strFolderPath = strFolderPath & "\"
    lngSearch = FindFirstFile(strFolderPath & "*.*", udtWFD)
    If lngSearch <> INVALID_HANDLE_VALUE Then
        GetFilesInFolder strFolderPath, strSearch
        Do
            If (udtWFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) Then
                strDirName = Left$(udtWFD.cFileName, InStr(udtWFD.cFileName, Chr(0)) - 1)
                If (strDirName <> ".") And (strDirName <> "..") Then
                    FindFiles strFolderPath & strDirName, strSearch
                    lngFoldercount = lngFoldercount + 1
                End If
            End If
        Loop While FindNextFile(lngSearch, udtWFD)
        FindClose lngSearch
    End If
End Sub

Private Sub GetFilesInFolder(ByVal strFolderPath As String, ByVal strSearch As String)
    Dim udtWFD As WIN32_FIND_DATA, lngSearch As Long, strFileName As String
    If Right$(strFolderPath, 1) <> "\" Then strFolderPath = strFolderPath & "\"
    lngSearch = FindFirstFile(strFolderPath & strSearch, udtWFD)
    If lngSearch <> INVALID_HANDLE_VALUE Then
        Do
            If (udtWFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) <> FILE_ATTRIBUTE_DIRECTORY Then
                strFileName = Left$(udtWFD.cFileName, InStr(udtWFD.cFileName, Chr(0)) - 1)
                lngFilecount = lngFilecount + 1
                varBytes = varBytes + FileLen(strFolderPath & strFileName)
            End If
        Loop While FindNextFile(lngSearch, udtWFD)
        FindClose lngSearch
    End If
End Sub

Einen Profi muss ich den Code sicher nicht erklären. :-)
Gruß
Nepumuk (VBA - Amateur)

Sub ShowFolderSize() Dim fs, f, s Set fs = CreateObject("Scripting.FileSystemObject") Set f = fs.GetFolder("C:\Programme") s = UCase(f.Name) & " uses " & f.Size & " bytes." MsgBox s, 0, "Folder Size Info" End Sub

Hallo Ralf,
in dieser Art wirst du deswegen behandelt, um deine Selbstüberschätzung etwas zu dämpfen. Wenn sich jemand als Profi bezeichnet und noch nicht mal die grundlegensten Techniken von VBA beherrsche, dann habe ich halt nur noch Spott übrig. Der Beitrag war nicht todernst gemeint und der Code war nur dazu da, dir zu zeigen, was mit VBA möglich ist.
Zu deiner letzten Frage. Wenn du eine For - Next Schleife schreibst, könnte ich dich genauso fragen, wo du die geklaut hast. Es gibt so gut wie nichts, was nicht schon einmal so oder so ähnlich gemacht wurde. Ist also alles geklaut? Oder willst du mit jeder Programmzeile das Rad neu erfinden?
Ich kann aber auch ganz normale Programme schreiben. Beispiel:
http://www.online-excel.de/excel/singsel_vba.php?f=80
Gruß
Nepumuk

Beliebteste Forumthreads (12 Monate)

Größe (MB) eines Dateiordners - die 2.

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Größe (MB) eines Dateiordners - die 2.

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread