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
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
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.
Thema: Work around a workaround - ProcessRTTags () (Gelesen 6364 mal)