1

Тема: Парсинг 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

Поделиться