ich hatte auch schon so eine Anforderung und hatte damals folgenden Code im Netz gefunden:
Function ExportPictures(doc As NotesDocument, path As String) As Variant
' ==================================================================
' Exports GIF and JPG images from a notes document into given destinationPath
' Picture's filename is path\<docid>_<number>.<extension>
' Tempfile used is path\Base64.tmp which is deleted after export
' Returns a list of strings containing filenames of exported pictures (if any)
' Base64 conversion is performed with Notes internal MIME functions, therefore
' a tempdoc is created but not saved
' ==================================================================
' by Guido Purper August 2005
' ==================================================================
Dim session As New NotesSession
Dim thisDB As NotesDatabase
Dim doc2 As NotesDocument
Dim filename As String
Dim f As Integer
Dim counter As Integer
Dim destinationPath As String
Dim stream As NotesStream
Dim mimeEntity As NotesMIMEEntity
Dim mimeHeader As NotesMimeHeader
Dim fileList List As String
Dim k(1 To 3, 1 To 3) As String
Dim i As Integer
Dim exporter As NotesDXLExporter
Dim dxl As String
Dim dxlPicture As String
Dim dxlPictureType As String
Dim key As String
Dim p1 As Long
Dim p2 As Long
On Error Goto err1
Set thisDB = session.CurrentDatabase
Set exporter = session.CreateDXLExporter
exporter.ConvertNotesBitmapsToGIF = True
' ================================
' Initialize some variables
' ================================
ExportPictures=""
Erase FileList
' === Key for imported GIFs ===
K(1,1)="<gif>" ' key tag in dxl stream
K(1,2)="</gif>" ' closing tag in dxl stream
K(1,3)="gif" ' file extension
' === Key for any picture converted into gif ===
K(2,1)="<gif originalformat='notesbitmap'>" ' key tag in dxl stream
K(2,2)="</gif>" ' closing tag in dxl stream
K(2,3)="gif" ' file extension
' === Key for JPEGs ===
K(3,1)="<jpeg>" ' key tag in dxl stream
K(3,2)="</jpeg>" ' closing tag in dxl stream
K(3,3)="jpg" ' file extension
' ================================
' Make sure destination path ends with a \
' ================================
If Right$(path,1)="\" Then
destinationPath=path
Else
destinationpath=path & "\"
End If
' ===========================================
' Convert document into DXL
' ===========================================
dxl = exporter.Export(doc)
' ---=== for debugging ===---
' Print "path=" &destinationPath
' f = Freefile
' Print "Debug output to " & destinationPath & "debug.dxl.txt"
' Open destinationPath & "debug.dxl.txt" For Output As f
'Print #f, DXL
'Close f
'Exit Function
' =========================================
' Remove CRs and LFs from DXL
' =========================================
dxl = Replace(dxl, Chr$(13), "")
dxl = Replace(dxl, Chr$(10), "")
' ===========================================
' Extract picture data from DXL and write it into tempfile
' ===========================================
For i=1 To 3
key = K(i,1)
p1 = Instr(p1+10, dxl, key , 5)
While p1>0
If p1 >0 Then
p2 =Instr(p1, dxl, k(i,2), 5)
If p2>0 Then
dxlPictureType = K(i,3)
dxlPicture = Mid$(dxl, p1+Len(key), p2-p1-Len(key))
' =====================
' Save DXL into tempfile
' =====================
f = Freefile
Open destinationPath & "Base64.tmp" For Output As f
Print #f, DXLPicture
Close f
' ===========================================
' Create a new Notes Document with embedded picture
' ===========================================
session.ConvertMIME = False
Set Doc2 = New NotesDocument( ThisDB)
Set MIMEEntity= doc2.CreateMIMEEntity
Set stream = session.CreateStream
If Not stream.Open(path & "Base64.tmp" , "binary") Then
Messagebox "ExportPictures(): Open tempfile failed"
Goto MyExit
End If
If stream.Bytes = 0 Then
Messagebox "ExportPictures(): Tempfile is empty"
Goto MyExit
End If
Call MimeEntity.SetContentFromBytes(stream, "image/gif", ENC_BASE64)
Call stream.Close
' =======================================
' Save embedded picture to file
' =======================================
Set stream = session.CreateStream
filename = destinationPath & doc.UniversalID & "_" & counter & "." & dxlPictureType
On Error Resume Next
Kill filename
On Error Goto err1
If Not stream.Open( filename, "binary") Then
Messagebox "ExportPictures(): Cannot write picture " & filename
Goto MyExit
End If
Set MIMEEntity = doc2.GetMIMEEntity
Call MimeEntity.GetContentAsBytes(stream)
Call stream.Close()
FileList(counter) = filename
counter=counter+1
End If ' p2>0
End If 'p1>0
p1 = Instr(p2+1, dxl, key , 5)
Wend
Next i
MyExit:
session.ConvertMIME = True ' Restore conversion
On Error Resume Next
'Kill path & "Base64.tmp"
Call stream.Close()
On Error Goto err1
ExportPictures = FileList
Exit Function
err1:
Print "ExportPictures(): " & Error$ & " in line " &Erl
Messagebox "ExportPictures(): " & Error$ & " in line " &Erl
session.ConvertMIME = True
On Error Resume Next
Kill path & "Base64.tmp"
Call stream.Close()
On Error Goto 0
Exit Function
End Function
Thema: in-line image bzw. eingebettes Bild , Exportieren oder als JPEG Abspeichern (Gelesen 8895 mal)