Save outlook email to my internal drive as .msg file

问题

I'm trying to save Outlook emails into my H:Drive. I want it as a run a script rule but I can't get it to work. There are no attachments involved and all I need it is to save it as a .msg file. Please lmk if you find a different way to tackle this problem.

Thanks

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

回答1:

Problem:

Folder Check was included in the Loop
FileName had Subject in it. That always creates problem unless some kind of manipulation is done. Because it contains various characters that are not permitted in the Name of a File in Windows.

Note:

Put it in any Module in Outlook and Run using F5 or by Creating a Shortcut.

Try:

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

回答2:

First of all, there is no need to create a new Outlook Application instance (twice in your sample code!) if your VBA macro is run by the rule. Instead, you can use the global Application property:

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

The sample code which is shown above saves the item against which the rule is run to the folder specified/hardcoded.

来源：https://stackoverflow.com/questions/57379087/save-outlook-email-to-my-internal-drive-as-msg-file

标签

vba

outlook