Public Function MessageToXML(itm As MailItem, attachmentPath As String) ' Запись поступившего письма в XML-объект Dim xmldoc As DOMDocument Dim mailNode As IXMLDOMElement Dim attachmentsNode As IXMLDOMElement Dim attachmentNode As IXMLDOMElement Dim attachObj As Attachment Dim recpt As Recipient Set xmldoc = New DOMDocument xmldoc.loadXML "<mailItem/>" Set mailNode = xmldoc.documentElement ' информация об отправителе addElement "sender", mailNode, itm.SenderName Set recpt = itm.Recipients.Add(itm.SenderName) recpt.Resolve If recpt.Resolved Then addElement "senderEmail", mailNode, _ recpt.AddressEntry.address End If ' время получения addElement "receivedTime", mailNode, itm.ReceivedTime ' обработка информации о присоединенных файлах If itm.Attachments.Count > 0 Then Set attachmentsNode = addElement("attachments", mailNode) On Error Resume Next For Each attachObj In itm.Attachments Set attachmentNode = addElement( _ "attachment", attachmentsNode) addElement "fileName", attachmentNode, _ attachObj.filename addElement "pathName", attachmentNode, _ attachmentPath addElement "displayName", attachmentNode, _ attachObj.DisplayName ' запомнить присоединенные файлы attachObj.SaveAsFile _ attachmentPath + attachObj.filename Next On Error GoTo 0 End If ' тема и тело письма addElement "subject", mailNode, itm.Subject addElement "body", mailNode, itm.body, True Set MessageToXML = xmldoc End Function Public Sub AddMessageToArchive(xmldoc As DOMDocument, filename$) ' Запись поступившего письма в XML-архив Dim externalDoc As DOMDocument Dim mailItemsNode As IXMLDOMElement ' подключение объекта одного письма к архиву Set externalDoc = New DOMDocument externalDoc.Load filename If externalDoc.parseError.errorCode <> 0 Then externalDoc.loadXML "<mailbag><mailItems/></mailbag>" End If Set mailItemsNode = externalDoc.selectSingleNode( _ "//mailItems") If externalDoc.selectNodes("//mailItem").Length > 0 Then 'существует mailItemsNode.insertBefore _ xmldoc.documentElement.cloneNode( _ True), mailItemsNode.childNodes(0) Else mailItemsNode.appendChild _ xmldoc.documentElement.cloneNode(True) End If externalDoc.Save filename End Sub Public Function addElement(ElementName As _ String, ParentNode As IXMLDOMElement, _ Optional ElementValue As Variant = Null, _ Optional asCData As _ Boolean = False) As IXMLDOMElement ' добавление описания параметра к объекту Dim node As IXMLDOMElement Dim cdataTextNode As IXMLDOMCDATASection Set node = ParentNode.appendChild( _ ParentNode.ownerDocument.createElement( _ ElementName)) If Not IsNull(ElementValue) Then If asCData Then ' элемент типа CDATA Set cdataTextNode = node.appendChild( _ ParentNode.ownerDocument. _ createCDATASection(ElementValue)) Else ' обычный элемент node.Text = CStr(ElementValue) End If End If Set addElement = node End Function