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/show...ching-pattern& )

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

Cheers

-Al