时间戳

首页 > 解决方案 > 将 Outlook 传入邮件移动到以相同代码开头的文件夹

vba - 将 Outlook 传入邮件移动到以相同代码开头的文件夹

问题描述

我正在尝试自动将传入消息移动到 Outlook 中的指定子文件夹。

包含 P000.0000 格式的项目编号的邮件应移动到以相同项目编号开头的收件箱的子文件夹中。

子文件夹将手动预先创建，因此用户可以决定在专用子文件夹中汇总哪些项目。

文件夹结构为收件箱>Actueel>P000.0000

第一点，检查传入消息的地方工作正常，但在那之后我迷路了......它从哪里开始For Each Folder In olFolderPrjcts

错误在这一行Set olFolder = objNS.GetDefaultFolder(olFolderInbox)

到目前为止，这是我想出的：

Private WithEvents myOlItems As Outlook.Items

Private Sub Application_Startup()
    Dim olApp As Outlook.Application
    Dim objNS As Outlook.NameSpace
    Dim olFolder As Outlook.MAPIFolder
      Set olApp = Outlook.Application
      Set objNS = olApp.GetNamespace("MAPI")
      Set olFolder = objNS.GetDefaultFolder(olFolderInbox)
      Set myOlItems = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub myOlItems_ItemAdd(ByVal item As Object)
  Dim Atts As Outlook.Attachments
  Dim Props As Outlook.UserProperties
  Dim Prop As Outlook.UserProperty
  Dim PropName As String

  PropName = "NumberAttachments"

  Set Atts = item.Attachments
  Set Props = item.UserProperties
  Set Prop = Props.Find(PropName, True)
  If Prop Is Nothing Then
    Set Prop = Props.Add(PropName, olText, True)
  End If

  Dim olFolder As Outlook.MAPIFolder
  Set olFolder = objNS.GetDefaultFolder(olFolderInbox)

  Dim olFolderPrjcts
  Set olFolderPrjcts = olFolder.Folders("actueel")

  Prop.Value = Atts.Count
  item.Save

  Dim Msg As Outlook.MailItem

  If TypeName(item) = "MailItem" Then
    Set Msg = item

    For Each Folder In olFolderPrjcts
        If Left(Msg.Subject, 9) = Left(Folder.Name, 9) Then
            Msg.Move (Folder)
        End If
    Next
' DO SOMETHING TO NEWLY ARRIVED MESSAGE
'     If Msg.Subject contains like P000.0000 AND
'       folder exists that starts with P000.0000
'       then move to that folder

  End If

End Sub

标签： vbaemailoutlook

解决方案

如果没有 Option Explicit，错误可能是运行时错误“424”：需要对象。

使用 Option Explicit 时，错误可能是编译错误：未定义变量。

Option Explicit

' Tools | Options | Editor tab
' Checkbox "Require Variable Declaration"

Private Sub myOlItems_ItemAdd(ByVal Item As Object)

    Dim objNS As Namespace  ' <--

    Dim olFolder As folder
    Dim folder As folder
    Dim olFolderPrjcts As folder

    Dim Msg As MailItem

    Set objNS = GetNamespace("MAPI")    ' <--

    Set olFolder = objNS.GetDefaultFolder(olFolderInbox)
    Set olFolderPrjcts = olFolder.Folders("actueel")

    If TypeName(Item) = "MailItem" Then

        Set Msg = Item

        For Each folder In olFolderPrjcts.Folders
            If Left(Msg.subject, 9) = Left(folder.name, 9) Then
                'Debug.Print Msg.subject
                'Debug.Print folder.name
                Msg.move folder ' <-- no brackets
                Exit For
            End If
        Next

  End If

End Sub

推荐阅读