Saving email headers as .msg - outlook

Question

Dear StackOverflowers.
I know a few programming languages, but unfortunately VBA is not one of them.
I'm trying to make a script that saves the headers from selected mails in Outlook as .msg-files.
I found a script that opens the headers as new messages, but how to I save them as e.g. [senders domain]_[date recieved].msg instead of opening them as new mails?
The script that I have:
Sub ViewInternetHeader()
Dim olItem As Outlook.MailItem, olMsg As Outlook.MailItem
Dim strHeader As String
For Each olItem In Application.ActiveExplorer.Selection
strHeader = GetInetHeaders(olItem)
Set olMsg = Application.CreateItem(olMailItem)
With olMsg
.BodyFormat = olFormatPlain
.Body = strHeader
.Display
End With
Next
Set olMsg = Nothing
End Sub
Function GetInetHeaders(olkMsg As Outlook.MailItem) As String
' Purpose: Returns the internet headers of a message.'
' Written: 4/28/2009'
' Author: BlueDevilFan'
' //techniclee.wordpress.com/
' Outlook: 2007'
Const PR_TRANSPORT_MESSAGE_HEADERS = "http://schemas.microsoft.com/mapi/proptag/0x007D001E"
Dim olkPA As Outlook.PropertyAccessor
Set olkPA = olkMsg.PropertyAccessor
GetInetHeaders = olkPA.GetProperty(PR_TRANSPORT_MESSAGE_HEADERS)
Set olkPA = Nothing
End Function

Answer 1

Use the MailItem.SaveAs method which saves the Microsoft Outlook item to the specified path and in the format of the specified file type. If the file type is not specified, the MSG format (.msg) is used. For example:
Sub SaveAsTXT()
Dim myItem As Outlook.Inspector
Dim objItem As Object
Set myItem = Application.ActiveInspector
If Not TypeName(myItem) = "Nothing" Then
Set objItem = myItem.CurrentItem
strname = objItem.Subject
'Prompt the user for confirmation
Dim strPrompt As String
strPrompt = "Are you sure you want to save the item? " & _
"If a file with the same name already exists, " & _
"it will be overwritten with this copy of the file."
If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then
objItem.SaveAs Environ("HOMEPATH") & "\My Documents\" & strname & ".txt", olTXT
End If
Else
MsgBox "There is no current active inspector."
End If
End Sub

Answer 2

So you want an MSG file that has no recipients, attachments, subject, etc, only the MIME headers as the body? Why do you want the MSG format then?
You can create an populate a text file using the Scripting.FileSystemObject and use its CreateTextFile method.

Answer 3

Thank you, Eugene.
I managed to put in your code.
But it doesn't give the file a name, it's only called ".msg", and it doesn't work, when I try to select more than one email.
Also, how do I avoid, that it opens a new mail with the header?
I have this script now:
Sub ViewInternetHeader()
Dim olItem As Outlook.MailItem, olMsg As Outlook.MailItem
Dim strHeader As String
For Each olItem In Application.ActiveExplorer.Selection
strHeader = GetInetHeaders(olItem)
Set olMsg = Application.CreateItem(olMailItem)
With olMsg
.BodyFormat = olFormatPlain
.Body = strHeader
.Display
End With
Next
Set olMsg = Nothing
Dim myItem As Outlook.Inspector
Dim objItem As Object
Set myItem = Application.ActiveInspector
If Not TypeName(myItem) = "Nothing" Then
Set objItem = myItem.CurrentItem
strname = objItem.SenderEmailAddress
'Prompt the user for confirmation
Dim strPrompt As String
strPrompt = "Are you sure you want to save the item? " & _
"If a file with the same name already exists, " & _
"it will be overwritten with this copy of the file."
If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then
objItem.saveas "C:\temp\" & strname & ".msg", OLTXT
End If
Else
MsgBox "There is no current active inspector."
End If
End Sub
Function GetInetHeaders(olkMsg As Outlook.MailItem) As String
Const PR_TRANSPORT_MESSAGE_HEADERS = "http://schemas.microsoft.com/mapi/proptag/0x007D001E"
Dim olkPA As Outlook.PropertyAccessor
Set olkPA = olkMsg.PropertyAccessor
GetInetHeaders = olkPA.GetProperty(PR_TRANSPORT_MESSAGE_HEADERS)
Set olkPA = Nothing
End Function