无止境循环-VBA脚本，在将MailItem添加到已发送文件夹时运行，然后创建副本

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

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

下面是完整的代码，有没有比我现在做的更好的方法？任何见解或指导都将不胜感激

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

---

Private，事件项作为Outlook.Items
私有子应用程序_启动（）
Dim olApp作为Outlook.Application
设置olApp=Outlook.Application
Set Items=GetNS（olApp）.GetDefaultFolder（olFolderSentMail）.Items
端接头
私有子项\u ItemAdd（ByVal项作为对象）
出错时继续下一步
MsgBox“邮件已添加到已发送文件夹，正在检查T-#”
将EmailSub设置为字符串
Dim-Subar作为变体
Dim ProjectNum作为字符串
Dim FullProjectNum作为字符串
黯淡的ProjNumLen一样长
Dim ParentFolderName作为字符串
将子文件夹名称设置为字符串
如果TypeName（item）=“MailItem”，则
'检查项目编号标记的电子邮件主题
如果InStr（item.Subject，“T-”）大于0，则
MsgBox“检测到T-#”
'将项目编号拆分为一个数组以进行提取
EmailSub=item.Subject
EmailSubAR=拆分（EmailSub，Chr（32））
对于i=LBound（emailsubar）到UBound（emailsubar）
如果InStr（r（i），“T-”>0，则
FullProjectNum=emailsubar（i）
MsgBox“T-#提取”
ProjNumLen=Len（FullProjectNum）
MsgBox（“T-#is”&ProjNumLen&“字符长”）
'项目编号长度检查和格式设置
如果ProjNumLen>=11，则
出口接头
如果结束
如果ProjNumLen您可以在保存新邮件之前，使用MailItem.UserProperties在新邮件上设置您自己的特殊属性。然后，当ItemAdd事件触发时，您可以检查该属性是否存在（MailItem.UserProperties.Find），如果设置了该属性，则跳过该项目。
而不是ItemAdd，请尝试应用程序\u ItemSend


它比看起来简单。在此了望会话模块中

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

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

这非常有效，并且不需要太多的编辑就可以使用我当前的代码。作为vb（和一般编程）的新手，非常感谢您的帮助！这看起来可以完成这项工作，而且肯定会在我负责的未来脚本中，将此方法与item add结合起来。谢谢你的帮助！
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

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