Function pp_CopyRTItems( actiondoc As NotesDocument, SourceDoc As NotesDocument, TargetDoc As NotesDocument) As NotesDocument
'Возвращает оригинал для TargetDoc, если оригинал был изменен
On Error Goto ErrHnd
Dim i As Long
Dim v
Dim AllDes
Dim Des As String
Dim TName As String
Dim SName As String
Dim ASourceDoc As NotesDocument
Dim ATargetDoc As NotesDocument
Dim TargetOrigDoc As NotesDocument
Dim InOrig As Integer
Dim HasOrig As Integer
Dim RemovedRT List As Integer
Dim OrigFields As Variant
Dim tmpDoc As NotesDocument
If actiondoc.rtfields(0)="" Then Exit Function
If Ubound( actiondoc.rtfields ) > 1 Then
'старый способ описания RT-полей
For i=0 To Ubound(actiondoc.rtfields)-1 Step 2
Set v=SourceDoc.getfirstitem(actiondoc.rtfields(i))
If Not v Is Nothing Then
Call v.CopyItemToDocument(TargetDoc,actiondoc.rtfields(i+1))
End If
Next
Else
'новый способ описания RT-полей (с поддержкой оригиналов)
'<SRT1>%<TRT1>[%O] : <SRT2>%<TRT1>[%O] : <SRT1>%<TRT2>...
Set tmpDoc = TargetDoc.ParentDatabase.CreateDocument 'врем. док. для RT-полей
HasOrig = False
Set ASourceDoc = pp_GetRTStorageDocument( SourceDoc )
AllDes = Evaluate(actiondoc.rtfields(0), SourceDoc)
For i = 0 To Ubound( AllDes )
Des = Cstr( AllDes( i ) )
SName = Trim$( Strleft(Des,"%" ) )
TName = PPR_Word(Des, "%",2)
If TName="" Or SName="" Then Error AGENTERRORNUM#, "Не правильный формат описания копируемых RT-полей"
InOrig = ( Ucase$(Trim$(PPR_Word(Des, "%",3))) = "O")
If InOrig And TargetOrigDoc Is Nothing Then
Set TargetOrigDoc = pp_GetRTStorageDocument( TargetDoc )
If TargetOrigDoc.UniversalId<>TargetDoc.UniversalId Then HasOrig = True
End If
If InOrig Then
Dim OrigS As String
Dim OrigT As String
Dim OrigType As String
Dim sOrigDes As String
Set ATargetDoc = TargetOrigDoc
Else
Set ATargetDoc = TargetDoc
End If
'// 23.11.05 для переноса полей с подписью в ЭО
Dim Sitem As Variant
Dim Titem As Variant
'на случай если в ASourceDoc нет поля для TName
If Not Iselement( RemovedRT(TName) ) Then
ATargetDoc.RemoveItem TName
RemovedRT(TName) = 1
End If
Set Sitem = ASourceDoc.GetFirstItem(SName)
If Not Sitem Is Nothing Then
Set Titem = tmpDoc.GetFirstItem( TName )
If Titem Is Nothing Then
Set Titem = Sitem.CopyItemToDocument( tmpDoc,TName )
Elseif Sitem.Type=RICHTEXT Or Sitem.Type=MIME_PART Then
Titem.AppendRTItem Sitem
Elseif Sitem.Type = Titem.Type Then
v = Titem.Values
v = Arrayappend( v, Sitem.Values )
Call tmpDoc.ReplaceItemValue( TName, v)
Else
Error 1001, "Type of source and target item doesn't match"
End If
End If
'//
Next
'Через CopyAllItems приходится делать потому что CopyItemToDocument(ATargetDoc) приводил к дублированию $FILE
Call tmpDoc.CopyAllItems( ATargetDoc, True )
If HasOrig Then Set pp_CopyRTItems = TargetOrigDoc
End If
Exit Function
ErrHnd:
Dim ErrStr As String
ErrStr = "pp_CopyRTItems Line " & Erl & "; " & Chr(10) & Error$
Resume Done
Done:
On Error Goto 0
Error agentERRORNUM#, ErrStr
End Function