Создание Кнопки Hotspot Внутри Richполя

  • Автор темы StarikStarik2705
  • Дата начала
S

StarikStarik2705

#1
есть такой клас, что он делает? он <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">
Код:
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 кто знает в чём беда? кто то сталкивался с такой задачей?
 

NickProstoNick

Статус как статус :)
Lotus team
22.08.2008
1 809
21
#2
Пост не в тему.
Да и информации мало.. Хотя бы описал что происходит или не происходит... или ты предлагаешь тут сидеть и отлаживать твой код?
 
S

StarikStarik2705

#3
Пост не в тему.
Да и информации мало.. Хотя бы описал что происходит или не происходит... или ты предлагаешь тут сидеть и отлаживать твой код?
нет я не предлагаю мне код отладить или ещё что то, информации сколько есть, впихнуть в таблицу нарисованую методом рич текста кнопку Хотспот. я спросил просто сталкивался ли кто что за лажа или нет? может решал кто то и подкинет идею возможно ли это вообще

Добавлено:
Пост не в тему.
Да и информации мало.. Хотя бы описал что происходит или не происходит... или ты предлагаешь тут сидеть и отлаживать твой код?

я хочу програмно сделать хотспот с нужным мне кодом внутри, и что бы кнопка эта в ячейк таблицы была. На XML таблицу я нарисовал всё в порядке, но вот как туда теперь хот спот всунуть я не знаю, вот и вопрос родился может кто посоветует что почитать или варианты предложит
 

ToxaRat

Чёрный маг
Lotus team
06.11.2007
3 231
18
#4
предпочитаю DXML делаю ричтекст от руки
а потом нужное повторяю программным способом :rolleyes:
 

savl

Lotus team
28.10.2011
2 136
105
#5
CтарыйStarik
Да, этот код вставляет в письмо или другой док с RT хотспот.
Вот эта часть формирует код внутри кнопки:
Код:
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
Надо вот эту строку result = button.AppendButton(body) вызвать в нужной ячейке, тогда добавится хотспот.

ToxaRat, по сути этот класс так и написан был. Сделали и повторили :rolleyes:
 

savl

Lotus team
28.10.2011
2 136
105
#6
CтарыйStarik
Надо в обработчик ошибки, где показывается строка добавить лог импортера.
Еще лучше посмотреть что там за код генерится и пытается вставить, думаю есть запрещенный символ.
 
S

StarikStarik2705

#7
CтарыйStarik
Да, этот код вставляет в письмо или другой док с RT хотспот.
Вот эта часть формирует код внутри кнопки:
Код:
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
Надо вот эту строку result = button.AppendButton(body) вызвать в нужной ячейке, тогда добавится хотспот.

ToxaRat, по сути этот класс так и написан был. Сделали и повторили :rolleyes:

я её и вызвал в нужной строке. Результат - в ячейке появились фразы :
<?xml version='1.0'?>
<DXLImporterLog>
</DXLImporterLog>
 

savl

Lotus team
28.10.2011
2 136
105
#8
А продебажить? или print XmlConvert(label)
А еще лучше весь этот xml сохранить в файлик и посмотреть, тем же notepad++

Добавлено: Весь код сохраняется в переменную dxl, вот ее записать в файл и посмотреть или msgbox'ом вывести
 
S

StarikStarik2705

#9
А продебажить? или print XmlConvert(label)
А еще лучше весь этот xml сохранить в файлик и посмотреть, тем же notepad++

Добавлено: Весь код сохраняется в переменную dxl, вот ее записать в файл и посмотреть или msgbox'ом вывести

<div class="sp-wrap"><div class="sp-head-wrap"><div class="sp-head folded clickable">"Code"</div></div><div class="sp-body"><div class="sp-content">
Код:
Function CreateNewButton(s As NotesSession, this_db As NotesDatabase) As NotesDocument

On Error Goto ErrorHandler

Dim newdoc As NotesDocument
Dim stream As NotesStream
Dim dmp As NotesDXLImporter

Set stream = s.CreateStream


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><code event="click"><lotusscript> msgbox "111" </lotusscript></code>Open </button>

</par>
</richtext>
</item>
</document>
</database>
}


Set dmp = s.CreateDXLImporter(stream, this_db)
dmp.DocumentImportOption = DXLIMPORTOPTION_CREATE
dmp.Process

Dim tmpNoteID As String
tmpNoteID = dmp.GetFirstImportedNoteID()


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


endsub:
Exit Function
ErrorHandler:	
Msgbox " ошибка на.. >> Error " & Error & " on " & Erl
Resume endsub
End Function


у меня вопрос, как методами XML сформировать кнопку? 
есть такой 

<&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> msgbox "111" </lotusscript></code>
Open </button>

</par>
</richtext>
</item>
</document>
</database>
но она начесто вешает Лотус. почему не занаю. 
я делал как говорили, выгрузил ДХЛ посмотрел, даже записал в него что то новое, но всё равно не понятна логика добавления тегов, не могу понять как мне всунуть в ту ячейку ьаблици что я хочу Хотспот. Пример моего кода такой 

