Macro to save emails to disk with piece of subject as folder

[amazingmatt]

Im only half way through but, i have a snag and i don't know why. This is the code so far, it is a mish mash of edited bits and pieces from all over the internet . The trouble arised when i added the regular expression function, it wont parse the string i send it, stating it expected an object.:banghead:


Function getQuoteNumber(ByVal quoteCheck As Collection) As String


Dim regEx, Match, Matches

Set regEx = New RegExp ' Create a regular expression.
regEx.Pattern = "\bQ\d+\b" ' Set pattern.
regEx.IgnoreCase = False ' Set case insensitivity.
regEx.Global = True ' Set global applicability.

Set Matches = regEx.Execute(quoteCheck) ' Execute search.

For Each Match In quoteCheck ' Iterate Matches collection.
'selects a range from the index of the character to the index of the character plus the length of the word
quoteCheck = ThisDocument.Range(Match.FirstIndex, Match.FirstIndex + Len(Match.Value))

Next

End Function



Sub SaveAsMSG()
Dim myOlApp As New Outlook.Application
Dim myOlExp As Outlook.Explorer
Dim myOlSel As Outlook.Selection
'Dim MsgTxt As String
'Dim x As Integer
Dim itemCounts As Integer
Set myOlExp = myOlApp.ActiveExplorer
Set myOlSel = myOlExp.Selection
Dim temp
For itemCounts = 1 To myOlSel.Count
strname = myOlSel.Item(itemCounts)
strname = makeLegal(strname)
strname = getQuoteNumber(strname)
'Prompt the user for confirmation
Dim strPrompt As String
strPrompt = "Are you sure you want to save the item? If a file with the same name already exists, it will be overwritten with this copy of the file."
If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then
Outlook.Application.ActiveExplorer.Selection(1).SaveAs "C:\" & strname & ".msg", olMSG
Else
MsgBox "There is some wierd problem."
End If




Next itemCounts

End Sub




Basicly in my office we receive alot of emails that need to be saved into the quote/job number associated with the client. The subject lines are typically:

"RE: blah blah blah blah blah - Q70392" or "RE: blah blah blah blah - 40329"

I am attempting to get the subject, copy the quote or job number, display it in a dialog for editing incase it is wrong or just display it if there isn't one, then save the email in outlook msg format with a date and time stamp to ensure it doesn's save over anything (many multiple copies are welcome), to the quote or current jobs dir in its own directory named with its quote or job number, which may already exist.

Phew what a mouthful! Any help is much appreciated.:help

Ps. I haven't stripped much not needed code yet.

[mvidas]

Hi Matt,

The "quoteCheck" argument is of type Collection (and you don't declare strname as anything so the compiler isn't picking up on it). You'll need to make a couple changes to your function. You should also put "Option Explicit" at the top of your module.'Function getQuoteNumber(ByVal quoteCheck As Collection) As String
Function getQuoteNumber(ByVal quoteCheck As String) As String
' Dim regEx, Match, Matches
'type these and change the name of Match to avoid confusion
Dim regEx As RegExp, vMatch As Match, Matches As MatchCollection
' regEx.Pattern = "\bQ\d+\b" ' Set pattern.
regEx.Pattern = "\bQ?\d+\b" ' if the Q is optional, alter the pattern accordingly
' For Each Match In quoteCheck ' Iterate Matches collection.
For Each vMatch In Matches ' Iterate Matches collection.
'selects a range from the index of the character to the index of the character plus the length of the word
' quoteCheck = ThisDocument.Range(Match.FirstIndex, Match.FirstIndex + Len(Match.Value))
getQuoteNumber = ThisDocument.Range(vMatch.FirstIndex, vMatch.FirstIndex + Len(vMatch.Value))

Why are you looping through the match collection if there is only one quote? Or, rather, what are you wanting to return from the function?

[amazingmatt]

I think the looping through is just still there because it worked 'as a whole' when i tested just that piece of code. Until i can modify it and have it work i don't make changes that i don't need yet. :cloud9: Ill try this now and see how it goes but, i think i need two regexp one for jobs and one for quotes as they are stored in different locations eg. e:\quotes\Q30284 and e:\current\30000 - 35000\32948, i just wanted to get one working before i tried to tackle this!

While i was waiting on a reply i went searching for help on how i might check if a file exists, even though i am going to use the time and date stamp i thought i should have a backup to make sure i never overwrite anything. Can you recommend a method? And thanks again! :clap:

[amazingmatt]

Hrm when i change the quoteCheck declaration back to string, i get a compile error that "For Each may only iterate over a collection or array."

Should this:
For Each Match In quoteCheck
Be changed to this:
For Each Match In Matches

[amazingmatt]

Function getQuoteNumber(ByVal quoteCheck As String) As String


