Question

我的VBA技能非常有限，但到目前为止，我想完成这个项目。

在我看来，下面的VBA代码可以很好地工作。它将所需的电子邮件保存到我的驱动器中。

Private WithEvents Items As Outlook.Items

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

End Sub

Private Sub Items_ItemAdd(ByVal item As Object)

On Error GoTo ErrorHandler

    'Only act if it's a MailItem
    Dim Msg As Outlook.MailItem
    If TypeName(item) = "MailItem" Then
        Set Msg = item

    'Change variables to match need. Comment or delete any part unnecessary.
        If (Msg.SenderEmailAddress = "noreply@test.com") Or _
        (Msg.Subject = "Smartsheet") Or _
        (Msg.Subject = "Defects") And _
        (Msg.Attachments.Count >= 1) Then

    'Set folder to save in.
    Dim olDestFldr As Outlook.MAPIFolder
    Dim myAttachments As Outlook.Attachments
    Dim Att As String

    'location to save in.  Can be root drive or mapped network drive.
    Const attPath As String = "C:\"


    ' save attachment
   Set myAttachments = item.Attachments
    Att = myAttachments.item(1).DisplayName
    myAttachments.item(1).SaveAsFile attPath & Att

    ' mark as read
   Msg.UnRead = False

End If
End If


ProgramExit:
  Exit Sub

ErrorHandler:
  MsgBox Err.number & " - " & Err.Description
  Resume ProgramExit
End Sub

我现在想将代码添加到附件保存后移动电子邮件到我的“测试”文件夹中。测试文件夹位于我的Outlook中的“收件箱”下。

我添加了 Set FldrDest = Session.Folders("Address1").Folders("Inbox").Folders("Test")

在 Private Sub Application_Startup（）下，然后将代码添加到VBA中。

代码在'标记后为已读

If .Parent.Name = "Test" And .Parent.Parent.Name = "Inbox" Then
      ' MailItem is already in destination folder
    Else
      .Move FldrDest
    End If

没有其他更改，但是它给了我编译错误。

Answer 1

MailItem.Move 实际上是一个函数，用于返回已在新目的地中移动的对象。旧对象有点“丢失”，请参阅如何使用它（我已经在整个代码;)中注释了删除部分）

Set Msg = .Move(FldrDest)
MsgBox Msg.SenderEmailAddress & vbCrLf & Msg.Subject

完整代码，其中包含一些改进建议（请参见'-->注释）：

Private WithEvents Items As Outlook.Items

'location to save in.  Can be root drive or mapped network drive.
'-->As it is a constant you can declare it there (and so, use it in the whole module if you want to do other things with it!)
Private Const attPath As String = "C:\"


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

Private Sub Items_ItemAdd(ByVal item As Object)

On Error GoTo ErrorHandler
    'Only act if it's a MailItem
    If TypeName(item) = "MailItem" Then
        Dim Msg As Outlook.MailItem
        '-->Use directly the parameter and keep it under wraps using "With", it'll improve efficiency
        With item
            'Change variables to match need. Comment or delete any part unnecessary.
            If (.SenderEmailAddress = "noreply@test.com" _
               Or .Subject = "Smartsheet" _
               Or .Subject = "Defects" _
               ) _
               And .Attachments.Count >= 1 Then


                Dim aAtt As Outlook.Attachment
                '-->Loop through the Attachments' collection
                for each aAtt in item.Attachments
                    '-->You can either use aAtt.DisplayName or aAtt.FileName
                    '-->You can test aAtt.Size or aAtt.Type

                    'save attachment
                    aAtt.SaveAsFile attPath & aAtt.DisplayName
                next aAtt

                'mark as read
                .UnRead = False

                Dim olDestFldr As Outlook.MAPIFolder
                Set FldrDest = Session.Folders("Address1").Folders("Inbox").Folders("Test")
                If .Parent.Name = "Test" And .Parent.Parent.Name = "Inbox" Then
                    'MailItem is already in destination folder
                Else
                    Set Msg = .Move(FldrDest)
                    MsgBox Msg.SenderEmailAddress & vbCrLf & Msg.Subject
                    'Msg.delete
                End If
            End If
        End With 'item
    End If


ProgramExit:
  Exit Sub

ErrorHandler:
  MsgBox Err.number & " - " & Err.Description
  Resume ProgramExit
End Sub

Answer 2

比我想象的要容易。刚刚添加了Msg.Delete.

循环

Outlook保存后删除电子邮件

2 个答案: