Тема: Парсинг XML и выгрузка вложений из данного XML файла.
Сделал скрипт, который во входящем доке парсит xml и вытаскивает все приложения в документ.
не у всех же юзеров обычно стоит прога для просмотра XML с большими вложениями.
Кнопочка выгружет с поля "attach" в папку "C:\XML\" все приложения с тега "application".
Приложения крепятся рядом с существующей XML в поле "attach".
Use "libBase64"
Use "GSS"
Sub Click(Source As Button)
On Error Goto ErrH
Dim session As New NotesSession
Dim db As NotesDatabase
Dim ws As New NotesUIWorkspace
Dim uidoc As NotesUIDocument
Dim doc As NotesDocument
Dim rtitemA As NotesRichTextItem
Dim nam As String, namout As String ' откуда куда
Dim strm As NotesStream
Dim outputStream As NotesStream
Dim domParser As NotesDOMParser
Dim docNode As NotesDOMNode
Set db = session.CurrentDatabase
Set uidoc = ws.CurrentDocument
Set doc = uidoc.Document
dpatch$ = "C:\XML\"
If doc.HasEmbedded Then
Set rtitemA = doc.GetFirstItem("attach" )
If Isempty( rtitemA.EmbeddedObjects) Then
Messagebox "В документе нет xml"
Exit Sub
Else
Forall obj In rtitemA.EmbeddedObjects
If ( obj.Type = EMBED_ATTACHMENT ) Then
If Lcase(Strrightback(obj.Source , ".")) = "xml" Then
'Messagebox "все вложения допустимые"
Call obj.ExtractFile( dpatch$ & obj.Source ) ' тоже фиг обработаешь ((
oname$ = dpatch$ & obj.Source
Print oname$
Set strm = session.CreateStream()
Set outputStream =session.CreateStream()
Call strm.Open(oname$, "UTF-8" )
Set domParser=session.CreateDOMParser(strm, outputStream)
domParser.Process
Set docNode = domParser.Document
Print "Старт XMLTree"
Call XMLTree(docNode,doc)
Print "Конец XMLTree"
strm.Close
Kill oname$
doc.ReplaceItemValue({SaveOptions},{0}).SaveToDisk=False
Call uidoc.Close
'Call doc.save(1,1)
Call ws.EditDocument(True, doc) ' False - чтение
If doc.empty(0) = "" Then
Msgbox "Нет приложений в XML"
Else
Call uidoc.FieldSetText("empty","") ' не работает ((((
Msgbox "Вложение прикреплено"
End If
End If
End If
End Forall
End If
End If
Exit Sub
ErrH:
Print "Ошибка получения вложения XML " & Error(Err) & " в строке " & Erl
End SubФункция XMLTree
Sub XMLTree(docNode As NotesDOMNode, doc As NotesDocument)
'Print "XMLTree"
On Error Goto ErrH
Dim ndnChild As NotesDOMNode
Dim ndnChild2 As NotesDOMNode
Dim eNode As NotesDOMElementNode
Dim numChildNodes As Integer, i As Integer, numAttributes As Integer, numChildren As Integer
Dim ndnnmAttrs As NotesDOMNamedNodeMap
Dim ndan As NotesDOMAttributeNode
If Not docNode.IsNull Then
Select Case docNode.NodeType
Case DOMNODETYPE_DOCUMENT_NODE: ' КОРНЕВОЙ УЗЕЛ
Print docNode.NodeName & " DOCUMENT_NODE"
Set ndnChild = docNode.FirstChild
numChildNodes = docNode.NumberOfChildNodes
While numChildNodes > 0
Call XMLTree(ndnChild,doc)
Set ndnChild = ndnChild.NextSibling
numChildNodes = numChildNodes - 1
Wend
Case DOMNODETYPE_ELEMENT_NODE:
Set eNode = docNode
'Print eNode.Tagname & " ELEMENT_NODE"
Set ndnChild = docNode.FirstChild
numChildNodes = docNode.NumberOfChildNodes
If docNode.ParentNode.NodeName = "application" And docNode.Nodename = "a" Then ' ВЛОЖЕНИЕ
Print "АТТАЧ"
Print docNode.Attributes.NumberOfEntries
Set ndnnmAttrs = docNode.Attributes
For i = 1 To docNode.Attributes.NumberOfEntries ' имя файла вложения
Set ndan = ndnnmAttrs.GetItem(i)
If ndan.NodeName = "download" Then
myfilename$ = ndan.NodeValue
Print "Файл " &myfilename$
Call doc.ReplaceItemValue("empty",myfilename$)
End If
Next
For i = 1 To docNode.Attributes.NumberOfEntries
Set ndan = ndnnmAttrs.GetItem(i)
If ndan.NodeName = "href" Then
Print "Атрибут " & ndan.NodeName & " - значение - " & Left (ndan.NodeValue, 40)
Dim plainText As String
' сохраняем в поток
oname$ = "C:\XML\" & myfilename$
strbase64$ = Strrightback( ndan.NodeValue, "base64,")
Print Left (strbase64$, 40)
Dim db As NotesDatabase
Dim session As New NotesSession
Dim docNew As NotesDocument
Dim mime As NotesMIMEEntity
Dim streamlnput As NotesStream
Set streamlnput= session.CreateStream 'создаем поток под ввод в него текста для MIME-содержимого
Dim streamOutput As NotesStream
Set streamOutput= session.CreateStream ' получения текста из MIME-содержимого
Set db = session.CurrentDatabase
Set docNew= New NotesDocument (db )
session.ConvertMIME = False 'запрещаем преобразование MIME_PART в rich text
Set mime = docNew.CreateMIMEEntity
If Not (mime Is Nothing) Then
'Call streamlnput.open (oname$)
Call streamOutput.Open(oname$, "binary") ' в поток inStream файл
Call streamlnput.WriteText( strbase64$ ) 'печатаем текст в поток
Call mime.SetContentFromText( streamlnput, {text/html; charset="KOI8-R"}, ENC_BASE64 )
Call mime.GetContentAsText( streamOutput, True ) 'получаем MIME-содержимое в поток
Call streamlnput.Close() 'закрываем входной поток
Call streamOutput.Close() 'закрываем выходной поток
session.ConvertMIME = True 'разрешаем преобразование MIME_PART в rich text
End If
End If
Next
Dim rtitem As NotesRichTextItem
Dim object As NotesEmbeddedObject
Set rtitem = doc.GetFirstItem( "attach" )
Set object = rtitem.EmbedObject (EMBED_ATTACHMENT, "",oname$)
Kill oname$
If Not docNode.FirstChild.isNull Then
Print Cstr(docNode.NodeValue)
Print Cstr(docNode.FirstChild.NodeValue)
End If
End If
While numChildNodes > 0
Call XMLTree(ndnChild,doc)
Set ndnChild = ndnChild.NextSibling
numChildNodes = numChildNodes - 1
Wend
Case DOMNODETYPE_TEXT_NODE:
'Print "текст:" & docNode.NodeValue
Case DOMNODETYPE_ATTRIBUTE_NODE
'Print "атрибут:" & docNode.NodeValue
End Select
End If
Exit Sub
ErrH:
Print "XMLTree: " & Err, Error & { в строке } & Erl & { ошибка } & Error(Err)
End Sub