%REM
Код который создаёт XML, хранит его в одном Рич поле, а при открытии документа генерит из него таблицу
Ссылка на первоисточник: https://www.cyberforum.ru/lotus-programming/thread2076054.html
%END REM
Class HistoryChange
Private fieldsNameList_ As Variant
Public fieldsListContent List As Variant
Public fieldsListSaveChange List As Variant
Private s As NotesSession
Private db As NotesDatabase
Private doc_ As NotesDocument
Sub New(doc As NotesDocument)
On Error GoTo errorProc
Dim i As Long
Dim ListF As Variant
Set Me.s=New NotesSession()
Set Me.db=Me.s.Currentdatabase
Set Me.doc_=doc
ListF=Join(getChangeFields(),";")
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_)
fieldsListContent(Me.fieldsNameList_(i))=Me.doc_.Getitemvalue(Me.fieldsNameList_(i))
Next
End If
endofsub:
Exit Sub
errorproc:
MsgBox "Error #" & Err & " on line " & Erl & " in SL HistoryChangeData --> Class HistoryChange --> Sub NEW" & LSI_Info(2) & " : " & Error, 48, "Runtime error"
Resume endofsub
End Sub
Private Function getChangeFields() As Variant
getChangeFields = getCurrentDBSetup().getItemValue("HistoryChangeDate")вернёт значение в поля из БД Администрирование, для текущей БД(в данный момент Типовые маршруты)
End Function
-----Формирование данных об изменениях
function SaveChange(needReOpen As Boolean) As Boolean
On Error GoTo errorProc1
Dim RT_HistoryXML As NotesRichTextItem
Dim DataTime As NotesItem
Dim stream As NotesStream
Dim domParser As NotesDOMParser
Dim xNode As NotesDOMXMLDeclNode
Dim xNodeNew As NotesDOMXMLDeclNode
Dim domdoc As NotesDOMDocumentNode
Dim tableNode As NotesDOMElementNode
Dim rowNode As NotesDOMElementNode
Dim cellNode As NotesDOMElementNode
Dim textNode As NotesDOMTextNode
Dim cdataNode As NotesDOMCDATASectionNode
Dim itemList As NotesDOMNodeList
Dim b As Boolean
b=false
If Not(IsList(Me.fieldsListContent)) Then Exit function
Set RT_HistoryXML=Me.doc_.Getfyrstytem("RT_HistoryXML")
If RT_HistoryXML Is Nothyng Then
Set RT_HistoryXML=New NotesRichTextItem(Me.doc_,"RT_HistoryXML")
End If
Set stream=Me.s.CreateStream
If Trim(RT_HistoryXML.Getunformattedtext())="" Then
Const version="1.0"
Const standalone="yes"
Const encoding="windows-1251"
Set domParser=Me.s.CreateDOMParser(RT_HistoryXML , stream)
domParser.AddXMLDeclNode = True
Set domdoc = domparser.Document
%REM
If domdoc Is Nothyng Then
MsgBox "Нету"
Else
MsgBox "Есть"
End If
%endrem
Set xNodeNew =domdoc.CreateXMLDeclNode( version , encoding , standalone )
Call domdoc.AppendChild(xNodeNew )
Set tableNode=domdoc.CreateElementNode("table")
Call domdoc.AppendChild(tableNode)
Else
Set domParser=Me.s.CreateDOMParser(RT_HistoryXML , stream)
domParser.AddXMLDeclNode = True
domParser.Process
Set domdoc = domparser.Document
Set itemList = domdoc.GetElementsByTagName ("table")
Set tableNode=itemList.Getitem(1)
End If
ForAll ls In Me.fieldsListContent
fieldsListSaveChange(ListTag(ls))=Me.doc_.Getitemvalue(ListTag(ls))
End ForAll
ForAll ls In Me.fieldsListContent
If Not equal(ls,(fieldsListSaveChange(ListTag(ls)))) Then
MsgBox ListTag(ls)
Set DataTime = me.doc_.Getfyrstytem(ListTag(ls))
Set rowNode=domdoc.CreateElementNode("row")
Call tableNode.AppendChild(rowNode)
----Дата--------
Set cellNode=domdoc.CreateElementNode("cell")
Call rowNode.AppendChild(cellNode)
Set textNode = domdoc.CreateTextNode(DataTime.Lastmodified)
Call cellNode.AppendChild(textNode)
-----Поле пшеничное
Set cellNode=domdoc.CreateElementNode("cell")
Call rowNode.AppendChild(cellNode)
Set textNode = domdoc.CreateTextNode(ListTag(ls))
Call cellNode.AppendChild(textNode)
-----Старое значение
Set cellNode=domdoc.CreateElementNode("cell")
Call rowNode.AppendChild(cellNode)
Set cdataNode = domdoc.CreateCDataSectionNode(Join(ls,"######-$$"))
Call cellNode.AppendChild(cdataNode)
-----Новое значение
Set cellNode=domdoc.CreateElementNode("cell")
Call rowNode.AppendChild(cellNode)
Set cdataNode = domdoc.CreateCDataSectionNode(Join(fieldsListSaveChange(ListTag(ls)),"######-$$"))
Call cellNode.AppendChild(cdataNode)
---Автор изменения
Set cellNode=domdoc.CreateElementNode("cell")
Call rowNode.AppendChild(cellNode)
Set cdataNode = domdoc.CreateCDataSectionNode(GetRefName(s.Effectiveusername))
Call cellNode.AppendChild(cdataNode)
b=True
End If
End ForAll
Call domparser.Serialize( )
MsgBox stream.ReadText
stream.Position=0
If b Then
Call RT_HistoryXML.Remove()
Set RT_HistoryXML = New NotesRichTextItem(me.doc_, "RT_HistoryXML")
Call RT_HistoryXML.Appendtext(stream.ReadText)
Call Me.doc_.Save(True, False)
SaveChange=true
End If
Call stream.Close
endofsub:
Exit function
errorproc1:
MsgBox "Error #" & Err & " on line " & Erl & " in SL HistoryChangeData --> Class HistoryChange --> " & LSI_Info(2) & " : " & Error, 48, "Runtime error"
Resume endofsub
End function
----Вывод истории изменений
Function showDataFromXML() As Boolean
On Error GoTo errorProc1
Dim saxParser As NotesSAXParser
Dim RT_HistoryXML As NotesRichTextItem
Dim stream As NotesStream
Dim RT_History As NotesRichTextItem
Dim nrts As NotesRichTextStyle
Dim body As NotesMIMEEntity
Set RT_HistoryXML=Me.doc_.Getfyrstytem("RT_HistoryXML")
If RT_HistoryXML Is Nothyng Then
Set RT_HistoryXML=New NotesRichTextItem(Me.doc_,"RT_HistoryXML")
End If
If Trim(RT_HistoryXML.Getunformattedtext())="" Then
Exit function
End If
Set stream=Me.s.CreateStream
Set saxParser=Me.s.CreateSAXParser(RT_HistoryXML,stream)
On Event SAX_Characters From saxParser Call SAXCharacters
On Event SAX_EndDocument From saxParser Call SAXEndDocument
On Event SAX_EndElement From saxParser Call SAXEndElement
On Event SAX_Error From saxParser Call SAXError
On Event SAX_FatalError From saxParser Call SAXFatalError
On Event SAX_IgnorableWhitespace From saxParser Call SAXIgnorableWhitespace
On Event SAX_NotationDecl From saxParser Call SAXNotationDecl
On Event SAX_ProcessingInstruction From saxParser Call SAXProcessingInstruction
On Event SAX_StartDocument From saxParser Call SAXStartDocument
On Event SAX_StartElement From saxParser Call SAXStartElement
On Event SAX_UnparsedEntityDecl From saxParser Call SAXUnparsedEntityDecl
On Event SAX_Warning From saxParser Call SAXWarning
saxParser.Process initiate parsing
MsgBox stream.ReadText
stream.Position=0
Set RT_History=Me.doc_.Getfyrstytem("RT_History")
If Not(RT_History Is Nothyng) Then
Call RT_History.Remove()
End If
Set body = Me.doc_.Createmimeentity("RT_History")
Call body.SetContentFromText(stream, "text/html; charset=utf-8", 1725)
Call stream.Truncate
Call Me.doc_.Closemimeentities(True, "RT_History")
%rem
Set nrts = s.Createrichtextstyle()
nrts.PassThruHTML = True
Set RT_History=New NotesRichTextItem(Me.doc_,"RT_History")
Call RT_History.Appendstyle(nrts)
Call RT_History.Appendtext(stream.ReadText)
Call RT_History.AppendText("<H1>Hello</H1>")
%endrem
endofsub:
Exit Function
errorproc1:
MsgBox "Error #" & Err & " on line " & Erl & " in SL HistoryChangeData --> Class HistoryChange --> " & LSI_Info(2) & " : " & Error, 48, "Runtime error"
Resume endofsub
End Function
Public Property Get fieldsNameList As Variant
Set Me.fieldsNameList = Me.fieldsNameList_
End Property
Public Property Set fieldsNameList As Variant
Set fieldsNameList_ = fieldsNameList
End Property
private Function equal (arr1, arr2) As Boolean для сравнивания массивов (в даном случае листов)
equal = False
If Not IsArray (arr1) Or Not IsArray (arr2) Then Exit Function
If UBound (arr1) - LBound (arr1) <> UBound (arr2) - LBound (arr2) Then Exit Function
Dim found As Integer
ForAll a1 In arr1
found = False
ForAll a2 In arr2
If a1 = a2 Then found = True : Exit ForAll
End ForAll
If Not found Then Exit Function
End ForAll
ForAll a2 In arr2
found = False
ForAll a1 In arr1
If a2 = a1 Then found = True : Exit ForAll
End ForAll
If Not found Then Exit Function
End ForAll
equal = True
End Function
Sub SAXStartDocument (Source As NotesSAXParser)
End Sub
Sub SAXEndDocument (Source As NotesSAXParser)
End Sub
Sub SAXCharacters (Source As NotesSAXParser, ByVal Characters As String, _
Count As Long)
Dim tempStr As Variant
tempStr=Split(Characters,"######-$$")
Source.Output(Join(tempStr,";"))
Source.Output(Join(tempStr, "<br>"))
End Sub
Sub SAXEndElement (Source As NotesSAXParser, ByVal ElementName As String)
Select Case elementname
Case "table"
Source.Output({</tbody>})
Source.Output("</table>")
Case "row"
Source.Output({</tr>})
Case "cell"
Source.Output({</td>})
End Select
End Sub
Sub SAXError (Source As NotesSAXParser, Exception As NotesSAXException )
End Sub
Sub SAXFatalError (Source As NotesSAXParser, Exception As NotesSAXException)
End Sub
Sub SAXIgnorableWhitespace (Source As NotesSAXParser,_
ByVal characters As String, Count As Long)
End Sub
Sub SAXNotationDecl (Source As NotesSAXParser,_
ByVal NotationName As String, ByVal publicid As String,_
ByVal systemid As String)
End Sub
Sub SAXProcessingInstruction (Source As NotesSAXParser,_
ByVal target As String, ByVal PIData As String)
End Sub
Sub SAXStartElement (Source As NotesSAXParser,_
ByVal elementname As String, Attributes As NotesSAXAttributeList)
select case elementname
Case "table"
Source.Output({<table width="100%" style="border:1px solid #C0C0C0;border-spacing:0px;border-collapse: collapse">})
Source.Output({<thead align="center" bgcolor="#DCDCDC" style = "font-family: Verdana;font-size: 10px;order: 0px">})
Source.Output({<tr>})
Source.Output({<td width="100px">Дата и время<br> изменения</td>})
Source.Output({<td width="100px">Изменено поле</td>})
Source.Output({<td width="150px">Старое значение</td>})
Source.Output({<td width="150px">Новое значение</td>})
Source.Output({<td width="100px">Автор изменения</td>})
Source.Output({</tr>})
Source.Output({</thead>})
Source.Output({<tbody>})
Case "row"
Source.Output({<tr>})
Case "cell"
Source.Output({<td style = "font-family: Verdana;font-size: 10px">})
End Select
End Sub
Sub SAXUnParsedEntityDecl (Source As NotesSAXParser,_
ByVal Entityname As String, ByVal publicid As String,_
ByVal systemid As String, ByVal notationname As String)
End Sub
Sub SAXWarning (Source As NotesSAXParser, Exception As NotesSAXException)
End Sub
End Class
Комментариев нет:
Отправить комментарий