'Dim regEx, Match, Matches
Dim regEx As RegExp, vMatch As Match, Matches As MatchCollection
Set regEx = New RegExp ' Create a regular expression.
regEx.Pattern = "\bQ\d+\b" ' Set pattern.
regEx.IgnoreCase = False ' Set case insensitivity.
regEx.Global = True ' Set global applicability.

Set Matches = regEx.Execute(quoteCheck) ' Execute search.

For Each Match In Matches ' Iterate Matches collection.
'selects a range from the index of the character to the index of the character plus the length of the word
'quoteCheck = ThisDocument.Range(Match.FirstIndex, Match.FirstIndex + Len(Match.Value))
getQuoteNumber = ThisDocument.Range(vMatch.FirstIndex, vMatch.FirstIndex + Len(vMatch.Value))
Next

End Function

With this code i get an error "Object variable or With block variable not set'

[mvidas]

I did put this in my original response, but it probably got overshadowed by what was after it. Since you changed the variable name to vMatch, you have to change that in the For Each loop too:For Each vMatch In Matches ' Iterate Matches collectionThe only other way you may get that error is because you may not have a "ThisDocument" object. I don't use Word as my email editor, so I don't know how thats going to work for you.

I just stepped back and looked again at the code, you don't even need to get anything from ThisDocument, you could just pull from the quoteCheck or even just the regexp match. From what it seems you're looking for, you only really need this:Function getQuoteNumber(ByVal quoteCheck As String) As String
Dim regEx As Object 'changed to object (and createobject later) to show late binding
Set regEx = CreateObject("vbscript.regexp") ' Create a regular expression object
regEx.Pattern = "\bQ\d+\b" ' Set pattern.
regEx.IgnoreCase = False ' Set case insensitivity.
If regEx.Test(quoteCheck) Then getQuoteNumber = regEx.Execute(quoteCheck).Item(0)
Set regEx = Nothing
End Function

[amazingmatt]

Op i saw a some of the problem i forgot to change one thing, but other things did not work but i solved them, i now have:

Option Explicit

Function getQuoteNumber(ByVal quoteCheck As String) As String

Dim regEx As RegExp, vMatch As Match, Matches As MatchCollection
Set regEx = New RegExp ' Create a regular expression.
regEx.Pattern = "\bQ\d+\b" ' Set pattern.
regEx.IgnoreCase = False ' Set case insensitivity.
regEx.Global = True ' Set global applicability.

Set Matches = regEx.Execute(quoteCheck) ' Execute search.

For Each vMatch In Matches ' Iterate Matches collection.

getQuoteNumber = vMatch.Value

Next

End Function



Sub SaveAsMSG()
Dim quoteOrJobContainer As String
Dim strname As String
Dim myOlApp As New Outlook.Application
Dim myOlExp As Outlook.Explorer
Dim myOlSel As Outlook.Selection
Dim itemCounts As Integer
Set myOlExp = myOlApp.ActiveExplorer
Set myOlSel = myOlExp.Selection

For itemCounts = 1 To myOlSel.Count
strname = myOlSel.Item(itemCounts)
strname = makeLegal(strname)
quoteOrJobContainer = strname
quoteOrJobContainer = getQuoteNumber(quoteOrJobContainer)
quoteOrJobContainer = quoteOrJobContainer & "\"
'Prompt the user for confirmation
Dim strPrompt As String
strPrompt = "Are you sure you want to save the item? If a file with the same name already exists, it will be overwritten with this copy of the file."
If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then
Outlook.Application.ActiveExplorer.Selection(1).SaveAs "C:\" & temp & strname & ".msg", olMSG
Else
MsgBox "There is some wierd problem."
End If




Next itemCounts

End Sub


Which works right up until it tries to save the file, this fails of course because the directory doesnt exist and hasn't been created so that is my next step!

Thanks a bunch for your help so far! :yay

[amazingmatt]

Ah you replied while i was posting, i will look at your suggestion a bit, it looks good cause it dumps the for each loop thing!

[mvidas]

missed a couple things back there..


Ill try this now and see how it goes but, i think i need two regexp one for jobs and one for quotes as they are stored in different locations eg. e:\quotes\Q30284 and e:\current\30000 - 35000\32948, i just wanted to get one working before i tried to tackle this!I'm not sure I follow you..? Can you explain more and I'd be glad to help





While i was waiting on a reply i went searching for help on how i might check if a file exists, even though i am going to use the time and date stamp i thought i should have a backup to make sure i never overwrite anything. Can you recommend a method?Sure! Take a look at:Sub AmazingMattFileExample()
Dim vFileName As String

vFileName = "C:\folder name\sub 1\file.txt"

'The Dir method returns the filename if it exists, or a blank string if not
If Len(Dir(vFileName)) = 0 Then
'blank string returned, file must not exist
MsgBox "The file '" & vFileName & "' does not exist."
Else
'file exists
MsgBox "The file '" & vFileName & "' does exist. The time stamp is:" & _
vbCrLf & FileDateTime(vFileName)
End If
End Sub

[mvidas]

