Live-Forum - Die aktuellen Beiträge
Datum
Titel
03.05.2024 15:00:19
MAX & WENN kombinieren ?
03.05.2024 14:23:54
Finden-Funktion ohne Suchen INNERHALB Strings
03.05.2024 13:31:36
Spaltenbereich wenn Buchstabe "F" vorhanden...
03.05.2024 13:09:39
MsgBox öffnen bei Eingabe eines Textes mit bestimmtem Wert
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1928to1932
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1928to1932
1928to1932
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Änderung

Änderung
23.04.2023 13:49:50
Rosel

Hallo zusammen,

ich habe ein Problem mit einem Makro, das ich im Netz gefunden habe. Leider liest das Makro nur Ordner und Unterordner aus und ich hätte aber auch gerne die Dateien mit ausgelesen, die nur "lose" in einem Ordner sind. Meine VBA Kenntnisse sind halt nicht so gut und trotz stundenlangem Probieren klappt es halt nicht. Wenn mir da jemand aus dem Forum behilflich sein könnte, wäre mein Tag gerettet.
Anbei das Makro.

https://www.herber.de/bbs/user/158843.txt

Danke schon mal.

Grüße von Rosel

30
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Änderung
23.04.2023 20:13:30
ralf_b
Das makro sieht doch erstmal gut aus. bis auf den Pfad C:\Test den du sicher noch anpassen musst.
Ansonsten solltest du etwas genauer werden.
Problem! Welches?
Funktioniert nicht! Was genau?


AW: Änderung
23.04.2023 20:43:04
Rosel
Hallo ralf_b,

dieses Makro funktioniert ja soweit auch. Nur wenn ich Dateien in einem Ordner ohne Unterordner habe, werden diese nicht ausgelesen. Z. B.: Ich habe den Ordner "C:\Test_Herber" und in diesem "SammelOrdner" sind ca. 100 unterschiedliche Dateien ohne zusätzlichen Ordner abgespeichert. Möchte ich diese auslesen, werden die aber nicht berücksichtigt. Würde ich aber in den Ordner "C:\Test_Herber" einen Unterordner installieren z. B. "C:\Test_Herber\Temp" und diese 100 Dateien in den "Temp Ordner" verschieben#, würde er mir dann diese Dateien auslesen. (Da ist irgendwo der ^berühmte Wurm drin!)

Grüße von Rosel


Anzeige
AW: Dateienauslesen
23.04.2023 22:03:11
GerdL
Hallo Rosel,

teste mal.
Option Explicit
Option Compare Text
' ****************************************************************
' Autor/en und Original-Quelltext unter:
' https://www.online-vba.de/vba_readfolder.php

' Verwendung der Quelltexte auf eigene Gefahr!
' Es gelten die Nutzungsbedingungen von https://www.online-vba.de

' ****************************************************************

Const sRootPath As String = "C:\TEST" 'Pfad bitte anpassen ohne Trennzeichen am Ende!!!
Private lRowCounter As Long
Private oSheet As Object

'Start der Routine: Call OVBAde_DateienMitUnterordnernAuslesen

Public Sub OVBAde_DateienMitUnterordnernAuslesen()
    Set oSheet = Sheets.Add
    oSheet.Activate
    oSheet.Cells(1, 1).Select
    Call CreateHeadLinesAndFormat
    lRowCounter = 2
    Call OVBAde_ReadSubFolder(sRootPath)
    Set oSheet = Nothing
End Sub

Private Sub CreateHeadLinesAndFormat()
  Dim i As Long
    
    oSheet.Cells(1, 1) = "Pfad"
    oSheet.Cells(1, 2) = "Dateiname"
    oSheet.Columns(1).ColumnWidth = 40
    oSheet.Columns(2).ColumnWidth = 40
    
    For i = 1 To 2
        With oSheet
            .Cells(1, i).Interior.ColorIndex = 11
            .Cells(1, i).Font.Color = vbWhite
            .Cells(1, i).Font.Bold = True
        End With
    Next i
End Sub

Private Sub OVBAde_ReadSubFolder(ByVal sPath As String)
  Dim oFSO As Object
  Dim oFolder As Object
  Dim oSubFolder As Object
  Dim oFile As Object
    
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFolder = oFSO.getfolder(sPath)
    
    With oSheet
    
        For Each oFile In oFolder.Files
         
                .Cells(lRowCounter, 1) = oFolder.Path
                .Cells(lRowCounter, 2) = oFile.Name
                lRowCounter = lRowCounter + 1
        
        Next
        
        For Each oSubFolder In oFolder.subfolders
        
            'Alle Dateien auflisten
            For Each oFile In oSubFolder.Files
                .Cells(lRowCounter, 1) = oSubFolder.Path
                .Cells(lRowCounter, 2) = oFile.Name
                lRowCounter = lRowCounter + 1
            Next oFile
            
            'Alle Unterverzeichnisse verarbeiten (rekursiv)
            Call OVBAde_ReadSubFolder(oSubFolder.Path)
        
        Next oSubFolder
    
    End With
    
    Set oFSO = Nothing
    Set oFile = Nothing
    Set oFolder = Nothing
    Set oSubFolder = Nothing
End Sub
Gruß Gerd


Anzeige
AW: Dateienauslesen
23.04.2023 22:53:00
Rosel
Hallo Gerd,

