Copy Outlook mail (.msg) in windows folder

问题

This code below create a folder for every e-mail that contains attachments. In the folder, we can find the attachments extracted and a word document. I would also like to have inside this folder a copy of the e-mail.

here is my working code below. I just don't know how to copy the e-mail!

Option Explicit

Sub Application_Startup()

Dim ol As Outlook.Application
Dim ns As Outlook.NameSpace
Dim fol As Outlook.Folder
Dim i As Object
Dim mi As Outlook.MailItem
Dim at As Outlook.Attachment
Dim rootfol As Outlook.Folder
Dim fso As Scripting.FileSystemObject
Dim dir As Scripting.Folder
Dim dirName As String

Set fso = New Scripting.FileSystemObject

Set ol = New Outlook.Application
Set ns = ol.GetNamespace("MAPI")
Set rootfol = ns.Folders(1)
Set fol = rootfol.Folders("boîte de réception").Folders("test")

For Each i In fol.Items
        If i.Class = olMail Then
        Set mi = i
        If mi.Attachments.Count > 0 Then

               dirName = "C:\Users\chadi\OneDrive\Documents\VBA\" & Format(mi.ReceivedTime, "yyyy-mm-dd hh-nn-ss ") & Left(Replace(mi.Subject, ":", ""), 20)

              If fso.FolderExists(dirName) Then
              Set dir = fso.GetFolder(dirName)
              Else
              Set dir = fso.CreateFolder(dirName)


          Dim mySpecialWordDocument As String
          mySpecialWordDocument = "C:\Users\chadi\OneDrive\Documents\Scanned Documents\CHADICV.docx"
          fso.CopyFile mySpecialWordDocument, dirName & "\" & Split(mySpecialWordDocument, "\")(UBound(Split(mySpecialWordDocument, "\")))



            End If

                For Each at In mi.Attachments
                at.SaveAsFile dir.Path & "\" & at.FileName


                Next at

                mi.Delete

                End If

        End If

    Next i


End Sub

EDIT :

I just added new lines that copy the email in .msg but it doesnt place it inside the created folder. Any help? this is the code I added :

Dim saveFolder As String
Dim sName As String
saveFolder = dirName
sName = mi.Subject
mi.SaveAs saveFolder & Format$(mi.CreationTime, "yyyymmdd_hhmmss_") & sName & ".msg", olMSG

回答1:

Ok got it. I had to add this code :

Dim sName As String
sName = mi.Subject
mi.SaveAs dirName & "\" & Format$(mi.CreationTime, "yyyymmdd_") & sName & ".msg"

under this code :


Set dir = fso.CreateFolder(dirName)

来源：https://stackoverflow.com/questions/59024638/copy-outlook-mail-msg-in-windows-folder

标签

excel

outlook