save email from outlook to local drive using vba - vba

Question

i am trying to save a selected mail from outlook to a folder dynamically created with mail's subject name. The code ran successfully for one mail. if i select different mail and try to run the macro it is showing path not found error. My code is below:
Public Sub OpslaanMails()
Dim OlApp As Outlook.Application
Set OlApp = New Outlook.Application
Set OlApp = CreateObject("Outlook.Application")
Dim fName, sName As String
Dim oMail As Outlook.MailItem
fName = "F:\Test\inwards\"
Set oMail = OlApp.ActiveExplorer.Selection.Item(1)
sName = oMail.Subject
makeSelectionDir (sName)
sPath = fName & "\" & sName & "\"
oMail.SaveAs sPath & sName & ".msg", olMsg
For Each oAttach In oMail.Attachments
oAttach.SaveAsFile sPath & oAttach.FileName
Set oAttach = Nothing
Next
End Sub
Sub makeSelectionDir(sName As String)
Dim fName, sPath As String
fName = "F:\Test\inwards\"
sPath = fName & sName
With CreateObject("Scripting.FileSystemObject")
If Not .FolderExists(sName) Then .CreateFolder sPath 'error is in this line
End With
End Sub

Answer 1

Make sure sName does not contain any characters illegal in a file name, such as ":".

Answer 2

I used your idea and changed two or three things to make it more robust.
Put this in a module in Outlook VBA Editor and run, having selected an email.
I also added the time and date at the beginning of the folder and email file names.
I left the part about saving file attachements but know that they are already embedded in the .msg file.
Const ILLEGAL_CHARACTERS = Array("*", "/", "\", "?", """", "<", ">", ":", "|")
Sub SaveEmailToFile()
Dim oMail As MailItem
Dim sPath As String
Dim sObj As String
Dim oAttach As Attachment
'Select email and process subject
If ActiveExplorer.Selection.Count = 0 Then
MsgBox "No emails are selected."
Exit Sub
End If
Set oMail = ActiveExplorer.Selection.Item(1)
With oMail
sObj = oMail.Subject
'Remove illegal characters from email subject
If sObj = "" Then
sObj = "No Object"
Else
For Each s In ILLEGAL_CHARACTERS
sObj = Replace(sObj, s, "")
Next s
End If
'Get date and time string from email received timestamp
dateStr = Year(.ReceivedTime) & "_" & _
Month(.ReceivedTime) & "_" & _
Day(.ReceivedTime) & " " & _
Hour(.ReceivedTime) & " " & _
Minute(.ReceivedTime) & " " & _
Second(.ReceivedTime) & " "
End With
sPath = "C:\Someplace\" & dateStr & sObj & "\"
'Create folder
With CreateObject("Scripting.FileSystemObject")
If Not .FolderExists(sPath) Then .CreateFolder sPath
End With
'Save email and attachements
oMail.SaveAs sPath & oMail.Subject & ".msg", olMSG
For Each oAttach In oMail.Attachments
oAttach.SaveAsFile sPath & oAttach.FileName
Next oAttach
End Sub

Answer 3

I could only recreate the error
path not found
if fName was not valid.
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant
Public Sub OpslaanMails()
Dim fName As String
Dim sName As String
Dim sPath As String
Dim oMail As MailItem
Dim oAttach As Attachment
fName = "F:\Test\inwards\"
Debug.Print "fName: " & fName
Set oMail = ActiveExplorer.Selection.Item(1)
sName = oMail.subject
Debug.Print "sName: " & sName
' Double slash accepted by Windows but not by some programmers
'If Right(fName, 1) = "\" Then
' fName = Left(fName, Len(fName) - 1)
' Debug.Print
' Debug.Print "fName: " & fName
'End If
' Double slash after fName preferable to no slash
sPath = fName & "\" & sName & "\"
Debug.Print "sPath: " & sPath
makeSelectionDir fName, sPath
' Possible illegal characters in sName not addressed.
' Do not test with replies nor forwards,
' the : in the subject is not a legal character.
oMail.SaveAs sPath & sName & ".msg", olMsg
For Each oAttach In oMail.Attachments
oAttach.SaveAsFile sPath & oAttach.FileName
Set oAttach = Nothing
Next
End Sub
Sub makeSelectionDir(fName As String, sPath As String)
With CreateObject("Scripting.FileSystemObject")
' Test for fName
' Otherwise there is file not found error in the create
If .FolderExists(fName) Then
' if subfolder does not exist create it
If Not .FolderExists(sPath) Then
.createFolder sPath
End If
Else
Debug.Print
Debug.Print "Folder " & fName & " does not exist."
'MsgBox "Folder " & fName & " does not exist."
End
End If
End With
End Sub
Inconsistency of sName vs sPath has been addressed in
If Not .FolderExists(sName) Then .CreateFolder sPath