PDA

Vollständige Version anzeigen : Dateinamen aus Ordner auslesen


golochim
12.12.2017, 08:44
Hallo,

ich benötige Hilfe bei folgendem Problem. Mit einem Makro :
Sub DateienAuflisten()

Dim lngZeile As Long
Dim objFileSystem As Object
Dim objVerzeichnis As Object
Dim objDateienliste As Object
Dim objDatei As Object

Set objFileSystem = CreateObject("scripting.FileSystemObject")
Set objVerzeichnis = objFileSystem.GetFolder("C:")
Set objDateienliste = objVerzeichnis.Files

lngZeile = 1

For Each objDatei In objDateienliste
If Not objDatei Is Nothing Then
ActiveSheet.Cells(lngZeile, 1) = objDatei.Name
lngZeile = lngZeile + 1
End If
Next objDatei

End Sub


kann ich die Dateien in einem bestimmten Verzeichnis auslesen und in eine Exceltabelle schreiben. Jetzt möchte ich aber, dass der User, das Verzeichnis, in dem die Dateien stehen selbst auswählen kann. Könnte mir jemand hier Helfen, wie ich das in dem Makro schreibe??

Gruß

Jojo

Jonas0806
12.12.2017, 08:54
Hallo Jojo,

z.B. so

'Herbers Excel/VBA-Beispiele
'Verzeichnisbaum aufrufen und Verzeichnis auswählen

Option Private Module

Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type

Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long

Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Sub DirAuswahl()
Dim msg As String

msg = "Wählen Sie bitte einen Ordner aus:"
MsgBox getdirectory(msg)
End Sub

Function getdirectory(Optional msg) As String
Dim bInfo As BROWSEINFO
Dim Path As String
Dim r As Long, x As Long, pos As Integer

bInfo.pidlRoot = 0&
If IsMissing(msg) Then
bInfo.lpszTitle = "Wählen Sie bitte einen Ordner aus."
Else
bInfo.lpszTitle = msg
End If
bInfo.ulFlags = &H1
x = SHBrowseForFolder(bInfo)
Path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal Path)
If r Then
pos = InStr(Path, Chr$(0))
getdirectory = Left(Path, pos - 1)
Else
getdirectory = ""
End If
End Function

golochim
12.12.2017, 09:17
Hallo Jonas,

vielen Dank für die Schnelle Lösung. Werde es gleich testen!


Gruß

Jojo

Beverly
12.12.2017, 09:28
Hi,

hier noch eine einfache Lösungsmöglichkeit ohne API-Funktion:

Sub DateienAuflisten()
Dim strPfad As String
Dim lngZeile As Long
Dim strDatei As String
lngZeile = 1
Application.ScreenUpdating = False
strPfad = GetFolder
strDatei = Dir(strPfad & "*.*")
If strPfad <> "" Then
Do
Cells(lngZeile, 1) = strDatei
strDatei = Dir
lngZeile = lngZeile + 1
Loop While strDatei <> ""
End If
Application.ScreenUpdating = True
End Sub

Function GetFolder() As String
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.InitialFileName = "E:/" 'Startordner anpassen!!
.ButtonName = "OK"
.Title = "Dateiauswahl"
.Show
If .SelectedItems.Count = 0 Then
GetFolder = ""
Else
GetFolder = .SelectedItems(1)
End If
End With
End Function



<hr width="20%" align="left"><img src="http://excel-inn.de/images/grusz.gif" height=35" align="left" alt="Grußformel"><a href="http://excel-inn.de/"><img border="0" src="http://excel-inn.de/images/logo1.gif" height=35" align="middle" alt="Beverly's Excel - Inn"></a>

golochim
12.12.2017, 12:21
Hallo Karin,

Deine Lösung finde ich super. Vielen Dank!

Gruß

Jojo

golochim
12.12.2017, 12:27
Hallo Karin,

Deine Lösung finde ich super. Vielen Dank!

Gruß

Jojo