例：在rtf域里面插button

样例来自：www.nsftools.com，修改增加了javascript按钮

'RichTextButton Class:

Option Public
Option Explicit

'** possible languages we can use with SetButtonLanguage
Const RTB_LOTUSSCRIPT = 1
Const RTB_FORMULA = 2
Const RTB_JAVASCRIPT = 3

'** possible types we can use with SetEdgeType
Const RTB_SQUARE = 1
Const RTB_ROUNDED = 2

Class RichTextButton
 '** This class makes it easy to create a button that can be appended
 '** to a NotesRichTextField. Here's an example of use:
 
 '** Dim rtbutton As New RichTextButton
 '** Call rtbutton.SetLabel("Formula Button")
 '** Call rtbutton.SetButtonLanguage(RTB_FORMULA)
 '** Call rtbutton.SetCode( |@Prompt([ok]; "My Button"; "You clicked my button");| )
 '** Set rtitem = doc.GetFirstItem("Body")
 '** Call rtbutton.AppendButton(rtitem)
 
 '** version 1.2
 '** September 2, 2005
 '** Julian Robichaux -- http://www.nsftools.com
 Private label As String
 Private edgeType As Integer
 Private buttonLanguage As Integer
 Private code As String
 
 Public Sub New ()
  label = "Button"
  edgeType = RTB_ROUNDED
  buttonLanguage = RTB_JAVASCRIPT
 End Sub
 
 Public Sub SetLabel (labelText As String)
  label = labelText
 End Sub
 
 Public Sub SetEdgeType (edgeType As Integer)
  Me.edgeType = edgeType
 End Sub
 
 Public Sub SetButtonLanguage (buttonLanguage As Integer)
  Me.buttonLanguage = buttonLanguage
 End Sub
 
 Public Sub SetCode (code As String)
  Me.code = code
 End Sub
 
 Public Function XmlConvert (txt As String) As String
  '** get rid of the text characters that XML doesn't like (accented
  '** characters are usually okay, as long as you use an encoding
  '** like ISO-8859-1
  XmlConvert = txt
  XmlConvert = Replace(XmlConvert, "&", "&")
  XmlConvert = Replace(XmlConvert, "<", "&lt;")
  XmlConvert = Replace(XmlConvert, ">", "&gt;")
 End Function
 
 Function AppendButton (rtitem As NotesRichTextItem) As String
  '** This function will attempt to append a button to a given
  '** NotesRichTextItem, using code that has been assigned
  '** to this object after it has been created (using the SetCode
  '** method). The code language (as set with the SetLanguageType
  '** method) can be either LotusScript or Formula language.
  
  '** If there is an error creating the button (often because the code
  '** doesn't compile correctly), this function will return the error
  '** message. If the button is created properly, an empty string
  '** will be returned.
  On Error Goto processError
  
  '** if no rich text item was given to us, just exit without doing anything
  If (rtitem Is Nothing) Then
   Exit Function
  End If
  
  Dim session As New NotesSession
  Dim db As NotesDatabase
  Dim doc As NotesDocument
  Dim body As NotesRichTextItem
  Dim importer As NotesDXLImporter
  
  Dim buttonCode As String
  Dim buttonTag As String
  Dim dxl As String
  Dim codeStr As String
  codeStr = "<code event='click'>"

  '** LotusScript和Formula的<code>代码
  '** set up the DXL to be used for the code in the button
  
  Select Case buttonLanguage
  Case RTB_LOTUSSCRIPT
   buttonCode = |<lotusscript>Sub Click(Source As Button)
