1

我最近完成了一个 Outlook vba 脚本，它将扫描添加到已发送文件夹的每个邮件项的主题行，在主题中查找项目编号。检测到后，脚本会提取项目编号，创建邮件项的副本，然后根据项目编号将该副本移动到共享邮箱文件夹（首先执行文件夹检查）。我目前已将其设置为首先创建邮件项目的副本，然后将该副本移动到新的文件夹目标。这样原始发送的邮件项将单独留在已发送文件夹中，而不会被删除。

我遇到的问题是当脚本在已发送文件夹中创建邮件项目的副本时，它会触发脚本的新实例（因为它在将新项目添加到已发送文件夹时运行）并重复此操作无限期地处理，创建和移动副本，直到 Outlook 被强制关闭。添加循环计数检查似乎没有帮助，因为每次添加项目时脚本都会从头开始。

下面是完整的代码，有没有比我现在做的更好的方法来解决这个问题？任何见解或方向将不胜感激！

编辑：忘记添加我已将此代码粘贴到我的 Outlook 的 ThisOutlookSession 中的 vb 开发人员选项卡（VbaProject.OTM 文件）

Private WithEvents Items As Outlook.Items

Private Sub Application_Startup()
  Dim olApp As Outlook.Application

  Set olApp = Outlook.Application
  Set Items = GetNS(olApp).GetDefaultFolder(olFolderSentMail).Items
End Sub

Private Sub Items_ItemAdd(ByVal item As Object)

  On Error Resume Next

  MsgBox "Mail Added to Sent Folder, Checking for T-#"

  Dim EmailSub As String
  Dim EmailSubArr As Variant
  Dim ProjectNum As String
  Dim FullProjectNum As String
  Dim ProjNumLen As Long
  Dim ParentFolderName As String
  Dim SubFolderName As String

    If TypeName(item) = "MailItem" Then
        'Checks Email Subject for Project Number Tag
        If InStr(item.Subject, "T-") > 0 Then

            MsgBox "T-# Detected"

            'Splits out Project Number into an Array for Extraction
            EmailSub = item.Subject
            EmailSubArr = Split(EmailSub, Chr(32))

              For i = LBound(EmailSubArr) To UBound(EmailSubArr)
                  If InStr(EmailSubArr(i), "T-") > 0 Then

                      FullProjectNum = EmailSubArr(i)
                      MsgBox "T-# Extracted"
                      ProjNumLen = Len(FullProjectNum)

                      MsgBox ("T-# is " & ProjNumLen & " Characters Long")

                      'Project Number Length Check and Formatting

                      If ProjNumLen >= 11 Then
                        Exit Sub
                      End If

                      If ProjNumLen <= 6 Then
                        Exit Sub
                      End If

                      If ProjNumLen = 10 Then
                      'Really Extended T-# Format 1(ie T-38322X12)
                      ProjectNum = Right(FullProjectNum, 8)
                      ParentFolderName = Left(ProjectNum, 2)
                      SubFolderName = Left(ProjectNum, 8)
                      End If

                      If ProjNumLen = 9 Then
                      'Extended T-# Format 1(ie T-38322X1)
                      ProjectNum = Right(FullProjectNum, 7)
                      ParentFolderName = Left(ProjectNum, 2)
                      SubFolderName = Left(ProjectNum, 7)
                      End If

                      If ProjNumLen = 8 Then
                      'Uncommon T-# Format (ie T-38322A)
                      ProjectNum = Right(FullProjectNum, 6)
                      ParentFolderName = Left(ProjectNum, 2)
                      SubFolderName = Left(ProjectNum, 6)
                      End If

                      If ProjNumLen = 7 Then
                      'Standard T-# Format (ie T-38322)
                      ProjectNum = Right(FullProjectNum, 5)
                      ParentFolderName = Left(ProjectNum, 2)
                      SubFolderName = Left(ProjectNum, 5)
                      End If

                      Exit For

                  End If
              Next i

            MsgBox ("Confirm Extraction (1 of 3) - Project Number is T-" & ProjectNum)
            MsgBox ("Confirm Extraction (2 of 3) - Parent Folder Will Be " & ParentFolderName)
            MsgBox ("Confirm Extraction (3 of 3) - Sub Folder Will Be " & SubFolderName)
            MsgBox ("Will Now Perform Folder Checks")

            'Perform Folder Checks, Creates Folders When Needed

            Dim fldrparent As Outlook.MAPIFolder
            Dim fldrsub As Outlook.MAPIFolder

            Set fldrparent = Outlook.Session.Folders("Projects").Folders("Project Root").Folders(ParentFolderName)
            Set fldrsub = Outlook.Session.Folders("Projects").Folders("Project Root").Folders(ParentFolderName).Folders(SubFolderName)

            If fldrparent Is Nothing Then
                MsgBox "Parent Folder Does Not Exist, Creating Folder"
                Set fldrparent = Outlook.Session.Folders("Projects").Folders("Project Root").Folders.Add(ParentFolderName)
            Else
                MsgBox "Parent Folder Already Exists, Do Nothing"
            End If

            If fldrsub Is Nothing Then
                MsgBox "Sub Folder Does Not Exist, Creating Folder"
                Set fldrsub = Outlook.Session.Folders("Projects").Folders("Project Root").Folders(ParentFolderName).Folders.Add(SubFolderName)
            Else
                MsgBox "Sub Folder Already Exists, Do Nothing"
            End If

            'Moves Copy of Email to Folder

            MsgBox "Copying Sent Email to Project Folder"

            Dim FolderDest As Outlook.MAPIFolder
            Dim myItem As Outlook.MailItem
            Dim myCopiedItem As Outlook.MailItem


            Set FolderDest = Outlook.Session.Folders("Projects").Folders("Project Root").Folders(ParentFolderName).Folders(SubFolderName)
            'Set myCopiedItem = item.Copy

            item.Move FolderDest

        Else
        MsgBox "Did not detect T-##### project number"
        End If

    End If

