Work around a workaround - ProcessRTTags ()

[eknori]

Nachdem die Function ProcessRTTags(...) ( in lib.appl.functions )aus welchem grunde auch immer in der Version 1.5.3 nicht mehr oder nicht unbedingt immer zu funktionieren scheint, habe ich mir den Code heute noch einmal vorgenommen.

Die Funktion steigt an dieser Stelle mit einem fehler aus

Code

		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

offenbar kommt das rtrange.textRun nicht mit den im text enthaltenen CRLF klar. Aber das wohl erst seit Neuestem. Hatten wir doch erst im November letzten Jahres einen Workaround implementiert, bei dem die <<tags>> nicht mehr aus dem RTfeld selber, sondern aus dem unformatierten Feldinhalt ( GetUnformattedText ) ermittelt. Hat ja auch ganz gut funktioniert.

Lange Rede, kurzer Sinn. Funktioniert nicht mehr, also muss eine neue Lösung her.
Hier also dann die momentan funktionierende Funktion

Code

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.
1.2/18.02.2007/Ulrich Krause/Replace all occurencies of space, CRL and TAB in rtitem.text
'###################################################################################
%END REM
	On Error 4504 Goto 	ERROR_4504
	On Error Goto ERRHANDLE   
	
	Const TAG_FORMULA_PREFIX = "["
	Const TAG_FORMULA_SUFFIX = "]"
	Const TAG_PREFIX = "<<"
	Const TAG_SUFFIX = ">>"
	Const TAG_DELIMITER ="~"
	Const TAG_FIELDDELIMITER = ":"
	
	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 strTag 				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
	
	ProcessRTTags = True
	
	If Not linkto Is Nothing Then
		strTemp = ""
		
	'/* 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( "tmpBody" )
		' added 18.02.2007, Ulrich Krause
		Dim arrSearch(2) As String
		Dim arrReplace(2) As String
		arrSearch(0) = " "
		arrSearch(1) = Chr$(13)+Chr$(10)
		arrSearch(2) = Chr$(9)
		arrReplace(0) = ""
		arrReplace(1) = ""
		arrReplace(2) = ""
		'Msgbox Trim( Replace( rtitem.text , arrSearch, arrReplace ))
		Call tmpRTitem.AppendText ( Trim ( Replace( rtitem.text , arrSearch, arrReplace )) )
		' END 18.02.2007
		Set tmpBody = tmpDoc.GetFirstItem("tmpBody")
     	 '/* end added
		
		Set rtnav = tmpbody.CreateNavigator
		Set rtrange = tmpbody.CreateRange
		
		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

Die Funktion ist der echte Horror, weil es selbst im Debugger keinerlei Anhaltspunkte gibt, warum beim rtRange.TextRun ein fehler auftritt. Alle Workarounds stützen sich mehr auf Vermutungen als auf sichere Erkenntnisse.
Hierzu einen Call bei IBM aufzumachen ist wahrscheinlich genauso sinnlos, wie dem Papst das Zölibat auszureden ... Aber das ist eine andere Geschichte.