Question

我有一个代码可以复制存档中超过2天的电子邮件，但如果我想在存档子文件夹中复制电子邮件，它将无法完成这项工作。欢迎任何帮助。

Sub Copy_d_2()
Dim myOutlookFolders As Outlook.Folder
    Dim objOutlook As Outlook.Application
    Dim objNamespace As Outlook.Folder
    Dim objSourceFolder As Outlook.Folder
    Dim objSourceFolderMAIN As Outlook.Folder
    Dim objDestFolder As Outlook.Folder
    Dim objVariant As Variant
    Dim lngMovedItems As Long
    Dim intCount As Integer
    Dim intDateDiff As Integer
    Dim strDestFolder As String

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 me " & b & " " & c


    Set objNamespace = Session.GetDefaultFolder(olFolderInbox)
    Set objSourceFolder = Session.Folders("Mailbox - Share").Folders("Inbox").Folders("all emails")
    Set objSourceFolderMAIN = Session.Folders("Archive Folders")

    Set objDestFolder = Session.Folders("Archive Folders").Folders(nam).Folders("d2")

    For intCount = objSourceFolder.Items.Count To 1 Step -1
        Set objVariant = objSourceFolder.Items.Item(intCount)
        DoEvents
        If objVariant.Class = olMail Then

             intDateDiff = DateDiff("d", objVariant.SentOn, Now)
             If intDateDiff > 2 Then
             objVariant.Copy objDestFolder
             lngMovedItems = lngMovedItems + 1

            End If
        End If
    Next

Set objDestFolder = Nothing
End Sub

Answer 1

这是类似的东西： How to move each emails from inbox to a sub-folder

然而，关于你的代码，我玩了一点，并设法做到了这一点：

Sub Copy_d_2()

    Dim myOutlookFolders        As Outlook.Folder
    Dim objOutlook              As Outlook.Application
    Dim objNamespace            As Outlook.Folder
    Dim objSourceFolder         As Outlook.Folder
    Dim objSourceFolderMAIN     As Outlook.Folder
    Dim objDestFolder           As Outlook.Folder
    Dim objVariant              As Variant
    Dim lngMovedItems           As Long
    Dim intCount                As Integer
    Dim intDateDiff             As Integer
    Dim strDestFolder           As String

    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 me " & b & " " & c

    Set objNamespace = Session.GetDefaultFolder(olFolderInbox)
    Set objSourceFolder = Session.Folders("review@vitoshacademy.com").Folders("Posteingang").Folders("InboxX")
    'Set objSourceFolderMAIN = Session.Folders("Archive")

    Set objDestFolder = Session.Folders("Archive").Folders("test1").Folders("test2")

    For intCount = objSourceFolder.Items.Count To 1 Step -1
        Set objVariant = objSourceFolder.Items.Item(intCount)
        DoEvents
        If objVariant.Class = olMail Then
                objVariant.Move objDestFolder
        End If
    Next

    Set objDestFolder = Nothing
End Sub

将邮件移动到子文件夹没有问题。并且不检查它是否至少2天。

复制存档子文件夹中的旧电子邮件

1 个答案: