Создание таблицы в RT-поле с помощью NotesRichTextTable

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

StarikStarik2705

#1
в общем не писал бы сюда если бы знал как это делать.

задача такая, нарисовал таблицу:
Код:
		REM Create a table
Dim rti As New NotesRichTextItem(Me.doc_, "RT_History")
Call rti.AppendText("Табличка")
Call rti.AddNewLine(2)
Dim rows As Integer, columns As Integer, a As Integer, b As Integer
rows = 1
columns= 5
Call rti.AppendTable(rows, columns)
REM Create a table
и теперь хочу в первые пять столбиков в ячейки таблицы что-то забить программно. как это сделать?

На форумах нашёл такой
<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">
Код:
		Dim rtnav As NotesRichTextNavigator
REM Find first table in Body item
Set rtnav = rti.CreateNavigator
If Not rtnav.FindFirstElement(RTELEM_TYPE_TABLE) Then
MessageBox "Body item does not contain a table,",, _
"Error"
Exit Sub
End If 
REM Set up range and navigator for table
Dim rtRangeTable As NotesRichTextRange
Set rtRangeTable = rti.CreateRange
Call rtRangeTable.SetBegin(rtnav)
Call rtRangeTable.SetEnd(rtnav)
Dim rtNavTable As NotesRichTextNavigator
Set rtNavTable = rtRangeTable.Navigator
REM Find cells in table
Dim rtRangeCell As NotesRichTextRange
Dim rtRangePara As NotesRichTextRange	
Set rtRangeCell = rti.CreateRange
Set rtRangePara = rti.CreateRange

Dim cellCounter As Long
cellCounter = 0
Call rtNavTable.FindFirstElement(RTELEM_TYPE_TABLECELL)
Call	rti.Update
Dim rtpStyle As NotesRichTextParagraphStyle
Do			
Call rti.BeginInsert( rtNavTable )
Call rti.AppendParagraphStyle(rtpStyle)
Call rti.AppendText("Дописываем какойто текст")
Call rti.EndInsert
'msg= "" 
cellCounter = cellCounter + 5

REM Set up range and navigator for cell
Call rtRangeCell.SetBegin(rtNavTable)
Call rtRangeCell.SetEnd(rtNavTable)
Dim rtNavCell As NotesRichTextNavigator
Set rtNavCell = rtRangeCell.Navigator

Loop While rtNavTable.FindNextElement(RTELEM_TYPE_TABLECELL)
который в первые две ячейки пишет "Дописываем какой-то текст", но мне бы хотелось почётче, другой вопрос, что сам разбираться буду очень долго, если кто может объясните как пользоваться этими методами.
 

NickProstoNick

Статус как статус :)
Lotus team
22.08.2008
1 802
21
#2
Тю... ну так в чем вопрос?
Берешь этот код, тестируешь его в отладчике и разбираешься как это работает. :mellow:
 

VladSh

начинающий
Lotus team
11.12.2009
1 260
5
#3
Класс NotesRichTextTable, см. пример. Но для установленных законом форм пользоваться не советую, т.к. нет возможности жёсткой установки размеров колонок и строк.
 
S

StarikStarik2705