es freut mich, dass Du mir auch helfen willst. Habe mich schon gefreut, weil die Dateien jetzt auch mit ausgelesen werden. Aber leider ist da ein Problem mit dabei, nämlich die Dateien und Ordner werden doppelt ausgelesen. Sonderbar ist, dass es nur die Dateien in den Ordnern sind. (Ordner werden natürlich auch doppelt ausgelesen).

Grüße von Rosel


AW: Änderung
24.04.2023 08:33:03
GerdL
Hallo Rosel,

probier nochmal so.

Option Explicit
Option Compare Text
' ****************************************************************
' Autor/en und Original-Quelltext unter:
' https://www.online-vba.de/vba_readfolder.php

' Verwendung der Quelltexte auf eigene Gefahr!
' Es gelten die Nutzungsbedingungen von https://www.online-vba.de

' ****************************************************************

Const sRootPath As String = "C:\Windows\Containers" 'Pfad bitte anpassen ohne Trennzeichen am Ende!!!
Private lRowCounter As Long
Private oSheet As Object

'Start der Routine: Call OVBAde_DateienMitUnterordnernAuslesen

Public Sub OVBAde_DateienMitUnterordnernAuslesen()
    Set oSheet = Sheets.Add
    oSheet.Activate
    oSheet.Cells(1, 1).Select
    Call CreateHeadLinesAndFormat
    lRowCounter = 2
    Call OVBAde_ReadSubFolder(sRootPath)
    Set oSheet = Nothing
End Sub

Private Sub CreateHeadLinesAndFormat()
  Dim i As Long
    
    oSheet.Cells(1, 1) = "Pfad"
    oSheet.Cells(1, 2) = "Dateiname"
    oSheet.Columns(1).ColumnWidth = 40
    oSheet.Columns(2).ColumnWidth = 40
    
    For i = 1 To 2
        With oSheet
            .Cells(1, i).Interior.ColorIndex = 11
            .Cells(1, i).Font.Color = vbWhite
            .Cells(1, i).Font.Bold = True
        End With
    Next i
End Sub

Private Sub OVBAde_ReadSubFolder(ByVal sPath As String, Optional nofolder As Boolean)
  Dim oFSO As Object
  Dim oFolder As Object
  Dim oSubFolder As Object
  Dim oFile As Object
    
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFolder = oFSO.getfolder(sPath)
    
    With oSheet
    
        If nofolder = False Then
        
        For Each oFile In oFolder.Files
         
                .Cells(lRowCounter, 1) = oFolder.Path
                .Cells(lRowCounter, 2) = oFile.Name
                lRowCounter = lRowCounter + 1
        
        Next
        
        End If
        
        For Each oSubFolder In oFolder.subfolders
            
            'Alle Dateien auflisten
            For Each oFile In oSubFolder.Files
                .Cells(lRowCounter, 1) = oSubFolder.Path
                .Cells(lRowCounter, 2) = oFile.Name
                lRowCounter = lRowCounter + 1
            Next oFile
            
            'Alle Unterverzeichnisse verarbeiten (rekursiv)
            Call OVBAde_ReadSubFolder(oSubFolder.Path, True)
        
        Next oSubFolder
    
    End With
    
    Set oFSO = Nothing
    Set oFile = Nothing
    Set oFolder = Nothing
    Set oSubFolder = Nothing
End Sub
Gruß Gerd


Anzeige
AW: Änderung
24.04.2023 11:31:01
Rosel
Guten Morgen Gerd,

habe alles getestet und die Menge der Dateien der ausgelesenen Ordner sind identisch mit der "Eigenschaftsanzeige" im Win Explorer. Eine kleine Bitte hätte ich noch, wo ich als Neuling auch so meine Probleme habe, mit den "erweiterten Dateieigenschaften". Da verzweifle ich einfach daran. Ich bräuchte nur eine Vorlage, den Rest könnte ich dann selber einbauen. Als Vorlage wäre z. B. die "Länge" = 27 für mich wichtig.
Danke, schon mal.

Grüße von Rosel


AW: Änderung
24.04.2023 11:47:37
GerdL
Hmm,

meinst du ohne die Dateiextension einlesen?
.Cells(lRowCounter, 2) = Split(oFile.Name, ".")(0)

Gruß Gerd


Anzeige
AW: Änderung
24.04.2023 11:56:03
Rosel
Hallo Gerd,

nein!!! Ich meinte diese "erweiterten Dateieigenschaften" wie "Länge" z. B. von einem Video, oder Bildbreite / Bildhöhe die dann beim Auslesen mit abgespeichert werden können. Das meinte ich!!!

Grüße von Rosel


AW: Änderung
24.04.2023 12:03:22
GerdL
Hallo Rosel,

das ist nicht meine Baustelle. Ich stelle für andere Antworter auf "Noch offen".


AW: Änderung
24.04.2023 12:15:59
Rosel
Hallo Gerd,

schade!!! Aber vielleicht könntest Du mir doch noch behilflich sein beim "Einbau" von der "flexiblen Laufwerks bzw. Ordnerauswahl". Das wäre einfacher, als jedes mal die Ordner von Hand ein zu tragen.

Grüße von Rosel


Anzeige
AW: Änderung
24.04.2023 13:10:15
Pierre
Hallo Rosel,

ich meine mich dunkel zu erinnern, dass vor nicht allzu langer Zeit hier bereits ein Thread existierte, wo es auch um das Auslesen von Datei- bzw. in deinem Fall Videoeigenschaften ging.

Vielleicht findest du im Archiv was?

Gruß Pierre


