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/showthread.php?60254-Code-Change-to-Save-multi-selected-emails&highlight=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