OUTLOOK带附件回复

lx105834038

OUTLOKK回复时我们经常想要直接把上一封的附件一起作为附件回复。
但是OUTLOOK只有转发才会带附件。虽然我们也可以通过把附件复制黏贴的方式完成带附件操作。
但是复制还要多操作几下，尤其如果附件比较多的话就更加麻烦了。
网上找了一段代码，一键完成带附件回复。
原代码：https://www.doc88.com/p-9903959852874.html?r=1

但是运行时发现回复的附件会把之前邮件的图片一起当作附件，这怎么可以呢！
F8运行了一下，发现这些图片附件都被统一以“imageXXX”的形式命名，那就简单了加个IF就OK啦。

楼主OUTLOOK版本：LTSC
系统版本：win10
使用方法：ALT+F11→在工程处右键”插入“-”模块“→复制代码→保存。

提醒：如果运行不成功，请保存VBA后重启OUTLOOK，另外宏安全性请调整为最低。

1. '带附件回复
   
2. Sub ReplyWithAttachments()
   
3. Dim rpl As Outlook.MailItem
   
4. Dim itm As Object
   
5. Set itm = GetCurrentItem()
   
6. If Not itm Is Nothing Then
   
7. Set rpl = itm.Reply
   
8. CopyAttachments itm, rpl
   
9. rpl.Display
   
10. End If
    
11. Set rpl = Nothing
    
12. Set itm = Nothing
    
13. End Sub
    
14. '带附件回复所有
    
15. Sub ReplyToAllWithAttachments()
    
16. Dim rpl As Outlook.MailItem
    
17. Dim itm As Object
    
18. Set itm = GetCurrentItem()
    
19. If Not itm Is Nothing Then
    
20. Set rpl = itm.ReplyAll
    
21. CopyAttachments itm, rpl
    
22. rpl.Display
    
23. End If
    
24. Set rpl = Nothing
    
25. Set itm = Nothing
    
26. End Sub
    
27. '获取主题名称
    
28. Function GetCurrentItem() As Object
    
29. Dim objApp As Outlook.Application
    
30. Set objApp = Application
    
31. On Error Resume Next
    
32. Select Case TypeName(objApp.ActiveWindow)
    
33. Case "Explorer"
    
34. Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1) '获取主题名称
    
35. Case "Inspector"
    
36. Set GetCurrentItem = objApp.ActiveInspector.CurrentItem '获取主题名称
    
37. End Select
    
38. Set objApp = Nothing
    
39. End Function
    
40. '复制附件
    
41. Sub CopyAttachments(objSourceItem, objTargetItem)
    
42. Set fso = CreateObject("Scripting.FileSystemObject")
    
43. Set fldTemp = fso.GetSpecialFolder(2) ' TemporaryFolder
    
44. strPath = fldTemp.Path & ""
    
45. For Each objAtt In objSourceItem.Attachments
    
46. If Left(objAtt, 5) = "image" Or Right(objAtt, 4) = ".jpg" Or Right(objAtt, 4) = ".png" Then
    
47. GoTo down
    
48. Else
    
49. strFile = strPath & objAtt.FileName
    
50. objAtt.SaveAsFile strFile
    
51. objTargetItem.Attachments.Add strFile, , , objAtt.DisplayName
    
52. fso.DeleteFile strFile
    
53. End If
    
54. down:
    
55. Next
    
56. Set fldTemp = Nothing
    
57. Set fso = Nothing
    
58. End Sub

复制代码

lx105834038

上面的代码可能误判了图片附件。而且有时候我们可能只需要回复部分的附件。
所以在复制附件代码中进行优化，增加一个选择的界面。
主代码：

1. '带附件回复
   
2. Sub ReplyWithAttachments()
   
3. Dim rpl As Outlook.MailItem
   
4. Dim itm As Object
   
5. Set itm = GetCurrentItem()
   
6. If Not itm Is Nothing Then
   
7. Set rpl = itm.Reply
   
8. CopyAttachments itm, rpl
   
9. rpl.Display
   
10. End If
    
11. Set rpl = Nothing
    
12. Set itm = Nothing
    