AW: Änderung
24.04.2023 13:13:50
GerdL
Hallo Rosel!
Option Explicit
Option Compare Text
' ****************************************************************
' Autor/en und Original-Quelltext unter:
' https://www.online-vba.de/vba_readfolder.php

' Verwendung der Quelltexte auf eigene Gefahr!
' Es gelten die Nutzungsbedingungen von https://www.online-vba.de

' ****************************************************************

Private sRootPath As String
Private lRowCounter As Long
Private oSheet As Object

'Start der Routine: Call OVBAde_DateienMitUnterordnernAuslesen

Public Sub OVBAde_DateienMitUnterordnernAuslesen()
    
    Dim Pfad
    
    Set Pfad = Application.FileDialog(msoFileDialogFolderPicker)
    With Pfad
        .Title = "Bitte Ordner wählen"
        .InitialFileName = ""
        If .Show = -1 Then
            sRootPath = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    
    Set oSheet = Sheets.Add
    oSheet.Activate
    oSheet.Cells(1, 1).Select
    Call CreateHeadLinesAndFormat
    lRowCounter = 2
    
    Call OVBAde_ReadSubFolder(sRootPath)
    
    Set oSheet = Nothing
    Set Pfad = Nothing

End Sub

Private Sub CreateHeadLinesAndFormat()
  Dim i As Long
    
    oSheet.Cells(1, 1) = "Pfad"
    oSheet.Cells(1, 2) = "Dateiname"
    oSheet.Columns(1).ColumnWidth = 40
    oSheet.Columns(2).ColumnWidth = 40
    
    For i = 1 To 2
        With oSheet
            .Cells(1, i).Interior.ColorIndex = 11
            .Cells(1, i).Font.Color = vbWhite
            .Cells(1, i).Font.Bold = True
        End With
    Next i
End Sub

Private Sub OVBAde_ReadSubFolder(ByVal sPath As String, Optional nofolder As Boolean)
  Dim oFSO As Object
  Dim oFolder As Object
  Dim oSubFolder As Object
  Dim oFile As Object
    
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFolder = oFSO.getfolder(sPath)
    
    With oSheet
    
        If nofolder = False Then
        
        For Each oFile In oFolder.Files
         
                .Cells(lRowCounter, 1) = oFolder.Path
                .Cells(lRowCounter, 2) = oFile.Name
                lRowCounter = lRowCounter + 1
        
        Next
        
        End If
        
        For Each oSubFolder In oFolder.subfolders
            
            'Alle Dateien auflisten
            For Each oFile In oSubFolder.Files
                .Cells(lRowCounter, 1) = oSubFolder.Path
                .Cells(lRowCounter, 2) = oFile.Name
                lRowCounter = lRowCounter + 1
            Next oFile
            
            'Alle Unterverzeichnisse verarbeiten (rekursiv)
            Call OVBAde_ReadSubFolder(oSubFolder.Path, True)
        
        Next oSubFolder
    
    End With
    
    Set oFSO = Nothing
    Set oFile = Nothing
    Set oFolder = Nothing
    Set oSubFolder = Nothing
End Sub
Gruß Gerd


Anzeige
AW: Änderung
24.04.2023 13:51:04
Rosel
Hallo Gerd,

alles Super. "Läuft wie geschmiert", sagt man doch so! Deshalb nochmals vielen Dank für Deine Bemühungen.
Schade, dass Du mir bei den "Eigenschaften" nicht weiterhelfen kannst. Ich habe mich auch schon hier im Forum umgeschaut, aber da sind meine ich, ""Shell.Application" und hier ist es ja ein "Scripting.FileSystemObject". Und da gibt es halt Unterschiede mit dem "Code".
Vielleicht ist im Forum jemand da, wo sich da mit dieser Sache auskennt. Den Namen "Nepumuk" habe ich da oft gelesen, wenn es um solche Sachen wie "Eigenschaften" ging.
Also, nochmals vielen Dank.

Grüße von Rosel


Anzeige
AW: Änderung
24.04.2023 15:23:27
Yal
Hallo zusammen,

diese Coding von VBA-Online hat für meinen Geschmack zu viele leere Zeilen und zu viele Variablen. Ausserdem "Call" und "CreateObject" sind nicht mehr zeitgemäss, vor allem wenn man ausführlich vom den Objekte aus der Bibliothek verwenden möchte. Besser ist es, die Bibliothek anzubinden. Dann hat man die Bib im Objekt-Katalog und Intellisense zur Seite.

Aufgabe 1: Bibiothek anbinden: in VB-Editor, "Extras", "Verweis", runter bis "Micorsoft Scripting Runtime", anhaken.
Aufgabe 1: im Objekt-Katalog ("Ansicht", "Objekt-Katalog") auf die Bibliothek "Scripting" setzen und die Objekte der Bibliothek anschauen.
Aufgabe 2: im Schritt-Modus beim offenen Lokalfenster laufen lassen und die Objekt und Eigenschaft während des Laufs anschauen.

Hier werden die Objekte FileSystemObjekt, Folder, File und dessen Eigenschaften Path, Name, Size und DateLastModified Gebrauch gemacht

' ****************************************************************
' Autor/en und Original-Quelltext unter: https://www.online-vba.de/vba_readfolder.php

' Es gelten die Nutzungsbedingungen von https://www.online-vba.de

' stark modifiziert von Yal, Herber Forum
' Verwendung der Quelltexte auf eigene Gefahr!
' ****************************************************************
'unter Anbindung von "Microsoft Scripting Runtime" ("Extras", "Verweise...", einhaken)
'Start der Routine: OVBAde_DateienMitUnterordnernAuslesen

