You can append Richtext to another RichtextItem using LotusScript, but there's no function that allows you to insert Richtext. I tried for awhile and finally found a solution using DXLExport, DXLImport and NotesStream. The remainder is only string manipulation.
First, the insertion point has to be tagged. The tag looks like this and should be terminated by a CRLF: RT:NameOfField
Code:
Const PATHNAME = "c:" Const TAG_PAR = |<par def=| Const TAG_RICHTEXT = |<richtext>| Const TAG_ITEM_NAME = |<item name='| Sub Click(Source As Button) Dim s As New NotesSession Dim db As NotesDatabase Dim dc As NotesDocumentCollection Dim doc As NotesDocument Dim ret As Boolean Set db = s.CurrentDatabase Set dc = db.UnprocessedDocuments Set doc = dc.GetFirstDocument Dim SourceFileName As String Dim MergeFileName As String SourceFileName = ExportXML ( doc ) Set doc = dc.GetNextDocument ( doc ) MergeFileName = ExportXML ( doc ) ret = InsertRichText ( SourceFileName , MergeFileName ,"RTONE") End Sub Function ExportXML ( doc As NotesDocument ) As String Dim s As New NotesSession Dim stream As NotesStream Set stream = s.CreateStream Dim exporter As NotesDXLExporter Dim FILENAME As String Dim universalID As String*32 universalID = doc.UniversalID FILENAME = PATHNAME + universalID +".xml" If Not stream.Open ( FILENAME ) Then Messagebox "Cannot open " & FILENAME,, "Error" Exit Function End If Call stream.Truncate Set exporter = s.CreateDXLExporter Call exporter.SetInput ( doc ) Call exporter.SetOutput ( stream ) Call exporter.Process ExportXML = FILENAME End Function Function InsertRichText ( SourceFile As String, MergeFile As String, FieldName As String) As Boolean %REM INSERTS a NotesRichTextItem into another NotesRichTextItem. You can define the insertion point by writing a RT:<SomeFieldName>
Tag the above into the field where the Richtext should be inserted.
Known issues: If RT:RTONE is located at the end of the RTItem it has to be terminated by a CRLF. Otherwise the DXLImporter fails.
%END REM
InsertRichText = False
Dim s As New NotesSession
Dim db As NotesDatabase
Set db = s.CurrentDatabase
Dim tmpDoc As NotesDocument
Set tmpDoc = New NotesDocument(db)
Dim rtXML As New NotesRichTextItem (tmpDoc, "Body")
Dim s_stream As NotesStream
Dim m_stream As NotesStream
Dim s_stream_buf As String
Dim m_stream_buf As String
Dim HAS_ATTACHMENTS As Boolean
HAS_ATTACHMENTS = False
Dim i As Integer
i = 1
' Open source stream
Set s_stream = s.CreateStream
If ( Not s_stream.open ( SourceFile )) Then
Exit Function
End If
' Read the Source File line by line
Do
s_stream_buf = s_stream.ReadText ( STMREAD_LINE, 4 )
Do While Instr ( Ucase ( s_stream_buf ) ,
Ucase ( "RT:" + FieldName ) )> 0
' insert data from merge file
Set m_stream = s.CreateStream
If ( Not m_stream.open ( MergeFile )) Then
Exit Function
End If
' Read the MergeFile line by line
Do
m_stream_buf = m_stream.ReadText ( STMREAD_LINE, 4 )
If Instr ( Ucase ( m_stream_buf ) ,
Ucase ( "<item name='" + FieldName +"'>" )) > 0 Then
Do
m_stream_buf = m_stream.ReadText ( STMREAD_LINE, 4 )
If Instr ( m_stream_buf, "<pardef" ) > 0 Then
m_stream_buf = m_stream.ReadText ( STMREAD_LINE, 4 )
End If
If Instr ( m_stream_buf, "</richtext></item>" ) > 0 Then
m_stream_buf = Left$ ( m_stream_buf,_
Len ( m_stream_buf ) - ( Len ( "</richtext></item>" ) +1 ) )
Call rtXML.AppendText ( m_stream_buf )
Exit Do
End If
Dim pos As Long
pos = Instr ( Ucase ( m_stream_buf ) ,
Ucase ( "<attachmentref name='" ) )
If pos > 0 Then
' Determine the <attachmentref name=
of all attachments in mergefile
' and store names in array for further use
HAS_ATTACHMENTS = True
Redim Preserve AttNames ( i ) As String
AttNames ( i -1 ) =_
Mid ( m_stream_buf , pos +21 ,_
Instr (Mid ( m_stream_buf , pos + 21 ,_
( Len(m_stream_buf ) - 21 )) , "'") -1 )
i = i +1
End If
Call rtXML.AppendText ( m_stream_buf )
Loop Until Instr(m_stream_buf, "</item>" ) > 0
Exit Do
End If
Loop Until m_stream.IsEOS
Dim m_stream_pos As Long
m_stream_pos = m_stream.Position
'store current stream position
m_stream.Close ' close stream
s_stream_buf = s_stream.ReadText (
STMREAD_LINE, 4 )' read next line
Loop
If HAS_ATTACHMENTS And Instr
( s_stream_buf, "</document>" ) > 0 Then
' strip the </document> tag from s_stream_buf
Call rtXML.AppendText ( Replace
( s_stream_buf , "</document>" , "" ) )
' append filedata
Forall m In AttNames
If Trim ( Cstr ( m )) = "" Then Exit Forall
Set m_stream = s.CreateStream
If ( Not m_stream.open ( MergeFile )) Then
Exit Function
End If
' do not read from beginning of stream
but restore last position
m_stream.Position = m_stream_pos
Dim FILENAME As String
FILENAME = Cstr ( m )
Dim tmp_buf As String
Do
m_stream_buf = m_stream.ReadText
( STMREAD_LINE, 4 )
If Instr ( m_stream_buf , "<item name='$FILE'" ) > 0 Then
tmp_buf = m_stream_buf '
m_stream_buf = m_stream.ReadText ( STMREAD_LINE, 4 )
If Instr ( m_stream_buf , FILENAME ) > 0 Then
Call rtXML.AppendText ( tmp_buf )
Call rtXML.AppendText ( m_stream_buf )
' loop through all lines until </item> is found
Do
m_stream_buf = m_stream.ReadText
( STMREAD_LINE, 4 )
m_stream_buf = Replace
( m_stream_buf , "</document>" , "" )
Call rtXML.AppendText ( m_stream_buf )
Loop Until Instr ( m_stream_buf , "</item>" ) > 0
End If
End If
Loop Until m_stream.IsEOS
Call m_stream.Close
End Forall
' finally append the closing tag </document>
Call rtXML.AppendText ( "</document>" )
Else
Call rtXML.AppendText ( s_stream_buf )
End If
Loop Until s_stream.IsEOS
s_stream.Close ' close dtream
' import the XML data and update the source document
Dim importer As NotesDXLImporter
Set importer = s.CreateDXLImporter ( rtXML , db )
importer.DocumentImportOption =
DXLIMPORTOPTION_REPLACE_ELSE_IGNORE
Call importer.Process
' delete the exported files from the filesystem
Kill ( sourceFile )
Kill ( mergeFile )
InsertRichText = True
End Function
For more information and detail, check out my blog post on this subject at http://www.eknori.de/archives/285.
Do you have comments on this tip? Let us know.
This tip was submitted to the SearchDomino.com tip library by member Ulrich Krause. Please let others know how useful it is via the rating scale below. Do you have a useful Lotus Notes, Domino, Workplace or WebSphere tip or code snippet to share? Submit it to our monthly tip contest and you could win a prize.
This was first published in June 2006