есть такой клас, что он делает? он <div class="sp-wrap"><div class="sp-head-wrap"><div class="sp-head folded clickable">"просто формирует кнопку внутри рич поля"</div></div><div class="sp-body"><div class="sp-content">
---------------------------
---------------------------
<?xml version='1.0'?>
<DXLImporterLog>
</DXLImporterLog>
---------------------------
ОК
---------------------------
скажу честно сам не силён ни в XML ни DXL но что то подсказывает что поламалась конструкция DXL кто знает в чём беда? кто то сталкивался с такой задачей?
Код:
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)
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_LOTUSSCRIPT
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, "<", "<")
XmlConvert = Replace(XmlConvert, ">", ">")
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
'** set up the DXL to be used for the code in the button
If (buttonLanguage = RTB_LOTUSSCRIPT) Then
buttonCode = |<lotusscript>Sub Click(Source As Button)
| & XmlConvert(code) & |
End Sub</lotusscript>|
Else
buttonCode = |<formula>| & XmlConvert(code) & |</formula>|
End If
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="UTF-8"?>
<!DOCTYPE document >
<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 & XmlConvert(label) & |
<code event='click'>| & buttonCode & |</code></button></par></richtext>
</item>
</document>|
'** create a new doc using the DXL above
Set db = session.CurrentDatabase
Set importer = session.CreateDXLImporter(dxl, db)
MsgBox importer.Log
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:
MsgBox importer.Log
If (importer.Log <> "") Then
AppendButton = importer.Log
Else
AppendButton = "Error " & Err & " on line " & Erl & ": " & Error$
End If
Exit Function
End Function
End Class
......................................................
'возникла у меня проблема когда захотел кнопку создать внутри таблицы рич поля, вот такой меседж :
Dim result As String
Dim button As New RichTextButton
Set rtNav=body.CreateNavigator
Call body.AppendTable( 1, 1 )
Call rtnav.FindFirstElement(RTELEM_TYPE_TABLECELL)
Call body.BeginInsert(rtnav)
Call button.SetLabel("1111111111")
Call button.SetButtonLanguage(RTB_LOTUSSCRIPT)
Call button.SetCode( |Messagebox "This is my <button>. " & "Don't wear it out."| )
result = button.AppendButton(body)
If (result <> "") Then
Call body.AppendText("There was an error creating the button. " & result)
End If
Call body.EndInsert---------------------------
<?xml version='1.0'?>
<DXLImporterLog>
</DXLImporterLog>
---------------------------
ОК
---------------------------
скажу честно сам не силён ни в XML ни DXL но что то подсказывает что поламалась конструкция DXL кто знает в чём беда? кто то сталкивался с такой задачей?