Private oSheet As Worksheet
Private oFSO As FileSystemObject

Public Sub OVBAde_DateienMitUnterordnernAuslesen()
Const sRootPath As String = "C:\TEST" 'Pfad bitte anpassen ohne Trennzeichen am Ende!!!
    
    Set oFSO = New FileSystemObject
    Set oSheet = Sheets.Add
        With oSheet.Range("A1:D1")
            .Value = Array("Pfad", "Dateiname", "Grösse", "Datum")
            .Interior.ColorIndex = 11
            .Font.Color = vbWhite
            .Font.Color = vbWhite
        End With
    End With
    OVBAde_ReadSubFolder oFSO.GetFolder(sRootPath)
End Sub

Private Sub OVBAde_ReadSubFolder(oFold As Folder)
Dim oSubFolder As Folder
Dim oFile As File
    
'Alle Dateien auflisten
    For Each oFile In oFold.Files
        With oSheet.Cells(Rows.Count, 1).End(xlUp)
            .Offset(1, 0) = oFold.Path
            .Offset(1, 1) = oFile.Name
            .Offset(1, 2) = oFile.Size
            .Offset(1, 3) = oFile.DateLastModified
        End With
    Next
'Alle Unterverzeichnisse verarbeiten (rekursiv)
    For Each oSubFolder In oFold.SubFolders
        OVBAde_ReadSubFolder oSubFolder
    Next oSubFolder
End Sub
VG
Yal


Anzeige
AW: Änderung
24.04.2023 16:03:26
Rosel
Hallo Yal,

schön, dass Du mir helfen willst. Aber das Problem ist ja dadurch immer noch vorhanden und zwar das mit den "Erweiterten Dateieigenschaften", die ich ja nur über eine "Ziffer" auslesen kann. Die normalen "Eigenschaften", die Du integriert hast, sind das kleinste Problem. Aber leider die nur über eine zugewiesene Zahl ermittelt werden können, machen unter Benützung von "Microsoft Scripting Runtime" so große Schwierigkeiten- Es wäre schön, wenn Du dafür eine Lösung finden würdest.

Grüße von Rosel

Hier habe ich mal "Code" von "https://stackoverflow.com/questions/47612821/get-extended-properties-from-files" gefunden. Vielleicht kannst Du damit was anfangen.

Set fso = CreateObject("scripting.filesystemobject")
Set obs = CreateObject("shell.application")
Set fol = fso.getfolder(".")
Set spl = obs.Namespace(fol.Path)
Set Files = fol.Files
filePath = fol.path&"\Info.txt"
Set objFile = fso.openTextFile(filePath, 2, True, True)

arr = Array("mp4", "mkv", "avi", "flv")

For Each file In Files
    ext = fso.GetExtensionName(file.Name)
    For Each ex In arr
        If StrComp(ext, ex, 1) = 0 Then
            objFile.writeline "NAME: "&spl.GetDetailsOf(spl.ParseName(file.Name),0)&vbcrlf&_
                              "SIZE: "&spl.GetDetailsOf(spl.ParseName(file.Name),1)&vbcrlf&_
                              "LENGTH: "&spl.GetDetailsOf(spl.ParseName(file.Name),27)&vbcrlf&_
                              "FRAME HEIGHT: "&spl.GetDetailsOf(spl.ParseName(file.Name),283)&vbcrlf&_
                              "FRAME WIDTH: "&spl.GetDetailsOf(spl.ParseName(file.Name),285)&vbcrlf&string(50,"==")
            Exit For
        End If
    Next

Next
objFile.Close
Set objFile = Nothing
Set Files = Nothing
Set spl = Nothing
Set fol = Nothing
Set obs = Nothing
Set fso = Nothing


Anzeige
AW: Änderung
24.04.2023 21:14:11
Yal
Hallo Rosel,

um an den "GetDetailsOf" ranzukommen, muss man den Folder über eine Shell.Application-Objekt instanzieren. Du hast wahrscheinlich in dem Objekt-Katalog von Scripting, dass der dort aufgelistete Folder-Objekt die Methode nicht besitzt. Somit kann sie nicht gerufen werden. Es muss eine andere Objekt-Definition her.

Folgender Code ist nicht getestet (ich habe keine Video-Datei)

'unter Anbindung von "Microsoft Scripting Runtime" ("Extras", "Verweise...", einhaken)
'Start der Routine: OVBAde_DateienMitUnterordnernAuslesen

Private oSheet As Worksheet
Private oFSO As FileSystemObject

Public Sub OVBAde_DateienMitUnterordnernAuslesen()
'Const sRootPath As String = "C:\TEST" 'Pfad bitte anpassen ohne Trennzeichen am Ende!!!
Const sRootPath As String = "C:\Temp"
    
    Set oFSO = New FileSystemObject
    Set oSheet = Sheets.Add
        With oSheet.Range("A1:D1")
            .Value = Array("Pfad", "Datum", "Dateiname", "Grösse", "Länge", "Fr_Höhe", "Fr_breite")
            .Interior.ColorIndex = 11
            .Font.Color = vbWhite
            .Font.Color = vbWhite
        End With
    End With
    OVBAde_ReadSubFolder oFSO.GetFolder(sRootPath)
End Sub

Private Sub OVBAde_ReadSubFolder(sPath As Folder)
Dim oSubFolder As Folder
Dim oFile As Scripting.File
Dim Details
    