| & XmlConvert(code) & |
End Sub</lotusscript>|  
  Case RTB_FORMULA
   buttonCode = |<formula>| & XmlConvert(code) & |</formula>|
  Case RTB_JAVASCRIPT
   buttonCode = |<javascript>| & XmlConvert(code) & |</javascript>| 
   codeStr = "<code for='web' event='onClick'>"

   '** JavaScript按钮的<code>代码
  End Select
  
  buttonTag = |<button width='2in' widthtype='fitcontent' wraptext='true' |
  If (edgeType = RTB_SQUARE) Then
   buttonTag = buttonTag & | edge='square' |
  Else
   buttonTag = buttonTag & | edge='rounded' |
  End If
  buttonTag = buttonTag & | bgcolor='system'>|
  
  '** DXL that will create a temporary doc with the button we want.
  '** We're adding the current user name in an Author field on
  '** this temporary document because we'll be deleting it at the end
  '** of this function, and the user may only have Author access to
  '** this database.
  dxl = |<?xml version='1.0' encoding='ISO-8859-1'?>
  <!DOCTYPE document SYSTEM 'xmlschemas/domino_6_5.dtd'>
<document xmlns='http://www.lotus.com/dxl' version='6.5'
 replicaid='0123456789ABCDEF' form='ButtonMaker'>
<item name='DocAuthor' authors='true' names='true'>
<text>| & XmlConvert(session.CommonUserName) & |</text></item>
  <item name='Body'><richtext>
<pardef id='1'/>
<par def='1'>
| & buttonTag  & codeStr &  buttonCode & |</code>| & XmlConvert(label) & |</button></par></richtext>
  </item>
</document>|
  Msgbox dxl
  '** create a new doc using the DXL above
  Set db = session.CurrentDatabase
  Set importer = session.CreateDXLImporter(dxl, db)
  importer.ReplicaRequiredForReplaceOrUpdate = False
  importer.DocumentImportOption = DXLIMPORTOPTION_CREATE
  Call importer.Process
  
  '** get the button from the doc we just created and append it to
  '** the rich text item we were given
  Set doc = db.GetDocumentByID(importer.GetFirstImportedNoteId)
  Set body = doc.GetFirstItem("Body")
  Call rtitem.AppendRTItem(body)
  
  '** try to delete the temporary doc. In case we can't delete it for some
  '** reason, a scheduled agent should be written to globally delete
  '** docs that use the form name specified in the DXL above.
  On Error Resume Next
  Call doc.RemovePermanently(True)
  
  Exit Function
  
  
processError:
  If (importer.Log <> "") Then
   AppendButton = importer.Log
  Else
   AppendButton = "Error " & Err & " on line " & Erl & ": " & Error$
  End If
  Exit Function
 End Function
 
 
End Class

Sub Initialize
 
 '** here's an example of how to call the class
 Dim session As New NotesSession
 Dim doc As NotesDocument
 Dim rtitem As NotesRichTextItem
 Dim button1 As New RichTextButton
 Dim button2 As New RichTextButton
 Dim result As String
 
 '** grab the first selected doc in the view
' Set doc = session.CurrentDatabase.UnprocessedDocuments.GetFirstDocument
 Set doc = session.DocumentContext
 Set rtitem = doc.GetFirstItem("Body")
 If (rtitem Is Nothing) Then
  Set rtitem = New NotesRichTextItem(doc, "Body")
 End If
 
 '** append a JavaScript button to the body
 Call button1.SetLabel("JavaScript Button & Stuff")
 Call button1.SetButtonLanguage(RTB_JAVASCRIPT)
 Call button1.SetCode( |
alert("测试");
| )
 Call rtitem.AddNewline(1)
 result = button1.AppendButton(rtitem)
 If (result <> "") Then
  Call rtitem.AppendText("There was an error creating the button. " & result)
 End If
 
 '** append a Formula button to the body
 Call button2.SetLabel("Formula Button")
 Call button2.SetEdgeType(RTB_SQUARE)
 Call button2.SetButtonLanguage(RTB_FORMULA)
 Call button2.SetCode( |@Prompt([ok]; "My Button"; "You clicked my button");| )
 Call rtitem.AddNewline(1)
 result = button2.AppendButton(rtitem)
 If (result <> "") Then
  Call rtitem.AppendText("There was an error creating the button. " & result)
 End If
 
 '** save and exit
 Call doc.Save(True, True)