Explorer via VBA aufrufen

[Telematix]

Hallo zusammen,

letzte Woche habe ich ein kleines Tool gebastelt welches die Ordner in einem Verzeichnis ausliest und Zählt.
Der zu durchsuchende Pfad wird manuell eingegeben und mit einem \ abgeschlossen.
Danach muss nur noch auf Ausführen geklickt werden und die Ordner werden auf der Linken Seite aufgelistet.
Wird der Pfad nun geändert und das Tool neu ausgeführt, so listen sich die weiteren Ordner darunter.

Da das Tool für meine Kollegen gestaltet ist und nach Möglichkeit ohne mein zutun Funktionieren sollte, würde ich gerne folgende Änderung vornehmen. Anstatt den zu durchsuchenden Pfad manuell einzutippen, müsste es doch möglich sein über ein Fenster/Explorer den Pfad zu wählen (ähnlich wie bei der Auswahl eines Installationspfades für ein neuen Programm). Bisher konnte ich hierzu keinen Ansatz entdecken und hoffe daher auf die schlauen Leute hier...


Gruß
Tele

[chris-ka]

Hi,

Ordnerauswahl hatte ich erst vor kurzem
http://www.clever-excel-forum.de/thread-5762.html

ich verwende gerne Variante1

Nur bist du Dir sicher das der Code alle Ordner auflistet!?
Ich habe gerade mal einen gewählt mit > 1000 Ordnern und 70 werden angezeigt.
Warum heißt die Datei Dateien zählen und Ordner sollen aufgelistet werden :)

[snb]

Code:

Sub M_snb()
   with application.filedialog(4)
      if .show then
         sn=split(createobject("wscript.shell").exec("cmd /c dir """ & .selecteditems(1) & "\*.*"" /b").stdout.readall,vbcrlf)
         cells(1,6).resize(Ubound(sn))=application.transpose(sn)
      end if
   end with
end sub

[Telematix]

Klasse, 
danke dafür.

Die bisherigen Ergebnisse haben alle gestimmt?!

Probeläufe waren vor allem Pfade mit größeren Mengen an Ordnern (z.b. 8800 Ordner oder 600 Ordner) und hat dort keine ausgelassen! Hast du einen Anhaltspunkt, warum es bei dir nicht geklappt hat?

Den Namen ist natürlich Blödsinn  :19:


Gruß
Tele

[chris-ka]

Hi,

versuche mal das und vergleiche. (Ich gebe aber hier den ganzen Pfad aus)

Code:

Option Explicit
Dim fs As Object, First As Integer
Sub alternative_zu_application_filesearch()
'by Kaiser 2012
Dim objShell As Object
Dim BrowseDir 'mit Absicht Varianten
Dim strVerzeichnis As String
Set objShell = CreateObject("Shell.Application") 'das könnte dann weg
Set BrowseDir = objShell.BrowseForFolder(0, "Ordner auswählen", &H1000, 17) 'das könnte dann weg
'On Error Resume Next
strVerzeichnis = BrowseDir.Items().Item().Path 'oder einfach fix den Pfad eintragen ;
If strVerzeichnis = "" Then: On Error GoTo 0: Exit Sub
Set fs = CreateObject("Scripting.FileSystemObject")
First = 1
ffile strVerzeichnis
End Sub
Sub ffile(strVerzeichnis As String)
Dim MyFolder As Object, FSO As Object, StrName As String, IntC As Integer, strPath As String
Static za As Long
Set FSO = fs.GetFolder(strVerzeichnis)
For Each MyFolder In FSO.SubFolders
    For IntC = 0 To First
        If First = 1 Then
            strPath = strVerzeichnis
            First = 0
        Else
            strPath = MyFolder
        End If
        za = za + 1
        Cells(za, 1).Value = strPath
    Next
    If FSO.SubFolders.Count > 0 Then
    ffile strVerzeichnis & "\" & MyFolder.Name
    End If
Next
End Sub

über Rekursion gelöst.
Das dauert aber ewig, wenn ein Verzeichnis mit tsd. von Ordnern gewählt wird.
Ansonsten gibt es noch eine Klasse von Nepumuk (über Google leicht zu finden, https://www.google.at/?gws_rd=ssl#q=Nepu...lternative)

edit
[anbei noch etwas schneller]

bei za. 800 Ordnern inkl Unterordnen von der Festplatte in 1 sek.

Code:

Option Explicit
Dim fs As Object, First As Integer, tmpstr As String
Sub alternative_zu_application_filesearch()
'by Kaiser 2012
tmpstr = ""
Columns(1).Clear
Dim objShell As Object, myarr
Dim BrowseDir 'mit Absicht Varianten
Dim strVerzeichnis As String
Set objShell = CreateObject("Shell.Application") 'das könnte dann weg
Set BrowseDir = objShell.BrowseForFolder(0, "Ordner auswählen", &H1000, 17) 'das könnte dann weg
'On Error Resume Next
strVerzeichnis = BrowseDir.Items().Item().Path 'oder einfach fix den Pfad eintragen ;
If strVerzeichnis = "" Then: On Error GoTo 0: Exit Sub
Set fs = CreateObject("Scripting.FileSystemObject")
First = 1
ffile strVerzeichnis
myarr = Split(tmpstr, ";")
Cells(1, 1).Resize(UBound(myarr)) = WorksheetFunction.Transpose(myarr)
End Sub
Sub ffile(strVerzeichnis As String)
Dim MyFolder As Object, FSO As Object, StrName As String, IntC As Integer, strPath As String
Set FSO = fs.GetFolder(strVerzeichnis)
For Each MyFolder In FSO.SubFolders
    For IntC = 0 To First
        If First = 1 Then
            strPath = strVerzeichnis
            First = 0
        Else
            strPath = MyFolder
        End If
       tmpstr = tmpstr & strPath & ";"
    Next
    If FSO.SubFolders.Count > 0 Then
        ffile strVerzeichnis & "\" & MyFolder.Name
    End If
Next
End Sub

übers Netzwerk mit 2500 Ordnern hat das aber mal 5 Min gedauert....

[Telematix]

Hallo zusammen,

dank eurer Hilfe hab ich nun den gewünschten Effekt erzielt,
bin jedoch nicht sicher warum das ganze bei dir chris-ka nicht funktioniert.

Habe das ganze Lokal und auf Server Ebene mit meinem und deinem Code getestet, komme jedoch an keiner Stelle Abweichungen/fehlende Ordner feststellen.

Name ist auch angepasst  :19:

Gruß
Tele

[chris-ka]

Hi,

bei mir werden nach wie vor keine Unterordner angezeigt :)
lg

[schauan]

Hallöchen,

der tele..-Code geht nicht rekursiv weiter nach unten. Es werden nur die Unterordner des gewählten Ordners angezeigt, nicht jedoch die Unterordner der Unterordner usw.

[Telematix]

Guten Morgen zusammen,

der Code soll ja auch nicht die Unterordner auflisten, also alles in Ordnung!

Vielen Dank zusammen und ein schönes Wochenende...

Gruß
Tele