outlook中批量保存附件的宏

前几天有人问MS Office Outlook（不是outlook express）中自动批量保存附件的软件，今天翻了翻office vba编程的书，学习一下。写了一个非常简单的宏，没有任何出错处理，只能在找不到合适的软件时对付着用。在outlook 2002中测试通过。

outlook中alt+F8，输入宏的名字，创建，把以下代码拷贝进去。选择要保存附件的邮件（选中邮件中某封信没有附件也没关系，宏可以判断的），执行宏即可。附件保存到的目录写在了宏里，你自己改folder那个变量。保存后的附件名字后半部分是附件原始名字，前面加了“mail<顺序号>”的前缀，防止重名，想整理文件时分类也方便一些。

Public Sub SaveAtt()
Dim msg As MailItem
Dim exp As Explorer
Dim att As Attachment
Dim mailIndex As Integer
Dim path As String
Dim folder As String
Set exp = Application.ActiveExplorer
'保存附件到哪个文件夹，末尾必须是斜杠
folder = "c:\temp"
mailIndex = 0
For Each msg In exp.Selection
If msg.Attachments.Count > 0 Then
mailIndex = mailIndex + 1
For Each att In msg.Attachments
'所有附件保存到folder指定的文件夹中，文件命名为：mailatt<编号>_附件原始文件名
path = folder + "mailatt" + CStr(mailIndex) + "_" + att.FileName
att.SaveAsFile path
Next
End If
Next
End Sub

复制代码

改写了一下，可以按邮件地址分类创建目录来保存。

Sub 批量保存附件()
Dim msg As MailItem
Dim exp As Explorer
Dim att As Attachment
Dim mailIndex As Integer
Dim path As String
Dim folder As String
Dim info As String
Set exp = Application.ActiveExplorer
Set Fso = CreateObject("Scripting.FileSystemObject")
'保存附件到哪个文件夹，末尾必须是斜杠
folder = "D:\Office\att"
mailIndex = 0
For Each msg In exp.Selection
If msg.Attachments.Count > 0 Then
mailIndex = mailIndex + 1
If Fso.FolderExists(folder + msg.SenderEmailAddress) = False Then
MkDir (folder + msg.SenderEmailAddress)
End If
For Each att In msg.Attachments
'所有附件保存到folder指定的文件夹中，文件命名为：mailatt<编号>_附件原始文件名
path = folder + CStr(msg.SenderEmailAddress) + "" + CStr(mailIndex) + "_" + att.FileName
att.SaveAsFile path
info = info & Chr(10) & "主题：" + msg.Subject & Chr(10) & "附件数量：" + CStr(msg.Attachments.Count)
Next
End If
Next
MsgBox info, vbInformation, "保存附件"
End Sub

复制代码

[ 本帖最后由灰儿于 2008-7-18 17:56 编辑 ]

灰儿 · 发表于 2008-7-18 18:06:49

Sub 批量保存附件()
Dim msg As MailItem
Dim exp As Explorer
Dim att As Attachment
Dim mailIndex As Integer
Dim path As String
Dim folder As String
Dim info As String
Set exp = Application.ActiveExplorer
Set Fso = CreateObject("Scripting.FileSystemObject")
'保存附件到哪个文件夹，末尾必须是斜杠
folder = "D:\Office"
mailIndex = 0
For Each msg In exp.Selection
If msg.Attachments.Count > 0 Then
mailIndex = mailIndex + 1
For Each att In msg.Attachments
'所有附件保存到folder指定的文件夹中，文件命名为：mailatt<编号>_附件原始文件名
path = folder + CStr(mailIndex) + "_" + att.FileName
att.SaveAsFile path
info = info & Chr(10) & "主题：" + msg.Subject & Chr(10) & "附件数量：" + CStr(msg.Attachments.Count)
Next
End If
Next
MsgBox info, vbInformation, "保存附件"
End Sub

复制代码