Const XSLT = |<xsl:stylesheet version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform" xmlns:ln="http://www.lotus.com/dxl">
<xsl:output
method="xml"
omit-xml-declaration="yes"
indent="no"/>
<xsl:param name="unid" select="'unid'"/>
<xsl:param name="replica" select="'replica'"/>
<xsl:template match="/">
<document form='tmpForm'>
<xsl:attribute name="replicaid"><xsl:value-of select="$replica" /></xsl:attribute>
<noteinfo><xsl:attribute name="unid"><xsl:value-of select="$unid" /></xsl:attribute></noteinfo>
<item name='Body'>
<richtext>
<pardef id='1'/>
<par def='1'>
<xsl:for-each select="//ln:attachmentref">
<xsl:copy-of select="."/>
</xsl:for-each>
</par>
</richtext>
</item>
</document>
</xsl:template>
</xsl:stylesheet>|
Class OmhProblem
Private t_fileItemName As String
Private t_stuffItemName As String
Private t_doc As NotesDocument
Private t_tmpDb As NotesDatabase
Private t_item As NotesRichTextItem
'
' @link https://codeby.net/ipb.html?s=&showtopic=42747&view=findpost&p=209313
' @param i_itemName - имя RT поля, которое нужно разобрать
' @param i_fileItemName - имя RT поля, в которое лягут файлы
' @param i_stuffItemName - имя RT поля, в которое ляжет все остальное
Sub new( i_doc As NotesDocument , i_itemName As String, i_fileItemName As String, i_stuffItemName As String )
Set t_doc = i_doc
Set t_item = t_doc.GetFirstItem( i_itemName )
t_fileItemName = i_fileItemName
t_stuffItemName = i_stuffItemName
Set t_tmpDb = t_doc.ParentDatabase '' в кач-ве временной базы лучше использовать какую-нить локальную БД
End Sub
Public Sub solve()
Call processStuff() ' текст
Call processFiles() ' аттачи
Call t_doc.Save( True, False )
End Sub
' формируем RT без аттачей. тут как бы проблем не возникает:
' копируем исходное поле во временный документ, валим все аттачи, копируем обратно
' нельзя использовать исходный документ, т.к. удаление аттача из RT удаляет $File.
Private Sub processStuff()
Dim doc As New NotesDocument( t_tmpDb )
Dim tmpItem As NotesRichTextItem
Set tmpItem = t_item.copyItemToDocument( doc , "Body" )
Forall eo In tmpItem.EmbeddedObjects
If ( eo.Type = EMBED_ATTACHMENT ) Then
Call eo.remove()
End If
End Forall
Call tmpItem.CopyItemToDocument( t_doc, t_stuffItemName )
End Sub
' формируем RT, содержащее только вложения исходного поля
' 1. копируем поле во временный документ
' 2. удаляем $File через doc.GetAttachment().remove - этот метод не удаляет ссылки на файлы в RT. Т.е. имеем RT с "битыми ссылками" на аттачи
' 3 .прогоняем документ через XSL Transformer, убирая из RT все, кроме аттачей
' 4. результирующий документ рендерим в указанное поле исходного документа.
'
' шаг 2 (танцы с удалением $File) нужен для оптимизации использования DXL:
' в противном случае через парсер пройдет контент файлов. Пара файлов по 10Mb вполне в состоянии уложить клиента.
Private Sub processFiles()
Dim doc As New NotesDocument( t_tmpDb )
Call t_item.copyItemToDocument( doc , "Body" )
Dim filenames As Variant
filenames = Evaluate("@AttachmentNames" , doc )
Forall filename In filenames
Call doc.GetAttachment(filename).remove()
End Forall
Set doc = doMagic( doc )
' копируем обратно $Files - без них падает copyItemToDocument
Call t_item.copyItemToDocument( doc , "TmpBody" )
Call safeRemoveRtField( "TmpBody" )
Call t_item.remove() ' чистим исходное поле
Call doc.GetFirstItem("Body").CopyItemToDocument( t_doc , t_fileItemName )
End Sub
Private Function doMagic(doc As NotesDocument) As NotesDocument
Dim session As New NotesSession
Call doc.Save(True, False ) ' сохранение нужно для того, чтобы найти документ после DXLImport.
Dim unid As String
unid = doc.UniversalID
Dim exporter As NotesDXLExporter
Set exporter = session.CreateDXLExporter(doc)
Dim xsl As NotesStream
Set xsl = session.CreateStream()
Call xsl.WriteText( XSLT )
Dim transformer As NotesXSLTransformer
Set transformer=session.CreateXSLTransformer( exporter , xsl )
Call transformer.AddParameter("unid" , unid )
Call transformer.AddParameter("replica" , doc.ParentDatabase.ReplicaID)
Dim importer As NotesDXLImporter
Set importer = session.CreateDXLImporter( transformer , t_tmpDb )
importer.DocumentImportOption = DXLIMPORTOPTION_REPLACE_ELSE_CREATE
Call exporter.process
Delete doc
Set doMagic = t_tmpDb.GetDocumentByUNID( unid )
End Function
' простое удаление RT поля сносит $Files.
' поэтому удалять RT следует примерно так:
Private Function safeRemoveRtField(itemName As String)
Const TMP_ITEM_NAME = "Killme"
Dim tmpItem As New NotesItem( t_doc , TMP_ITEM_NAME , "" )
Call t_doc.ReplaceItemValue(itemName , tmpItem )
Call t_doc.RemoveItem(itemName)
Call t_doc.RemoveItem(TMP_ITEM_NAME)
End Function
End Class
