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
