How to get a file path in a excel workbook using a index in the e-mail subject

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:bow:

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

Would lines below enough and correctly to make item 1) work of my previous post? I am sorry to post twice in a row but I am trying to separete my attemps of my original question.

CODE TO GET THE QUOTE NUMBER IN THE E-MAIL SUBJECT:

Dim oMail As Outlook.MailItem
Dim QuoteNumber As String
Dim thesubject As String

thesubject = oMail.Subject
QuoteNumber = Mid(thesubject, InStr(1, thesubject, "PSARK") + 7,

Item 1) solved. I need help how can I do item 2).

Best Regards,

I will put the "search intelligence" in the workbook using a formula in a cell, so my program would only need to write the value that I've got from the subject write on a specific cell of my control sheet and read the cell with the result of the corresponding path. Anyone could help me with following function/commands:

1) Open a specific excel workboook in a specific folder.
2) Write a value on a specific cell.
3) Read the result of a specific cell.

Close this topic! Program is finished.
[VBA]Sub SaveAsMsgIn(MyMail As MailItem)

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
Dim QuoteNumber As String
Dim thesubject As String
Dim ExFilePath As String

id=52[/url] for
strID = MyMail.EntryID
Set olNS = Application.GetNamespace("MAPI")
Set oMail = olNS.GetItemFromID(strID)
thesubject = oMail.Subject
QuoteNumber = Mid(thesubject, InStr(thesubject, "PSARK"), 12)
Set objExcel = CreateObject("Excel.Application")
objExcel.Workbooks.Open "C:\Temp\Book1.xlsx"
objExcel.Cells(1, 1) = QuoteNumber
ExFilePath = objExcel.Cells(2, 2)

' ### USER OPTIONS ###
blnOverwrite = False ' False = don't overwrite, True = do overwrite
strFolderPath = ExFilePath ' path to target folder

If EnsureFolderExistence(strFolderPath) <> "PATH DOES NOT EXIST" Then
strSubject = CleanFileName(oMail.Subject)
strSaveName = Format(Now, " yymmdd") & "_" & 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, " yymmdd") & "_" & strSubject & "_" & looper & ".msg"
Loop
Else
If fso.FileExists(strFolderPath & strSaveName) Then
fso.DeleteFile strFolderPath & strSaveName
End If
End If
oMail.SaveAs strFolderPath & "\e-mail\entrada\" & strSaveName, olMSG
End If

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

Sub SaveAsMsgOut(MyMail As MailItem)

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
Dim QuoteNumber As String
Dim thesubject As String
Dim ExFilePath As String

id=52[/url] for
strID = MyMail.EntryID
Set olNS = Application.GetNamespace("MAPI")
Set oMail = olNS.GetItemFromID(strID)
thesubject = oMail.Subject
QuoteNumber = Mid(thesubject, InStr(thesubject, "PSARK"), 12)
Set objExcel = CreateObject("Excel.Application")
objExcel.Workbooks.Open "C:\Temp\Book1.xlsx"
objExcel.Cells(1, 1) = QuoteNumber
ExFilePath = objExcel.Cells(2, 2)

' ### USER OPTIONS ###
blnOverwrite = False ' False = don't overwrite, True = do overwrite
strFolderPath = ExFilePath ' path to target folder

If EnsureFolderExistence(strFolderPath) <> "PATH DOES NOT EXIST" Then
strSubject = CleanFileName(oMail.Subject)
strSaveName = Format(Now, " yymmdd") & "_" & 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, " yymmdd") & "_" & strSubject & "_" & looper & ".msg"
Loop
Else
If fso.FileExists(strFolderPath & strSaveName) Then
fso.DeleteFile strFolderPath & strSaveName
End If
End If
oMail.SaveAs strFolderPath & "\e-mail\saida\" & 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



Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

End Sub

[/VBA]