Re: A directory existing, you can send this function a Path and it will check it if it exists, and create it if it doesn't:Function CheckMakeUNCPath(ByVal vPath As String) As String
Dim PathSep As Long, oPS As Long
If Right(vPath, 1) <> "\" Then vPath = vPath & "\"
PathSep = InStr(3, vPath, "\") 'position of drive separator in path
If PathSep = 0 Then Exit Function 'invalid path
Do
oPS = PathSep
PathSep = InStr(oPS + 1, vPath, "\") 'position of directory
If PathSep = 0 Then Exit Do
If Len(Dir(Left(vPath, PathSep), vbDirectory)) = 0 Then Exit Do 'check path
Loop
Do Until PathSep = 0
MkDir Left(vPath, PathSep)
oPS = PathSep
PathSep = InStr(oPS + 1, vPath, "\")
Loop
CheckMakeUNCPath = vPath
End FunctionSo your saveas could look like:ActiveExplorer.Selection(1).SaveAs CheckMakeUNCPath("C:\" & quoteOrJobContainer) _
& strName & ".msg", olMsg

To see it in action outside of your outlook routine:Sub justforkicks()
CheckMakeUNCPath "C:\a\b\c\d\e\f\g\h\i\j\k\l\m"
End Sub

[amazingmatt]

Awsome i can play much with that!

Regarding the other thing:


Ill try this now and see how it goes but, i think i need two regexp one for jobs and one for quotes as they are stored in different locations eg. e:\quotes\Q30284 and e:\current\30000 - 35000\32948, i just wanted to get one working before i tried to tackle this!

Emails come in, some with job number eg 33452 some with quote numbers Q55492
I decieded a while ago that i would check for quote numbers first, this seemed easier to me because it is alpha numeric and i was going to capture the numbers one character at a time using a loop, a Q with a number after it is almost certainly the quote number i was looking for so it was a good idea. I changed to regex when i discovered i could, i didn't realize i could reference vbscript etc, and i have used regex before scripting for my mud client. Anyway i want to capture the job or quote number, determine what sort i have captured so i can save them in their designated location, eg
jobs - E:\current\70000-75000\73290\RE blahblahblah - 73290.msg
quotes E:\quotes\Q55392\RE blahblahblah - Q55392.msg

I hope this helps your understanding, sorry if i seem a bit thick sometimes, i only get to work on this very late at night after a long day at work!

[mvidas]

I understand, it is still too early for me :)

I would say you should use one regex pattern: \bq?\d{5}\b or use \d+ like you had, unless they always are 5 digit numbers

Then you can test if it has a Q in the beginning or not to determine if its a quote number or job number. You would have to turn RegEx.Global = True back on (I deleted it since you only were looking for one match), and could loop through the matchcollection checking to see which you're getting. Or just set 2 patterns with the same regexp object, either way works (and neither is really faster than the other if you're only getting 2 matches)

[amazingmatt]

yeah i think \d+ to a space or period . as sometimes clients add comments to the subject.

PS. By the way, it is my intention to use this only until i can turn it into a
com addin for outlook. If there is anything you know i should change now
for easier transition that would be much appreciated.
:Thinkingo

[mvidas]

I'm not sure I'm the best to be giving advice about com addins, as I've made only 2 or 3 for outlook. I can point you to some links I read about while doing that, or I can just help if/when you need it.

What you may want to start with is create a global Application variable and always qualify everything with that (as you'll likely be setting that with your AddinInstance_OnConnection event), to save time later so you dont have to hunt the non-qualified code down later.

When I've begun designing code that will be an addin, I create my own OnConnection sub and OnDisconnection sub and create/release everything I need from there (and then call those from Application_Startup and Application_Quit for the time being). Those don't actually create everything themselves, but it calls subroutines to do the initialization/releasing for me (as well as create/delete toolbar buttons). Let me see if I can get an example of the code from the Designer object...
'Private Sub AddinInstance_OnConnection(ByVal Application As Object, ByVal _
ConnectMode As AddInDesignerObjects.ext_ConnectMode, _
ByVal AddInInst As Object, custom() As Variant)
Public Sub OnConnection()
Set olApp = Application
On Error GoTo 0
If InitializeEverything = False Then
ClearEverything
RemoveToolbarButtons
Else
CreateToolbarButtons
End If
End Sub

'Private Sub AddinInstance_OnDisconnection(ByVal RemoveMode _
As AddInDesignerObjects.ext_DisconnectMode, custom() As Variant)
Public Sub OnDisconnection()
ClearEverything
RemoveToolbarButtons
End Sub
I have a boolean function called InitializeEverything that, well, initializes everything I need to have. If that fails, it returns false (and as you can see, calls ClearEverything). Similarly with my CreateToolbarButtons and RemoveToolbarButtons. I think getting something similar to that with your code would be a good start, and making sure everything is qualified as best as possible.

[amazingmatt]

It must be a common trait among Matt's to be amazing

[mvidas]

Tis a great name :)