Question

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

下面是我的工作代码。我只是不知道如何复制电子邮件！

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，但没有将其放置在创建的文件夹中。有什么帮助吗？这是我添加的代码：

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

Answer 1

确定。我必须添加此代码：

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

在此代码下：


Set dir = fso.CreateFolder(dirName)

在Windows文件夹中复制Outlook邮件（.msg）

1 个答案: