Outlook Macro to Save e-Mail Files

Outlook Macro to Save e-Mail Files

For background to this, see the section on e-mail in this post: https://blog.tectonicspeed.com/2017/09/personal-archiving-get-your-shit.html

ub SaveMails()


 Const OLTXT = 0

  Dim currentExplorer As Explorer

  Dim Selection As Selection

  Dim oMail As Outlook.MailItem

  Dim obj As Object

  Dim sPath As String

  Dim dtDate As Date

  Dim sName As String

  Dim rName As String

  Dim fName As String

  Dim feName As String

  

  Set currentExplorer = Application.ActiveExplorer

    Set Selection = currentExplorer.Selection


 For Each obj In Selection

  Set oMail = obj

  sName = oMail.Subject

  rName = oMail.ReceivedByName

  fName = oMail.SenderName

  feName = oMail.SenderEmailAddress

  

  ReplaceCharsForFileName sName, "_"

 

  dtDate = oMail.ReceivedTime

  sName = sName & "-" & Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _

    vbUseSystem) & Format(dtDate, "-hhnnss", _

    vbUseSystemDayOfWeek, vbUseSystem) & "-to " & rName & "-from " & feName & ".txt"

  

  oMail.SaveAs "C:\Users\Sanford\OutlookSaves\" & sName, OLTXT

  

  Next

 

End Sub

 

Private Sub ReplaceCharsForFileName(sName As String, _

  sChr As String _

)

  sName = Replace(sName, "/", sChr)

  sName = Replace(sName, "\", sChr)

  sName = Replace(sName, ":", sChr)

  sName = Replace(sName, "?", sChr)

  sName = Replace(sName, Chr(34), sChr)

  sName = Replace(sName, "<", sChr)

  sName = Replace(sName, ">", sChr)

  sName = Replace(sName, "|", sChr)


End Sub