13. End Sub
    
14. '带附件回复所有
    
15. Sub ReplyToAllWithAttachments()
    
16. Dim rpl As Outlook.MailItem
    
17. Dim itm As Object
    
18. Set itm = GetCurrentItem()
    
19. If Not itm Is Nothing Then
    
20. Set rpl = itm.ReplyAll
    
21. CopyAttachments itm, rpl
    
22. rpl.Display
    
23. End If
    
24. Set rpl = Nothing
    
25. Set itm = Nothing
    
26. End Sub
    
27. '获取主题名称
    
28. Function GetCurrentItem() As Object
    
29. Dim objApp As Outlook.Application
    
30. Set objApp = Application
    
31. On Error Resume Next
    
32. Select Case TypeName(objApp.ActiveWindow)
    
33. Case "Explorer"
    
34. Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1) '获取主题名称
    
35. Case "Inspector"
    
36. Set GetCurrentItem = objApp.ActiveInspector.CurrentItem '获取主题名称
    
37. End Select
    
38. Set objApp = Nothing
    
39. End Function
    
40. '复制附件
    
41. Sub CopyAttachments(objSourceItem, objTargetItem)
    
42. Set fso = CreateObject("Scripting.FileSystemObject")
    
43. Set fldTemp = fso.GetSpecialFolder(2) ' TemporaryFolder
    
44. strPath = fldTemp.path & ""
    
45. If MsgBox("本邮件附件个数：" & objSourceItem.Attachments.Count & "，是否添加所有附件回复？", vbYesNo) = vbYes Then
    
46.         For i = 1 To objSourceItem.Attachments.Count
    
47.               Set objAtt = objSourceItem.Attachments(i)
    
48.               objAtt.SaveAsFile path & objAtt.FileName
    
49.               strFile = strPath & objAtt.FileName
    
50.               objAtt.SaveAsFile strFile
    
51.               objTargetItem.Attachments.Add strFile, , , objAtt.DisplayName
    
52.               fso.DeleteFile strFile
    
53.         Next i
    
54.     Else
    
55.           UserForm1.Show
    
56. 
    
57. For j = 0 To UserForm1.ListBox2.ListCount - 1
    
58.       n = UserForm1.ListBox2.List(j)
    
59.       For i = 1 To objSourceItem.Attachments.Count
    
60.             Set objAtt = objSourceItem.Attachments(i)
    
61.             If objAtt = n Then
    
62.                Set objAtt = objSourceItem.Attachments(i)
    
63.                objAtt.SaveAsFile path & objAtt.FileName
    
64.                strFile = strPath & objAtt.FileName
    
65.                objAtt.SaveAsFile strFile
    
66.                objTargetItem.Attachments.Add strFile, , , objAtt.DisplayName
    
67.                fso.DeleteFile strFile
    
68.             End If
    
69.       Next i
    
70. Next j
    
71. End If
    
72. Set fldTemp = Nothing
    
73. Set fso = Nothing
    
74. End Sub

复制代码

UserForm1窗体代码：

1. 'Listbox1项目全选
   
2. Private Sub CheckBox1_Click()
   
3. Dim i, j
   
4. If CheckBox1 = True Then
   
5.     For i = 0 To ListBox1.ListCount - 1
   
6.           ListBox1.Selected(i) = True
   
7.     Next i
   
8. Else
   
9.       For j = 0 To ListBox1.ListCount - 1
   
10.           ListBox1.Selected(j) = False
    
11.      Next j
    
12. End If
    
13. End Sub
    
14. 'Listbox2项目全选
    
15. Private Sub CheckBox3_Click()
    
16. Dim i, j
    
17. If CheckBox3 = True Then
    
18.     For i = 0 To ListBox2.ListCount - 1
    
19.           ListBox2.Selected(i) = True
    
20.     Next i
    
21. Else
    
22.       For j = 0 To ListBox2.ListCount - 1
    
23.             ListBox2.Selected(j) = False
    
24.       Next j
    
25. End If
    
26. End Sub
    
27. '剔除Listbox1图片附件
    
28. Private Sub CheckBox2_Click()
    
