代码之家 › 专栏 › 技术社区 › t3chb0t

脚本在每次执行时只移动几个“收件箱”项目

outlook-2016 outlook-vba vba

0

t3chb0t · 技术社区 · 7 年前

我有以下几点 VBA 脚本 Outlook 这会把邮件转到 Archives 文件夹(不在特殊类别中分类)。它既有效又无效。我是说它动了一些电子邮件,但跳过其他的,所以我必须运行它多次,直到 Inbox 已经清理干净了。我不明白为什么它会这样。它没有抛出任何异常,只是没有对所有项目都执行它的工作。你能看出什么可疑之处吗?

Option Explicit

Sub CleanUpInbox()

    Dim ns As Outlook.NameSpace
    Set ns = GetNamespace("MAPI")
    Dim inbox As Outlook.Folder: Set inbox = ns.GetDefaultFolder(olFolderInbox)
    Dim archive As Outlook.Folder: Set archive = ns.Folders("my@mailbox.abc").Folders("Archives").Folders("2018")

    Dim maxDiffInDays As Integer: maxDiffInDays = 14
    Dim today As Date: today = DateValue(now())

    On Error GoTo bang

    Dim mail As Variant ' Outlook.MailItem
    For Each mail In inbox.Items

        If mail Is Nothing Then
            GoTo continue
        End If

        Dim receivedOn As Date: receivedOn = DateValue(mail.ReceivedTime)
        Dim diff  As Integer: diff = DateDiff("d", receivedOn, today)
        Dim isOld As Boolean: isOld = True ' diff > maxDiffInDays
        If isOld Then

            'Debug.Print diff
            'Debug.Print mail.Subject
            'Debug.Print mail.Categories

            Dim isPinned As Boolean: isPinned = InStr(mail.Categories, "PINNED")
            Dim isTTYL As Boolean: isTTYL = InStr(mail.Categories, "TTYL")

            If LinqAll(False, isPinned, isTTYL) Then
                Debug.Print mail.Subject
                mail.Move archive
            End If

        End If


GoTo continue

bang:

        Debug.Print "bang!"
        Debug.Print Err.Description

continue:

    Next

End Sub

Function LinqAll(ByVal Expected As Boolean, ParamArray Values() As Variant) As Boolean

    Dim x As Variant
    For Each x In Values
        If x <> Expected Then
            LinqAll = False
            Exit Function
        End If
    Next
    LinqAll = True

End Function

Function LinqAny(ByVal Expected As Boolean, ParamArray Values() As Variant) As Boolean

    Dim x As Variant
    For Each x In Values
        If x = Expected Then
            LinqAny = True
            Exit Function
        End If
    Next
    LinqAny = False

End Function

2 回复 | 直到 7 年前

1

EarlyBird2 7 年前

不知道我是否遗漏了什么,但你的代码似乎可以处理任何旧邮件,因为 isOld 在循环中为真。有什么特别的理由 isPined 和 isTTYL 每个循环?你试过了吗:

Sub CleanUpInbox()

Dim ns As Outlook.Namespace
Dim inbox As Outlook.Folder: Set inbox = ns.GetDefaultFolder(olFolderInbox)
Dim archive As Outlook.Folder: Set archive = ns.Folders("my@mailbox.abc").Folders("Archives").Folders("2018")
Dim maxDiffInDays As Integer: maxDiffInDays = 14
Dim today As Date: today = DateValue(Now())
Dim mail As Variant ' Outlook.MailItem
Dim receivedOn As Date
Dim diff  As Integer
Dim isOld As Boolean
Dim isPinned As Boolean
Dim isTTYL As Boolean

Set ns = GetNamespace("MAPI")
On Error GoTo bang

For Each mail In inbox.Items

    If mail Is Nothing Then
        GoTo continue
    End If

    isOld = False
    receivedOn = DateValue(mail.ReceivedTime)
    diff = DateDiff("d", receivedOn, today)

    If diff > maxDiffInDays Then
        isOld = True
    End If
    isPinned = InStr(mail.Categories, "PINNED")
    isTTYL = InStr(mail.Categories, "TTYL")

    If LinqAll(False, isPinned, isTTYL) Then
        Debug.Print mail.Subject
        mail.Move archive
    End If

    GoTo continue

bang:
    Debug.Print "bang!"
    Debug.Print Err.Description

continue:
Next

End Sub

2

1

t3chb0t 7 年前

我已经解决了。你不能用 Items 在一个 For Each 同时循环 .Move 它的项目。就像在 C# . 唯一的区别是 C.* 在 VBA 只需减少项目数,然后停止-o

相反,我用 Do While 还有两个柜台。一个计算已处理项,另一个是 项目 . 现在它处理一切。

Sub CleanUpInbox2()

    ' ... other variables

    Dim processCount As Integer
    Dim itemIndex As Integer: itemIndex = 1
    Dim itemCount As Integer: itemCount = inbox.Items.Count
    Do While processCount < itemCount

        processCount = processCount + 1

        Set mail = inbox.Items(itemIndex)

        ' ... body

        If LinqAll(False, isPinned, isTTYL) Then
            Debug.Print mail.Subject
            mail.Move archive
            moveCount = moveCount + 1
        Else
            itemIndex = itemIndex + 1
        End If

bang:
        Debug.Print "bang!"
        Debug.Print Err.Description

continue:

    Loop

    Debug.Print "Emails processed: " & processCount
    Debug.Print "Emails moved: " & moveCount

End Sub

我试图复制 项目 首先,但我没有成功(显然没有 new Outlook.Items )所以我用索引。