Ja auch von mir ein Danke. Ich hab das in die neue Version eingebaut. Allerdings ein wenig verändert, so das es aus der Spoofmessage heraus funktioniert und nicht nur im eigenen Dokument sucht, sondern auch in Parent bzw. Basedocs, und das die Klammern (<< und >>) erhalten bleiben können. Die braucht der Dispatcher nämlich manchmal bei Antworten.
Function ReplaceSubjectFields(Me_Subject As String, Me_Linkdoc As NotesDocument, Me_Parentdoc As NotesDocument, Me_Basedoc As notesdocument) As String
%REM
###################################################################################
Goal: replace variables that are represented by fieldnames written in << >>.
Check against P and B to get fieldnames also from Parent and Basedocs
Check against X because the << and the >> have to stay sometimes
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Arguments: Description:
me_Subject String String where field values have to be inserted
me_Linkdoc NotesDocument Notes Document
me_Parentdoc NotesDocument Parentdocument, if available
me_Basedoc NotesDocument Basedocument if available
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Return:
the text Value of that field or an empty string if there is no value
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Example:
mystring = RpelaceSubjectFields(Subject,Thisdocument, Parentdocument, Basedocument)
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
VERSION / WHEN / WHO / CHANGES
1.0/??.02.2006/Andreas Schultheis
1.1/21.02.2006/Thomas Schulte/integrated checking against (p)arent and (b)asedocs.
Integrated Checking against x to keep the << and >> where they should be keeped
'###################################################################################
%END REM
Dim me_FieldName As String, me_FieldValue As String
Dim iPos1 As Integer, iPos2 As Integer
Dim iLen1 As Integer, iLen2 As Integer
Dim me_doc As NotesDocument
Dim Me_Item As notesitem
Dim Me_ArrRetGetFieldFrom As Variant
On Error Goto ERRHANDLE
iLen1 = Len(TAG_PREFIX)
iLen2 = Len(TAG_SUFFIX)
ReplaceSubjectFields = ""
Do
' get the start tag
iPos1 = Instr(Me_Subject, TAG_PREFIX)
If iPos1 > 0 Then
' search the end tag
iPos2 = Instr(iPos1 + iLen1, Me_Subject, TAG_SUFFIX)
If iPos2 > 0 Then
' Cut the string between the tags. This could contain a fieldname or a array
Me_FieldName = Mid(me_Subject, iPos1 + iLen1, iPos2 - iPos1 - iLen1)
' Split the Fields name to check where the field should come from and get the right document
Me_arrRetGetFieldFrom = Arrayunique ( Split ( Me_FieldName, TAG_FIELDDELIMITER ), 5 )
If Me_arrRetGetFieldFrom(0) = "b"Then
If Not Me_basedoc Is Nothing Then
Set Me_doc = Me_Basedoc
Me_FieldName = Cstr ( Me_ArrRetGetFieldFrom(1) )
Else
Set Me_Doc = Me_LinkDoc
End If
Elseif Me_arrRetGetFieldFrom(0) = "p" Then
If Not Me_parentdoc Is Nothing Then
Set Me_Doc = Me_Parentdoc
Me_Fieldname = Cstr ( Me_ArrRetGetFieldFrom(1) )
Else
Set Me_Doc = Me_LinkDoc
End If
Elseif Me_arrRetGetFieldFrom(0) = "x" Then
Me_Fieldname = Cstr ( Me_ArrRetGetFieldFrom(1) )
Set Me_Doc = Me_LinkDoc
Else
Set Me_Doc = Me_LinkDoc
End If
' split and check
If Me_doc.HasItem(Me_FieldName) Then
' get the fields value
Set me_item = Me_doc.GetFirstItem(Me_FieldName)
Me_FieldValue = Me_item.Text
If Me_arrRetGetFieldFrom(0) <> "x" Then
ReplaceSubjectFields = ReplaceSubjectFields + Left(Me_Subject, iPos1 - 1) + Me_FieldValue
Else
' keep the prefix and the suffix
ReplaceSubjectFields = ReplaceSubjectFields + Left(Me_Subject, iPos1 - 1) + TAG_PREFIX + Me_FieldValue + TAG_SUFFIX
End If
Else
' if the field does not exist write the original context
ReplaceSubjectFields = ReplaceSubjectFields + Left(Me_Subject, iPos2 + iLen2)
End If
' do the next step after the end tag
Me_Subject = Mid(Me_Subject, iPos2 + iLen2)
Else
' Nothing else found
ReplaceSubjectFields = ReplaceSubjectFields + Me_Subject
End If
Else
' nothing found
ReplaceSubjectFields = ReplaceSubjectFields + Me_Subject
End If
Loop Until (iPos1 = 0) Or (iPos2 = 0)
EXITPOINT:
Exit Function
ERRHANDLE:
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