29. If CheckBox2 = True Then
    
30.     For i = 0 To ListBox1.ListCount - 1
    
31.           n = Right(ListBox1.List(i), 4)
    
32.           If n = ".jpg" Or n = ".png" Or n = ".jepg" Then
    
33.              ListBox1.Selected(i) = False
    
34.           Else
    
35.                 ListBox1.Selected(i) = True
    
36.           End If
    
37.     Next i
    
38. Else
    
39.       For j = 0 To ListBox1.ListCount - 1
    
40.             n = Right(ListBox1.List(i), 4)
    
41.             If n = ".jpg" Or n = ".png" Or n = ".jepg" Then
    
42.                   ListBox1.Selected(j) = False
    
43.             End If
    
44.       Next j
    
45. End If
    
46. End Sub
    
47. '剔除Listbox2图片附件
    
48. Private Sub CheckBox4_Click()
    
49. If CheckBox4 = True Then
    
50.     For i = 0 To ListBox2.ListCount - 1
    
51.           n = Right(ListBox2.List(i), 4)
    
52.           If n = ".jpg" Or n = ".png" Or n = ".jepg" Then
    
53.              ListBox2.Selected(i) = True
    
54.           End If
    
55.     Next i
    
56. Else
    
57.       For j = 0 To ListBox2.ListCount - 1
    
58.             n = Right(ListBox2.List(j), 4)
    
59.             If n = ".jpg" Or n = ".png" Or n = ".jepg" Then
    
60.                ListBox2.Selected(j) = False
    
61.             End If
    
62.       Next j
    
63. End If
    
64. End Sub
    
65. 
    
66. Private Sub CommandButton1_Click()
    
67. UserForm1.hide
    
68. End Sub
    
69. 
    
70. Private Sub CommandButton2_Click()
    
71. UserForm1.hide
    
72. End Sub
    
73. 
    
74. '选择要添加附件
    
75. Private Sub CommandButton3_Click()
    
76. Dim i, j
    
77. A:
    
78. Label3 = ListBox1.ListCount
    
79. Label4 = ListBox2.ListCount
    
80. For j = ListBox1.ListCount - 1 To 0 Step -1
    
81.      If ListBox1.Selected(j) = True Then
    
82.          ListBox2.AddItem ListBox1.List(j), 0
    
83.          ListBox1.RemoveItem (j)
    
84.          GoTo A
    
85.      End If
    
86. Next j
    
87. End Sub
    
88. '选择要移除附件
    
89. Private Sub CommandButton4_Click()
    
90. A:
    
91. Label3 = ListBox1.ListCount
    
92. Label4 = ListBox2.ListCount
    
93. For j = ListBox2.ListCount - 1 To 0 Step -1
    
94.      If ListBox2.Selected(j) = True = True Then
    
95.          ListBox1.AddItem ListBox2.List(j), 0
    
96.          ListBox2.RemoveItem (j)
    
97.          GoTo A
    
98.      End If
    
99. Next j
    
100. End Sub
     
101. 
     
102. Private Sub UserForm_Initialize()
     
103. Dim objApp As Outlook.Application
     
104. Set objApp = Application
     
105. On Error Resume Next
     
106. Select Case TypeName(objApp.ActiveWindow)
     
107. Case "Explorer"
     
108. Set Item = objApp.ActiveExplorer.Selection.Item(1) '获取主题名称
     
109. Case "Inspector"
     
110. Set Item = objApp.ActiveInspector.CurrentItem  '获取主题名称
     
111. End Select
     
112. Set objApp = Nothing
     
113. Label2 = "邮件主题：" & vbclf & Item
     
114. Dim olAtt As Attachment
     
115. Dim i As Integer
     
116. i = Item.Attachments.Count
     
117. Label3 = i
     
118. Label4 = 0
     
119. With ListBox
     
120.         For j = 1 To i
     
121.              Set olAtt = Item.Attachments(j)
     
122.              ListBox1.AddItem olAtt, 0
     
123.         Next j
     
124. End With
     
125. ListBox1.ListIndex = 0
     
126. End Sub
     

复制代码