Dateieigenschaften - Autor | HERBERS Excel Forum

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo beyersdorf
starte dies mal aus einem leeren tabellenblatt.

Sub Dateieigenschaften()
'Orignal von k.rola
    Const STRFOLDER As String = "d:\Eigene Dateien" 'anpassen
    Dim objShell As Object
    Dim objFolder As Object
    Dim x As Byte
    Dim spalte As Integer
    Dim zeile As Long
    Dim varName, arrHeaders(34)
    If Dir(STRFOLDER, 16) = "" Then
      MsgBox "Der Ordner " & STRFOLDER & " wurde nicht gefunden!" & Space(10), 64, "weise hin..."
      Exit Sub
    End If
    Application.ScreenUpdating = False
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.Namespace(STRFOLDER)
    spalte = 1
    For x = 0 To 33
            Select Case x
            Case 0, 3 To 5, 9
                arrHeaders(x) = objFolder.GetDetailsOf(varName, x)
                Cells(1, spalte + x) = arrHeaders(x)
            End Select
    Next
    Rows(1).Font.Bold = True
    zeile = 2
    For Each varName In objFolder.Items
        If varName Like "*.xls" Then
            For x = 0 To 33
                    Select Case x
                    Case 0, 3 To 5, 9
                        Cells(zeile, spalte + x) = objFolder.GetDetailsOf(varName, x)
                    End Select
            Next
            zeile = zeile + 1
        End If
    Next
    Columns.AutoFit
    Application.ScreenUpdating = True
End Sub

Ich denke das kommt dem was du willst schon sehr nah...
ransi

Hallo Walter!
Auf die schnelle mal umgebaut!

' **********************************************************************
' Modul: Modul2 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit
Dim varName As Object
Dim x As Byte
Dim spalte As Integer
Dim zeile As Long
Dim objShell As Object
Dim objFolder As Object
Dim arrHeaders(34)
Sub DateieigenschaftenMitSubFolder()
'Orignal von k.rola
Const STRFOLDER As String = "F:\Office\Excel\" 'anpassen

If Dir(STRFOLDER, 16) = "" Then
  MsgBox "Der Ordner " & STRFOLDER & " wurde nicht gefunden!" & Space(10), 64, "weise hin..."
  Exit Sub
End If

Application.ScreenUpdating = False

Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(STRFOLDER)

spalte = 1

For x = 0 To 33
  Select Case x
    Case 0, 3 To 5, 9
      arrHeaders(x) = objFolder.GetDetailsOf(varName, x)
      Cells(1, spalte + x) = arrHeaders(x)
  End Select
Next

Rows(1).Font.Bold = True
zeile = 2

getDetails objFolder

Columns.AutoFit
Application.ScreenUpdating = True

Set objShell = Nothing
Set objFolder = Nothing

End Sub

Private Function getDetails(objF)
Dim objSF As Object
For Each varName In objF.Items
  If varName.IsFolder Then
    Set objSF = objShell.Namespace(varName)
    getDetails objSF
  Else
    If varName Like "*.xls" Then
      For x = 0 To 33
        Select Case x
          Case 0, 3 To 5, 9
            Cells(zeile, spalte + x) = objF.GetDetailsOf(varName, x)
        End Select
      Next
      zeile = zeile + 1
    End If
  End If
Next
Set objSF = Nothing
End Function

'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************

Beliebteste Forumthreads (12 Monate)

Dateieigenschaften - Autor

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread