outlook指定文件邮件附件进行下载并重命名

南京北京

各位大神大家好
在这里潜水了一段时间，也研究了一段时间，但是收效甚微，因此将此需求列出，请大神指点,
在工作中，由于会经常涉及一些申请需求，需要做申请台账，申请的模板是一致的均为：.xlsx或则.xls文件，目前我在论坛上找到了如下代码可以批量下载附件:


原文地址如下：
源文件链接为：http://simondu.blog.51cto.com/754321/730919
现在存在如下需求：
1、由于在申请的时候会附带一定的照片，不过照片不需要保存，但是这个程序会保存所有附件，我只需要保存.xlsx或.xls文件
2、这个程序在运行中会下载FOR Download这个文件下所有的历史文件附件，但是我仅希望它下载新到达的邮件附件
3、由于申请模板是固定的，因此附件的命名基本都是一致，但是附件中A3单元格均是不重复信息，因此希望可以用A3单元格信息进行重命名。
如上信息还望大神们不吝指点，谢谢！

threedomvip

两种思路，
第一，直接打开读取单元格数据后保存 （没有测试过请自行测试）
第二，保存后改名 （应该可行）
代码如下：

1. Public Sub SaveToFolder(MyMail As Outlook.MailItem)
   
2. Dim strID As String
   
3. Dim objNS As Outlook.Namespace
   
4. Dim objMail As Outlook.MailItem
   
5. Dim objAtt As Outlook.Attachment
   
6. Dim c As Integer
   
7. Dim save_name As String
   
8. Dim save_path As String
   
9. Dim ext As String
   
10. Dim ReFormatExcel
    
11. Dim wkb
    
12. 
    
13. strID = MyMail.EntryID
    
14. Set objNS = Application.GetNamespace("MAPI")
    
15. Set objMail = objNS.GetItemFromID(strID)
    
16. 
    
17. On Error Resume Next
    
18. 
    
19. If objMail.Attachments.Count > 0 Then
    
20.     For c = 1 To objMail.Attachments.Count
    
21.         Set objAtt = objMail.Attachments(c)
    
22.         save_name = objAtt.Filename
    
23.             
    
24.             'μúò»ÖÖ·½·¨￡oÖ±½ó′ò¿aoó¶áè¡μ￥Ôa¸ñêy¾Y¸ÄÃû±￡′æ
    
25.             '--------------------------------------------------------------------------------------
    
26. '            If objAtt.Filename Like "*.xl*" Then
    
27. '
    
28. '                Set ReFormatExcel = CreateObject("Excel.Application")
    
29. '                Set wkb = ReFormatExcel.Workbooks.Open(Filename:=objAtt.Filename)
    
30. '
    
31. '                    If Right(save_name, 4) = "." Then
    
32. '                        ext = ".xls"
    
33. '                    Else
    
34. '                        ext = ".xlsx"
    
35. '                    End If
    
36. '
    
37. '                save_name = wkb.Sheets(1).Range("A3").Value
    
38.             '--------------------------------------------------------------------------------------
    
39. 
    
40.                 save_path = "D:\test" 'Ä©Î2Îñ±Ø¼óéÏ·′D±¸ü
    
41.                
    
42.                 'èç1ûÎļt¼D2»′æÔúÔò′′½¨
    
43.                 If Dir(save_path, 16) = Empty Then
    
44.                     VBA.MkDir (save_path)
    
45.                 End If
    
46.                
    
47.             objAtt.SaveAsFile save_path & save_name
    
48.             End If
    
49.     Next
    
50. End If
    
51. 
    
52. 
    
53. 'μú¶tÖÖ·½·¨￡o±￡′æoó¸ÄÃû
    
54. '---------------------------------------------------------------------
    
55. 'If save_name Like "*.xl*" Then
    
56. '
    
57. 'Set ReFormatExcel = CreateObject("Excel.Application")
    
58. 'Set wkb = ReFormatExcel.Workbooks.Open(Filename:=save_path & save_name)
    
59. 
    
60. '    If Right(save_name, 4) = "." Then
    
61. '        ext = ".xls"
    
62. '    Else
    
63. '        ext = ".xlsx"
    
64. '    End If
    
65. 'save_name = wkb.Sheets(1).Range("A3").Value
    
66. '
    
67. 'wkb.SaveAsFile save_path & save_name & ext
    
68. 'End If
    
69. 
    
70. '---------------------------------------------------------------------
    
71. 
    
72. objMail.Delete
    
73. 
    
74. Set objAtt = Nothing
    
75. Set objMail = Nothing
    
76. Set objNS = Nothing
    
77. End Sub
    
78. 
    
79. 
    
80. 
    

复制代码