Dimensioner på billeder

Den her finder højde og bredde på en billed fil. Så ka du jo selv putte den i en fil.

Dim P As IPictureDisp

Set P = LoadPicture("C:\MatchboxMand.bmp")
Debug.Print Int(P.Width / 26.4583) & "x" & Int(P.Height / 26.4583)

Tak for super indlæg. Hvis jeg f.eks. har filstierne i et regneark i en laaang række A, kan jeg så på en eller anden måde få Width i B og Height i C?

sådan skal din import kode se ud

Sub ListFiles(Directory As String, SubDir As Boolean)
    Dim r As Long, i As Long
    Dim P As IPictureDisp
    If Directory = "" Then Exit Sub
    If Right(Directory, 1) <> "\" Then Directory = Directory & "\"

    '  Insert headers
    r = 1
    Cells.ClearContents
    Cells(r, 1) = "FileName"
    Cells(r, 2) = "Size"
    Cells(r, 3) = "Date/Time"
    Cells(r, 4) = "Bredde/Højde"
    Range("A1:C1").Font.Bold = True
    r = r + 1

    On Error Resume Next
    With Application.FileSearch
        .NewSearch
        .LookIn = Directory
        .Filename = "*.*"
        .SearchSubFolders = SubDir
        .Execute
        For i = 1 To .FoundFiles.Count
            Cells(r, 1) = .FoundFiles(i)
            Cells(r, 2) = FileLen(.FoundFiles(i))
            Cells(r, 3) = FileDateTime(.FoundFiles(i))
            Set P = LoadPicture(.FoundFiles(i))
            Cells(r, 4) = Int(P.Width / 26.4583) & "x" & Int(P.Height / 26.4583)
            r = r + 1
        Next i
    End With
End Sub

Sejt, det virker super duper. Læg et svar

point til shy, ikke til mig ;-))

Sub ListFiles(Directory As String, SubDir As Boolean)
    Dim r As Long, i As Long
    Dim P As IPictureDisp
    If Directory = "" Then Exit Sub
    If Right(Directory, 1) <> "\" Then Directory = Directory & "\"

    '  Insert headers
    r = 1
    Cells.ClearContents
    Cells(r, 1) = "FileName"
    Cells(r, 2) = "Size"
    Cells(r, 3) = "Date/Time"
    Cells(r, 4) = "Bredde/Højde"
    Range("A1:C1").Font.Bold = True
    r = r + 1

    On Error Resume Next
    With Application.FileSearch
        .NewSearch
        .LookIn = Directory
        .Filename = "*.*"
        .SearchSubFolders = SubDir
        .Execute
        For i = 1 To .FoundFiles.Count
            Cells(r, 1) = .FoundFiles(i)
            Cells(r, 2) = FileLen(.FoundFiles(i))
            Cells(r, 3) = FileDateTime(.FoundFiles(i))
            Set P = LoadPicture(.FoundFiles(i))
            Cells(r, 4) = Int(P.Width / 26.4583) & "x" & Int(P.Height / 26.4583)
            r = r + 1
    Set P = Nothing ' skal vist lige med
        Next i
    End With
End Sub

ja, shy fandt i grove træk løsningen, så han har fortjent pointene, men kabbak, du er jo en genial mand, har efterhånden fået en masse super svar fra dig, der virkeligt har påvirket mit job, firma og stilling og løn...så 1.000.000 tak til dig

tak for rosen

kabbak skal vel have en del af din lønforhøjelse, så?

...der er mange brugere af eksperten, der skal putte i den pulje :-)

shy, lægger du et svar?

lukker spm.