So, habs noch hinbekommen:
Dieses Script läuft jetzt zwar minimal langsamer (weil es das komplette Bild und nicht nur die ersten 32 k einliest),
aber dafür kann es auch bei den hier angehängten Dateien die Info auslesen.
Das schafft es, indem es das bild über ein Array verteilt...
Hier also der Quellcode:
Function GetImageProperties(ImageFileName As String)
Dim filename As String
Dim idx As Integer, idy As Integer
Dim xPos As Integer, yPos As Integer
Dim xPos2 As Integer, yPos2 As Integer
filename = ImageFileName
' Set all properties to default values
m_Width = 0
m_Height = 0
m_Depth = 0
m_ImageType = itUNKNOWN
' Read 32k of the image file into a buffer
' NB - this is a LotusScript limitation and 32K may not be enough
' to read a JPEG's image data but it probably will.
' Erweiterung: Ab sofort werden JE 32k in ein Array geladen, um auch grössere JPGs bearbeiten zu können
Redim bBuf(BUFFERSIZE,0)
lpos = 0
iFN = Freefile
Open FileName For Binary As iFN
idx = 0
idy = 0
Do While Not Eof( iFN ) And idy <= BUFFERSIZE
If idx > BUFFERSIZE Then
idx = 0
idy = idy + 1
Redim Preserve bBuf( BUFFERSIZE,idy )
End If
bBuf(idx,idy) = Asc(Inputb( 1 , ifn ))
idx = idx + 1
Loop
Close iFn
If bBuf(0,0) = 127 And bBuf(1,0) = 80 And bBuf(2,0) = 78 Then
m_ImageType = itPNG ' this is a PNG file
ImageType = "PNG"
Select Case bBuf(25,0) ' get bit depth
Case 0
m_Depth = bBuf(24,0) ' greyscale
Case 2
m_Depth = bBuf(24,0) * 3 ' RGB encoded
Case 3
m_Depth = 8 ' Palette based, 8 bpp
Case 4
m_Depth = bBuf(24,0) * 2 ' greyscale with alpha
Case 6
m_Depth = bBuf(24,0) * 4 ' RGB encoded with alpha
' This value is outside of it's normal range, so we'll assume that this is not a valid file
Case Else
m_ImageType = itUNKNOWN
End Select
If m_ImageType Then ' if the image is valid then
m_Width = Mult(bBuf(19,0), bBuf(18,0)) ' get the width
m_Height = Mult(bBuf(23,0), bBuf(22,0)) ' get the height
End If
End If
If bBuf(0,0) = 71 And bBuf(1,0) = 73 And bBuf(2,0) = 70 Then ' this is a GIF file
m_ImageType = itGIF
ImageType = "GIF"
m_Width = Mult(bBuf(6,0), bBuf(7,0)) ' get the width
m_Height = Mult(bBuf(8,0), bBuf(9,0)) ' get the height
m_Depth = (bBuf(10,0) And 7) + 1 ' get bit depth
End If
If bBuf(0,0) = 66 And bBuf(1,0) = 77 Then ' this is a BMP file
m_ImageType = itBMP
ImageType = "BMP"
m_Width = Mult(bBuf(18,0), bBuf(19,0)) ' get the width
m_Height = Mult(bBuf(22,0), bBuf(23,0)) ' get the height
m_Depth = bBuf(28,0) ' get bit depth
End If
If m_ImageType = itUNKNOWN Then ' if the file is not one of the above type then check to see if it is a JPEG file
Do
' loop through looking for the byte sequence FF,D8,FF which marks the begining of a JPEG file
' lPos will be left at the postion of the start
' da diese Zeichen laut JPG- Standard IMMER an den drei ersten Stellen stehen, interessiert uns die Begrenzung hier nicht
If (bBuf(lPos,0) = &HFF And bBuf(lPos + 1,0) = &HD8 And bBuf(lPos + 2,0) = &HFF) _
Or (lPos >= BUFFERSIZE - 10) Then Exit Do
' move our pointer up
lPos = lPos + 1
Loop
lPos = lPos + 2
If lPos >= ( Cdbl( BUFFERSIZE ) * Cdbl( BUFFERSIZE ) ) - 10 Then Exit Function
Do
' loop through the markers until we find the one starting with FF,C0 which is the block containing the
' image information
Do
' loop until we find the beginning of the next marker
yPos = lPos \ BUFFERSIZE
xPos = lPos Mod BUFFERSIZE
If bBuf( xPos , yPos ) = &HFF Then
yPos = (lPos + 1) \ BUFFERSIZE
xPos = (lPos + 1) Mod BUFFERSIZE
If bBuf( xPos, yPos ) <> &HFF Then Exit Do
End If
lPos = lPos + 1
If lPos >= ( Cdbl( BUFFERSIZE ) * Cdbl( BUFFERSIZE ) ) - 10 Then Exit Function
Loop
' move pointer up
lPos = lPos + 1
yPos = lPos \ BUFFERSIZE
xPos = lPos Mod BUFFERSIZE
Select Case bBuf(xPos, yPos)
Case &HC0 To &HC3, &HC5 To &HC7, &HC9 To &HCB, &HCD To &HCF
' we found the right block
Exit Do
End Select
yPos = ( lPos + 2 ) \ BUFFERSIZE
xPos = ( lPos + 2 ) Mod BUFFERSIZE
yPos2 = ( lPos + 1 ) \ BUFFERSIZE
xPos2 = ( lPos + 1 ) Mod BUFFERSIZE
lPos = lPos + Mult(bBuf(xPos, yPos), bBuf(xPos2,yPos2)) ' otherwise keep looking
If lPos >= ( Cdbl( BUFFERSIZE ) * Cdbl( BUFFERSIZE ) ) - 10 Then Exit Function
Loop
' If we've gotten this far it is a JPEG and we are ready to grab the information.
m_ImageType = itJPEG
ImageType = "JPEG"
yPos = ( lPos + 5 ) \ BUFFERSIZE
xPos = ( lPos + 5 ) Mod BUFFERSIZE
yPos2 = ( lPos + 4 ) \ BUFFERSIZE
xPos2 = ( lPos + 4 ) Mod BUFFERSIZE
m_Height = Mult(bBuf(xPos,yPos), bBuf(xPos2,yPos2)) ' get the height
yPos = ( lPos + 7 ) \ BUFFERSIZE
xPos = ( lPos + 7 ) Mod BUFFERSIZE
yPos2 = ( lPos + 6 ) \ BUFFERSIZE
xPos2 = ( lPos + 6 ) Mod BUFFERSIZE
m_Width = Mult(bBuf(xPos,yPos), bBuf(xPos2,yPos2)) ' get the width
yPos = ( lPos + 8 ) \ BUFFERSIZE
xPos = ( lPos + 8 ) Mod BUFFERSIZE
m_Depth = Mult(bBuf(xPos,yPos), bBuf(xPos2,yPos2)) * 8 ' get the color depth
End If
'GetImageProperties = ImageType+","+Cstr(m_height)+"," & Cstr(m_width)+"," & Cstr(m_depth)
ImageProps(0) = ImageType
ImageProps(1) = Cstr(m_height)
ImageProps(2) = Cstr(m_width)
ImageProps(3) = Cstr(m_depth)
getimageproperties = ImageProps
End Function
Hoffe, das hilft jemandem...
Tode
Thema: Bildimport scheitert an manchen JPG Dateien (Gelesen 5681 mal)