Verzeichnis auswählen und Auflisten

Private Function GetFolder() As String 'Funktion um den Ordner auszuwählen Dim objShell As Object Dim strPath As String Set objShell = CreateObject("Shell.Application") Set varFolder = objShell.BrowseForFolder(0, "Folder", &H4000, 17) If varFolder Is Nothing Then Set varFolder = Nothing Set objShell = Nothing Exit Function End If GetFolder = varFolder.Self.Path Set objShell = Nothing End Function

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Code: [Cc] Private Declare PtrSafe Function lstrcat Lib "kernel32" Alias "lstrcatA" ( _ ByVal lpString1 As String, _ ByVal lpString2 As String) As LongPtr Private Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" ( _ lpBrowseInfo As BROWSEINFO) As LongPtr Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" ( _ ByVal pidl As LongPtr, _ ByVal pszPath As String) As Long Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" ( _ ByVal lpClassName As String, _ ByVal lpWindowName As String) As LongPtr Private Declare PtrSafe Function CoTaskMemFree Lib "ole32" ( _ ByVal hMem As LongPtr) As Long Private Type BROWSEINFO hOwner As LongPtr pidlRoot As Long pszDisplayName As String lpszTitle As String ulFlags As Long lpfn As LongPtr lParam As LongPtr iImage As Long End Type

Function GetAOrdner() As String Dim xl As InfoT, IDList As Long, RVal As Long, FolderName As String With xl .hwnd = FindWindow("xlmain", vbNullString) ' .hwnd = FindWindow("", "Auswahl") ' Userform Auswahl .Title = lstrcat("Bitte wählen Sie ein Verzeichnis", "") .Flags = 1 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 GetAOrdner = FolderName End Function

Hallo Mirko,
hier mal das Ganze an 64-Bit angepasst. Aber ich lese gerade, Du möchtest die Großversion mit den Dateien drin. Wäre da nicht eher GetOpenFileName die richtige Wahl?
Wenn dieses hier nicht das gewünschte ist, melde Dich noch mal...

Code:
[Cc][+][-]

Private Declare PtrSafe Function lstrcat Lib "kernel32" Alias "lstrcatA" ( _
        ByVal lpString1 As String, _
        ByVal lpString2 As String) As LongPtr
Private Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" _
        Alias "SHBrowseForFolderA" ( _
        lpBrowseInfo As InfoT) As LongPtr
Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" _
        Alias "SHGetPathFromIDListA" ( _
        ByVal pidl As LongPtr, _
        ByVal pszPath As String) As Long
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" ( _
        ByVal lpClassName As String, _
        ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function CoTaskMemFree Lib "ole32" ( _
        ByVal hMem As LongPtr) As Long

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

Function GetAOrdner() As String
    Dim xl As InfoT, IDList As LongPtr, RVal As Long, FolderName As String
    With xl
        .hwnd = Application.hwnd
        .Title = "Bitte wählen Sie ein Verzeichnis"
        .Flags = 1
    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
    GetAOrdner = FolderName
End Function

_________________________
viele Grüße aus Freigericht 😊
Karl-Heinz

Code: [Cc][+][-] Private Declare PtrSafe Function SHBrowseForFolderA Lib "shell32.dll" ( _ lpBrowseInfo As InfoT) As LongPtr Private Declare PtrSafe Function SHGetPathFromIDListA Lib "shell32.dll" ( _ ByVal pidl As LongPtr, ByVal pszPath As String) As Long Private Declare PtrSafe Function CoTaskMemFree Lib "ole32" ( _ ByVal hMem As LongPtr) As Long Private Type InfoT hwnd As LongPtr Root As Long DisplayName As String Title As String Flags As Long FName As LongPtr lParam As LongPtr Image As Long End Type Function GetAOrdner() As String Dim xl As InfoT, IDList As LongPtr, RVal As Long, FolderName As String With xl .hwnd = Application.hwnd .Title = "Bitte wählen Sie ein Verzeichnis!" .Flags = 1 End With IDList = SHBrowseForFolderA(xl) If IDList <> 0 Then FolderName = Space(256) RVal = SHGetPathFromIDListA(IDList, FolderName) CoTaskMemFree (IDList) FolderName = Trim(FolderName) FolderName = Left(FolderName, Len(FolderName) - 1) End If GetAOrdner = FolderName End Function

Code: [Cc][+][-] Option Explicit Sub FileSearchList() 'Auflisten von Dateien aus Ordner und Unterordner Dim OutZeile As Long, sArr() As String, sPath As String sPath = "D:\Pictures" 'Pfad <<< anpassen >>>> FileOut OutZeile, sArr, CreateObject("scripting.filesystemobject").GetFolder(sPath) With ThisWorkbook.Sheets("Dateien") 'Ausgabeblatt <<< anpassen >>>> .Cells.ClearContents .Cells(1, 1).Resize(1, 4).Value = Split("Pfad Dateiname Datum, Größe") .Cells(2, 1).Resize(OutZeile, 4).Value = Application.Transpose(sArr()) End With MsgBox OutZeile & " Dateien gefunden!", vbInformation, "Dateisuche" End Sub Sub FileOut(i As Long, sArr, oPath As Object) Dim oFile As Object, oDir As Object, Obj As Variant On Error Resume Next For Each oFile In oPath.Files 'Ordner durchsuchen If Err = 0 Then With oFile Err = 0 ReDim Preserve sArr(3, i) DoEvents sArr(0, i) = Replace(.Path, "\" & .Name, "") sArr(1, i) = .Name 'Dateinamen im Direktfenster ausgeben sArr(2, i) = FileDateTime(.Path) sArr(3, i) = .Size i = i + 1 End With End If Next For Each oDir In oPath.Subfolders 'Unterordner durchsuchen Obj = FileDateTime(oDir) FileOut i, sArr, oDir Next End Sub

Beliebteste Forumthreads (12 Monate)

Verzeichnis auswählen und Auflisten

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Verzeichnis auswählen und Auflisten

15 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread