Outlook Macro to Save e-Mail Files
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