Листинг 5. Процедуры преобразования входящих писем в XML-архив

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