1.需求描述最近有个同事收到了 50 多封邮件,每个邮件基本带一个附件,问我有没有办法帮忙批量处理,我马上想到用 VBA 来进行批量处理,然后上网搜了一下解决办法,这里将实现步骤记录下来。 2.实现步骤打开 Outlook 的选项,进入信任中心,打开信任中心设置,点击宏设置后选中启用所有宏点确定保存(等会记得改回去) 在收件箱上右键选择 新建文件夹,命名为:For Download 选中所有要导出附件的邮件后,右键点击 移动 选刚刚新建的 For Download 文件夹 完成后可以打开该文件夹看看邮件是否已经移过去 接着按 Alt+F11 调出 VBA编辑器(这里如果无法弹出编辑器,可以参照评论区小伙伴的意见:进入选项 → 自定义功能区 → 勾选开发工具),双击 ThisOutlookSession,然后在弹出窗口粘贴如下代码,然后点击运行按钮 Function FileFolderExists(strFullPath As String) As Boolean '---判断文件夹是否存在
If Not Dir(strFullPath, 16) = vbNullString Then
FileFolderExists = True
Else
FileFolderExists = False
End IfEnd FunctionFunction CreateParentFile(strPath As String) As String '---创建存放所有附件的父文件夹
While FileFolderExists(strPath) = True
strPath = strPath + CStr(Timer())
CreateParentFile (strPath)
Wend
CreateParentFile = strPathEnd FunctionSub SaveTheAttachment() '---主函数,用于保存右键附件
Dim olApp As New Outlook.Application Dim nmsName As Outlook.NameSpace
Dim vItem As Object
Dim path As String '---文件夹名称
Dim result As Integer '---点击弹窗结果
Set nmsName = olApp.GetNamespace('MAPI')
Set myFolder = nmsName.GetDefaultFolder(olFolderInbox)
Set fldFolder = myFolder.Folders('For Download') '---如果邮件在别的文件夹,只需要改这里就行
path = CreateParentFile('D:\Attachment') '---如果想换个存放附件的文件夹名称,改这里即可
VBA.MkDir (path) '---创建父文件夹,用于存放所有文件
For Each vItem In fldFolder.Items '-----Save Attachment-------
For Each att In vItem.Attachments
att.SaveAsFile path & '\' & att.FileName Next
'------Save Attachment--------
Next
Set fldFolder = Nothing
Set nmsName = Nothing
'------下载完成--------
result = MsgBox('附件已下载完成,请至目标文件夹查看!', 0 + 64 + 0, '下载成功') '---提示下载完成
Select Case result Case 1
Shell 'explorer.exe ' & path, vbNormalFocus '---打开输出文件夹
End Select
'------下载完成--------End Sub
3.功能升级根据评论区反馈,对之前的功能做了一些升级 升级功能:
实现代码: Const SpecialCharacters As String = '\/:*?<>|' '---不能用于创建文件夹的特殊字符Function ReplaceSpecialCharacters(myString As String) As String '---去字符串中除特殊字符的函数 Dim newString As String, L As Long, i As Long Dim char As Variant newString = myString L = Len(newString) For i = 1 To L char = Mid(newString, i, 1) If InStr(SpecialCharacters, char) > 0 Then newString = Replace(newString, char, '') '---碰到特殊字符直接删除 End If Next i ReplaceSpecialCharacters = newStringEnd FunctionFunction FileFolderExists(strFullPath As String) As Boolean '---判断文件夹是否存在 If Not Dir(strFullPath, 16) = vbNullString Then FileFolderExists = True Else FileFolderExists = False End IfEnd FunctionFunction CreateParentFile(strPath As String) As String '---创建存放所有附件的父文件夹 While FileFolderExists(strPath) = True strPath = strPath + CStr(Timer()) CreateParentFile (strPath) Wend CreateParentFile = strPathEnd FunctionSub SaveTheAttachment() '---主函数,用于保存右键附件 Dim olApp As New Outlook.Application Dim nmsName As Outlook.NameSpace Dim vItem As Object Dim sbj As String '---邮件主题 Dim path As String '---文件夹名称 Dim filepath As String '---文件路径 Dim result As Integer '---点击弹窗结果 Set nmsName = olApp.GetNamespace('MAPI') Set myFolder = nmsName.GetDefaultFolder(olFolderInbox) Set fldFolder = myFolder.Folders('For Download') '---如果邮件在别的文件夹,只需要改这里就行 path = CreateParentFile('D:\Attachment') '---如果想换个存放附件的文件夹名称,改这里即可 VBA.MkDir (path) '---创建父文件夹,用于存放所有文件 For Each vItem In fldFolder.Items sbj = vItem.Subject '---获取邮件主题 filepath = path + '\' + ReplaceSpecialCharacters(sbj) 'Debug.Print filepath '---打印输出文件夹路径 On Error Resume Next '---遇到异常直接跳过 VBA.MkDir (filepath) '---创建以主题命名的文件夹 '-----Save Attachment------- For Each att In vItem.Attachments att.SaveAsFile filepath & '\' & att.FileName Next '------Save Attachment-------- Next Set fldFolder = Nothing Set nmsName = Nothing '------下载完成-------- result = MsgBox('附件已下载完成,请至目标文件夹查看!', 0 + 64 + 0, '下载成功') '---提示下载完成 Select Case result Case 1 Shell 'explorer.exe ' & path, vbNormalFocus '---打开输出文件夹 End Select '------下载完成--------End Sub 最后记得:删除代码,关闭窗口,将宏设置还原 4.处理问题4.1 特殊字符处理增加函数去除主题内的 特殊字符,因为包含特殊字符,无法创建对应文件夹,如下图所示 Const SpecialCharacters As String = '\/:*?<>|' '---不能用于创建文件夹的特殊字符Function ReplaceSpecialCharacters(myString As String) As String '---去字符串中除特殊字符的函数
Dim newString As String, L As Long, i As Long
Dim char As Variant
newString = myString
L = Len(newString)
For i = 1 To L char = Mid(newString, i, 1)
If InStr(SpecialCharacters, char) > 0 Then
newString = Replace(newString, char, '') '---碰到特殊字符直接删除
End If
Next i
ReplaceSpecialCharacters = newStringEnd Function 4.2 文件夹自动创建修复Attachment文件夹已存在的问题,现在不需要创建该文件夹,直接运行代码即可,如果存在相同文件夹,则在文件夹后面加个当天毫秒值 Function FileFolderExists(strFullPath As String) As Boolean '---判断文件夹是否存在 If Not Dir(strFullPath, 16) = vbNullString Then FileFolderExists = True Else FileFolderExists = False End IfEnd FunctionFunction CreateParentFile(strPath As String) As String '---创建存放所有附件的父文件夹 While FileFolderExists(strPath) = True strPath = strPath + CStr(Timer()) CreateParentFile (strPath) Wend CreateParentFile = strPathEnd Function 4.3 下载完成后提示代码结尾加了个 弹框提示,不然不知道时候下载结束了,点击关闭或确定,会打开下载附件的文件夹 '------下载完成--------
result = MsgBox('附件已下载完成,请至目标文件夹查看!', 0 + 64 + 0, '下载成功') '---提示下载完成
Select Case result Case 1
Shell 'explorer.exe ' & path, vbNormalFocus '---打开输出文件夹
End Select'------下载完成-------- |
|
来自: xiaozhuang > 《OUTLOOK》