Outlook保存附件到用户指定文件夹

mj13800138000

从论坛找到高人写的代码，我这边有个需求是能不能将添加功能让“用户手动选择指定文件夹”，请大侠指点！

============Quote=============

需求：添加按钮，保存选中邮件的所有附件到一个目录中。

代码：

PrivateWithEvents vsoCommbandSaveAttach As CommandBarButton

Private Sub Application_Startup()

CalladdTotalButton

End Sub

增加工具栏

Sub addTotalButton()

On ErrorResume Next

DimvsoCommandBar As CommandBar

‘得到要添加的工具栏

SetvsoCommandBar = Outlook.ActiveExplorer.CommandBars("ExcelClub")

‘如果工具栏为空，则增加

If(vsoCommandBar Is Nothing) Then

SetvsoCommandBar = Outlook.ActiveExplorer.CommandBars.add("ExcelClub",msoBarTop)

‘在工具栏上增加一个按钮

SetvsoCommbandSaveAttach = vsoCommandBar.Controls.add(1)

vsoCommbandSaveAttach.Caption= "Save Attachment"

vsoCommbandSaveAttach.FaceId= 66

vsoCommbandSaveAttach.Style= msoButtonIconAndCaption

‘显示增加的工具栏

vsoCommandBar.Visible= True

Else

Set vsoCommbandSaveAttach= vsoCommandBar.Controls(1)

End If

End Sub

‘增加的按钮（Save Attachment）的执行

Private Sub vsoCommbandSaveAttach_Click(ByVal Ctrl AsOffice.CommandBarButton, CancelDefault As Boolean)

‘出现错误时下一句代码继续运行

OnError Resume Next

DimobjItem As Outlook.MailItem

DimAttachment As Outlook.Attachment

‘遍历所有选中的项

ForEach objItem In Application.ActiveExplorer.Selection

‘如果选中的是邮件

IfobjItem.Class = olMail Then

‘遍历邮件中的所有附件

ForEach Attachment In objItem.Attachments

‘将附件保存在c盘根目录下

Attachment.SaveAsFile"c:\" & Attachment.FileName

Next

End If

Next

MsgBox"附件保存在c盘根目录下"

End Sub

结果如图

============Unquote=============