Hi,
folgendes Script (für Aktionsbutton im Eingangsordner) in einem Mailfile macht eine "Quoted Reply" also eine Antwort in der jede Zeile mit Quotes beginnt.
Was mir jetzt noch fehlt, damit dies identisch ist mit "Antwort" etc.: falls an dem Dok nichts geändert wird und die Esc-Taste gedrückt wird, soll Notes das Dok einfach schließen ohne einer Abfrage "Fenster Schließen ....".
Danke schon im Voraus!
Bob
Und nun das Script (in "Click" der Aktion kopieren):
Sub Click(Source As Button)
Dim session As New NotesSession
Dim thisDB As NotesDatabase
Dim coll As NotesDocumentCollection
Dim uiws As New NotesUIWorkspace
Dim doc As NotesDocument
Dim uidocReply As NotesUIDocument
Dim rtitemBody As Variant
Dim sBodyOriginal$
Dim sBodyConverted$
Dim vntMailDbFile,vntxdMailDbServer
Set thisDB = session.CurrentDatabase
Set coll = thisDB.UnprocessedDocuments
If coll.count > 1 Then
Msgbox "Diese Aktion kann nicht auf mehrere gewählte Dokumente ausgeführt werden !", 16, "Warnung:"
Exit Sub
End If
'We will process only one document even if the user marked multiple ... So the user won't lost the overview, and we will get no troubles with too many windows ...
Set doc = coll.GetNthDocument (1)
Set rtitemBody=doc.GetFirstItem("Body")
sBodyOriginal=rtitemBody.GetFormattedText(False,0)
vntMailDbServer=Evaluate("@Subset(@MailDbName;1)")
vntMailDbFile=Evaluate("@Subset(@MailDbName;-1)")
Set uidocReply=uiws.ComposeDocument(Cstr(vntMailDbServer(0)),Cstr(vntMailDbFile(0)), "Reply")
'If the user marked one document but his cursor points to another doc, the body of the marked doc will be converted,
'but From and Subject will be taken from the documents the cursor points to:
Call uidocReply.FieldSetText ("SendTo", doc.From (0) )
Call uidocReply.FieldSetText ("Subject", "Re: " & doc.Subject (0) )
sBodyConverted=ManipulateReplyText(doc, sBodyOriginal)
Call uidocReply.FieldSetText("Body", sBodyConverted)
End Sub
Function ManipulateReplyText (note As NotesDocument, body As String)
'Adding > to the begining of each line of the "History text" and
'Aligning the text Left (wrapping)
Print "Formatting ""History"" text"
Dim bd As Variant
Dim Header As NotesItem
Dim dateItem As NotesItem
Dim InFrom As NotesName
Dim GetInternetFullName$, HeaderString$, pos%, tmpString$, pos1%, dont%,tmp$
Dim y%, x%, b%, xx%, xb
'dividing the text to lines and addding the > sign
If note.hasitem("$AdditionalHeaders") Then
'starting here: inbound messages seem to have $AdditionalHeaders
Set Header=note.GetFirstItem("$AdditionalHeaders")
If Header.values(0) = "" Then
'GetInternetFullName=note.InheritedFrom(0)
GetInternetFullName=note.From(0)
Goto Continue
End If
Else
If Not note.HasItem("tmpAdditionalHeaders") Or note.tmpAdditionalHeaders(0)="" Then
'GetInternetFullName=note.InheritedFrom(0)
GetInternetFullName=note.From(0)
Goto continue
End If
Set Header=note.Getfirstitem("tmpAdditionalHeaders")
End If
HeaderString=Header.values(0)
pos=Instr(HeaderString,"From: ")
tmpString=Mid(HeaderString,pos+6)
pos1=Instr(tmpString,"<")
If pos1=0 Then 'The full name will appear in (...)
pos1=Instr(tmpString,"(")
tmpString=Mid(tmpString,pos1+1)
pos1=Instr(tmpString,")")
GetInternetFullName=Mid(tmpString,1,pos1-1)
dont=True
Goto Continue
End If
tmpString = Mid(tmpString,1,pos1-1)
pos=Instr(tmpString,|"|)
If pos<>0 Then
tmpString=Mid(tmpString,pos+1)
pos=Instr(tmpString,|"|)
GetInternetFullName=Mid(tmpString,1,pos-1)
Else
GetInternetFullName=tmpString
End If
Continue:
Set InFrom=New NotesName(GetInternetFullName)
' and starting here: I found that inbound messages had a PostedDate item, Not tmpSentOn
If note.HasItem("tmpSentOn") Then
postDate = note.tmpSentOn(0)
Else
Set dateItem = note.GetFirstItem("PostedDate")
postDate = dateItem.Text
End If
tmp="On " & postDate & note.tmpSentOn(0) & " " & InFrom.Common & " wrote:" & Chr(13) & Chr(10) & Chr(13) & Chr(10) & "> "
y=1
b=1
For x=1 To Len(body)
xx=Asc(Mid(body,x,1))
If x<>Len(body) Then xb=Asc(Mid(body,x+1,1))
'Now that we know the current and the next characters we can consider whether they will cause a line feed, so we can insert our ">".
If xx=10 Or xx=13 Or xx=11 Or xx=12 Then
'if this combination occurs then we skip the next one so we don't LF twice.
If xx=10 And xb=13 Or xx=13 And xb=10 Then
x=x+1
tmp=tmp & Chr (xx) & Chr (xb) & "> "
Else
tmp=tmp & Chr(xx) & "> "
End If
b=1
Else
tmp=tmp & Mid(body,x,1)
b=b+1
End If
Next
ManipulateReplyText=tmp
End Function
Thema: Spezial-Script: keine Änderung umsetzen (Gelesen 1750 mal)