Automatically save .MSG when an email contains a reference number

[Quizomi]

Hello everyone,

I am just starting to play around with VBA, but I am having a hard time solving this one. I often work with emails that contain reference numbers, and I am saving each of those emails as .MSG files in my hard drive. However, I was wondering if there was a way so that I could set up my outlook to export files that contain a specific reference number to a pre-designated folder (one folder for each reference number).

Of course, creating a rule that automatically saves emails containing a particular string in a particular Outlook folder is a piece of cake. However would Outlook allow me to obtain the behaviour above automatically?

The reason I ask is because the macros I have found on the Internet allow me at best to prompt me to select a folder from my hard drive and to export all selected emails in .msg format to that folder, upon activation.

I would greatly appreciate any input or tips pointing me to the right direction. Thanks!!

Quizomi

[gmayor]

What you ask is fairly straightforward provided the macro required to save the message can find the reference number. Where would the macro look for that and how would it recognize it as an ID number as opposed to any other type of numbering? Where also do you wish to save the folders and their message contents?

I have posted code that will do something similar several times however http://www.vbaexpress.com/forum/show...=Save+messages has most of the code elements that you need to save a message, check it is unique, create a folder where the required folder is missing and avoid illegal filename characters. What that example doesn't do is identify the ID number.

[Quizomi]

Thanks for your input, I'll give the code a run and report back. Essentially my code will be a four digits number that follows a threeletter prefix (I. E. DCS2034, DCS3022), and I save those emails in folders with the same identifier. Ideally outlook would look for the right folder based on the identifier found in the email. I'm not sure VBA would be smart enough to check the folder name and store automatically.

Thanks again

[gmayor]

The code I linked will need some modification to fulfil your requirement. It is just a pointer to some of the functions that will be required.

The folder is not so much the issue as the identification code. Where in the message is that code number? The macro has to be able to put a handle on it in order to determine where to save the message. Is it always they same three letters? Are they always upper case?

Do you want a folder tree with one folder for each message ID e.g.

C:\Path\DCS2034\DCS2034.msg
C:\Path\DCS3022\DCS3022.msg
etc

or is it one folder for the three letter code with all the messages beginning e.g. DCS

C:\Path\DCS\DCS2034.msg
C:\Path\DCS\DCS3022.msg
etc

[Quizomi]

Gmayor, the reference would always be DCS***X and would be found either in the body or subject at random, however the letter may not always be upper case. The paths would look like C:\Path\DCS3022 TEXT\DCS3022.msg

So this is what I have so far:

Public Sub GetValueUsingRegEx(myItem As MailItem)
' Set reference to VB Script library
' Microsoft VBScript Regular Expressions 5.5

Dim olMail As Outlook.MailItem
Dim Reg1 As RegExp
Dim colMatches As matchCollection
Dim M1 As Match
Dim Path As String
Dim enviro As String
Dim Match As String

Path = "X:\Path"

Set olMail = myItem

Set Reg1 = New RegExp

Reg1.IgnoreCase = True
Reg1.Pattern = "DCS\d\d\d\d\d?"
Reg1.Global = False

If Reg1.test(olMail.Body) Then

Set colMatches = Reg1.Execute(olMail.Body)
Match = Reg1.Execute(olMail.Body)(0)

For Each M1 In colMatches
MsgBox (M1)
Next

End If

Subject = olMail.Subject
Subject = Replace(Subject, ":", "_")
fullPath = (Path & "" & Match & "" & Subject & ".msg")

olMail.SaveAs (fullPath)
MsgBox fullPath
MsgBox Match
MsgBox Subject
MsgBox ("Done")

End Sub





Again, that's very basic as I am still learning. This script is trigerred by a rule once an email contains the word "DCS". The current scrip works only if the folder "DCS***X" (the Xs representing my reference number) is already created and does not contain any additional text. What I'm looking for is for my script to look for the four-digit number that follows the text "DCS" and to save the email under the folder that starts with the same number under "X:\Path", ignoring any additional text in the folder name after the DCS***X reference number.

Any idea? Thanks in advance

[gmayor]

Based on your comments I think the following should work for you. It uses several of the functions I referred you to and includes a macro to test the main macro, which you can run as a script from a rule

Option Explicit

Sub TestMacro()
'Graham Mayor - http://www.gmayor.com - Last updated - 10 Feb 2018
Dim olMsg As MailItem
    On Error Resume Next
    Set olMsg = ActiveExplorer.Selection.Item(1)
    FileMessage olMsg
lbl_Exit:
    Exit Sub
End Sub

