Sub MySaveAs()
Dim objApp As Outlook.Application
Dim objSel As Outlook.Selection
Dim x As Integer
Dim sSubjectName As String
Dim ynTried As Boolean
Dim dteDate As String
Dim fs
Dim myPath As String
Dim Final As String
' Find the currently selected emails
Set objApp = CreateObject("Outlook.Application")
Set objSel = objApp.ActiveExplorer.Selection
dteDate = Format(Date - 3, "MM-DD-YY")
Set fs = CreateObject("Scripting.FileSystemObject")
Final = "c:\test\" & dteDate
MkDir Final
' For each email
For x = 1 To objSel.Count
With objSel.Item(x)
' perform save only on selected mail messages
If .Class = olMail Then
' some subjects are unsuitable for file names
' so allow renaming if necessary
sSubjectName = .Subject
ynTried = False
If InStr(1, sSubjectName, Asc(58), 1) _
' you will need to add aditional Asc() characters here
Then GoTo ErrorSaving
On Error GoTo ErrorSaving
.SaveAs Final & "\" & sSubjectName & x & ".msg", olMSG
'On Error GoTo 0
End If
End With
Next
Set objSel = Nothing
Set objApp = Nothing
Exit Sub
ErrorSaving:
If ynTried Then 'they only get one chance to rename the message
MsgBox "The message '" & sSubjectName & "' was not saved successfully", vbOKOnly, "Save Failed"
Resume Next 'skips the save
Else
' get a new subject name from user
ynTried = True
MsgBox (sSubjectNames & " not a valid name")
sSubjectName = InputBox("Error: Subject name not suitable. Please type a new name excluding any special characters (i.e. :,'.!@ etc)", _
"Save Failed", sSubjectName)
Resume
End If
End Sub