Function ProcessRTTags(rtitem As NotesRichTextItem, linkto As NotesDocument, basedoc As NotesDocument, parentdoc As NotesDocument) As Integer
%REM
###################################################################################
Goal: Replace defined tags in richtext item rtitem with corresponding items/values from referenced docs
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Arguments: Description:
rtitem NotesRichTextItem RichTextItem to search for tags and replace them with appropriate values
linkto NotesDocument actual document
basedoc NotesDocument base document of actual document
parentdoc NotesDocument parent document of actual document
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Return:
TRUE or FALSE.
TRUE if the function runs without an error
FALSE if the function has an error
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Example:
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
VERSION / WHEN / WHO / CHANGES
1.0/22.03.2006/Marc Aigner/--
1.1/26.04.2006/Thomas Schulte/added functionality to enter newlines with multivalue fields and replace CRLF within strings.
'###################################################################################
%END REM
'On Error 4504 Goto ERROR_4504
On Error Goto ERRHANDLE
Const TAG_FORMULA_PREFIX = "["
Const TAG_FORMULA_SUFFIX = "]"
Dim rtnav As NotesRichTextNavigator
Dim rtrange As NotesRichTextRange
Dim fieldreaddoc As NotesDocument
Dim strT As String
Dim strReplT As String
Dim strTemp As String
Dim getString As String
Dim arrRetFieldNames As Variant
Dim arrRetGetFieldFrom As Variant
Dim ret As Integer
Dim retvar As Variant
Dim readfromitem As NotesItem
Dim CrLf As String
CrLf = Chr$(13) & Chr$(10)
ProcessRTTags = True
If Not linkto Is Nothing Then
%REM
%END REM
'/* added 28.05.2006 to avoid illegal function Call on line 425, Ulrich Krause
' http://atnotes.de/index.php?topic=30710.msg193619#msg193619
Dim tmpdoc As NotesDocument
Dim tmpRTitem As NotesRichTextItem
Dim tmpbody As NotesRichTextItem
Set tmpDoc = db.CreateDocument
Set tmpRTitem = tmpdoc.CreateRichTextItem( "tempBody" )
Dim unformatted As String
unformatted = rtitem.GetUnformattedText()
unformatted = Replace(unformatted, crLF, "")
unformatted = Replace(unformatted, Chr$(10), "")
unformatted = Replace(unformatted, Chr$(13), "")
Call tmpRTitem.AppendText( unformatted )
Set tmpbody = tmpDoc.GetFirstItem("tempBody")
'/* end added
Set rtnav = tmpbody.CreateNavigator
Set rtrange = tmpbody.CreateRange
'Set rtnav = rtItem.CreateNavigator
'Set rtrange = rtItem.CreateRange
strTemp = ""
If rtnav.FindFirstString ( TAG_PREFIX, _
RT_FIND_CASEINSENSITIVE) Then
Do
Call rtrange.SetBegin ( rtnav )
strTemp = strTemp + TAG_DELIMITER + Mid ( rtrange.textRun, 3, Instr( rtrange.textRun,TAG_SUFFIX ) -3 )
Loop While rtnav.FindNextString ( TAG_PREFIX, RT_FIND_CASEINSENSITIVE )
End If
arrRetFieldNames = Arrayunique ( Split ( strTemp, TAG_DELIMITER ), 5 )
Set rtrange = rtItem.CreateRange
Forall t In arrRetFieldNames
strT = Cstr ( t )
strReplT = Cstr( t )
arrRetGetFieldFrom = Arrayunique ( Split ( StrT, TAG_FIELDDELIMITER ), 5 )
Select Case arrRetGetFieldFrom(0)
Case "b"
If Not basedoc Is Nothing Then
strT = Cstr ( ArrRetGetFieldFrom(1) )
Set fieldreaddoc = Basedoc
End If
Case "p"
If Not parentdoc Is Nothing Then
strT = Cstr ( ArrRetGetFieldFrom(1) )
Set fieldreaddoc = Parentdoc
End If
' added 15.12.2006, Ulrich Krause. Fixes a problem with <<b: and <<p: tags as reported by AHG
Case Else
Set fieldreaddoc = linkto
End Select
'if no source doc referenced then use actual document
If fieldreaddoc Is Nothing Then Set fieldreaddoc = LinkTo
getstring = ""
If ( Not strT = "" ) Then
'Check if we have a formula or a item name
If Left(Trim(strT), 1) = TAG_FORMULA_PREFIX Then
'we have a formula string => process with source document
strT = Strleftback(Strright(strT, TAG_FORMULA_PREFIX), TAG_FORMULA_SUFFIX)
retVar = CheckAndEvaluate(strT, fieldreaddoc)
getstring = retvar(0)
Else
'we have a item name => use item text as value if it is a richttext else use cstr values and separate the values with chr10 chr13
' if there are multiple values in that item
If ItemTextExists ( fieldReadDoc, strT ) Then
Set readfromitem = fieldreaddoc.getfirstitem(strT)
If readfromitem.Type <> TEXT And readfromitem.Type <> DATETIMES And readfromitem.Type <>NUMBERS Then
getstring = fieldReadDoc.GetFirstItem( strT ).text
Else
Forall v In readfromitem.Values
If getstring <> "" Then
getstring = getstring + "°" + Cstr(v)
Else
getstring = Cstr(v)
End If
End Forall
End If
' replace every occurence of chr(10) + chr(13) with chr(0) in getstring
'CrLf = Chr$(13) & Chr$(10) ' Carriage Return and a Line Feed character
getstring = Replace(getstring,CrLf,"°")
' 15.11.2006, Thomas Schulte, Code added
' needed because of issue reported here --> http://atnotes.de/index.php?topic=33526.msg210617#msg210617
Do While Right(getstring,1) = "°"
getstring = Left(getstring, Len(getstring)-1)
Loop
' End 15.11.2006, Thomas Schulte, Code added
End If
End If
'replace tag with evaluated value from item text or formula
If Trim(getstring) <> "" Then
ret = rtrange.FindAndReplace _
( TAG_PREFIX & strReplT & TAG_SUFFIX,_ ' find
getstring, _ ' replaceWith
RT_REPL_ALL + RT_FIND_CASEINSENSITIVE)
Call rtItem.Update ' Must update before looping
End If
End If
End Forall
Set rtnav = rtItem.CreateNavigator
Set rtrange = rtItem.CreateRange
If rtnav.FindFirstString("°") Then
Do
Call rtrange.SetBegin(rtnav)
Call rtrange.SetEnd(rtnav)
Call rtrange.remove
Call rtitem.BeginInsert(rtnav)
Call rtitem.addnewline(1)
Call rtitem.EndInsert
Call rtitem.Update
Set rtnav = rtItem.CreateNavigator
Set rtrange = rtItem.CreateRange
Loop While rtnav.FindFirstString("°")
ERROR_4504: ' according to issue mentioned here --> http://atnotes.de/index.php?topic=33526.msg210617#msg210617
End If
End If
EXITPOINT:
Exit Function
ERRHANDLE:
ProcessRTTags = False
xProc = Getthreadinfo(LSI_THREAD_PROC)
xError = xProc & ": " &Trim$(Str$(Err)) & " on line " & Cstr(Erl) & ": " & Error$
If UseOpenLog Then
Call LogError
Elseif LogScriptErrors Then
Call ThrowException ( xProc, xError )
End If
Print xError 'In all cases
If ResumeMethodNext Then
Resume Next
Else
Resume EXITPOINT
End If
End Function
