Outlook - 使用.xls附件和特定发件人从电子邮件中保存文件,然后将电子邮件移至子文件夹

时间:2013-08-22 14:03:07

标签: vba outlook email-attachments subdirectory

我希望在收件箱中收到来自具有.xls附件的特定电子邮件地址的新电子邮件时触发宏。 我试图在outlook中设置一个规则,但它不会过滤发件人,也不会有附件。

我想做的是以下内容:

  1. 当新邮件进入收件箱时,请检查它是否来自某个电子邮件地址ag:Myaddress.me.co.uk。如果电子邮件不是来自正确的地址,则不执行任何操作。
  2. 如果主题行有某些词,例如:“价格检查”。主题不匹配什么也不做。
  3. 如果电子邮件来自正确的地址,请检查新电子邮件是否附带.xls附件。如果它没有.xls附件就什么都不做。
  4. 将附件保存在文件夹中,例如:“C:\ MyFolder”
  5. 将电子邮件标记为已读并移至子文件夹,例如:“PriceCheckFolder”
  6. 我一直在使用此代码检查收件箱,但它会查看文件夹中的所有电子邮件,我只希望它查看符合条件的第一个实例。

    非常感谢梅琳达

    ‘in thisworkbook
    
    Private WithEvents Items As Outlook.Items
    
    Private Sub Application_Startup()
      Dim olApp As Outlook.Application
      Dim objNS As Outlook.NameSpace
      Dim SubFolder As MAPIFolder
    
      Set olApp = Outlook.Application
      Set objNS = olApp.GetNamespace("MAPI")
      ' default local Inbox
      Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
    End Sub
    
    
    Private Sub Items_ItemAdd(ByVal item As Object)
    
      On Error GoTo ErrorHandler
    
      Dim Msg As Outlook.MailItem
    
      If TypeName(item) = "MailItem" Then
        Set Msg = item
        Call SaveAttachmentsToFolder
      End If
    
    ProgramExit:
      Exit Sub
    
    ErrorHandler:
      MsgBox Err.Number & " - " & Err.Description
      Resume ProgramExit
    End Sub
    
    
    Sub SaveAttachmentsToFolder()
    
    'Error handling
      On Error GoTo SaveAttachmentsToFolder_err
    
    
    ‘in module1
    
    ' Declare variables
      Dim ns As NameSpace
      Dim Inbox As MAPIFolder
      Dim SubFolder As MAPIFolder
      Dim item As Object
      Dim Atmt As Attachment
      Dim FileName As String
      Dim i As Integer
      Dim varResponse As VbMsgBoxResult
      Dim StringLength As Long
      Dim Filename1 As String
      Dim FilenameA As String
      Dim FilenameB As String
    
    'Set the variable values to be used in the code
      Set ns = GetNamespace("MAPI")
      Set Inbox = ns.GetDefaultFolder(olFolderInbox)
      Set SubFolder = Inbox.Folders("Test")
      i = 0
    
    ' Check subfolder for messages and exit of none found
      If SubFolder.Items.Count = 0 Then
      ' "Nothing Found"
        Exit Sub
      End If
    
    ' Check each message for attachments
      For Each item In SubFolder.Items
        For Each Atmt In item.Attachments
          ' Check filename of each attachment and save if it has "xls" extension
          If Right(Atmt.FileName, 3) = "xls" Then
            StringLength = Len(Atmt.FileName)
    
            FileName = "\\feltfps0003\gengrpshare0011\Value Team\Melinda_BK\OutlookVBA\TestOutput\" & Left(Atmt.FileName, (StringLength - 13)) & Format(item.CreationTime, "ddmmmyyyy") & ".xls"
            Atmt.SaveAsFile FileName
            i = i + 1
          End If
        Next Atmt
      Next item
    
    ' Clear memory
    SaveAttachmentsToFolder_exit:
      Set Atmt = Nothing
      Set item = Nothing
      Set ns = Nothing
      Exit Sub
    
    ' Handle Errors
    SaveAttachmentsToFolder_err:
        MsgBox "An unexpected error has occurred." _
        & vbCrLf & "Please note and report the following information." _
        & vbCrLf & "Macro Name: GetAttachments" _
        & vbCrLf & "Error Number: " & Err.Number _
        & vbCrLf & "Error Description: " & Err.Description _
        , vbCritical, "Error!"sub
    Resume SaveAttachmentsToFolder_exit
    End Sub
    

1 个答案:

答案 0 :(得分:0)

  

我尝试在Outlook中设置规则,但它不会过滤发件人,也不会附件。

创建一个调用以下脚本的规则。

它将在所有传入邮件上运行,但只执行您查找的任何电子邮件地址的代码

Sub checkEmailSenderAndDoStuff(myItem As MailItem)

    'set this up as a script to run on all incoming mail
    Dim myTargetEmailAddress As String
    myTargetEmailAddress = "whatever@wherever.com"

    'this will check if the sender email is whatever sender
    'you want to check from
    If myItem.SenderEmailAddress = myTargetEmailAddress Then
        'do whatever you wanted to do with attachments, moving, etc
    End If
End Sub