Editing extended file properties using powershell or VBA?

Is there a way to edit/change the extended file properties of a file using powershell? In particular I'd like to change the extended file properties of a .msg file which has been exported from outlook. I have seen a program online (proprietary code) that saves a .msg file with extended file properties such that it can be sorted in file explorer. The extended properties that were enabled on the .msg were useful information such as date received, the sender etc.

I can't for the life of me find an easy way of doing this in VBA or powershell and I'm wondering if anyone has any ideas or solutions. Currently I've created a macro that simply saves the information in the file name but putting it in the extended file properties is much more useful.

What frustrates me the most is that someone has clearly done this and I don't know how. I would have thought it would be quite simple. Alas.

EDIT: Please see my current code

Public Sub SaveMessageAsMsg()
Dim xMail As Outlook.MailItem
Dim xObjItem As Object
Dim xPath As String
Dim xDtDate As Date

Dim xName, xFileName As String
On Error Resume Next
Set xShell = CreateObject("Shell.Application")
Set xFolder = xShell.BrowseForFolder(0, "Select a folder:", 0, "C:\Users\" & Environ("UserName") & "ANON VARIABLE")
If Not TypeName(xFolder) = "Nothing" Then
    Set xFolderItem = xFolder.self
    xFileName = xFolderItem.Path & "\"
Else
    xFileName = ""
    Exit Sub
End If
For Each xObjItem In Outlook.ActiveExplorer.Selection
    If xObjItem.Class = olMail Then
        Set xMail = xObjItem
        SenderName = xMail.SenderName
        xName = xMail.Subject
        xDtDate = xMail.ReceivedTime
        xName = Replace(Format(xDtDate, "yyyy-mm-dd ", vbUseSystemDayOfWeek, _
          vbUseSystem) & " @ " & Format(xDtDate, "hh:mm:ss", _
          vbUseSystemDayOfWeek, vbUseSystem) & " - " & SenderName & " - " & xName & ".msg", ":", ".")
        Dim RegEx As Object
        Set RegEx = CreateObject("VBScript.RegExp")
        With RegEx
            .Pattern = "[\\/\*\?""<>\|]"
            .Global = True
            ValidName = .Replace(xName, "")
        End With       
        xPath = xFileName + ValidName
        xMail.SaveAs xPath, olMSG
    End If
Next
End Sub

Solution

You cannot easily do that in VBA or Outlook Object Model: these extra properties must be set on the OLE storage level used by the MSG file.

If using Redemption (I am its author) is an option, it exposes olMsgWithSummary format (similar to olMsg and olMsgUnicode in OOM) that will do what you need. The script below saves the currently selected Outlook message:

set Session = CreateObject("Redemption.RDOSession")
Session.MAPIOBJECT = Application.Session.MAPIOBJECT
set oMsg = Application.ActiveExplorer.Selection(1)
set rMsg = Session.GetRDOObjectFromOutlookObject(oMsg)
rMsg.SaveAs "c:\temp\ExtraProps.msg", 1035 '1035 is olMsgWithSummary

Your script above would like like the following (off the top of my head):

Public Sub SaveMessageAsMsg()
Dim xMail As Outlook.MailItem
Dim xObjItem As Object
Dim xPath As String
Dim xDtDate As Date
Dim rSession As Object
Dim rSession As Object

Dim xName, xFileName As String
On Error Resume Next
Set xShell = CreateObject("Shell.Application")
Set xFolder = xShell.BrowseForFolder(0, "Select a folder:", 0, "C:\Users\" & Environ("UserName") & "ANON VARIABLE")
If Not TypeName(xFolder) = "Nothing" Then
    Set xFolderItem = xFolder.self
    xFileName = xFolderItem.Path & "\"
Else
    xFileName = ""
    Exit Sub
End If
set rSession = CreateObject("Redemption.RDOSession")
rSession.MAPIOBJECT = Outlook.Session.MAPIOBJECT
For Each xObjItem In Outlook.ActiveExplorer.Selection
    If xObjItem.Class = olMail Then
        Set xMail = xObjItem
        SenderName = xMail.SenderName
        xName = xMail.Subject
        xDtDate = xMail.ReceivedTime
        xName = Replace(Format(xDtDate, "yyyy-mm-dd ", vbUseSystemDayOfWeek, _
          vbUseSystem) & " @ " & Format(xDtDate, "hh:mm:ss", _
          vbUseSystemDayOfWeek, vbUseSystem) & " - " & SenderName & " - " & xName & ".msg", ":", ".")
        Dim RegEx As Object
        Set RegEx = CreateObject("VBScript.RegExp")
        With RegEx
            .Pattern = "[\\/\*\?""<>\|]"
            .Global = True
            ValidName = .Replace(xName, "")
        End With       
        xPath = xFileName + ValidName
        set rMsg = rSession.GetRDOObjectFromOutlookObject(xMail)
        rMsg.SaveAs xPath, 1035
    End If
Next
End Sub