我希望在收件箱中收到来自具有.xls附件的特定电子邮件地址的新电子邮件时触发宏。 我试图在outlook中设置一个规则,但它不会过滤发件人,也不会有附件。
我想做的是以下内容:
我一直在使用此代码检查收件箱,但它会查看文件夹中的所有电子邮件,我只希望它查看符合条件的第一个实例。
非常感谢梅琳达
‘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
答案 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