在Windows文件夹中复制Outlook邮件(.msg)

问题描述

下面的代码为每个包含附件的电子邮件创建一个文件夹.在文件夹中，我们可以找到提取的附件和Word文档.我还希望在此文件夹中有一封电子邮件副本.

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

我刚刚添加了新行，将电子邮件复制为.msg，但没有将其放置在创建的文件夹中.有什么帮助吗?这是我添加的代码:

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

推荐答案

确定.我必须添加此代码:

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"

在此代码下:

Set dir = fso.CreateFolder(dirName)

这篇关于在Windows文件夹中复制Outlook邮件(.msg)的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持！