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

2018-10-09T06:58:18Z

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

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

2018-10-09T06:58:14Z

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

Форум компьютерной помощи — Выгрузка всех вложений из XML документа в rich поле.

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

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