点击下载此附件
代 码:
Dim myFilter As String
Dim folder As String
Dim myOlApp As Object
Dim myNamespace As Object ' Outlook.NameSpace
Dim myFolder As Object ' Outlook.folder
Dim mymailitem As Variant
Dim att As Variant
Dim Path As String
myFilter = InputBox("请输入邮件标题的过滤关键字:", , "测试")
folder = InputBox("请输入邮件附件的保存目录:", , "D:\新建文件夹")
Set myOlApp = CreateObject("Outlook.Application")
Set myNamespace = myOlApp.GetNamespace("MAPI")
Set myFolder = myNamespace.GetDefaultFolder(6)
For Each mymailitem In myFolder.Items
If mymailitem.UnRead Then
If InStr(mymailitem.Subject, myFilter) Then
mymailitem.UnRead = False
If mymailitem.Attachments.Count > 0 Then
For Each att In mymailitem.Attachments
Path = folder & "\" & mymailitem.Subject & "-" & att.FileName
Debug.Print Path
att.SaveAsFile Path
Next
Else
MsgBox mymailitem.SenderEmailAddress & "无附件"
End If
End If
End If
Next
MsgBox "完工了"
演 示: