Save outlook email to my internal drive as .msg file - vba

Question

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

Answer 1

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.

Answer 2

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