AW: PDF ohne Pfad speichern
07.03.2024 18:36:42
Oppawinni
Ich kann es halt auch nicht lassen, ne Variante mit File System Object.
Über eine Funktion werden die Pfade erst in einer Collection gesammelt, ggf. auch aus Unterverzeichnissen.
Dort kann man dann mit den Pfaden anstellen was man will.
Gut, ist ein bisschen viel Überhang für diesen einfachen Fall der Ausgabe von Dateinamen.
Sub findMyPDFs()
Dim strFolder As String
Dim strExtension As String
Dim fso As Object
Dim colPaths As Collection
Dim wksOut As Worksheet
Dim lngOutCol As Long
Dim lngRowCount As Long
Dim path As Variant
' Dim objFileDialog As FileDialog
Set wksOut = Tabelle2
Set fso = CreateObject("Scripting.FileSystemObject")
lngOutCol = 1
lngRowCount = 2
strExtension = "pdf"
' Set objFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
' With objFileDialog
' .AllowMultiSelect = False
' .InitialFileName = Application.DefaultFilePath
' .InitialView = msoFileDialogViewSmallIcons
' .Title = "Bitte den Ordner auswählen"
' If .Show Then strFolder = .SelectedItems(1)
' End With
' Set objFileDialog = Nothing
' If strFolder = "" Then
' Exit Sub
' End If
strFolder = "C:\Documents\"
If Not fso.folderexists(strFolder) Then
MsgBox "Pfad " & vbCrLf & strFolder & vbCrLf & "nicht gefunden", vbOKOnly Or vbExclamation, "Ojee"
Exit Sub
End If
Set colPaths = findFilesInFolderByExt(strFolder, strExtension, false)
For Each path In colPaths
wksOut.Cells(lngRowCount, lngOutCol).Value = fso.getfile(path).Name
' wksOut.Cells(lngRowCount, lngOutCol).Value = path
lngRowCount = lngRowCount + 1
Next
End Sub
Private Function findFilesInFolderByExt(ByVal SourceFolderName As String, ByVal fileExtension As String, _
Optional includeSubfolders As Boolean = False) As Collection
'Erzeugt eine Collection mit Pfaden von Dateien der Erweiterung fileEtension ausgehend vom Pfad SourceFolderName
'für includeSubFolders = True erfolgt die Suche rekursiv, also auch in Unterordnern und deren Unterordnern,
'ausgenommen sind System und Hidden und Folders und natürlich auch Folder für die keine Leserechte bestehen.
Dim fso As Object, SourceFolder As Object, SubFolder As Object
Dim FileItem
Dim Result As New Collection
Dim i As Long, j As Long, x
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.GetDrive(fso.GetDriveName(SourceFolderName)).path = SourceFolderName Then
Set SourceFolder = fso.GetDrive(fso.GetDriveName(SourceFolderName)).RootFolder
Else
Set SourceFolder = fso.GetFolder(SourceFolderName)
End If
'check for ReadAccess
On Error Resume Next
If Not (SourceFolder.Files.Count >= 0) Then
Exit Function
End If
On Error GoTo 0
For Each FileItem In SourceFolder.Files
If LCase(fso.GetExtensionName(FileItem.path)) = LCase(fileExtension) Then
Result.Add FileItem.path
End If
Next FileItem
DoEvents
If includeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
If Not ((SubFolder.Attributes And (vbSystem Or vbHidden)) > 0) Then
Dim SubResult As Collection
Set SubResult = findFilesInFolderByExt(SubFolder.path, fileExtension, True)
If SubResult.Count > 0 Then
For Each x In SubResult
Result.Add x
Next
End If
Set SubResult = Nothing
End If
Next SubFolder
End If
Set findFilesInFolderByExt = Result
End Function