How to insert RichText into RichText using LotusScript

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.