Sub FileMessage(olItem As MailItem)
'Graham Mayor - http://www.gmayor.com - Last updated - 10 Feb 2018
Dim strPath As String: strPath = "C:\Path\"
Dim strID As String
Dim lngID As Long
Dim lngPara As Long
Dim sBody As String
Dim vPara As Variant
    'check if item is a mail item
    If Not TypeName(olItem) = "MailItem" Then GoTo lbl_Exit
    'Look for DCS in the subject
    lngID = InStr(1, UCase(olItem.Subject), "DCS")
    'If present grab the 7 characters starting with DCS
    If lngID > 0 Then
        strID = Mid(olItem.Subject, lngID, 7)
        'ensure that the string is a valid ID
        If Not IsNumeric(Right(strID, 4)) Then strID = ""
    End If
    'DCS string is not in the subject so look in the body
    If strID = "" Then
        sBody = olItem.Body
        'split the body into paragraphs
        vPara = Split(sBody, Chr(13))
        For lngPara = 0 To UBound(vPara)
            'check the paragraphs for the string DCS
            ' and if found validate it asa before
            lngID = InStr(1, UCase(vPara(lngPara)), "DCS")
            If lngID > 0 Then
                strID = Mid(vPara(lngPara), lngID, 7)
                If Not IsNumeric(Right(strID, 4)) Then strID = ""
            End If
            'ID is found so stop looking
            If Not strID = "" Then Exit For
        Next lngPara
    End If
    'ID is found so set the path to match
    If Not strID = "" Then
        strPath = strPath & UCase(strID) & Chr(92)
        'create the folder path if it doesn't exist
        CreateFolders strPath
        'and save the message with a unique name
        SaveUnique olItem, strPath, UCase(strID)
    End If
lbl_Exit:
    Exit Sub
End Sub

Private Sub CreateFolders(strPath As String)
     'A Graham Mayor/Greg Maxey AddIn Utility Macro
    Dim oFSO As Object
    Dim lngPathSep As Long
    Dim lngPS As Long
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    lngPathSep = InStr(3, strPath, "\")
    If lngPathSep = 0 Then GoTo lbl_Exit
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Do
        lngPS = lngPathSep
        lngPathSep = InStr(lngPS + 1, strPath, "\")
        If lngPathSep = 0 Then Exit Do
        If Len(Dir(Left(strPath, lngPathSep), vbDirectory)) = 0 Then Exit Do
    Loop
    Do Until lngPathSep = 0
        If Not oFSO.FolderExists(Left(strPath, lngPathSep)) Then
            oFSO.CreateFolder Left(strPath, lngPathSep)
        End If
        lngPS = lngPathSep
        lngPathSep = InStr(lngPS + 1, strPath, "\")
    Loop
lbl_Exit:
    Set oFSO = Nothing
    Exit Sub
End Sub
 
Private Function SaveUnique(oItem As Object, _
    strPath As String, _
    strFileName As String)
    'Graham Mayor - http://www.gmayor.com - Last updated - 10 Feb 2018
    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 String) As Boolean
'Graham Mayor - http://www.gmayor.com - Last updated - 10 Feb 2018
    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 String) As Boolean
'Graham Mayor - http://www.gmayor.com - Last updated - 10 Feb 2018
    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

[Quizomi]

Thanks a lot Gmayor for your help!

I still have one issue however: if I already have a DCS folder (i.e; "DCS1234 Test"), the macro will create an additional folder "DCS1234" and place the email there.

If that helps, the macro does not actually need to check whether the folder will exist as it deffinitely will: it only needs to save in a folder titled "DCS1234" or "DCS1234 Text".

Thanks again

Thanks again

[gmayor]

The macro checks to see if there is a folder with the required name. It only creates a folder if the folder doesn't exist.

It uses the folder name format DCS1234 which is what you asked for. It doesn't know anything about other folders that may have DCS1234 as part of the name. Macros do not do guesswork. You have to tell them what it is you want them to do.

If you want the macro to use a folder named like 'DCS1234 Test' then change the line

strPath = strPath & UCase(strID) & Chr(92)

to

strPath = strPath & UCase(strID) & " Test" & Chr(92)

and it will use that format instead.

[Quizomi]

Thanks for your input.

I've found a way for VBA, short of guessing the folder, to take the first folder that starts with DCS1234 and fill the path, using:

    Dim sFolder As String, sPathMatch As String
        
    On Error Resume Next
    sPathSeek = Path & Match & "*"
    sFolder = Dir(sPathSeek, vbDirectory)

    Do While Len(sFolder) > 0
        If Left(sFolder, 1) <> "." Then
            If (GetAttr(sFolder) And vbDirectory) = vbDirectory Then
                sPathMatch = sFolder
                Exit Do
            End If
        End If
        sFolder = Dir
    Loop

    msgbox IIf(sPathMatch = "", "DCS folder for " & Match & " does not exist. Check that the name of the root DCS has not been changed, or edit the Macro to update the root folder path.", "Match: " & sPathMatch)

Thanks for your help