Save emails to a Directory based on code in subject

[AlmostAble]

So I'm just wondering if this is possible before starting work on it, so sorry for lack of details, I'm not looking for some to do the work for me, more a confirmation it's possible. and any help will be greatly appreciated.

Is this possible with Outlook/Vba

I have a product code, in the following format AU1612345 (country/year/4 digit code) arriving in an email with information, i need this email saved into a specific windows folder directory based on the code.

Directory example based on the code AU1612345:

C:/Australia/2016/2000-3000/AU1612345

i want to use an outlook rule to identify the email, VBA to pull the code from the email subject/body, create the correct directory folder directory if it doesn't exist and save the email.

At the moment I'm using excel and VBA to break apart the product code, create the folder directory and open the folder for me to manually move the file.

if i can get outlook/vba can do this automatically when the email arrives it would speed things up a whole lot.

Thanks
Jim

[excelliot]

Is product code part of subject or body?

[AlmostAble]

Is product code part of subject or body?

it can be either, so whichever is easier to work with

[excelliot]

check this works with code in subject line...

Put call code in ThisOutlookSession



Public WithEvents olItems As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set olItems = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub olItems_ItemAdd(ByVal Item As Object)
On Error GoTo ErrorHandler
Dim msg As Outlook.MailItem
Dim destFolder As String
Dim myCode As String
Dim sName As String
Dim regEx As Object
Dim matches

sName = Item.Subject
ReplaceCharsForFileName sName, "_"
If TypeName(Item) = "MailItem" Then
Set msg = Item

' check if subject field contains CODE
Set regEx = CreateObject("VBScript.RegExp")
With regEx
.Pattern = "\w+\d{7}"
.IgnoreCase = True
.Global = True
End With

If regEx.Test(Item.Subject) Then
Set matches = regEx.Execute(Item.Subject)
myCode = matches(0)
Else
Exit Sub
End If


destFolder = "C:/Australia/2016/2000-3000/" destFolder = destFolder & myCode
' if subfolder doesn't exist, create it
If Dir(destFolder, vbDirectory) = "" Then
MkDir destFolder
End If
' Copy msg to local folder
Item.SaveAs destFolder & "/" & sName & ".msg", olMSG
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
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



Cheers!!

[gmayor]

If the ID is in the subject and includes the colon as indicated then it is reasonably straightforward to extract the code from the subject, create the path, save the message with a unique name using the code below run from a rule to identify the incoming messages. I have included a test macro so that you can test it with an existing message. You will of course have to include all your country codes in the GetPath function - I have included Australia and a few other suggestions. The only part I am confused about is the ID number itself i.e. AU1612345: Which is Country (AU), Year (2016) and a four digit code, presumably '2345' - What's the extra 1 for? I have not used it in the example. I assume you can modify the code if necessary? You also had the folder separators as / rather than \. I have changed that so it will work.

The code goes in an ordinary new module in Outlook.


Option Explicit

Sub Test()
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
SaveMessage olMsg
lbl_Exit:
Exit Sub
End Sub

Sub SaveMessage(olItem As MailItem)
Dim fName As String
Dim fPath As String
fPath = GetPath(olItem.Subject)
fName = Right(fPath, 9)
fPath = Left(fPath, (Len(fPath) - 9))
fName = Replace(fName, Chr(58) & Chr(41), "")
fName = Replace(fName, Chr(58) & Chr(40), "")
fName = Replace(fName, Chr(34), "-")
fName = Replace(fName, Chr(42), "-")
fName = Replace(fName, Chr(47), "-")
fName = Replace(fName, Chr(58), "-")
fName = Replace(fName, Chr(60), "-")
fName = Replace(fName, Chr(62), "-")
fName = Replace(fName, Chr(63), "-")
fName = Replace(fName, Chr(124), "-")
CreateFolders fPath
SaveUnique olItem, fPath, fName
lbl_Exit:
Exit Sub
End Sub

Function GetPath(strSubject As String)
Dim strID As String
Dim strPath As String
Dim strCountry As String
Dim strYear As String
Dim strRange As String
Dim i As Integer
If InStr(1, strSubject, Chr(58)) > 0 Then
strID = Left(strSubject, InStr(1, strSubject, Chr(58)) - 1)
strID = Right(strID, 9)
Select Case Left(strID, 2)
Case "AU": strCountry = "Australia"
Case "US": strCountry = "USA"
Case "UK": strCountry = "United Kingdom"
Case Else: strCountry = "Unlisted"
End Select
i = Mid(strID, 6, 1)
strPath = "C:\" & strCountry & "\20" & _
Mid(strID, 3, 2) & "\" & i & "000-" & _
(i + 1) & "000\" & strID
GetPath = strPath
Else
GetPath = ""
End If
lbl_Exit:
Exit Function
End Function

Private Function SaveUnique(oItem As Object, _
strPath As String, _
strFileName As String)
'An Outlook macro by Graham Mayor
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(strFileName)
Do While FileExists(strPath & strFileName & ".msg") = True
strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
oItem.SaveAs strPath & strFileName & ".msg"
lbl_Exit:
Exit Function
End Function

Private Function FileExists(filespec) As Boolean
'An Outlook macro by Graham Mayor
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(filespec) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function

Private Function FolderExists(fldr) As Boolean
'An Outlook macro by Graham Mayor
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If (fso.FolderExists(fldr)) Then
FolderExists = True
Else
FolderExists = False
End If
lbl_Exit:
Exit Function
End Function

Private Function CreateFolders(strPath As String)
'An Outlook macro by Graham Mayor
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
vPath = Split(strPath, "\")
strPath = vPath(0) & "\"
For lngPath = 1 To UBound(vPath)
strPath = strPath & vPath(lngPath) & "\"
If Not FolderExists(strPath) Then MkDir strPath
Next lngPath
lbl_Exit:
Exit Function
End Function

[excelliot]

if it is solved mark it as complete :)

[bigal.nz]

if it is solved mark it as complete :)

I am about to embark on a similar project myself (scraping data from a email http://www.vbaexpress.com/forum/showthread.php?55471-Monitor-for-incoming-emails-matching-pattern& )

I am wondering why neither you nor gmayor used the built in new mail event?

Cheers

-Al