复制每月存档中的电子邮件

Question

我必须每天在每月存档中复制超过 2 天的电子邮件。我的问题是，如果今天是 01 或 02 .12.2016，那么我必须在当前 - 11.2016 之前的一个月内移动电子邮件。我无法获得正确的代码 - 如果电子邮件日期是 T-2 并且电子邮件月份不是当前月份，则将电子邮件移动到当前月份之前的月份，否则移动到当前月份的存档中。欢迎任何帮助，谢谢。

Sub Archive_Outlook_eMails_To_Backup_PST_Folder()
    Dim SourceFolder As Outlook.MAPIFolder, DestFolder As Outlook.MAPIFolder
    Dim MailItem As Outlook.MailItem
    Dim SourceMailBoxName As String, DestMailBoxName As String
    Dim Source_Pst_Folder_Name As String, Dest_Pst_Folder_Name  As String
    Dim MailsCount As Double, NumberOfDays As Double


Dim a As Date
a = Now()

Dim b As String
b = Format(a, "mmmm")

Dim c As String
c = Format(a, "yyyy")

Dim nam As String
nam = "Archive " & b & " " & c


    NumberOfDays = 2

    Source_Pst_Folder_Name = "Inbox"
    Set SourceFolder = Session.Folders("Mailbox - Share ALL").Folders("Inbox").Folders("0.Archive")

    DestMailBoxName = nam
    Dest_Pst_Folder_Name = "0.Archive"
    Set DestFolder = Outlook.Session.Folders(DestMailBoxName).Folders(Dest_Pst_Folder_Name)

    MailsCount = SourceFolder.Items.Count
    While MailsCount > 0


        Set MailItem = SourceFolder.Items.Item(MailsCount)
        If VBA.DateValue(VBA.Now) - VBA.DateValue(MailItem.ReceivedTime) >= NumberOfDays Then
            Dim myCopiedItem As Outlook.MailItem
            Set myCopiedItem = MailItem.Copy
            myCopiedItem.Move DestFolder

        End If

        MailsCount = MailsCount - 1

    Wend

    MsgBox "Mailes in " & Source_Pst_Folder_Name & " are Processed"
End Sub

Answer 1

这是一种可能，检查当前日期。如果小于3，那么你去具体案例：

Sub Archive_Outlook_eMails_To_Backup_PST_Folder()
    Dim SourceFolder As Outlook.MAPIFolder, DestFolder As Outlook.MAPIFolder
    Dim MailItem As Outlook.MailItem
    Dim SourceMailBoxName As String, DestMailBoxName As String
    Dim Source_Pst_Folder_Name As String, Dest_Pst_Folder_Name  As String
    Dim MailsCount As Double, NumberOfDays As Double


Dim a As Date
a = Now()

Dim b As String
b = Format(a, "mmmm")

Dim c As String
c = Format(a, "yyyy")

Dim nam As String
nam = "Archive " & b & " " & c


    NumberOfDays = 2

    Source_Pst_Folder_Name = "Inbox"
    Set SourceFolder = Session.Folders("Mailbox - Share ALL").Folders("Inbox").Folders("0.Archive")

    DestMailBoxName = nam
    Dest_Pst_Folder_Name = "0.Archive"
    Set DestFolder = Outlook.Session.Folders(DestMailBoxName).Folders(Dest_Pst_Folder_Name)

    MailsCount = SourceFolder.Items.Count
    While MailsCount > 0


        Set MailItem = SourceFolder.Items.Item(MailsCount)
        If VBA.DateValue(VBA.Now) - VBA.DateValue(MailItem.ReceivedTime) >= NumberOfDays Then
        Select Case VBA.Now

        Case Is < 3:
            Dim myCopiedItem As Outlook.MailItem
            Set myCopiedItem = MailItem.Copy
            myCopiedItem.Move DestFolder 'The folder should be changed

        Case Else:
            Dim myCopiedItem As Outlook.MailItem
            Set myCopiedItem = MailItem.Copy
            myCopiedItem.Move DestFolder

        End If

        MailsCount = MailsCount - 1

    Wend

    MsgBox "Mailes in " & Source_Pst_Folder_Name & " are Processed"
End Sub

只是一个改进的小想法 - 将所有 dim 放在最上面，而不是像 Dim myCopiedItem As Outlook.MailItem 这样的代码周围。无论如何，它们在一开始就被初始化了。

Answer 2

更换怎么样

Dim a As Date
a = Now()

Dim b As String
b = Format(a, "mmmm")

Dim c As String
c = Format(a, "yyyy")

Dim nam As String
nam = "Archive " & b & " " & c

来自

Dim nam As String
nam = "Archive " & format(now()-2, "mmm yyyy")

（-2 以到达正确的文件夹）

复制每月存档中的电子邮件

Copy emails in monthly archive

excel

vba

outlook

archive