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
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
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
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
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
Hallo Karlheinz,
das ist doch beim NameSpace, der keinen Spaß macht?
Hallo schauan,
leider verstehe ich das nicht. Was bedeutet das? Ist das so ein Insider-Witz?
Trotzdem Danke
Gruß Karlheinz
Hallöchen,
anders gesagt - wo kommt der Fehler?
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
Hallo schauan,
jetzt kommt
Laufzeitfehler '91':
Objektvariable oder With-Blockvariable nicht festgelegt
Was habe ich falsch gemacht?
Gruß
Karlheinz