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

zhoucs00

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



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

代码如下：

1. Sub Savetheattachment()
   
2.     Dim olApp As New Outlook.Application
   
3.     Dim nmsName As Outlook.NameSpace
   
4.     Dim vItem As Object
   
5.     Set nmsName = olApp.GetNamespace("MAPI")
   
6.     Set myFolder = nmsName.GetDefaultFolder(olFolderInbox)
   
7.     Set fldFolder = myFolder.Folders("For Download")
   
8.          
   
9.     For Each vItem In fldFolder.Items
   
10.        '-----Save Attachment-------
    
11.         For Each att In vItem.Attachments
    
12.             att.SaveAsFile "D:\Email Attachment Temp" & att.FileName
    
13.         Next
    
14.         '------Save Attachment--------
    
15.     Next
    
16.      
    
17.     Set fldFolder = Nothing
    
18.     Set nmsName = Nothing
    
19. End Sub
    

复制代码

主要步骤为：

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




该贴已经同步到 zhoucs00的微博

闻启学

==   又是你

哈哈哈  不玩foxmail 了

你代码放在那里的

zhoucs00

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

哈哈哈  不玩foxmail 了

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

dsd999

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

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

dsd999

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

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

zhoucs00

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

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

qisile

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

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

qisile

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

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

1. Sub 选择执行()
   
2.     Dim i
   
3.     i = InputBox("请输入1或2,1代表将For Download中的附件全部保存，2代表将选中的邮件中的附件全部保存", "提示")
   
4.     If i = 1 Then
   
5.         Call Savetheattachment1
   
6.     ElseIf i = 2 Then
   
7.         Call Savetheattachment2
   
8.     Else
   
9.         MsgBox "输入有误！"
   
10.         Exit Sub
    
11.     End If
    
12. End Sub
    
13. '将For Download中的附件全部保存
    
14. Sub Savetheattachment1()
    
15.     Dim olApp As New Outlook.Application
    
16.     Dim nmsName As Outlook.NameSpace
    
17.     Dim vItem As Object
    
18.     Set nmsName = olApp.GetNamespace("MAPI")
    
19.     Set myFolder = nmsName.GetDefaultFolder(olFolderInbox)
    
20.     Set fldFolder = myFolder.Folders("For Download")
    
21.     dd = "C:\Email Attachment Temp"
    
22.     If Dir(dd, vbDirectory) = "" Then MkDir dd
    
23.     '若无C:\Email Attachment Temp 文件夹则新建该文件夹
    
24.     For Each vItem In fldFolder.Items
    
25.     '对fldFolder里的每一封邮件进行循环
    
26.         For Each att In vItem.Attachments
    
27.         '对每一封带附件的邮件
    
28.         fn = "C:\Email Attachment Temp" & att.FileName
    
29.         'fn为路径+附件名
    
30.         n = 1
    
31.         Do Until Dir(fn) = ""
    
32.         '如果为空，说明该路径下没有该文件
    
33.         fn = "C:\Email Attachment Temp\ " & n & "_" & att.FileName
    
34.         '有该文件名则重命名前面加数字
    
35.         n = n + 1
    
36.         Loop
    
37.         att.SaveAsFile fn
    
38.         '附件存到C:\Email Attachment Temp中
    
39.         Next
    
40.     Next
    
41.     Set fldFolder = Nothing
    
42.     Set nmsName = Nothing
    
43.     MsgBox "已导出全部附件到“C:\Email Attachment Temp”，请查看。"
    
44. End Sub
    
45. '将选中的邮件中的附件全部保存
    
46. Sub Savetheattachment2()
    
47.     dd = "C:\Email Attachment Temp"
    
48.     If Dir(dd, vbDirectory) = "" Then MkDir dd
    
49.     '若无C:\Email Attachment Temp 文件夹则新建该文件夹
    
50.    
    
51.     Dim objItem As Outlook.MailItem
    
52.     For Each objItem In Application.ActiveExplorer.Selection
    
53.     If objItem.Class = olMail Then
    
54.         For Each att In objItem.Attachments
    
55.         '对每一封带附件的邮件
    
56.         fn = "C:\Email Attachment Temp" & att.FileName
    
57.         'fn为路径+附件名
    
58.         n = 1
    
59.         Do Until Dir(fn) = ""
    
60.         '如果为空，说明该路径下没有该文件
    
61.         fn = "C:\Email Attachment Temp\ " & n & "_" & att.FileName
    
62.         '有该文件名则重命名前面加数字
    
63.         n = n + 1
    
64.         Loop
    
65.         att.SaveAsFile fn
    
66.         '附件存到C:\Email Attachment Temp中
    
67.         Next
    
68.     End If
    
69.     Next
    
70.    
    
71.     MsgBox "已导出全部附件到“C:\Email Attachment Temp”，请查看。"
    
72. End Sub
    

复制代码

六月的雨2018

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