vba - 将 Outlook 电子邮件另存为“.msg”而不是“文件”
问题描述
我有这段代码可以浏览 Outlook 中“今天”文件夹中的所有电子邮件,然后将所有电子邮件 (.msg) 保存到名为发件人名称的文件夹中。
有时文件以文件类型“文件”保存。
如何解决此问题以确保将电子邮件保存为 .msg 文件?
Sub SaveAttachments()
'https://www.fontstuff.com/outlook/oltut01.htm
'Declare Variables
Dim ns As NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim Savefolder As String
Dim i As Integer
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox).Folders("Today")
i = 0
'Stop script if there are no emails
If Inbox.Items.Count = 0 Then
MsgBox "There are no messages in the Inbox.", vbInformation, "Nothing Found"
Exit Sub
End If
'Display the number of emails
MsgBox Inbox.Items.Count, vbInformation, _
"Number of Emails?"
'Go through each email
For Each Item In Inbox.Items
'Create a path for the save folder
Savefolder = "C:\Users\work\Desktop\22_11_18\Test\" & Item.SenderName
'If the email has attachments, then create a folder
If Item.Attachments.Count > 0 Then
MkDir Savefolder
'If the folder already exists, skip to the next statement
On Error Resume Next
'Save the email as a .msg file
Item.SaveAs Savefolder & "\" & Item.Subject & ".msg"
End If
Next Item
End Sub
解决方案
如果主题中的字符都有效,则可以使用主题。
Option Explicit
Private Sub SaveMail_ContainingAttachments_ValidSubject()
'Declare Variables
Dim ns As Namespace
Dim targetFolder As Folder
Dim itm As Object
Dim atmt As Attachment
Dim strSaveFolder As String
Dim validSubject As String
Set ns = GetNamespace("MAPI")
Set targetFolder = ns.GetDefaultFolder(olFolderInbox)
Set targetFolder = targetFolder.Folders("Today")
'Stop script if there are no emails
If targetFolder.Items.count = 0 Then
MsgBox "There are no messages in " & targetFolder & ".", vbInformation, "Nothing Found"
Exit Sub
End If
'Display the number of emails
MsgBox targetFolder.Items.count, vbInformation, "Number of Emails?"
'Go through each email
For Each itm In targetFolder.Items
'If the email has attachments, then create a folder
If itm.Attachments.count > 0 Then
'Create a path for the save folder
strSaveFolder = "C:\Users\work\Desktop\22_11_18\Test\" & itm.senderName
' Bypass error if the folder already exists
On Error Resume Next
MkDir strSaveFolder
' Discontinue error bypass as soon as the purpose is served
' Let unknown errors generate then fix them
On Error GoTo 0
' Replace or remove invalid characters
' Possible options "_" or " " or "" ....
validSubject = ReplaceIllegalChar(itm.subject, "_")
If validSubject <> itm.subject Then
Debug.Print itm.subject
Debug.Print validSubject
End If
'Save the email as a .msg file
itm.SaveAs strSaveFolder & "\" & validSubject & ".msg"
End If
Next itm
End Sub
Private Function ReplaceIllegalChar(strInput, strReplace)
Dim RegX As Object
Set RegX = CreateObject("vbscript.regexp")
RegX.Pattern = "[\" & Chr(34) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]"
RegX.IgnoreCase = True
RegX.Global = True
' Replace with another string
ReplaceIllegalChar = RegX.Replace(strInput, strReplace)
ExitFunction:
Set RegX = Nothing
End Function
推荐阅读
- javascript - 是什么|| {}).property 在 Javascript 中的意思
- reactjs - 在重新渲染时从 Props 设置值后,React useState 未更新
- python - 如何使用 Python 将列表列表插入数据库
- javascript - 在开发/实时服务器上修改了 Yarn.lock
- itext7 - iText7 ViewerPreferences:默认情况下应显示书签
- python - 如果您没有输入正确的变量,则创建一个循环的函数
- ios - (自动化:Appium\Java)(Xamarin Forms\iOS 13)在应用程序内下载后,元素在树中不可见
- google-apps-script - 你如何从谷歌脚本设置图表聚合设置
- angular - 页面加载时的角度 p-inputswitch
- java - 使用 Java 将文件推送到现有的 GitLab 存储库?