如何.Save作为非唯一的发送电子邮件到Windows文件夹

Question

我有VBA代码，其主要功能是：

1. 加载表单
2. 允许用户选择股票电子邮件回复
3. 使用完整的回复文字打开word文档
4. 使用文字
创建回复
5. 搜索电子邮件并创建包含公司文件编号的字符串集合
6. 将文件编号添加到Excel列表
7. 发送回复

现在，我想在Windows文件夹中为每个文件编号保存已发送项目的一个副本。我一直在尝试等待物品发送并移动到已发送物品。问题是，在调用send方法之后，mailitem在代码完成之前不会发送或移动到已发送的项目，所以我最终会进入无限循环。

我发现的所有选项都涉及使用类模块和WithEvents。如果我想将每个发送的项目复制到该文件夹​​，那将会有效。我想不出任何可以区分此宏创建的电子邮件与普通电子邮件的标准。我可以进入Excel文件列表，但是每次发送都会让每个人的机器陷入困境。

有没有办法让电子邮件发送时发现并移动到已发送的项目？我的代码发送，等待它去发送项目，以及保存电子邮件在下面。注意我有两个全局变量：cReply（Outlook.MailItem - 回复）和fNums（Collection - 文件编号）。

我在Outlook 2016中编码，但希望将模块移动到Outlook 2010中。

Sub Send()
    Dim badChar As String
    badChar = "\/:*?™""® <>|.&@#_+`©~;-+=^$!,'" & Chr(34)
    Dim x As Integer
    Dim fName As String
    Dim inSentItems As Boolean
    Dim olApp As Outlook.Application
    Dim olNS As Outlook.NameSpace
    Dim olFldr As Outlook.MAPIFolder
    Dim cSent As Outlook.MailItem
    Dim sentMoment As Date
    fName = cReply.Subject
    For x = 1 To Len(badChar)
        fName = Replace(fName, Mid(badChar, x, 1), "-")
    Next x
    Set olApp = GetObject(, "Outlook.Application")
    Set olNS = olApp.GetNamespace("MAPI")
    Set olFldr = olNS.GetDefaultFolder(olFolderSentMail)
    inSentItems = True
    x = olFldr.Items.Count
    sentMoment = Now
    cReply.Send
    Do While olFldr.Items.Count <> x + 1
        If Now - sentMoment > TimeValue("0:00:10") Then
            inSentItems = False
            Exit Do
        End If
        DoEvents
    Loop
    If inSentItems Then
        Set cSent = olFldr.Items(olFldr.Items.Count)
        For x = 1 To fNums.Count
            cSent.SaveAs sentFldrPth & fNums.Item(x) & " - " & fName & ".msg", olMSG
        Next x
        'cSent.Delete
    End If
    Set olApp = Nothing
    Set olNS = Nothing
    Set olFldr = Nothing
End Sub

Answer 1

您可以使用SaveSentMessageFolder保存到另一个文件夹。

https://msdn.microsoft.com/en-us/library/office/ff868473.aspx

使用ItemAdd代码监控此其他文件夹。完成后，您可以将邮件移动到“已发送邮件”文件夹。