я взял ноду таблицы, единственую, и к ней принудительно присоиденил ещё строку с моим хотспотом. Вроде всё не плохо, но вот если я хочу в другую ячейку что добавить плюёться, и почему ума не приложу
If Trim(child.NodeName) = "table" Then															
Dim newcell As String
Dim hotspot As String
Dim value As String
hotspot = |<tablerow><tablecell><par def='2'/>
<pardef id="6" /> <par def="2"> 	
<actionhotspot hotspotstyle='none'>Click me!
<code event='click'>
<lotusscript>
Sub Click(Source As Button)	
Msgbox {Hello!}
End Sub
</lotusscript>
</code>
</actionhotspot>
</par>
</tablecell></tablerow>|
newcell = Strleft(Strrightback(dxl,"<tablerow>"),"</tablerow>")
Set newChild = domParser.Document.CreateTextNode("tablerow")											
newChild.NodeValue	= hotspot
Call child.AppendChild(newChild)												
End If
 
S

StarikStarik2705

#10
есть продвижение) кнопка готова и кладёться в рич текст с таким кодом как хочу
но возник вопрос....а как её засунуть в ячейку таблици? нарисованой рич методами, да и возможно такое?<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">
Код:
Sub Click(Source As Button)
On Error Goto errsub

Dim s As New NotesSession
Dim doc As NotesDocument	
Dim button As NotesDocument	
Dim ws As New NotesUIWorkspace
Dim this_db As NotesDatabase
Dim rtitem As NotesRichTextItem

Set this_db = s.CurrentDatabase
Set doc = ws.CurrentDocument.Document