#5
Протестировал и в общем выход нашёл, спасибо но теперь гомно в другом.
<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">
Код:
		Set RTItem = New NotesRichTextItem(doc, \"RT_History\")
Let RTItem.SaveToDisk = False
Set Black = s.CreateRichTextStyle
Let Black.NotesColor = COLOR_BLACK
Set Green = s.CreateRichTextStyle
Let Green.NotesColor = COLOR_DARK_GREEN
Set Blue = s.CreateRichTextStyle
Let Blue.NotesColor = COLOR_DARK_BLUE
Set Bold = s.CreateRichTextStyle
Let Bold.Bold = True
Let Bold.FontSize = 8
Set Regular = s.CreateRichTextStyle
Let Regular.Bold = False
Let Regular.FontSize = 8


Dim flag As Boolean \' что бы один раз заголовок в цикле нарисовать
Dim DataTime As NotesItem
flag = false

Set Styles(\"Header\") = New MyNotesCellHeaderStyle
Set Styles(\"Data\") = New MyNotesCellDataStyle
Set Styles(\"Red\") = New MyNotesCellRedStyle
Set Styles(\"Green\") = New MyNotesCellGreenStyle
Set Styles(\"Gray\") = New MyNotesCellGrayStyle
Set Styles(\"Link\") = New MyNotesCellLinkStyle

CurentRow = 1
Dim XTable1 As XTable

\'	If XTable.rowCount > 1 Then
\'		CurentRow = XTable.rowCount + 1
\'	Else
\'		CurentRow = 1
\'	End If

Set XTable = New XNotesTable(CurentRow, 5)
ForAll x In fieldsListContent
If  Not equal(x,(fieldsListSaveChange(ListTag(x)))) then	
Set DataTime = doc.Getfirstitem(ListTag(x))			
\'определим сколько строк в таблице будет	 
CurentRow = CurentRow + 1 
If CurentRow > 1 Then		
Dim tableStyle As New MyNotesTableStyle(7)
Set XTable.Style = tableStyle						
If Not flag Then
XTable.row(1).column(1).value = \"Дата и время изменения\"
XTable.row(1).column(2).value = \"Изменено поле\"
XTable.row(1).column(3).value = \"Старое значение\"
XTable.row(1).column(4).value = \"Новое значение\"
XTable.row(1).column(5).value = \"Автор изменения\"
Set XTable.row(1).style = Styles(\"Header\")
flag = true
End If	
XTable.row(CurentRow).column(1).value = DataTime.Lastmodified
XTable.row(CurentRow).column(2).value = DataTime.Name
XTable.row(CurentRow).column(3).value = x(0)
XTable.row(CurentRow).column(4).value = Join(fieldsListSaveChange(ListTag(x)))
XTable.row(CurentRow).column(5).value = s.Effectiveusername
Set XTable.row(CurentRow).style = Styles(\"Data\")
End If
End If
end ForAll



If CurentRow > 1 Then		
Call XTable.InsertToRTItem(RTItem)		
End If


код рисует, таблицу, пять колонок, ну и то что мне надо, но сохранив док, закрыв его, и потом снова открыв увидел таблицу. почему не возможно проверить потом в РТ поле что там есть таблица или нет? 
Dim rti As NotesRichTextItem
Set rti = doc.GetFirstItem(\"RT_History\")
Dim rtnav As NotesRichTextNavigator
Set rtnav = rti.CreateNavigator
If Not rtnav.FindFirstElement(RTELEM_TYPE_TABLE) Then
Messagebox \"Body item does not contain a table,\",, \"Error\"
Exit Sub
End If
выдаёт упорно ошибку что таблицы там нет
что посоветуете?
 

savl

Lotus team
28.10.2011
2 131
102
#6
Это не баг, а фича. Так оно и работает. RT поля не существует до сохранения документа, только после.
 
S

StarikStarik2705

#7
Это не баг, а фича. Так оно и работает. RT поля не существует до сохранения документа, только после.
шутка была в том что, я его сохранил, переоткрыл, а таблицу не видит хоть ты ....в общем проблему решил
<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">
Код:
On Error GoTo errorProc1

Dim i As Long


Set Me.s=New NotesSession()
Set Me.db=Me.s.Currentdatabase
Set Me.doc_=doc		
If Trim(ListF)="" Then
ReDim ME.fieldsNameList_(0)
Me.fieldsNameList_(0)=""
Else
Me.fieldsNameList_=Split(ListF,";")			
End If
If (Me.fieldsNameList_(0))<>"" Then
For i=LBound(Me.fieldsNameList_) To UBound(Me.fieldsNameList_)
fieldsListSaveChange(Me.fieldsNameList_(i))=Me.doc_.Getitemvalue(Me.fieldsNameLi
st_(i))
Next
End If	

Dim tableStyle As New MyNotesTableStyle(7)

If doc.Getfirstitem("RT_History") Is Nothing Then
Set RTItem = new NotesRichTextItem(doc, "RT_History")
Let RTItem.SaveToDisk = False
Else
Set RTItem = doc.Getfirstitem("RT_History")
End If

Set Black = s.CreateRichTextStyle
Let Black.NotesColor = COLOR_BLACK
Set Green = s.CreateRichTextStyle
Let Green.NotesColor = COLOR_DARK_GREEN
Set Blue = s.CreateRichTextStyle
Let Blue.NotesColor = COLOR_DARK_BLUE
Set Bold = s.CreateRichTextStyle
Let Bold.Bold = True
Let Bold.FontSize = 8
Set Regular = s.CreateRichTextStyle
Let Regular.Bold = False
Let Regular.FontSize = 8


Dim flag As Boolean ' что бы один раз заголовок в цикле нарисовать
Dim DataTime As NotesItem

flag = false

Set Styles("Header") = New MyNotesCellHeaderStyle
Set Styles("Data") = New MyNotesCellDataStyle
Set Styles("Red") = New MyNotesCellRedStyle
Set Styles("Green") = New MyNotesCellGreenStyle
Set Styles("Gray") = New MyNotesCellGrayStyle
Set Styles("Link") = New MyNotesCellLinkStyle

CurentRow = 1

Set XTable = New XNotesTable(CurentRow, 5)
ForAll x In fieldsListContent
If  Not equal(x,(fieldsListSaveChange(ListTag(x)))) then	
Set DataTime = doc.Getfirstitem(ListTag(x))			
'определим сколько строк в таблице будет	 
CurentRow = CurentRow + 1 
If CurentRow > 1 Then		
'Dim tableStyle As New MyNotesTableStyle(7)
Set XTable.Style = tableStyle						
If Not flag Then
XTable.row(1).column(1).value = "Дата и время изменения"
XTable.row(1).column(2).value = "Изменено поле"
XTable.row(1).column(3).value = "Старое значение"
XTable.row(1).column(4).value = "Новое значение"
XTable.row(1).column(5).value = "Автор изменения"
Set XTable.row(1).style = Styles("Header")
flag = true
End If	
XTable.row(CurentRow).column(1).value = DataTime.Lastmodified
XTable.row(CurentRow).column(2).value = DataTime.Name
XTable.row(CurentRow).column(3).value = x(0)
XTable.row(CurentRow).column(4).value = Join(fieldsListSaveChange(ListTag(x)))
XTable.row(CurentRow).column(5).value = s.Effectiveusername
Set XTable.row(CurentRow).style = Styles("Data")
End If
End If
end ForAll

If CurentRow > 1 Then		
Call XTable.InsertToRTItem(RTItem)		
End If


Call doc.Save( True, False )	

endofsub:
Exit Sub
errorproc1:
MsgBox "Error #" & Err & " on line " & Erl & " in SL HistoryChangeData --> Class HistoryChange --> " & LSI_Info(2) & " : " & Error, 48, "Runtime error"
Resume endofsub
думаю может кому и пригодиться
спасибо вам
 

VladSh

начинающий
Lotus team
11.12.2009
1 260
5
#8
Если бы ещё и классы, начинающиеся с MyNotes_, то возможно и пригодилось бы :mellow:
 
S

StarikStarik2705

#9
Если бы ещё и классы, начинающиеся с MyNotes_, то возможно и пригодилось бы :)
<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">
Код:
Option Declare
Option Public

Private FAIL_ON_NONE_EXISTING_CELL As Boolean
Public Class X_Table
Private style_ As XStyle


Public Property Set Style As XStyle
Set me.style_ = Style
End Property

Public Property Get Style As XStyle
Set Style = me.style_
End Property
End Class
Public Class XCell As X_Table

Private value_ As Variant
Private type_ As String
%REM
Property Set Value
Description: Comments for Property Set
%END REM
Public Property Set Value
me.value_ = Value
End Property

Public Property Get Value
Value = me.value_
End Property

Public Property Set cellType As String
me.type_ = cellType
End Property

Public Property Get cellType As String
cellType = me.Type_
End Property

Public Property Get StrValue As String
StrValue = CStr(me.value_)
End Property

End Class
%REM
Class XRow
Description: Comments for Class
%END REM
Public Class XRow As X_Table

Private cells_ List As XCell
Private columnCount_ As Integer

Public Sub New(column As Integer)
Dim i As Integer
For i = 1 To column
Set me.cells_(CStr(i)) = New XCell()
Next
columnCount_ = column
End Sub

Public Function column(colnumber As Integer) As XCell
If columnCount_< colnumber Then
If FAIL_ON_NONE_EXISTING_CELL Then
Error 1002, "XRow: Несуществующая ячейка"
Else
'TODO: Обработка добавления Столбцов
End If
End If
If IsElement(cells_(CStr(colnumber))) Then
Set column = cells_(CStr(colnumber))
End If
End Function

Public Function SetColumn(colnumber As Integer, Cell As XCell) As XCell
If columnCount_< colnumber Then
If FAIL_ON_NONE_EXISTING_CELL Then
Error 1002, "XRow: Несуществующая ячейка"
Else
'TODO: Обработка добавления Столбцов
End If
End If
If IsElement(cells_(CStr(colnumber))) Then
Set cells_(CStr(colnumber)) = Cell
Set SetColumn = Cell
End If
End Function

%REM
Function SetRowValues
Description: Comments for Function
%END REM
Public Property Set Values
Dim tmp As Variant
tmp = Values
If Not(IsArray(tmp)) Then
Error 1002, "XRow, Values: ожидается массив"
End If

Dim i As Integer

If UBound(tmp) + 1 > columnCount_ Then
If FAIL_ON_NONE_EXISTING_CELL Then
Error 1002, "XRow: Несуществующая ячейка"
Else
'TODO: Обработка добавления Столбцов
End If
End If

For i = LBound(tmp) + 1 To UBound(tmp) + 1
me.cells_(i).Value = tmp(i - 1)
Next		
End Property

End Class

%REM
Class XColor
Description: Comments for Class
%END REM
Public Class XStyle
%REM
Sub Apply
Description: Comments for Sub
%END REM
Public Function Apply(inParam As Variant) As Variant

End Function
End Class
%REM
Class XTable
Description: Comments for Class
%END REM
Public Class XTable As X_Table

Private rows_ List As XRow
Private rowCount_ As Integer
Private columnCount_ As Integer

%REM
Sub New
Description: Comments for Sub
%END REM
Public Sub New(rows As Integer, column As Integer)
Dim i As Integer
For i = 1 To rows
Set me.rows_(CStr(i)) = New XRow(column)
Next		
me.rowCount_ = rows
me.columnCount_ = column
End Sub

%REM
Function row
Description: Comments for Function
%END REM
Public Function row(rownumber As Integer) As XRow
If rowCount_< rownumber Then
If FAIL_ON_NONE_EXISTING_CELL Then
Error 1001, "Несуществующая строка"
Else
Call addRow(rownumber)
End If
End If
If IsElement(rows_(CStr(rownumber))) Then
Set row = rows_(CStr(rownumber))
End If
End Function

%REM
Property Get rowCount_
Description: Comments for Property Get
%END REM
Public Property Get rowCount As Integer
rowCount = rowCount_
End Property


%REM
Property Get columnCount
Description: Comments for Property Get
%END REM
Public Property Get columnCount As Integer
columnCount = columnCount_
End Property

%REM
Sub addRow
Description: Comments for Sub
%END REM
Private Sub addRow(rownumber As Integer)
Dim i As Integer
For i = rowCount_ + 1 To rownumber
Set me.rows_(CStr(i)) = New XRow(columnCount_)
Next		
me.rowCount_ = rownumber
End Sub
End Class

%REM
Class XNotesTable
Description: Comments for Class
%END REM
Public Class XNotesTable As XTable 


%REM
Sub New
Description: Comments for Sub
%END REM

Public Sub New(rows As Integer, column As Integer)

End Sub

%REM
Sub InsertToRTItem
Description: Comments for Sub
%END REM
Public Sub InsertToRTItem(rtitem As NotesRichTextItem) 



'Добавляем 
If me.Style Is Nothing Then
Call rtitem.AppendTable( me.rowCount, me.columnCount,)
Else
Call rtitem.AppendTable( me.rowCount, me.columnCount,,,me.Style.Apply(Nothing) )
Call rtitem.Appendtext("11111111")
End If


Dim rtNav As NotesRichTextNavigator
Set rtNav = rtitem.CreateNavigator

Call rtNav.GetFirstElement(RTELEM_TYPE_TABLE)

Dim rtTable As NotesRichTextTable
Set rtTable= rtNav.GetElement

Call me.Style.Apply(rtTable)

Call rtNav.FindFirstElement(RTELEM_TYPE_TABLECELL)

Dim i As Integer, j As Integer

For i = 1 To me.rowCount
For j = 1 To me.columnCount
Call rtitem.BeginInsert( rtNav )				
If Not me.row(i).Style Is Nothing Then
Call rtitem.Appendstyle(me.row(i).Style.Apply(rtitem))
End If								
If Not me.row(i).column(j).Style Is Nothing Then
Call rtitem.Appendstyle(me.row(i).column(j).Style.Apply(rtitem))
End If			

If me.row(i).column(j).cellType = "Link" Then
Dim tmp As Variant
Set tmp = me.row(i).column(j)
Call rtitem.AppendText( StrLeft(me.row(i).column(j).StrValue,"%Link%"))
Call rtitem.Appenddoclink(tmp.LinkDoc, "")
Call rtitem.AppendText( StrRight(me.row(i).column(j).StrValue,"%Link%") )
Else
Call rtitem.AppendText( me.row(i).column(j).StrValue )
End If				
Call rtitem.EndInsert												
Call rtNav.FindNextElement( RTELEM_TYPE_TABLECELL )						
Next
Next

End Sub
End Class
Class MyNotesTableStyle As XStyle

Private colCount_ As Integer
Private s As NotesSession

Sub New (colCount As Integer)
colCount_ = colCount
Set Me.s = New NotesSession
End Sub

Function Apply(inParam As Variant) As Variant

If inParam Is Nothing Then
Dim tableColStyles() As Variant
ReDim tableColStyles(1 To colCount_)

Dim i As Integer
For i = 1 To colCount_

Set tableColStyles(i) = s.CreateRichTextParagraphStyle
tableColStyles(i).FirstLineLeftMargin = RULER_ONE_CENTIMETER *0.1
tableColStyles(i).LeftMargin = RULER_ONE_CENTIMETER *0.1

Select Case i
Case 1
tableColStyles(i).RightMargin = RULER_ONE_CENTIMETER * 4
Case 2
tableColStyles(i).RightMargin = RULER_ONE_CENTIMETER * 4
Case 3
tableColStyles(i).RightMargin = RULER_ONE_CENTIMETER * 5					
Case 4
tableColStyles(i).RightMargin = RULER_ONE_CENTIMETER * 6
Case 5
tableColStyles(i).RightMargin = RULER_ONE_CENTIMETER * 6.8
Case Else
tableColStyles(i).RightMargin = RULER_ONE_CENTIMETER * 2.2
End Select
Next
Apply = tableColStyles
Else
Dim w As New NotesUIWorkspace
Dim doc As NotesDocument
Set doc = w.Currentdocument.Document 

Dim rtTable As NotesRichTextTable
Set rtTable = inParam
rtTable.Style = TABLESTYLE_TOP
Dim color As NotesColorObject
Set color = s.CreateColorObject

If doc.Getitemvalue("FlagForRTitem")(0) = "1" Then
color.NotesColor = color.Setrgb(255,255,255) 'если в первый столбец(шапка) нарисован, но все остальные таблицы с первого рядка должны быть в нейтральном цвете
Else
color.NotesColor = color.Setrgb(220,220,220)	
End If		
Call rtTable.SetColor( color )
color.NotesColor = COLOR_WHITE
Call rtTable.SetAlternateColor( color )

End If
End Function
End Class
' Стиль ячеек заголовка
Class MyNotesCellHeaderStyle As XStyle

Private s As NotesSession

Sub New ()
Set Me.s = New NotesSession
End Sub

Function Apply(inParam As Variant) As Variant

Dim rtItem As NotesRichTextItem
Set rtItem = inParam 

Dim nrts As NotesRichTextStyle
Set nrts = s.Createrichtextstyle()

nrts.Fontsize = 8
nrts.Bold = True
nrts.Notesfont = rtItem.Getnotesfont("Verdana", True)

nrts.PassThruHTML = False

Set Apply = nrts
End Function

End Class
' Стиль ячеек просроченного поручения
Class MyNotesCellRedStyle As XStyle

Private s As NotesSession

Sub New ()
Set Me.s = New NotesSession
End Sub

Function Apply(inParam As Variant) As Variant

Dim rtItem As NotesRichTextItem
Set rtItem = inParam 

Dim nrts As NotesRichTextStyle
Set nrts = s.Createrichtextstyle()

nrts.Fontsize = 8
nrts.Bold = False
nrts.Notesfont = rtItem.Getnotesfont("Verdana", True)
nrts.Underline = False

Dim color As NotesColorObject
Set color = s.CreateColorObject
nrts.NotesColor = color.SetRGB(255, 0, 0)

nrts.PassThruHTML = False

Set Apply = nrts
End Function

End Class
' Стиль ячеек исполненного поручения
Class MyNotesCellGreenStyle As XStyle
Private s As NotesSession

Sub New ()
Set Me.s = New NotesSession
End Sub

Function Apply(inParam As Variant) As Variant

Dim rtItem As NotesRichTextItem
Set rtItem = inParam 

Dim nrts As NotesRichTextStyle
Set nrts = s.Createrichtextstyle()

nrts.Fontsize = 8
nrts.Bold = False
nrts.Notesfont = rtItem.Getnotesfont("Verdana", True)
nrts.Underline = False

Dim color As NotesColorObject
Set color = s.CreateColorObject
nrts.NotesColor = color.SetRGB(0, 128, 0)

nrts.PassThruHTML = False

Set Apply = nrts
End Function
End Class

' Стиль ячеек дочернего поручения
Class MyNotesCellGrayStyle As XStyle
Private s As NotesSession

Sub New ()
Set Me.s = New NotesSession
End Sub

Function Apply(inParam As Variant) As Variant

Dim rtItem As NotesRichTextItem
Set rtItem = inParam 

Dim nrts As NotesRichTextStyle
Set nrts = s.Createrichtextstyle()

nrts.Fontsize = 8
nrts.Bold = True
nrts.Notesfont = rtItem.Getnotesfont("Verdana", True)
nrts.Underline = False

Dim color As NotesColorObject
Set color = s.CreateColorObject
nrts.NotesColor = color.SetRGB(128, 128, 128)

nrts.PassThruHTML = False

Set Apply = nrts
End Function

End Class

' Стиль ячеек таблицы
Class MyNotesCellDataStyle As XStyle
Private s As NotesSession

Sub New ()
Set Me.s = New NotesSession
End Sub
Function Apply(inParam As Variant) As Variant

Dim rtItem As NotesRichTextItem
Set rtItem = inParam 


Dim nrts As NotesRichTextStyle
Set nrts = s.Createrichtextstyle()

nrts.Fontsize = 8
nrts.Bold = False
nrts.Notesfont = rtItem.Getnotesfont("Verdana", True)
nrts.Underline = False

Dim color As NotesColorObject
Set color = s.CreateColorObject
nrts.NotesColor = color.SetRGB(0, 0, 0)

nrts.PassThruHTML = False

Set Apply = nrts
End Function

End Class

' Стиль ячеек таблицы
Class MyNotesCellLinkStyle As XStyle
Private s As NotesSession

Sub New ()
Set Me.s = New NotesSession
End Sub

Function Apply(inParam As Variant ) As Variant

Dim rtItem As NotesRichTextItem
Set rtItem = inParam 

Dim nrts As NotesRichTextStyle
Set nrts = s.Createrichtextstyle()	
nrts.Underline =True

Dim color As NotesColorObject
Set color = s.CreateColorObject
nrts.NotesColor = color.SetRGB(33, 129, 255)

Set Apply = nrts
End Function

End Class
'</Стили объекта таблицы>

Class LinkCell As XCell
Public LinkDoc As NotesDocument 

Public Sub New()
cellType = "Link"
End Sub

End Class