1 Тема от admin

  • admin
  • admin
  • Administrator
  • Неактивен
  • Зарегистрирован: 2010-04-07
  • Сообщений: 1,227
  • Репутация : 0

Тема: Выгрузка всех вложений из XML документа в rich поле.

Sub Click(Source As Button)
    ' прикрепляет в карточку в  приложение все вложения из XML дока.
    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
    flagXMLsize = "0"
   
    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" )
                        xmlsize$= strm.Bytes
                        Print xmlsize$ & " размер вложения"
                        If xmlsize$ < 4000000 Then
                            Messagebox "Вложения имеют размер менее 4 МБ. Выгрузка вложений не нужна."
                            Exit Sub
                        End If
                        Set domParser=session.CreateDOMParser(strm, outputStream)
                        domParser.Process
                        Set docNode = domParser.Document
                        Print "Старт XMLTree"
                        Call XMLTree(docNode,doc)
                        Print "Конец XMLTree"
                        strm.Close
                        Kill oname$
                       
                        Print "flagXMLsize " & flagXMLsize
                        If flagXMLsize = "0" Then
                            Msgbox "Нет вложений больше 4мб!"
                            Exit Sub
                        End If
                       
                        doc.ReplaceItemValue({SaveOptions},{0}).SaveToDisk=False
                        Call uidoc.Close
                        Call ws.EditDocument(True, doc)  '  False - чтение
                       
                        If  Fname = "" Then
                            Msgbox "Нет приложений в XML"                           
                        Else
                            Msgbox "Вложение прикреплено"
                        End If
                       
                    End If
                End If
            End Forall
        End If
    End If
   
    Exit Sub
ErrH:
    Print "Ошибка получения вложения XML " & Error(Err) & " в строке " & Erl   
End Sub

Поделиться

2 Ответ от admin

  • admin
  • admin
  • Administrator
  • Неактивен
  • Зарегистрирован: 2010-04-07
  • Сообщений: 1,227
  • Репутация : 0

Re: Выгрузка всех вложений из XML документа в rich поле.

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$
                        Fname=myfilename$
                    End If
                Next
               
                For i = 1 To docNode.Attributes.NumberOfEntries ' проход по атрибутам href с контентом
                    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.WriteText( strbase64$ ) 'печатаем текст в поток
                            Call streamOutput.Open(oname$, "binary")    ' в поток inStream файл       
                           
                            Call mime.SetContentFromText( streamlnput, {text/html; charset="KOI8-R"}, ENC_BASE64 )
                            Call mime.GetContentAsText( streamOutput, True ) 'получаем MIME-содержимое в поток streamOutput
                            xmlsize$=streamOutput.Bytes
                            Print xmlsize$
                            If xmlsize$ > 4000000 Then
                                flagXMLsize = "1"
                                Print "флаг размера 1"
                            Else
                                Print "флага размера нет"
                            End If
                            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

Поделиться