Document.Properties

Sub Schaltfläche1_BeiKlick() Set fs = Application.FileSearch Set fo = CreateObject("Scripting.FileSystemObject") With fs .LookIn = "C:\Verzeichnis" .SearchSubFolders = True .Filename = "*.*" If .Execute() > 0 Then For i = 1 To .FoundFiles.Count Set f = fo.GetFile(.FoundFiles(i)) Worksheets("Tabelle1").Cells(5 + i, 1).Value = f.Name Worksheets("Tabelle1").Cells(5 + i, 2).Value = f.DateLastModified Worksheets("Tabelle1").Cells(5 + i, 3).Value = f.BuiltinDocumentProperties(3) Next i Else MsgBox "There were no files found." End If End With End Sub

Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Betreff

Datum

Anwender

hallo alexander,
wenn du dir die dateieigenschaften anschaust wirst du feststellen, dass die hier anders aussehen als bei den xls. manchmal sind weitere nicht dabei, und wenn sind's vielleicht andere. schaue dir mal den code an:

Sub ExtendedInfos()
   Dim objShell As Object
   Dim objFolder As Object
   Dim iCounter As Integer, iRow As Integer, iCol As Integer
   Dim strFileName As Variant
   Dim arrHeaders(34)
   Dim FileName As Variant, iFil As Long, Verz$
   On Error GoTo Fehler
   FileName = Application.GetOpenFilename("PDF-Files (*.PDF), *.PDF", 1, "DateiInfo", "Infos", True)
   If Not (IsArray(FileName)) Then Exit Sub
   Application.Calculation = xlCalculationManual
   Application.EnableEvents = False
   Application.ScreenUpdating = False
   Cells.ClearContents
   Verz = CurDir()
   If Right(Verz, 1) <> "\" Then Verz = Verz & "\"
   Set objShell = CreateObject("Shell.Application")
   Set objFolder = objShell.Namespace(UCase(Verz))
   For iCounter = 0 To 33
      arrHeaders(iCounter) = _
         objFolder.getdetailsof(strFileName, iCounter)
      Cells(1, iCounter + 1) = arrHeaders(iCounter)
   Next iCounter
   For iFil = LBound(FileName) To UBound(FileName)
       FileName(iFil) = Mid(FileName(iFil), Len(Verz) + 1)
   Next
   iRow = 2
   For Each strFileName In objFolder.items
       For iFil = LBound(FileName) To UBound(FileName)
           If (StrComp(strFileName.Name, Left(FileName(iFil), Len(FileName(iFil)) - 4), vbTextCompare) = 0) Then
              For iCounter = 0 To 33
                  Cells(iRow, iCounter + 1).Value = iCounter + 1
                  Cells(iRow, iCounter + 1).Value = arrHeaders(iCounter)
                  Cells(iRow, iCounter + 1).Value = objFolder.getdetailsof(strFileName, iCounter)
              Next iCounter
              iRow = iRow + 1
              Exit For
           End If
       Next iFil
   Next strFileName
   GoTo Ende
Fehler:
   MsgBox Err.Description
Ende:
   Application.Calculation = xlCalculationAutomatic
   Application.EnableEvents = True
   Application.ScreenUpdating = True
End Sub

Code eingefügt mit Syntaxhighlighter 2.5

gruss andre

Beliebteste Forumthreads (12 Monate)

1 Beitrag zum Forumthread Beitrag zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread