Inlezen afmetingen van JPG bestand

[1107972]

Hallo,

Ik ben bezig om een macro te maken waarmee je de afbeelding kan vervangen in een excel bestand. In principe lukt alles maar wil nog een extra controle uitvoeren waarbij de afmetingen van de afbeeldingen moeten voldoen aan een bepaald formaat (bijvoorbeeld 120 x 120 pixels). Als deze voldoet mag de afbeelding pas ingevoegd/vervangen worden.

Ik heb al de locatie van de afbeelding (sPath_Image) en je mag er vanuit gaan dat deze correct is. Het betreft altijd een JPG formaat.

Is er een functions of iets dergelijks om de originele afmetingen van de afbeeldingen uit te lezen zonder dat je deze hoeft te openen of in te voegen.

Wat ik tot nu toe heb kunnen vinden is alleen maar het ophalen van informatie over de bestandsgrootte van de afbeelding.

Alvast bedankt

Grt Eric

 

[Warme bakkertje]

Option Explicit
 
Type ImageSize
 Width As Long
 Height As Long
 End Type
 
Sub test()
 Dim vPic As Variant
 Dim sPicFile As String
 Dim uSize As ImageSize
 
vPic = Application.GetOpenFilename("Jpg images (*.jpg), *.jpg")
 If vPic = False Then Exit Sub
 sPicFile = CStr(vPic)
 If Dir(sPicFile) <> "" Then
 uSize = GetImageSize(sPicFile)
 MsgBox uSize.Width & " * " & uSize.Height
 End If
 End Sub
 
Function GetImageSize(ByVal sFileName As String) As ImageSize
 On Error Resume Next
 Dim iFN As Integer
 Dim bTemp(3) As Byte
 Dim lFlen As Long
 Dim lPos As Long
 Dim bHmsb As Byte
 Dim bHlsb As Byte
 Dim bWmsb As Byte
 Dim bWlsb As Byte
 Dim bBuf(7) As Byte
 Dim bDone As Byte
 Dim iCount As Integer
 
lFlen = FileLen(sFileName)
 iFN = FreeFile
 Open sFileName For Binary As iFN
 Get #iFN, 1, bTemp()
 
If bTemp(0) = &HFF And bTemp(1) = &HD8 And bTemp(2) = &HFF Then
 'Debug.print "JPEG"
 lPos = 3
 Do
 Do
 Get #iFN, lPos, bBuf(1)
 Get #iFN, lPos + 1, bBuf(2)
 lPos = lPos + 1
 Loop Until (bBuf(1) = &HFF And bBuf(2) <> &HFF) Or lPos > lFlen
 
For iCount = 0 To 7
 Get #iFN, lPos + iCount, bBuf(iCount)
 Next iCount
 If bBuf(0) >= &HC0 And bBuf(0) <= &HC3 Then
 bHmsb = bBuf(4)
 bHlsb = bBuf(5)
 bWmsb = bBuf(6)
 bWlsb = bBuf(7)
 bDone = 1
 Else
 lPos = lPos + (CombineBytes(bBuf(2), bBuf(1))) + 1
 End If
 Loop While lPos < lFlen And bDone = 0
 GetImageSize.Width = CombineBytes(bWlsb, bWmsb)
 GetImageSize.Height = CombineBytes(bHlsb, bHmsb)
 End If
 Close iFN
 End Function
 
Private Function CombineBytes(lsb As Byte, msb As Byte) As Long
 CombineBytes = CLng(lsb + (msb * 256))
 End Function

 

[1107972]

Heb hem even snel bekeken en het lijkt op wat ik zoek. Ga er van het weekend eens mee aan de slag. Ik hou u op de hoogte.

Thanks.

 

[snb]

Hiervoor gebruik ik:

sub pixels_snb()
   For Each it In CreateObject("shell.application").Namespace("G:\afbeeldingen").Items
    If it.Name = "afbeeling_2.jpg" Then
        c01 = it.Parent.getdetailsof(it, 26)
        Exit For
    End If
   Next

   msgbox c01
end sub

 

[1107972]

Ik heb ermee gespeeld en heb de macro van Warme Bakkertje gebruikt. Die gaf mij het beste resultaat.

Thanks voor de hulp.

Groeten Eric

 

[snb]

Hoezo ?

 

[1107972]

Bij jou macro kwam er niet gelijk een goede uitkomst uit. Zal wel aan mijn kopieer vaardigheden liggen. Daarnaast moet ik bij de jouwe de link en de naam van het bestand appart invoeren. Terwijl in mijn situatie het één waarde is. Dit komt dus beter overeen met die van de Warme Bakker.

Toch bedankt voor je reactie.