Richtextfelder export - Formatierter Text

Private Function Dokument(doc As NotesDocument) As Integer
		Const PROCNAME = "Dokument"
		On Error Goto errHandler

		Dim intReturn As Integer

		intReturn = True 'Generic error condition

		Dim strDocFolderPath As String
		Dim strItemFolderPath As String
		Dim itm As NotesItem
		Dim rtItem As NotesRichTextItem
		Dim stream As NotesStream
		Dim outStream As NotesStream
		Dim stmXSL As NotesStream
		Dim ndxle As NotesDXLExporter
		Dim nxslTransformer As NotesXSLTransformer
		Dim lstFieldCounter List As Integer
		Dim neoAttachment As NotesEmbeddedObject
		Dim strImageData As String
		Dim strHtmlData As String

		nLog.LogAction {Processing document with UNID = "} & doc.UniversalID & {"}
		strDocFolderPath = strOutputFolder & doc.UniversalID & DIRSEP
		intReturn = EnsureDirectory(strDocFolderPath)
		Select Case intReturn
		Case False 'No error
			'Procced below
		Case True 'Unknown error
			Error 9999, {Unknown error while trying to ensure that the folder "} & strDocFolderPath & {" exists}
		Case Else 'Already logged by Dokument
			Goto endFunc
		End Select

		'Write out the text contents of the document
		Set stream = ses.CreateStream
		'################
		'We can create the stream in memory, but the following is useful for looking at the contents of the stream for debugging
		'stream.Open strDocFolderPath & "contents.xml"
		'stream.Truncate
		'################
		Set ndxle = ses.CreateDXLExporter
		With ndxle
			.OutputDOCTYPE = False
			.ConvertNotesBitmapsToGIF = True
			.SetInput doc
			.SetOutput stream
			.Process
		End With

		'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
		'Now we take the stream that we created containing the raw XML and transform it first to extract the HTML for each RTF
		Set outStream = ses.CreateStream
		'outStream.Open strDocFolderPath & "contents.htm"
		'outStream.Truncate
		Set stmXSL = ses.CreateStream
		stmXSL.WriteText XSL_RICHTEXT
		stmXSL.Position = 0

		Set nxslTransformer = ses.CreateXSLTransformer(stream, stmXSL, outStream)
		nxslTransformer.Process

		outStream.Position = 0
		strHtmlData = outStream.ReadText

		'Since our resulting transformation stream contains all HTML within the stream,
		'the following function call breaks them up into separate files
		SplitStream strHtmlData, strDocFolderPath, "§§§§§", "¦¦¦¦¦", False
		'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

		'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
		'Using the same raw XML stream, we transform it to extract the image data
		Set outStream = ses.CreateStream
		Set stmXSL = ses.CreateStream
		stmXSL.WriteText XSL_ANYIMG
		stmXSL.Position = 0

		Set nxslTransformer = ses.CreateXSLTransformer(stream, stmXSL, outStream)
		nxslTransformer.Process

		outStream.Position = 0
		strImageData = outStream.ReadText

		'Since our resulting transformation stream contains all images within the stream,
		'the following function call breaks them up into separate files
		SplitStream strImageData, strDocFolderPath, "§§§§§", "¦¦¦¦¦", True
		'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

		'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
		'Now we extract any attachments that are contained in each of the RT items to a folder named as the RT item
		'The XSL transformation to HTML already made reference to these attachments when searching for dxl:attachmentref
		Forall x In doc.Items
			Set itm = x
			If itm.Type = RICHTEXT Then
				Set rtItem = itm
				If Iselement(lstFieldCounter(itm.Name)) Then
					lstFieldCounter(itm.Name) = lstFieldCounter(itm.Name) + 1
				Else
					lstFieldCounter(itm.Name) = 1
				End If
				strItemFolderPath = strDocFolderPath & itm.Name & DIRSEP
				intReturn = EnsureDirectory(strItemFolderPath)
				Select Case intReturn
				Case False 'No error

					'Detach any attachments
					If Not Isempty(rtItem.EmbeddedObjects) Then
						Forall o In rtItem.EmbeddedObjects
							Set neoAttachment = o
							If neoAttachment.Type = EMBED_ATTACHMENT Then
								neoAttachment.ExtractFile strItemFolderPath & neoAttachment.Source
							End If
						End Forall
					End If

				Case True 'Unknown error
					Error 9999, {Unknown error while trying to ensure that the folder "} & strItemFolderPath & {" exists}
				Case Else 'Already logged by Dokument
					Goto endFunc
				End Select
			End If
		End Forall


		
		intReturn = False 'No Error
		Goto endFunc

errHandler:
		On Error Resume Next
		intReturn = Err
		nLog.LogError Err, "[" & PROCNAME & " " & Erl & "] " & Error
		Resume endFunc

endFunc:
		Dokument = intReturn
	End Function