In R6, there have been some great improvements in the accessibility of rich text fields and the various items that can exist within them (for example, tables and doc links) through LotusScript, but hotspot buttons are not one of them.
However, using DXL, you can create a hotspot button dynamically and add it to a rich text field on the fly. In this example, the user selects a number of entries from a database library, and buttons to open up each database are created in a new memo.
The code within the buttons is created when a temporary document is processed and imported, each button including the Replica ID for the individual database. The function of the buttons is not as important as the fact that each button was created from scratch.
NOTE: Similar code can be used for creating other design elements on the fly. The easiest way to learn the DXL format is to use the DXL Viewer under Tools in Designer.
Code:
(Options)
Option Public
Option Explicit
(Declarations)
' Change this to the ReplicaID of a
valid Database Library
Const LibraryDBRepID =
"0000000000000000"
Sub Initialize
' Purpose: Compose a memo with
one or more buttons containing
' dynamically-created LotusScript using DXL
On Error Goto ErrorHandler
Dim s As New NotesSession
Dim ws As New NotesUIWorkspace
Dim this_db As NotesDatabase
Set this_db = s.currentdatabase
' Open the Database Library
Dim library_db As New NotesDatabase( "", "" )
If library_db.OpenByReplicaID
( this_db.Server, LibraryDBRepID ) Then
Print( library_db.Title &
" was successfully opened" )
Else
Print( "Unable to open database" )
Exit Sub
End If
' Prompt user to select Database documents
Dim db_coll As NotesDocumentCollection
Set db_coll = ws.PickListCollection
(PICKLIST_CUSTOM, True,
this_db.Server, _
library_db.FilePath, "Databases by _Title",_
"Select Database(s)", "Please select
at least one database:" )
If db_coll.Count = 0 Then
Messagebox "No databases selected", 0, "Error"
Exit Sub
End If
Dim strDBRepID As String
Dim strDBTitle As String
Dim doc As NotesDocument
Dim newdoc As NotesDocument
Dim rtitem As NotesRichTextItem
Dim nitem As NotesItem
' Open current user's mail file and
create a new document
Dim maildb As New NotesDatabase( "", "" )
Call maildb.OpenMail
Dim memodoc As
New NotesDocument(maildb)
memodoc.form = "Memo"
memodoc.subject = "Database Access Email"
Dim body As New NotesRichTextItem
(memodoc, "Body")
Call body.AppendText
("Here are some database links:")
Call body.AddNewLine(2)
' Get the first database library document
Set doc = db_coll.GetFirstDocument
' Loop through all the selected documents,
creating buttons for each
While Not ( doc Is Nothing )
' Get the Replica ID of the Database
strDBRepID = doc.ReplicaID(0)
' It's necessary to replace any ampersands
in the Database Title with its
' HTML equivalent as DXL can't convert
special characters such as &, <, and >
' < less than = <
' > greater than = >
' & ampersand = &
strDBTitle = Replace(doc.Title(0), "&", "&")
If (strDBRepID = "") Or (strDBTitle = "") Then
Else
' Call the function to create the new
document with the button and return the
new document
Set newdoc = CreateNewButton(s, ws, this_db,
strDBRepID, strDBTitle)
' Get the Rich Text field
Set nitem = newdoc.GetFirstItem
( "tmpButtonBody" )
If ( nitem.Type = RICHTEXT ) Then
Set rtitem = nitem
' Append the newly created button
Call body.AppendRTItem( rtitem )
Else
' If there's a problem getting the
Rich Text field, print to the memo
Call body.AppendText("Error creating button.")
End If
' Delete the imported document
Call newdoc.Remove(True)
' Append the Database Title and Owner
Call body.AddTab(1)
Call body.AppendText(doc.Title(0))
Call body.AddTab(1)
Call body.AppendText("DB Owner: "
+ doc.DBOwner(0))
Call body.AddNewLine(1)
End If
' Get the next document in the collection
Set doc = db_coll.GetNextDocument (doc)
Wend
' Update the Rich Text field
Call body.Update
' Open the current memo in the UI
Dim uidoc As NotesUIDocument
Set uidoc = ws.EditDocument(True, memodoc)
Exit Sub
ErrorHandler:
Print Lsi_info(2) + " - Error #"
& Format$(Err) & " at line " &
Format$(Erl) & ": " & Error$
Messagebox Lsi_info(2) + " - Error #"
& Format$(Err) & " at line " &
Format$(Erl) & ": " & Error$, 0, "Error"
Exit Sub
End Sub
Function CreateNewButton(s As
NotesSession, ws As NotesUIWorkspace,
this_db As
NotesDatabase, strDBRepID As String,
strDBTitle As String) As NotesDocument
' Purpose: Build a document using DXL
and import into the current database and
return the new document
On Error Goto ErrorHandler
Dim newdoc As NotesDocument
Dim stream As NotesStream
Dim dmp As NotesDXLImporter
Set stream = s.CreateStream
' Build the DXL document including the
button in the Rich Text field
stream.WriteText {<&xml
version='1.0' encoding='utf-8' ?>
<database xmlns=
"http://www.lotus.com/dxl"
version="1.01">
<databaseinfo replicaid="} +
this_db.ReplicaID +
{"/>
<document form="tmpButtonProfile">
<item name='tmpButtonBody'>
<richtext>
<par>
<button width="2in" widthtype="fitcontent"
wraptext="true" bgcolor="system"
name="AccessButton"
type="normal" default="false" edge=
"rounded" readingorder="lefttoright">
<font size="9pt" style="bold" name="Arial"
pitch="variable" truetype="true"
familyid="20" />
<code event="options">
<lotusscript>Option
Explicit</lotusscript></code>
<code event="click"><lotusscript>
Sub Click(Source As Button)
'} + strDBTitle + { Access Button
On Error Goto ErrorHandler
Dim ws As New NotesUIWorkspace
Dim session As New NotesSession
Dim this_db As NotesDatabase
Dim strDBRepID As String, strDBTitle
As String, CurrentServer As String
Dim newdb As New NotesDatabase("", "")
Set this_db = session.CurrentDatabase
CurrentServer = this_db.Server
' build internal variables from external variables
strDBRepID = ModRepID("} + strDBRepID + {")
strDBTitle = "} + strDBTitle + {"
' attempt to open database on current server
If newdb.OpenByReplicaID
( CurrentServer, strDBRepID ) Then
Call ws.OpenDatabase
( CurrentServer, newdb.FilePath, "", "",
True, False )
Else
' prompt user if unsuccessful
Messagebox "Can't open " +
strDBTitle + Chr(10) + " on " +
CurrentServer + _
". Please contact the Help Desk."
End If
Exit Sub
ErrorHandler:
Messagebox "Error #" +
Format$(Err) + " at line " + Format$(Erl) + ": "
+ Error$, 0, "ERROR"
Print "Error #" + Format$(Err) + "
at line " + Format$(Erl) + ": " +
Error$
Exit Sub
</lotusscript></code>
<code event="ModRepID">
<lotusscript>
Function ModRepID
(strDatabaseRepID As String) As String
' remove colon from Replica ID
and return result
Dim FindColon As Integer
Dim RepIDStart As String
Dim RepIDEnd As String
FindColon = Instr(1, strDatabaseRepID, ":")
If FindColon > 0 Then
RepIDStart = Mid(strDatabaseRepID, 1,
FindColon - 1)
RepIDEnd = Mid(strDatabaseRepID,
FindColon + 1)
strDatabaseRepID = RepIDStart +
RepIDEnd
End If
ModRepId = strDatabaseRepID
End Function
</lotusscript></code>Open
Database</button>
</par>
</richtext>
</item>
</document>
</database>}
' Import new document with button
into current database
Set dmp = s.CreateDXLImporter
(stream, this_db)
dmp.DocumentImportOption =
DXLIMPORTOPTION_CREATE
dmp.Process
' Get the NoteID of the newly created document
Dim tmpNoteID As String
tmpNoteID = dmp.GetFirstImportedNoteID( )
' Get the document by the NoteID and return it
Set newdoc =
this_db.GetDocumentByID(tmpNoteID)
If Not (newdoc Is Nothing) Then
Set CreateNewButton = newdoc
Else
Messagebox "New document could
not be found.", 0, "ERROR"
End If
Exit Function
ErrorHandler:
' If there's a problem processing the
DXL, you will be prompted with the Row
and Column
Msgbox dmp.Log
Print Lsi_info(2) + " - Error #" & Format$(Err)
& " at line " &
Format$(Erl) & ": " & Error$
Messagebox Lsi_info(2) + " - Error #"
& Format$(Err) & " at line " &
Format$(Erl) & ": " & Error$, 0, "Error"
Exit Function
End Function
Do you have comments on this tip? Let us know.
This tip was submitted to the SearchDomino.com tip exchange by member Bryce Berry. Please let others know how useful it is via the rating scale at the end of the tip. Do you have a useful Notes/Domino tip or code to share? Submit it to our monthly tip contest and you could win a prize and a spot in our Hall of Fame.