ProgramExit:
  Exit Sub

End Sub

Function GetNS(ByRef app As Outlook.Application) As Outlook.NameSpace
  Set GetNS = app.GetNamespace("MAPI")
End Function
4

3 回答 3

0

您可以在保存之前使用 MailItem.UserProperties 在新消息上设置您自己的特殊属性。然后，您可以在 ItemAdd 事件触发时检查该属性是否存在 (MailItem.UserProperties.Find)，如果设置了该属性，则跳过该项目。

于 2013-05-09T23:41:17.927 回答
0

而不是 ItemAdd 尝试 Application_ItemSend。

http://msdn.microsoft.com/en-us/library/office/ff865076(v=office.14).aspx

它比看起来简单。在ThisOutlookSession模块中。

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'  your code here
End Sub

您可以使用链接中提供的示例对其进行测试。

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean) 

    Dim prompt As String 

    prompt = "Are you sure you want to send " & Item.Subject & "?" 

    If MsgBox(prompt, vbYesNo + vbQuestion, "Sample") = vbNo Then 

        Cancel = True 

    End If 

End Sub
于 2013-05-09T23:54:20.283 回答
0

添加模块级变量，例如“m_cancelAdd”，并在 Item.Copy 之前将其值设置为 true。在 ItemAdd 事件处理程序的最开始检查 m_cancelAdd 的值，如果为真，则重置它并退出处理程序。HTH。

Private WithEvents Items As Outlook.Items
Private m_cancelAdd As Boolean

Private Sub Items_ItemAdd(ByVal Item As Object)

    If (m_cancelAdd) Then
        m_cancelAdd = False
        Exit Sub
    End If

    Dim myCopiedItem As Outlook.MailItem
    Dim FolderDest

    m_cancelAdd = True
    Set myCopiedItem = Item.Copy
    Debug.Print "Item copy created..."

    Set FolderDest = Outlook.Session.Folders("Projects").Folders("Project Root").Folders(ParentFolderName).Folders(SubFolderName)
    Item.Move FolderDest

End Sub
于 2013-05-10T00:19:47.370 回答