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. But, after some trial and error, SearchDomino.com member Ulrich Krause has figured out a way it can be done using DXLExport, DXLImport and NotesStream.
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.