Public Sub SaveMessageAsMsg()
Dim objWord As Word.Application
Dim dlgSaveAs As FileDialog
  
  Dim oMail As Outlook.MailItem
  Dim objItem As Object
  Dim sPath, strFolderpath As String
  Dim dtDate As Date
  Dim sName As String
  Dim enviro As String
 
Set objWord = CreateObject("Word.Application")

Set dlgSaveAs = objWord.FileDialog(msoFileDialogSaveAs)
 
    
enviro = CStr(Environ("USERPROFILE"))
For Each objItem In ActiveExplorer.Selection
Set oMail = objItem
   
  sName = oMail.Subject
  ReplaceCharsForFileName sName, "_"
 
  dtDate = oMail.ReceivedTime
  sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
    vbUseSystem) & Format(dtDate, "-hhnnss", _
    vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName


 dlgSaveAs.InitialFileName = enviro & "\Documents\" & sName
 
    If dlgSaveAs.Show = -1 Then
        strFolderpath = dlgSaveAs.SelectedItems(1)
    End If
      
'remove .docx from file name
sPath = Left(strFolderpath, Len(strFolderpath) - 5) 

  Debug.Print sPath
  oMail.SaveAs sPath & ".msg", olMSG
Next

    Set objWord = Nothing
    Set dlgSaveAs = Nothing

End Sub