特定の電子メール アドレスからの .xls 添付ファイル付きの新しい電子メールが受信トレイに受信されたときに、マクロをトリガーしたいと考えています。Outlook でルールを設定しようとしましたが、送信者や添付ファイルがある場合にフィルター処理されません。
私がやりたいことは次のとおりです。
- 新しいメールが受信トレイに届いたら、それが特定のメール アドレス ag:Myaddress.me.co.uk からのものかどうかを確認します。電子メールが正しいアドレスからのものでない場合は、何もしません。
- 件名に「Price Checks」などの特定の単語が含まれている場合。件名が一致しない場合は何もしません。
- 電子メールが正しいアドレスからのものである場合 新しい電子メールに .xls 添付ファイルがあることを確認します。.xls 添付ファイルがない場合は、何もしません。
- 添付ファイルをフォルダーに保存します。例:「C:\MyFolder」
- 電子メールを既読としてマークし、サブ フォルダーに移動します (例: "PriceCheckFolder")。
このコードを使用して受信トレイを確認していますが、フォルダー内のすべてのメールを調べており、基準に適合する最初のインスタンスのみを確認したいと考えています。
どうもありがとうメリンダ
‘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