Breite und Höhe von Bildern

[Karlheinz16]

Hallo Exceler, ich lese mit folgendem VBA den Ordner mit Bildern aus. Das funktioniert wunderbar. Aber, so wie immer, wenn es dem Esel zu gut geht, geht er aufs Eis. Ich möchte gerne diesen Code erweitern. Und zwar sollte er noch die Pixel der Bilder anzeigen. Ist das überhaupt möglich?

Code:

Sub DateienKalmi300()

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

With Worksheets("Kalmi300")
    Sheets("Kalmi300").Select
ActiveSheet.Unprotect

Range("A4:A5000").ClearContents
    Range("A2").Select
   
Set objFileSystem = CreateObject("scripting.FileSystemObject")
Set objVerzeichnis = objFileSystem.getfolder("F:\Pictures\Kalmi\Bilder\300x300\")
Set objDateienliste = objVerzeichnis.Files

lngZeile = 4

For Each objDatei In objDateienliste
    If Not objDatei Is Nothing And Right(LCase(objDatei.Name), 4) = ".jpg" Then
          ActiveSheet.Cells(lngZeile, 1) = objDatei.Name
          lngZeile = lngZeile + 1
     End If

Next objDatei
End With
ActiveSheet.Protect

End Sub

Vielen Dank für eure Hilfe

Gruß

Karlheinz

[volti]

Hallo Karlheinz,

schau mal, ob Dich dies weiterbringt...

Code:

Sub Test()
  Debug.Print GetDetails("D:\Pictures\Fotos\2008\Urlaub\Kroatien\", "Kroatien_2008.jpg")
End Sub

Function GetDetails(sPath As String, sFile As String)
  With CreateObject("Shell.Application").Namespace(CVar(sPath))
       GetDetails = .GetDetailsOf(sFile, 31) & " " & .GetDetailsOf(.ParseName(sFile), 31)
  End With

End Function

_________
viele Grüße
Karl-Heinz

[Karlheinz16]

Hallo Karl-Heinz, vielen Dank für deinen Versuch mir zu helfen. Wenn ich das richtig sehe, dann ist das für "1" Bild, ich stelle mir aber das etwas anders vor. So zum Beispiel:

Bild:      Breite: Höhe:
IMG_1     300    247
IMG_2   1500    900
IMG_3     147    315

Also eine Auflistung sämtlicher Bilder mit den dazu gehörigen Abmessungen.

Trotzdem, vielen Dank für deinen Versuch.

Gruß

Karlheinz

[volti]

Hallo Karlheinz,

hier noch ein Versuch. Leider ungetestet, da ich weder eine Testdatei noch den Testordner mit Bildern habe.
Aber vielleicht hilft es Dir trotzdem.

Tipp: Die WITH-Klausel kann entfallen, da Du da ja gar nicht drauf referenzierst. Dazu müsstest Du jeweils einen Punkt vor die betreffenden Befehle setzen. (.Cells...)
Da Du das Blatt ja selektiert hast, ist es aber ohnehin immer das ActiveSheet.......

Code:

Sub DateienKalmi300()

  Dim lngZeile As Long
  Dim objFileSystem As Object
  Dim objVerzeichnis As Object
  Dim objDateienliste As Object
  Dim objDatei As Object
  Dim sArr() As String
  
  Sheets("Kalmi300").Select
  ActiveSheet.Unprotect

  Range("A4:A5000").ClearContents
  Range("A2").Select
  
  Set objFileSystem = CreateObject("scripting.FileSystemObject")
  Set objVerzeichnis = objFileSystem.GetFolder("F:\Pictures\Kalmi\Bilder\300x300\")
  Set objDateienliste = objVerzeichnis.Files

  lngZeile = 4

  For Each objDatei In objDateienliste
      If Not objDatei Is Nothing And Right(LCase(objDatei.Name), 4) = ".jpg" Then
        
         Cells(lngZeile, 1).Value = objDatei.Name
         With CreateObject("Shell.Application").Namespace(CVar(objDatei.Path))
              sArr = Split(.GetDetailsOf(.ParseName(objDatei.Name), 31), " x ")
         End With
         Cells(lngZeile, 2).Value = Mid$(sArr(0), 2)
         Cells(lngZeile, 3).Value = Left$(sArr(1), Len(sArr(1)) - 1)
        
         lngZeile = lngZeile + 1
      End If
  Next objDatei
  ActiveSheet.Protect

End Sub

_________
viele Grüße
Karl-Heinz

[Karlheinz16]

Hallo Karl-Heinz,
leider läuft der Code nicht. Es kommt folgende Fehlermeldung:

Laufzeitfehler '-2147467259(80004005)
Automatisierungsfehler
Unbekannter Fehler

Keine Ahnung, was das bedeuten soll.

Gruß

Karlheinz

[schauan]

Hallo Karlheinz,

das ist doch beim NameSpace, der keinen Spaß macht?

[Karlheinz16]

Hallo schauan,
leider verstehe ich das nicht. Was bedeutet das? Ist das so ein Insider-Witz?

Trotzdem Danke

Gruß Karlheinz

[schauan]

Hallöchen,

anders gesagt - wo kommt der Fehler?

[schauan]

Hallöchen,

hier mal noch was, wo es mit dem NameSpace klappt - wie gesagt, falls dass die Klemmstelle war. Der Code kommt ohne das FileSystemObjekt aus.
Ich hab die Size nicht extra gesplittet, und du müsstest sicher noch den Blattnamen anpassen (statt der 1) und ggf. auch nicht das ganze Blatt leeren...

Code:

Public Sub ExtractImageSize()
    Dim varPath, varFileName
    Dim objShell As Object, objFolder As Object
    Dim lngZeile  As Integer
    
    'Pfad festlegen
    varPath = "C:\Test\"
    'Blatt 1 aktivieren
    Worksheets(1).Activate
    'komplettes Blatt 1 leeren
    Cells.ClearContents
    'Objekte instanzieren
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.Namespace(varPath)
    
    'Schleife ueber alle Items des Ordners
    For Each varFileName In objFolder.Items
      Debug.Print varFileName.isfolder 'Zeile kann weg ...
      'Wenn .jpg im Filename enthalten ist, dann
      'Hinweis: ein Schelm, der .jpg irgendwo anders hat als am Ende :-)
      If InStr(1, varFileName, ".jpg") Then
        'Zeilenzaehler hochsetzen (Start hier bei Zeile 1, ansonsten vor der Schleife einen Startwert -1 programmieren)
        lngZeile = lngZeile + 1
        'Filename in Spalte A ausgeben
        Cells(lngZeile, 1) = varFileName.Name
        'Size in Spalte B ausgeben
        Cells(lngZeile, 2) = objFolder.GetDetailsOf(varFileName, 31)
      'Ende Wenn .jpg im Filename enthalten ist, dann
      End If
    'Ende Schleife ueber alle Items des Ordners
    Next
End Sub

[Karlheinz16]

Hallo schauan, 
jetzt kommt 

Laufzeitfehler '91':
Objektvariable oder With-Blockvariable nicht festgelegt

Was habe ich falsch gemacht?

Gruß

Karlheinz