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.
