Srs,

I am using the code below to save e-mails from my outlook to my hard drive but I would like to find a way to change the file path according to a index got from the subject of the e-mail. I have very little experience with VBA, and donīt know the commands, I would really appreciate any help to start my program or at least a tip if what I am searching for is possible or not.

The index is a quote number. I would like to copy it from the subject of the e-mail and search its file path in a control excel worksheet where I have the file path of each quote number.

So I have to challenges that I am still looking a wayout:

1) All the quotes have the following format "PSARK"+7numbers. So I would like to correctly get the quote number anytime it is written "PSARK" in the e-mail subject.
2) To get the file path I would use the quote number copied in stage one and search the file path in my control worksheet.


Sorry for my poor english.

Best Regards,
Eduardo

code:


Sub SaveAsMsg(MyMail As MailItem)
' requires reference to Microsoft Scripting Runtime
' \Windows\System32\Scrrun.dll
Dim fso As FileSystemObject
Dim strSubject As String
Dim strSaveName As String
Dim blnOverwrite As Boolean
Dim strFolderPath As String
Dim looper As Integer
Dim strID As String
Dim olNS As Outlook.NameSpace
Dim oMail As Outlook.MailItem

strID = MyMail.EntryID
Set olNS = Application.GetNamespace("MAPI")
Set oMail = olNS.GetItemFromID(strID)
' ### USER OPTIONS ###
blnOverwrite = False ' False = don't overwrite, True = do overwrite
strFolderPath = "C:\RAAN\Data\Emails" ' path to target folder
strFolderPath = strFolderPath & Format(Now, " yyyymm") & "" ' Adds year/month
subfolder

If EnsureFolderExistence(strFolderPath) <> "PATH DOES NOT EXIST" Then
strSubject = CleanFileName(oMail.Subject)
strSaveName = Format(Now, " yyyymmdd") & "_" & strSubject & ".msg"
Set fso = CreateObject("Scripting.FileSystemObject")
If blnOverwrite = False Then
looper = 0
Do While fso.FileExists(strFolderPath & strSaveName)
looper = looper + 1
strSaveName = Format(Now, " yyyymmdd") & "_" & strSubject & "_" &
looper & ".msg"
Loop
Else
If fso.FileExists(strFolderPath & strSaveName) Then
fso.DeleteFile strFolderPath & strSaveName
End If
End If
oMail.SaveAs strFolderPath & strSaveName, olMSG
End If

Set oMail = Nothing
Set olNS = Nothing
Set fso = Nothing
End Sub

Function EnsureFolderExistence(strPath) As String
Dim fso As FileSystemObject
On Error Resume Next

Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(strPath) Then
fso.CreateFolder strPath
If Err <> 0 Then
EnsureFolderExistence = "PATH DOES NOT EXIST"
End If
End If

Set fso = Nothing
End Function

Function CleanFileName(strText As String) As String
Dim strStripChars As String
Dim intLen As Integer
Dim i As Integer
strStripChars = "/\[]:=," & Chr(34)
intLen = Len(strStripChars)
strText = Trim(strText)
For i = 1 To intLen
strText = Replace(strText, Mid(strStripChars, i, 1), "")
Next
CleanFileName = strText
End Function