CODEWITHSUNDEEP
vbaoutlook
cavaliers999
cavaliers999

Reputation: 23

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

Upvotes: 2

Views: 5191

Answers (2)

Eugene Astafiev
Eugene Astafiev

Reputation: 49455

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.

Upvotes: 1

Mikku
Mikku

Reputation: 6664

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

Upvotes: 1

Related Questions