| Const PATHNAME = "c:\" |
| |
| 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 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 DXLImpoter |
| fails. |
| %END |
| 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 |
| |
| |
| Set s_stream = s.CreateStream |
| If ( Not s_stream.open ( SourceFile )) Then |
| Exit Function |
| End If |
| |
| Do |
| s_stream_buf = s_stream.ReadText ( STMREAD_LINE, 4 ) |
| Do While Instr ( Ucase ( s_stream_buf ) , Ucase ( "RT:" + FieldName ) )> 0 |
| |
| Set m_stream = s.CreateStream |
| If ( Not m_stream.open ( MergeFile )) Then |
| Exit Function |
| End If |
| |
| 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 |
| |
| |
| 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 |
| |
| m_stream.Close |
| s_stream_buf = s_stream.ReadText ( STMREAD_LINE, 4 ) |
| Loop |
| |
| If HAS_ATTACHMENTS And Instr ( s_stream_buf, "</document>" ) > 0 Then |
| |
| Call rtXML.AppendText ( Replace ( s_stream_buf , "</document>" , "" ) ) |
| |
| 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 |
| |
| 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 ) |
| |
| 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 |
| |
| Call rtXML.AppendText ( "</document>" ) |
| Else |
| Call rtXML.AppendText ( s_stream_buf ) |
| End If |
| |
| Loop Until s_stream.IsEOS |
| s_stream.Close |
| |
| |
| Dim importer As NotesDXLImporter |
| Set importer = s.CreateDXLImporter ( rtXML , db ) |
| importer.DocumentImportOption = DXLIMPORTOPTION_REPLACE_ELSE_IGNORE |
| Call importer.Process |
| |
| Kill ( sourceFile ) |
| Kill ( mergeFile ) |
| InsertRichText = True |
| |
| End Function |