'Alle Dateien auflisten
    For Each oFile In oFolder.Files
        With oSheet.Cells(Rows.Count, 1).End(xlUp)
            .Offset(1, 0) = oFolder.Path
            .Offset(1, 1) = oFile.DateLastModified
            Details = Array()
            Details = Details_auslesen(oFile)
            If UBound(Details) = 4 Then .Offset(1, 2).Resize(1, 5) = Details
        End With
    Next
'Alle Unterverzeichnisse verarbeiten (rekursiv)
    For Each oSubFolder In oFolder.subfolders
        OVBAde_ReadSubFolder oSubFolder
    Next oSubFolder
End Sub

Function Details_auslesen(Datei As File)
Dim ShApp As Object 'Shell-Objekt
Dim ShFolder As Object 'Folder-Objekt (nach Shell-App Muster, nicht nach FileSystemObject)
Dim ShFolderItem As Object 'Folder-Item, also Datei, nach Shell.GetItem
Const cExtListe = "mp4 mkv avi flv" 'Leerzeichen getrennt wg Split (Split splittet per Default auf Leerzeichen)

'keine Verarbeitung, wenn nicht in der Liste
    If Not InStr(1, cExtListe, oFSO.GetExtensionName(Datei.Name)) Then Exit Function
    
    Set ShApp = CreateObject("Shell.Application")
    Set ShFolder = ShApp.Namespace(Datei.ParentFolder.Path)
    Set ShFolderItem = ShFolder.ParseName(Datei.Name)
    ReDim Details_auslesen(4)
    Details_auslesen(0) = ShFolder.GetDetailsOf(ShFolderItem, 0) 'Name
    Details_auslesen(1) = ShFolder.GetDetailsOf(ShFolderItem, 1) 'Size
    Details_auslesen(2) = ShFolder.GetDetailsOf(ShFolderItem, 27) 'Length
    Details_auslesen(3) = ShFolder.GetDetailsOf(ShFolderItem, 283) 'Frame Height
    Details_auslesen(4) = ShFolder.GetDetailsOf(ShFolderItem, 285) 'Frame Width
End Function
VG
Yal


AW: Änderung
24.04.2023 21:40:04
Rosel
Hallo Yal,

es gibt ein Problem mit einem Lz Fehler "424" - Objekt erforderlich.
Hier bei " 'Alle Dateien auflisten For Each oFile In oFolder.Files" taucht der Fehler auf.

Grüße von Rosel


AW: Änderung
24.04.2023 22:08:40
Yal
Hmm... schlampig gearbeitet.

