AW: Danke für die Hilfe ! Bleibt stehen...
21.05.2018 14:56:33
Sepp
Hallo Sigrid,
sorry, hatte deine xl-Version nicht beachtet.
Modul Modul1
Option Explicit
Sub test()
Dim strPath As String
strPath = ShellBrowseForFolder("D:\")
If Len(strPath) Then
MsgBox countFiles(Directory:=strPath, SubFolders:=True)
End If
End Sub
Private Function ShellBrowseForFolder(Optional StartPath As String = "") As String
Dim objShell As Object
Dim lngRoot As Long
Dim objFolder As Object
lngRoot = 17
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "Ordner auswählen", 0, IIf(Len(StartPath), StartPath, lngRoot))
If Not objFolder Is Nothing Then
ShellBrowseForFolder = objFolder.Self.Path
End If
Set objFolder = Nothing
Set objShell = Nothing
End Function
Private Function countFiles(ByVal Directory As String, Optional ByVal FileName As String = "", Optional ByVal SubFolders As Boolean = False) As Long
Dim objFSO As Object, objFolder As Object, objFile As Object, objSubF As Object
Dim lngCount As Long
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(Directory)
If Len(FileName) Then
For Each objFile In objFolder.Files
If objFile.Name Like FileName Then lngCount = lngCount + 1
Next
Else
lngCount = objFolder.Files.Count
End If
If SubFolders Then
For Each objSubF In objFolder.SubFolders
lngCount = lngCount + countFiles(objSubF.Path, FileName, SubFolders)
Next
End If
countFiles = lngCount
Set objSubF = Nothing
Set objFile = Nothing
Set objFolder = Nothing
Set objFSO = Nothing
End Function
VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media
Code erstellt und getestet in Office 16 - mit VBAHTML 12.6.0