Excel VBA-将电子邮件移至其他文件夹

Question

我得到了一个项目，可以进入收件箱中的特定文件夹。进入文件夹后，我必须解压缩附件并将电子邮件正文另存为文本文件。完成此操作后，我需要将这两封邮件附加到电子邮件上，以将其发送到附加了文件监视程序的另一个邮箱（Mailbox2）。

[一旦发送到Mailbox2后，尝试将电子邮件移动到另一个文件夹时遇到问题

-------------------------------------
Private Sub Application_NewMail()


Dim NS As Outlook.NameSpace
Set NS = Outlook.Application.GetNamespace("MAPI")

Dim Inbox As Folder
Set Inbox = NS.GetDefaultFolder(olFolderInbox)

Dim SubFolder As Folder
Set SubFolder = Inbox.Folders("TESTER")


Dim Destination As String
Destination = "MyFolder\"


Dim Atmt As Attachment
Dim FileName As String
Dim Subject As String
Dim txtFile As String


For Each Email In SubFolder.Items
    For Each Atmt In Email.Attachments
        If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
            FileName = Destination & Email.SenderName & " " & Atmt.FileName
            Atmt.SaveAsFile FileName
            I = I + 1
        End If
    Next Atmt

    Subject = Email.SenderName

    Dim rmv As Variant
    rmv = Array("\", "/", ":", "*", "?", """", "<", ">", "|")

    Dim r As Variant 

    For Each r In rmv 
        Subject = Replace(Subject, r, "")
    Next r

    txtFile = Destination & Subject & ".txt"

    Open txtFile For Output As #1
        Write #1, Email.Body
    Close #1

    Call Send_Mail(Subject)
    Call DeleteExample
Next Email

End Sub
-------------------------------------
Public Sub Send_Mail(Subject As String)
  Dim OutlookApp As Outlook.Application
  Dim OutlookMail As Outlook.MailItem
  Set OutlookApp = New Outlook.Application
  Set OutlookMail = OutlookApp.CreateItem(olMailItem)
  StrPath = "MyFolder\"

  With OutlookMail
  .Display
    .To = "[email protected]"
    .CC = "[email protected]"
    .BCC = "[email protected]"
    .Subject = "Test mail"
    strfile = Dir(StrPath & "*.*")
    Do While Len(strfile) > 0
        If (Right(strfile, 3) = "txt" Or Right(strfile, 3) = "pdf" Or Right(strfile, 4) = "xlsx") Then
            .Attachments.Add StrPath & strfile
        End If
    strfile = Dir
    Loop
    .Send
  End With
End Sub
-------------------------------------
Sub DeleteExample()
'Deletes all files in the folder
    Kill "MyFolder\*.*"
End Sub
-------------------------------------

我一直在尝试将此逻辑嵌入到Application_NewMail（）的for循环中

For Each Email In SubFolder.Items
    For Each Atmt In Email.Attachments
        If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
            FileName = Destination & Email.SenderName & " " & Atmt.FileName
            Atmt.SaveAsFile FileName
            I = I + 1
        End If
    Next Atmt

    Subject = Email.SenderName

    Dim rmv As Variant
    rmv = Array("\", "/", ":", "*", "?", """", "<", ">", "|")

    Dim r As Variant 

    For Each r In rmv 
        Subject = Replace(Subject, r, "")
    Next r

    txtFile = Destination & Subject & ".txt"

    Open txtFile For Output As #1
        Write #1, Email.Body
    Close #1

    Call Send_Mail(Subject)
    Call DeleteExample
    Call MoveEmail()


Next Email
-------------------------------
Sub MoveEmail()
Dim NS As Outlook.NameSpace
Set NS = Outlook.Application.GetNamespace("MAPI")

Dim Inbox As Folder
Set Inbox = NS.GetDefaultFolder(olFolderInbox)

Dim SubFolder As Folder
Set SubFolder = Inbox.Folders("TESTER")

   For Each Email In SubFolder.Items
      SubFolder.MoveTo (Inbox.Folders("END"))
   Next Email

End Sub

但是它正在将整个“ TESTER”文件夹移到“ END”文件夹中

Answer 1

进一步处理后，我发现了如何将电子邮件移至其他文件夹。

这是逻辑

Sub MoveEmail()
Dim NS As Outlook.NameSpace
Set NS = Outlook.Application.GetNamespace("MAPI")

Dim Inbox As Folder
Set Inbox = NS.GetDefaultFolder(olFolderInbox)

Dim SubFolder As Folder
Set SubFolder = Inbox.Folders("TESTER")

   For Each Email In SubFolder.Items
      Email.Move (Inbox.Folders("END"))
   Next Email


End Sub