Ersetze den Sub-Überschrift in:
Private Sub OVBAde_ReadSubFolder(oFolder As Folder)
Siehst Du auch warum? (ich erwarte keine Antwort. Es ist aber trotzdem wichtig, dass Du dir die Frage stellst und nachgehst, sonst bleibst Du immer auf "s'funktioniert nicht und ich brauche jemand... ;-)

VG
Yal


AW: Änderung
24.04.2023 22:45:30
Rosel
Hallo Yal,

leider kommt die nächste Fehlermeldung "Fehler beim kompilieren - ReDim ungültig". Das Problem bei mir ist halt unzureichendes Englisch und als VBA Anfängerin fehlendes Wissen. Ich bin bestimmt nicht der Mensch, der gleich das Forum bemüht. Bei diesem Makro suche ich schon abwechselnd mehrere Tage nach der perfekten Lösung. Denn mein Ehrgeiz lässt mir da schon keine Ruhe, aber wie gesagt: Irgendwo ist die berühmte Grenze erreicht und dann ist halt Schluss mit lustig. Dann hoffe ich halt, dass mir ein "GutMensch" aus dem Forum weiter helfen kann bzw. wird.

Grüße von Rosel


AW: Änderung
24.04.2023 23:31:04
Yal
Habe noch eine Fehler in einen anderen Teil gefunden, daher noch den ganzen Code. Bitte komplett übernehmen, keine Mischung.

'unter Anbindung von "Microsoft Scripting Runtime" ("Extras", "Verweise...", einhaken)
'Start der Routine: OVBAde_DateienMitUnterordnernAuslesen

Private oSheet As Worksheet
Private oFSO As FileSystemObject

Public Sub OVBAde_DateienMitUnterordnernAuslesen()
'Const sRootPath As String = "C:\TEST" 'Pfad bitte anpassen ohne Trennzeichen am Ende!!!
Const sRootPath As String = "C:\Temp"
    
    Set oFSO = New FileSystemObject
    Set oSheet = Sheets.Add
    With oSheet.Range("A1:D1")
        .Value = Array("Pfad", "Datum", "Dateiname", "Grösse", "Länge", "Fr_Höhe", "Fr_breite")
        .Interior.ColorIndex = 11
        .Font.Color = vbWhite
        .Font.Color = vbWhite
    End With
    OVBAde_ReadSubFolder oFSO.GetFolder(sRootPath)
End Sub

Private Sub OVBAde_ReadSubFolder(oFolder As Folder)
Dim oSubFolder As Folder
Dim oFile As Scripting.File
Dim Details
    
'Alle Dateien auflisten
    For Each oFile In oFolder.Files
        With oSheet.Cells(Rows.Count, 1).End(xlUp)
            .Offset(1, 0) = oFolder.Path
            .Offset(1, 1) = oFile.DateLastModified
            Details = Array()
            Details = Details_auslesen(oFile)
            If UBound(Details) = 4 Then .Offset(1, 2).Resize(1, 5) = Details
        End With
    Next
'Alle Unterverzeichnisse verarbeiten (rekursiv)
    For Each oSubFolder In oFolder.subfolders
        OVBAde_ReadSubFolder oSubFolder
    Next oSubFolder
End Sub

Function Details_auslesen(Datei As File)
Dim ShApp As Object 'Shell-Objekt
Dim ShFolder As Object 'Folder-Objekt (nach Shell-App Muster, nicht nach FileSystemObject)
Dim ShFolderItem As Object 'Folder-Item, also Datei, nach Shell.GetItem
Dim Ergebnis(4) As String
Const cExtListe = "mp4 mkv avi flv" 'Leerzeichen getrennt wg Split (Split splittet per Default auf Leerzeichen)

'keine Verarbeitung, wenn nicht in der Liste
    If Not InStr(1, cExtListe, oFSO.GetExtensionName(Datei.Name)) Then Exit Function
    
    Set ShApp = CreateObject("Shell.Application")
    Set ShFolder = ShApp.Namespace(Datei.ParentFolder.Path)
    Set ShFolderItem = ShFolder.ParseName(Datei.Name)
    
    Ergebnis(0) = ShFolder.GetDetailsOf(ShFolderItem, 0) 'Name
    Ergebnis(1) = ShFolder.GetDetailsOf(ShFolderItem, 1) 'Size
    Ergebnis(2) = ShFolder.GetDetailsOf(ShFolderItem, 27) 'Length
    Ergebnis(3) = ShFolder.GetDetailsOf(ShFolderItem, 283) 'Frame Height
    Ergebnis(4) = ShFolder.GetDetailsOf(ShFolderItem, 285) 'Frame Width
    Details_auslesen = Ergebnis
End Function
VG
Yal


AW: Änderung
24.04.2023 23:53:22
Rosel
Hallo Yal,

die nächste Fehlermeldung "Lz Fehler 13 - Typen unverträglich" ist mit gekommen.

If UBound(Details) = 4 Then .Offset(1, 2).Resize(1, 5) = Details

Grüße von Rosel


AW: Änderung
25.04.2023 09:37:58
Yal
Also ehrlich gesagt fehlt es mir schwer, Dir ein Auto in der Hand zu geben, wenn Du noch nicht mal Fahrrad fahren kannst.
Verstehe mich nicht falsch, aber das Ziel ist eine punktuelle Unterstützung, nicht dass ich zum perönlichen Assistent werde.

Wenn Du niemand in deiner Nähe hast, der Dir die Basics von VBA beibringen kann, wird es schwierig, es aus der Ferne zu machen. Ich habe, wie gesagt, keine Dateien von dem gegebenen Typen zur Hand um den Code zu testen. Das sehe ich auch nicht als meine Aufgabe.

Versuche mit diesem Code:
If IsArray(Details) Then .Offset(1, 2).Resize(1, 5) = Details
VG
Yal


AW: Änderung
25.04.2023 11:45:53
Rosel
Guten Morgen Yal,

ich kann mir denken, dass Dich manche Forums Teilnehmer manchmal etwas nerven können. Aber was wären Wir "VBA Novizen" ohne Euere Hilfe und Geduld. Du - als "Profi" - hast ja auch so Deine Probleme mit diesem Project und was soll ich dann erst noch da verrichten können. Ich bin schon froh, wenn ich die einfacheren Sachen erledigen kann. Soviel dazu!!!
Nun zum Makro, die Fehlermeldung ist weg. Aber es werden nur diese beiden Eigenschaften angezeigt.

 With oSheet.Cells(Rows.Count, 1).End(xlUp)
            .Offset(1, 0) = oFolder.Path
            .Offset(1, 1) = oFile.DateLastModified
            Details = Array()
die anderen Eigenschaften werden nicht berücksichtigt.
Du kannst ja das auch auf Deinem PC bzw. Laptop testen, da brauchst Du deswegen keine Videos auf dem Rechner haben. Man kann ja hier "Const cExtListe = "mp4 xlsm avi flv" die Auswahl zum Auslesen belegen und schon hat man wenigstens die Möglichkeit zu sehen, ob das Makro diese "Eigenschaften" mit berücksichtigt oder nicht.
Es wäre jetzt auf jeden Fall natürlich schade, wenn Du kurz vor erreichen der Ziellinie aufgeben würdest.

Grüße von Rosel


AW: Änderung
25.04.2023 18:20:08
Yal
Hallo Rosel,

es ist mal so, dass diese Details nicht für alle Dateityp vorhanden sind. Frame height macht nur bei Video sinn.
unter https://dot-sharp.com/en/net-getdetailsof-en/
findest Du eine detailierte Liste der Eigenschaften. Es ist übrigens 293 & 295 und nicht 283 & 285. Wer gut googeln kann (und auch Englisch), ist nartürlich in Vorteil.

Dieser Code funktioniert bei mir: 
'unter Anbindung von "Microsoft Scripting Runtime" ("Extras", "Verweise...", einhaken)
'Start der Routine: OVBAde_DateienMitUnterordnernAuslesen

Private oSheet As Worksheet
Private oFSO As FileSystemObject

Public Sub OVBAde_DateienMitUnterordnernAuslesen()
Const sRootPath As String = "C:\TEST" 'Pfad bitte anpassen ohne Trennzeichen am Ende!!!
    
    Set oFSO = New FileSystemObject
    Set oSheet = Sheets.Add
    With oSheet.Range("A1:G1")
        .Value = Array("Pfad", "Datum", "Dateiname", "Grösse", "Länge", "Fr_Höhe", "Fr_breite")
        .Interior.ColorIndex = 11
        .Font.Color = vbWhite
        .Font.Bold = True
    End With
    OVBAde_ReadSubFolder oFSO.GetFolder(sRootPath)
End Sub

Private Sub OVBAde_ReadSubFolder(oFolder As Folder)
Dim oSubFolder As Folder
Dim oFile As Scripting.File
Dim Details
    
'Alle Dateien auflisten
    For Each oFile In oFolder.Files
        With oSheet.Cells(Rows.Count, 1).End(xlUp)
            .Offset(1, 0) = oFolder.Path
            .Offset(1, 1) = oFile.DateLastModified
            .Offset(1, 2) = oFile.Name 'wird, falls vorhanden, von Details überschrieben
            .Offset(1, 3) = oFile.Size 'dito
            Details = Array()
            Details = Details_auslesen(oFile)
            If IsArray(Details) Then .Offset(1, 2).Resize(1, 5) = Details
        End With
    Next
'Alle Unterverzeichnisse verarbeiten (rekursiv)
    For Each oSubFolder In oFolder.subfolders
        OVBAde_ReadSubFolder oSubFolder
    Next oSubFolder
End Sub

Function Details_auslesen(Datei As File)
Dim ShApp As Object 'Shell-Objekt
Dim ShFolder As Object 'Folder-Objekt (nach Shell-App Muster, nicht nach FileSystemObject)
Dim ShFolderItem As Object 'Folder-Item, also Datei, nach Shell.GetItem
Dim Ergebnis(4) As String
Dim T
Const cExtListe = "mp4 mkv avi flv" 'Leerzeichen getrennt wg Split (Split splittet per Default auf Leerzeichen)

'keine Verarbeitung, wenn nicht in der Liste
    If InStr(1, cExtListe, oFSO.GetExtensionName(Datei.Name)) = 0 Then Exit Function
    
    Set ShApp = CreateObject("Shell.Application")
    Set ShFolder = ShApp.Namespace(Datei.ParentFolder.Path)
    Set ShFolderItem = ShFolder.ParseName(Datei.Name)
'Details on GetDetailsOf in https://dot-sharp.com/en/net-getdetailsof-en/

    Ergebnis(0) = ShFolder.GetDetailsOf(ShFolderItem, 0) 'Name
    Ergebnis(1) = ShFolder.GetDetailsOf(ShFolderItem, 1) 'Size
    Ergebnis(2) = ShFolder.GetDetailsOf(ShFolderItem, 27) 'Length
    Ergebnis(3) = ShFolder.GetDetailsOf(ShFolderItem, 293) 'Frame Height
    Ergebnis(4) = ShFolder.GetDetailsOf(ShFolderItem, 295) 'Frame Width
    Details_auslesen = Ergebnis
End Function
Yal


AW: Änderung
25.04.2023 22:31:22
Rosel
Hallo Yal,

die "Kuh ist vom Eis"! Es ist vollbracht, war auch eine schwere Geburt mit diesen "Eigenschaften". Habe jetzt mal ein paar Test gemacht und es ist soweit ich es auf die Schnelle überprüfen konnte, alles oK. Das was noch ansteht und ich aber selber machen kann, sind die Verschiebungen und Ergänzungen der Eigenschaften, Spaltenbreite etc. Dazu reichen meine Kenntnisse mittlerweile in VBA aus.
Übrigens war ich die ganze Zeit über auch nicht untätig und habe mich auch schlau gemacht. Hier im Forum gibt es auch Makros, die die kompletten "Dateieigenschaften auslesen können. Insgesamt sind es momentan 320 Eigenschaften. Wobei wiederum - da kann ich Dir noch was beibringen - diese Eigenschaften von PC / Laptop unterschiedlich sein können. Bei mir sind es bei der Bildweite die 316 und Bildhöhe die 314. Aber trotz allem sage ich Dir recht herzlich Danke für Deine Hilfe und Geduld.

Grüße von Rosel


AW: Änderung
25.04.2023 18:20:29
Firmus
Hallo Rosel,

erst einmal allgemein: Die Dateiattribute sind eine Geschichte für sich.
1. die ganz alten (Dateiname, Erstellt, Geändert, ......)
sind auslesbar wie du es bisher versucht hattest.
Das war die Welt von TXT, GIF, DOC,....
Zu finden sind sie m.E. in der MFT (Masterfiletable) und zu sehen über den Explorer
2. neuere Attribute kamen über die Zeit, und neue Speicherplätze dafür und Methoden zum Auslesen.
Gespeichert sind sie als META-Daten innerhalb jeder Datei.
Auszulesen sind sie mit GetDetailsOf .....
3. Die Foto- und Videowelt hat sich dies zunutze gemacht und fast alle Foto- bzw. Video-Metadaten dort reingepackt.
Die einzelnen Attribute sind nummeriert.
Auszulesen sind sie mit GetDetailsOf .....
Leicht irreführend ist, dass die alten Attribute über diese Methode auch ausgelesen werden können.
4. Seit es Fotos mit GPS-Daten gibt, sind auch diese als Meta-Daten in jeder Datei hinterlegt,
und werden über eine weitere Methode (WIA) ausgelesen.

Und eingehend auf deinen/Yals Code:

Die getestete Version ist hier: https://www.herber.de/bbs/user/158887.xlsm

Folgende Aspekte führten zu Korrekturen:

1. Überschriften gehen von Spalte A bis G, nicht von A bis D, korrigiert

2. Details = Array() wird gesetzt, damit hat Details keine Elemente mehr
Wenn dann als nächste Datei KEINE Datei lt. Filter "mp4 mkv avi flv" gelesen wird,
existiert für das array Details kein Index, Ergebnis: Laufzeitfehler 13
Lösung: eigene Error-Routine einsetzen und an exakt dieser Stelle diesen
Fehler ignorieren.

3. Es wird für jede gefundene Datei eine Zeile ausgegeben, selbst wenn diese Datei
durch den Filter fällt, z. B. pdf xlsx docx ....
Ich sehe das nicht als Fehler, sondern "it works as designed"

4. If Not InStr(1, cExtListe, oFSO.GetExtensionName(Datei.Name)) Then Exit Function
Diese Zeile hat nicht gefiltert auf die vier Endungen. Die Ursache konnte ich nicht erkennen.
Deshalb habe ich das NOT entfernt und anstelle dessen die Treffer abgefragt und im IF-Zweig verarbeitet.
Der Filter wird jetzt richtig angewandt. MP4 und AVI habe ich explizit getestet.

Gruß,
Firmus


AW: Änderung
25.04.2023 23:20:29
Rosel
Hallo Firmus,

war ganz erstaunt, dass sich noch ein "Forumer" an dieser "Geburt" beteiligt. Deinen Ausführungen nach, habe ich doch vieles etwas besser verstanden, als vorher. Aber trotzdem muss ich noch viel lernen, bis ich mal so weit bin. Ja, Dein Makro ist natürlich genau so wie das von "Yal", hat aber wieder andere Vorteile. Wichtig ist für mich natürlich, dass sie das machen, für das ich sie gebrauche. Nämlich zum Dateien auslesen. Wenn das Makro jetzt noch die LZ Fehler 13 Meldung abfangen könnte, wäre das schön. Vielleicht hast Du da eine Idee wie man das kurz und schmerzlos noch einbauen könnte.
Vielen Dank trotzdem schon mal.

Grüße von Rosel


AW: Änderung
26.04.2023 09:15:01
Yal
Hallo Rosel,

aber gern lasse ich mir was beibringen. Es ist nur so, dass ich nicht mehr "auf Vorrat" lerne, sondern nur noch "nach Bedarf" oder Neugierigkeit. Ich hatte bisher keine Ahnung vom GetDetailsOf und deswegen war es eine Belustigung, sich daran einzuarbeiten. Aber es wiederbrauchen werde ich vermutlich nie.

@Firmus:
alle Fehler richtig erkannt. Unseren Post haben sich überschneiden. Meine letzte Version beseitigt alle erwähnte Punkten.

Laufzeit Fehler 13 sollte inzwischen mit "If IsArray(Details) Then" beseitigt sein. Ein fehlertolerante Handlung ist hier nicht zwingend. Man hätte bei nicht treffende Extension eine Dummy-Array (UBound ist dann -1) als Rückgabewert geben können. Also die Verlagerung der "Details = Array()" in die Function "Details_auslesen".

"If Not InStr (..." InStr liefert nicht direkt einen boolsche Wert (True/False) sondern Zahl. Das "Not" von 17 (entspricht als Boolean reduziert True) ist daher -18 (entspricht auch True). Daher ist die Lösung die Null-Gleichheit zu prüfen: gleich null heisst nicht vorhanden.

VG
Yal


AW: Änderung
26.04.2023 09:56:39
Rosel
Hallo Yal,

meine Antwort war auch nicht bös gemeint! Ich wollte nur noch mal zum Ausdruck bringen, dass auch ein "Profi" nicht alles wissen kann. "Gerd" hat da gleich gesagt, dass er da raus ist und der kann vieles. Ich habe kaum Grundkenntnisse in VBA und da fällt es einem schon schwer, gewisse Sachen zu verstehen um es auch nach vollziehen zu können. Aber Gott sei Dank gibt es das "Herber Forum" und da wird dir ja geholfen. Trotzdem noch mal vielen Dank und vielleicht bis zum nächsten Problem.

Grüße von Rosel


AW: Änderung
26.04.2023 13:12:03
Yal
:-) ich habe auch nicht gemeint, dass ich es böse angenommen hätte. Ich gebe aber zu, dass ich amüsiert-sarkastisch gestimmt war.

Auf Grund der vielen verschiedenen Definitionen der Datei-Eigenschaften ist es mir unklar, ob es überhaupt eine zentrale Definition gibt, oder je nach Dateityp zu begutachten. Im Stackoverflow-Beitrag war die Rede von 283, ich habe iwo anders 293 gesehen, jetzt stellst Du fest, dass die Info in 317 zu haben sei.
Dementsprechend nehme ich als Wissen heraus, dass hier stets zu prüfen ist, dass man tatsächlich bekommt, was man sich erhofft.

Und genau an der Stelle war das Anliegen meines Kommentars: über GetDetailsOf habe ich was gelernt, was ich bisher nicht kannte. Hätte es den Reiz des Unbekannten nicht gegeben, hätte ich vermutlich nicht recherchiert. Aber welche Nummer für was stehen, das werde ich in 2 Tage vergessen haben. Solche Wissen ist nicht stabil oder ausschlaggebend genug, dass ich es mir merken müsste.
Und dementsprechend habe ich erlaubt zu schmunzeln, dass das eine grosse Entdeckung sei. Bitte verzeihe meine Frechheit ;-)

VG
Yal

Links zu Excel-Dialogen

Frame

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige