将 Outlook 电子邮件作为 .msg 文件保存到我的内部驱动器

Question

我正在尝试将 Outlook 电子邮件保存到我的 H:Drive。我希望它作为运行脚本规则，但我无法让它工作。不涉及任何附件，我只需要将其保存为 .msg 文件。如果您找到解决此问题的其他方法，请 lmk。

谢谢

Sub ExtractEmailToFolder2(itm As Outlook.MailItem)

Dim OlApp As Outlook.Application
Set OlApp = New Outlook.Application
Dim Mailobject As Object
Dim Email As String
Dim NS As NameSpace
Dim Folder As MAPIFolder
Set OlApp = CreateObject("Outlook.Application")

Dim fso As Object
Dim fldrname As String
Dim fldrpath As String

' Setup Namespace
  Set NS = ThisOutlookSession.Session
' Display select folder dialog
  Set Folder = NS.PickFolder
' Create Folder File
  Set fso = CreateObject("Scripting.FileSystemObject")

' loop to read email address from mail items.
For Each Mailobject In Folder.Items
fldrpath = "H:\Backup stuff\"
If Not fso.folderexists(fldrpath) Then
    fso.createfolder (fldrpath)
End If

Set objCopy = Mailobject.Copy
objCopy.SaveAs fldrpath & "\" & objCopy.Subject, olMSG

Next
Set OlApp = Nothing
Set Mailobject = Nothing

End Sub

Answer 1

首先，如果您的 VBA 宏按规则运行，则无需创建新的 Outlook Application 实例（在您的示例代码中两次！）。相反，您可以使用全局 Application 属性：

Sub ExtractEmailToFolder2(itm As Outlook.MailItem)

Dim fso As Object
Dim fldrname As String
Dim fldrpath As String

' Create Folder if required
  Set fso = CreateObject("Scripting.FileSystemObject")

fldrpath = "H:\Backup stuff\"
If Not fso.folderexists(fldrpath) Then
    fso.createfolder (fldrpath)
End If

itm.SaveAs fldrpath & "\" & "your_unique_filename.msg", olMSG

Set OlApp = Nothing
Set Mailobject = Nothing

End Sub

上面显示的示例代码将运行规则所针对的项目保存到指定/硬编码的文件夹中。

Answer 2

问题：

• 文件夹检查包含在循环中
• 文件名中有主题。除非进行某种操作，否则这总是会产生问题。因为它包含 Windows 中文件名中不允许出现的各种字符。

注意：

• 将其放入 Outlook 的任何模块中，然后使用 F5 或创建快捷方式运行。

试试：

Sub ExtractEmailToFolder2()


Dim OlApp As Outlook.Application
Set OlApp = New Outlook.Application
Dim Mailobject As Object
Dim Email As String
Dim NS As NameSpace
Dim Folder As MAPIFolder
Set OlApp = CreateObject("Outlook.Application")

Dim fso As Object
Dim fldrname As String
Dim fldrpath As String

' Setup Namespace
  Set NS = ThisOutlookSession.Session
' Display select folder dialog
  Set Folder = NS.PickFolder
' Create Folder File
  Set fso = CreateObject("Scripting.FileSystemObject")

  fldrpath = "H:\Backup stuff\"

If Not fso.folderexists(fldrpath) Then
    fso.createfolder (fldrpath)
End If


' loop to read email address from mail items.
i = 1

For Each Mailobject In Folder.Items

    Mailobject.SaveAs fldrpath & "\mail" & i & ".msg", olMsg
    i = i + 1

Next
Set OlApp = Nothing
Set Mailobject = Nothing


End Sub