Hi
Hab dieses Bild Import Script das hier im Forum so rumlungert mal eingebaut. Es funktioniert im großen und ganzen auch. Nur bei JPG Dateien von manchen Digitalkameras gibts einen Fehler. Wenn ich diese JPG Dateien dann in paint öffne und nochmals als JPG abspeichere klappt es auf einmal. Woran kann das liegen. Hab die Suche schon benutzt, aber nichts gefunden. Google half auch nicht weiter
hier nochmal der Code:
Sub Click(Source As Button)
Dim session As New NotesSession
Dim db As NotesDatabase
Dim pdoc As NotesDocument
Dim workspace As New NotesUIWorkspace
Dim uidoc As NotesUIDocument
Dim doc As NotesDocument
Dim rtitem As NotesRichTextItem
Dim object As NotesEmbeddedObject
Dim Filename As String
Dim fileth As String
Dim ImageType As String
Dim ImageHeight As String
Dim ImageWidth As String
Dim ImageDepth As String
Dim kategorie As String
Dim auswahl(3) As Variant
Dim kategorie2 As String
Dim album As String
Dim albumname As String
Dim anzahlok As String
Dim anzahlerr As String
Dim dateierr As Variant
Dim maxhoehe As String
Dim maxbreite As String
Dim ausgabe As String
On Error Goto ErrorHandling
Set db = session.CurrentDatabase
Set pdoc = db.GetProfileDocument("einstellungen")
maxhoehe = pdoc.getitemvalue("einst_maxhoehe")(0)
maxbreite = pdoc.getitemvalue("einst_maxbreite")(0)
anzahlok = 0
anzahlerr = 0
files = workspace.OpenFileDialog(True, "File List", "Supported Images|*.jpg;*.gif", "C:\")
If Isempty(files) Then Exit Sub ' Exit if the user selects the Cancel button
kategorie = Inputbox("In welcher Galerie sollen die Bilder angelegt werden","Album benennen","")
Forall FileList In files ' Loop through the list of files selected
Filename = Filelist ' Get the current filename
' GetImageProperties returns an array of ImageType, height, width and bit-depth
imgProps = GetImageProperties(Filename)
ImageType = imgProps(0)
ImageHeight = imgProps(1) ' Get the image height
ImageWidth = imgProps(2) ' Get the image width
ImageDepth = imgProps(3) ' Get the image bit-depth
'Prüfen ob die maximale Höhe und Breite eingehalten wird
If ImageHeight > maxhoehe Or ImageWidth > maxbreite Then
dateierr = dateierr + Filename + Chr(10)
anzahlerr = anzahlerr+1
Else
' Now, we will create a new document and attach the selected image to it.
Set doc = New NotesDocument( db ) ' Create a new Notes Doc
Set rtitem = New NotesRichTextItem( doc, "Image" ) ' Create a new richtext item
Set object = rtitem.EmbedObject ( EMBED_ATTACHMENT, "", filename) ' Attach the file to it
Print "Bild " & Filename & "wird importiert"
doc.Form = "bilder" ' Set the form name
doc.kategorie = kategorie
doc.HEIGHT = Cint(ImageHeight) ' Write the height
doc.Width = Cint(ImageWidth) ' Write the width
doc.colordepth = Cint(ImageDepth) ' Write the colour depth
doc.filesize = Filelen(filename) ' Write the filename
anzahlok = anzahlok + 1
Call doc.Save( True, True ) ' Save the backend document
Set uidoc = workspace.EditDocument( True, doc ) ' Open the backend doc in the UI
Call uidoc.GotoField( "ImageView" ) ' Make the ImageView field the focus
Select Case Imagetype ' Select which image type this file is
Case "GIF":
Call uidoc.Import("GIF Image",filename) ' Import the GIF image into the field
Call uidoc.fieldsettext("ImageType", "GIF Image") ' Set the Image type field
Case "JPEG":
Call uidoc.Import("JPEG Image",filename) ' Import the JPEG image into the field
Call uidoc.fieldsettext("ImageType", "JPEG Image") ' Set the Image type field
End Select
Call uidoc.FieldSetText("Filename", filename) ' Set the filename field
uidoc.save ' Save the UI Doc
Call uidoc.close(True) ' Close the UI Doc
End If
End Forall ' loop through any of the remaining files
If dateierr = "" Then
ausgabe = ""
Else
ausgabe = Chr(10) & "Die folgenden Dateien sind größer als die zulässigen Maße (" & maxbreite & "x" & maxhoehe & ") und konnten deshalb nicht importiert werden: " & Chr(10) & Chr(10) & dateierr
End If
Messagebox "Importierte Dateien: " & anzahlok & Chr(10) & "Nicht Importierte Dateien: " & anzahlerr &_
Chr(10) & ausgabe , 64, "Importieren abgeschlossen"
Exit Sub
ErrorHandling:
Messagebox "Es ist folgender Fehler aufgetreten: " & Str(Err) & " in Zeile " & Cstr(Erl) & ": " & Error$
Exit Sub
End Sub
und die Biblio:
Function GetImageProperties(ImageFileName As String)
filename = ImageFileName
' Set all properties to default values
m_Width = 0
m_Height = 0
m_Depth = 0
m_ImageType = itUNKNOWN
' Read the first 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.
Redim bBuf(BUFFERSIZE)
lpos = 0
iFN = Freefile
Open FileName For Binary As iFN
idx = 0
Do While Not Eof( iFN ) And idx < BUFFERSIZE
bBuf(idx) = Asc(Inputb( 1 , ifn ))
idx = idx + 1
Loop
Close iFn
If bBuf(0) = 127 And bBuf(1) = 80 And bBuf(2) = 78 Then
m_ImageType = itPNG ' this is a PNG file
ImageType = "PNG"
Select Case bBuf(25) ' get bit depth
Case 0
m_Depth = bBuf(24) ' greyscale
Case 2
m_Depth = bBuf(24) * 3 ' RGB encoded
Case 3
m_Depth = 8 ' Palette based, 8 bpp
Case 4
m_Depth = bBuf(24) * 2 ' greyscale with alpha
Case 6
m_Depth = bBuf(24) * 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), bBuf(18)) ' get the width
m_Height = Mult(bBuf(23), bBuf(22)) ' get the height
End If
End If
If bBuf(0) = 71 And bBuf(1) = 73 And bBuf(2) = 70 Then ' this is a GIF file
m_ImageType = itGIF
ImageType = "GIF"
m_Width = Mult(bBuf(6), bBuf(7)) ' get the width
m_Height = Mult(bBuf(8), bBuf(9)) ' get the height
m_Depth = (bBuf(10) And 7) + 1 ' get bit depth
End If
If bBuf(0) = 66 And bBuf(1) = 77 Then ' this is a BMP file
m_ImageType = itBMP
ImageType = "BMP"
m_Width = Mult(bBuf(18), bBuf(19)) ' get the width
m_Height = Mult(bBuf(22), bBuf(23)) ' get the height
m_Depth = bBuf(28) ' 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
If (bBuf(lPos) = &HFF And bBuf(lPos + 1) = &HD8 And bBuf(lPos + 2) = &HFF) _
Or (lPos >= BUFFERSIZE - 10) Then Exit Do
' move our pointer up
lPos = lPos + 1
Loop
lPos = lPos + 2
If lPos >= 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
If bBuf(lPos) = &HFF And bBuf(lPos + 1) _
<> &HFF Then Exit Do
lPos = lPos + 1
If (lPos >= BUFFERSIZE - 10) Then Exit Function
Loop
' move pointer up
lPos = lPos + 1
Select Case bBuf(lPos)
Case &HC0 To &HC3, &HC5 To &HC7, &HC9 To &HCB, &HCD To &HCF
' we found the right block
Exit Do
End Select
lPos = lPos + Mult(bBuf(lPos + 2), bBuf(lPos + 1)) ' otherwise keep looking
If lPos >= BUFFERSIZE - 10 Then Exit Function 'check for end of buffer
Loop
' If we've gotten this far it is a JPEG and we are ready to grab the information.
m_ImageType = itJPEG
ImageType = "JPEG"
m_Height = Mult(bBuf(lPos + 5), bBuf(lPos + 4)) ' get the height
m_Width = Mult(bBuf(lPos + 7), bBuf(lPos + 6)) ' get the width
m_Depth = bBuf(lPos + 8) * 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
Fehlermeldung die bei manchen JPG kommt ist:
Fehler 183 in Line 50 Variant does not Contain a Variant
Das wäre diese Zeile:
If bBuf(0) = 71 And bBuf(1) = 73 And bBuf(2) = 70 Then ' this is a GIF file
Hat jemand ne Ahnung warum es manchmal geht und manchmal nicht?