批量导出Outlook 2010附件 VBA代码问题

zhoucs00 · 发表于 2014-12-25 15:57

本帖最后由 zhoucs00 于 2014-12-25 15:58 编辑

大家好，我在网上找到一段批量导出outlook 附件的代码，但我运行时出现如下错误；不知什么原因，还请大家能够帮忙修改一下；

vba代码.png

源文件链接为：http://simondu.blog.51cto.com/754321/730919

代码如下：

Sub Savetheattachment()
Dim olApp As New Outlook.Application
Dim nmsName As Outlook.NameSpace
Dim vItem As Object
Set nmsName = olApp.GetNamespace("MAPI")
Set myFolder = nmsName.GetDefaultFolder(olFolderInbox)
Set fldFolder = myFolder.Folders("For Download")
For Each vItem In fldFolder.Items
'-----Save Attachment-------
For Each att In vItem.Attachments
att.SaveAsFile "D:\Email Attachment Temp" & att.FileName
Next
'------Save Attachment--------
Next
Set fldFolder = Nothing
Set nmsName = Nothing
End Sub

复制代码

主要步骤为：

1)在Inbox里面创建一个文件夹，命名为For Download，把需要导出附件的Email邮件放在For Download里面。
2)在D盘创建一个文件夹，命名为Email Attachment Temp
3)打开outlook，按下Alt+F11 粘贴如下代码：
4)点击运行；

该贴已经同步到 zhoucs00的微博

闻启学 · 发表于 2014-12-27 23:23

== 又是你

哈哈哈不玩foxmail 了

你代码放在那里的

zhoucs00 · 发表于 2014-12-29 14:31

闻启学发表于 2014-12-27 23:23
== 又是你

哈哈哈不玩foxmail 了

小闻老师！这是outlook呀，不知道那句为什么出错了，搞不懂呀；
我看了你写的那个一步一步教你发邮件的那个帖子很棒；/呲牙

dsd999 · 发表于 2015-1-5 09:39

zhoucs00 发表于 2014-12-29 14:31
小闻老师！这是outlook呀，不知道那句为什么出错了，搞不懂呀；
我看了你写的那个一步一步教你发邮件的那 ...

代码没问题，检查你创建的目录拼写是否正确。

dsd999 · 发表于 2015-1-5 09:39

zhoucs00 发表于 2014-12-29 14:31
小闻老师！这是outlook呀，不知道那句为什么出错了，搞不懂呀；
我看了你写的那个一步一步教你发邮件的那 ...

代码没问题，检查你创建的目录拼写是否正确。

zhoucs00 · 发表于 2015-1-6 16:32

dsd999 发表于 2015-1-5 09:39
代码没问题，检查你创建的目录拼写是否正确。

嗯，刚看到，谢谢您的指导/呲牙

qisile · 发表于 2015-2-12 22:29

dsd999 发表于 2015-1-5 09:39
代码没问题，检查你创建的目录拼写是否正确。

请问如何进行将Inbox以及子文件夹里的收件日期在指定日期（从A日期到B日期）邮件中的附件全部下载另存，并且当附件名重复时自动重命名呢？
非常感谢

qisile · 发表于 2015-2-13 00:20

qisile 发表于 2015-2-12 22:29
请问如何进行将Inbox以及子文件夹里的收件日期在指定日期（从A日期到B日期）邮件中的附件全部下载另存， ...

已经寻找到部分解决方案，如果能重命名在文件名（不含扩展名）的后面就好了。
对全部的邮件另存附件还在寻找解决方案中

Sub 选择执行()
Dim i
i = InputBox("请输入1或2,1代表将For Download中的附件全部保存，2代表将选中的邮件中的附件全部保存", "提示")
If i = 1 Then
Call Savetheattachment1
ElseIf i = 2 Then
Call Savetheattachment2
Else
MsgBox "输入有误！"
Exit Sub
End If
End Sub
'将For Download中的附件全部保存
Sub Savetheattachment1()
Dim olApp As New Outlook.Application
Dim nmsName As Outlook.NameSpace
Dim vItem As Object
Set nmsName = olApp.GetNamespace("MAPI")
Set myFolder = nmsName.GetDefaultFolder(olFolderInbox)
Set fldFolder = myFolder.Folders("For Download")
dd = "C:\Email Attachment Temp"
If Dir(dd, vbDirectory) = "" Then MkDir dd
'若无C:\Email Attachment Temp 文件夹则新建该文件夹
For Each vItem In fldFolder.Items
'对fldFolder里的每一封邮件进行循环
For Each att In vItem.Attachments
'对每一封带附件的邮件
fn = "C:\Email Attachment Temp" & att.FileName
'fn为路径+附件名
n = 1
Do Until Dir(fn) = ""
'如果为空，说明该路径下没有该文件
fn = "C:\Email Attachment Temp\ " & n & "_" & att.FileName
'有该文件名则重命名前面加数字
n = n + 1
Loop
att.SaveAsFile fn
'附件存到C:\Email Attachment Temp中
Next
Next
Set fldFolder = Nothing
Set nmsName = Nothing
MsgBox "已导出全部附件到“C:\Email Attachment Temp”，请查看。"
End Sub
'将选中的邮件中的附件全部保存
Sub Savetheattachment2()
dd = "C:\Email Attachment Temp"
If Dir(dd, vbDirectory) = "" Then MkDir dd
'若无C:\Email Attachment Temp 文件夹则新建该文件夹
Dim objItem As Outlook.MailItem
For Each objItem In Application.ActiveExplorer.Selection
If objItem.Class = olMail Then
For Each att In objItem.Attachments
'对每一封带附件的邮件
fn = "C:\Email Attachment Temp" & att.FileName
'fn为路径+附件名
n = 1
Do Until Dir(fn) = ""
'如果为空，说明该路径下没有该文件
fn = "C:\Email Attachment Temp\ " & n & "_" & att.FileName
'有该文件名则重命名前面加数字
n = n + 1
Loop
att.SaveAsFile fn
'附件存到C:\Email Attachment Temp中
Next
End If
Next
MsgBox "已导出全部附件到“C:\Email Attachment Temp”，请查看。"
End Sub

复制代码

六月的雨2018 · 发表于 2017-4-16 15:07

解决了吗，我和你遇到同样的问题

		自动登录	找回密码
密码			免费注册

[求助] 批量导出Outlook 2010附件 VBA代码问题