Set rtitem = doc.GetFirstItem(\"Body\")
If rtitem Is Nothing Then
Set rtitem = New NotesRichTextItem(doc, \"Body\")
End If
Call CreateNewButton(s, this_db , rtitem) 

\'Call rtitem.Update

Call doc.Save(True,False)



Dim unid As String
Dim db As NotesDatabase
Dim SourceDoc As NotesUIDocument	
Set SourceDoc = ws.CurrentDocument
Set db = this_db
unid=Cstr(doc.UniversalID)
Delete doc
Call SourceDoc.Close()
Set doc=db.GetDocumentByUNID(unid)
Call ws.EditDocument(True,doc)	

endsub:
Exit Sub
errsub:
Msgbox \" ошибка на.. >> Error \" & Error & \" on \" & Erl
Resume endsub
End Sub
Function CreateNewButton(s As NotesSession, this_db As NotesDatabase, rt As NotesRichTextItem) 
\' Purpose: Build a document using DXL and import into the current database and return the new document


\'url$ = \"?OpenAgent\"
On Error Goto ErrorHandler

Dim newdoc As NotesDocument
Dim stream As NotesStream
Dim dmp As NotesDXLImporter

Set stream = s.CreateStream


stream.WriteText |<?xml version=\'1.0\' encoding=\'utf-8\' ?>

<database xmlns=\'http://www.lotus.com/dxl\' version=\'8.5.3\'> 

<document form=\'JournalEntry\'> 

<item name=\'Subject\'><text>DXL demo</text></item>

<item name=\'Body\'>

<richtext>

<par>

<actionhotspot hotspotstyle=\'none\'>Click me!
<code event=\'click\'>
<lotusscript>
Sub Click(Source As Button)	
msgbox {1111}
end sub
</lotusscript>
</code>
</actionhotspot>

</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
tmpNoteID = dmp.GetFirstImportedNoteID()

\' Get the document by the NoteID and return it
Set newdoc = this_db.GetDocumentByID(tmpNoteID)
Call rt.AppendRTItem(newdoc.GetFirstItem(\"Body\")			)
\'	If Not (newdoc Is Nothing) Then
\'	Set CreateNewButton = newdoc
\'	Else
\'		Messagebox \"New document could not be found.\", 0, \"ERROR\"
\'	End If
\'	
Exit Function


endsub:
Exit Function
ErrorHandler:	
Msgbox \" ошибка на.. >> Error \" & Error & \" on \" & Erl
Resume endsub
End Function
 

savl

Lotus team
28.10.2011
2 136
105
#11
Судя по работе кода, я был не прав в самом начале.

Сам DXL - это документ с RT-полем "Body" и кнопкой в нем.
Код записывается в dxl и импортируется в базу, во временный документ.
Затем из этого временного документа поле "Body", добавляется в RT-поле основного документа.
Получается, что бы добавить кнопку в ячейку таблицы надо создать таблицу в dxl и в нужной ячейке вставлять код кнопки.
Но это подойдет если таблицы не было в основном документе.

Если же таблица была, то надо будет выгружать основной документ в DXL, пропарсить его и в нужных ячейках вставить кнопки.
Затем сделать импорт DXL
 

lmike

нет, пердело совершенство
Lotus team
27.08.2008
6 586
272
#12
надо убрать код под спойлер и обернуть тегами <code=vbscript></code>
 

lmike

нет, пердело совершенство
Lotus team
27.08.2008
6 586
272
#14
как я поправил первый пост
 

lmike

нет, пердело совершенство
Lotus team
27.08.2008
6 586
272
#16
открываем в режиме редактирования первый пост, смотрим как я его исправил (теги добавил) добаляем аналогичные
в режиме полного редактирования, спойлер - это свернутый текст (под смайликами - теги)

Добавлено: спойлер добавлять "вокруг" <code></code>
 
S

StarikStarik2705

#18
Всем благодарен за отзывы и предложения, в общем то что хотел сделать получилось, нарисовал таблицу с пмощью DXLи добавил HOTSPOT с нужным мне кодо, вот пример кода если вдруг кому то надо будет решать такую задачу:


<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">
Код:
%REM
Class createTable
Description: Comments for Class
%END REM
Class TableDXL	
Private s As NotesSession
Private db As NotesDatabase
Private doc As NotesDocument	

Sub New(doc_ As NotesDocument)
On Error GoTo errorProc

Set Me.s=New NotesSession()
Set Me.db=Me.s.Currentdatabase
Set Me.doc=doc_			
endofsub:
Exit Sub
errorproc:
MsgBox "Error #" & Err & " on line " & Erl 
Resume endofsub	
End Sub

Function createHotSpot (Script As String) As String
Dim hotSpot As String
hotspot = |
<par>
<actionhotspot hotspotstyle='none'>Link to VIEW
<code event='click'>
<lotusscript>
Sub Click(Source As Button)
| & Script & | 
end sub
</lotusscript>
</code>
</actionhotspot>	
</par>
|
createHotSpot = hotspot
End Function

%REM
Sub appendRow
Description: Comments for Sub
%END REM
Function appendTable(docCol As NotesDocumentCollection,rt As NotesRichTextItem) As NotesDocument
On Error GoTo ErrorHandler
Dim tmpNoteID As String
Dim newdoc As NotesDocument
Dim stream As NotesStream
Dim dmp As NotesDXLImporter
Dim tableRow As String
Dim i As Long
Dim firstDoc As NotesDocument
Dim tempDoc As NotesDocument
Dim Script As String


Set firstDoc=docCol.GetFirstDocument
While Not (firstDoc Is Nothing)
Set tempDoc = docCol.GetNextDocument(firstdoc)
'	For i = 1 To docCol.Count
Script = |	
Const unid = "| & Trim(firstDoc.Universalid) & |"		
Dim OSV As NotesDatabase	
Dim viewOSV As NotesView
Dim mDoc As NotesDocument	
Set OSV = GetCurrentDb ("OSV", "")	
Set mDoc = OSV.getDocumentByUnid(unid)
Set viewOSV = OSV.GetView("OSVStatus")
If Not viewOSV Is Nothing Then
If Not mDoc Is Nothing Then
Call wsGL.Opendatabase(OSV.Server, OSV.FilePath, viewOSV.Aliases)

Call wsGL.Currentview.Selectdocument(mDoc)	
End If
End If|				
tableRow = tableRow	& Chr(10)& |
<tablerow> 		
<tablecell><par></par></tablecell>
<tablecell>| & createHotSpot(Script) & |</tablecell>
<tablecell><par></par></tablecell>
</tablerow>	
|
'Next			
Set firstDoc=tempDoc
Wend	

Set stream = s.CreateStream
stream.WriteText |<?xml version='1.0' encoding='utf-8' ?>
<database xmlns='http://www.lotus.com/dxl' version='8.5.3'> 
<document form='Form'> 
<item name='Subject'><text>DXL table</text></item>
<item name='Body'>
<richtext>
<table rightmargin="50%"> 
<border style="solid" width="0px" color="black" /> 	
<tablecolumn /><tablecolumn /><tablecolumn />
<tablerow> 		
<tablecell bgcolor="#C0C0C0" ><par>Ссылка на документ</par></tablecell>
<tablecell bgcolor="#C0C0C0" ><par>Переход в представление по документу</par></tablecell>
<tablecell bgcolor="#C0C0C0" ><par>Столбци поиска</par></tablecell>
</tablerow>	| & tableRow & |							
</table>	 
</richtext>
</item>
</document>
</database>	|
' Import new document with button into current database
Set dmp = s.CreateDXLImporter(stream, me.db)
dmp.DocumentImportOption = DXLIMPORTOPTION_CREATE
dmp.Process

' Get the NoteID of the newly created document
tmpNoteID = dmp.GetFirstImportedNoteID()

' Get the document by the NoteID and return it
Set newdoc = me.db.GetDocumentByID(tmpNoteID)
Call rt.AppendRTItem(newdoc.GetFirstItem("Body"))
Set appendTable = newdoc		
endsub:
Exit Function
ErrorHandler:	
MsgBox "appendTable ошибка на.. >> Error " & Error & " on " & Erl
Resume endsub
End Function		
End Class

конечно код ещё сырой и нюансов конечно же куча может быть, но в общем я доволен пока тем что есть)
 

savl

Lotus team
28.10.2011
2 136
105
#19
Код:
& Script &
Вот этот Script главное не забыть профильтровать на xml-символику.
В целом - здорово, весьма.