Save Emails on a Server Using a VBA & Userform

[nathandavies]

Hi All,

I'm new to this forum and VBA and have seen a thread this morning "Save Emails on Hard Drive"

I was wondering if this code can be changed at all to complete the following?

1. When the macro is run a input box appears for a string of text to input the location of the folder on a server. IE Project Number
2. When the project number is inputted the macro will search through our server “P:\Group\JOBDATA” and find the folder and save any incoming emails to a specific folder “Email.In” within the “Correspondence” Folder and “Email.Out” for outgoing emails.

I know this might be asking a lot but if anyone can help that would be greatly appreciated!!

[Charlize]

As a starting point. Highlight a single email and perform this macro. You can test the incomming and outgoing standard folders of outlook. Based on the folder, the macro should save in the correct folder (in or out). Use at your own risk. First try it with F8 key to follow the steps of the macro. When you hover over the variables during this, you can follow the values of those. Good luck.

Sub JOBDATA_SAVE_EMAIL()
'The unique number of your project
Dim ProjectID As String
'the mail we want to process
Dim objItem As Outlook.MailItem
'question for saving, use subject to save
Dim strPrompt As String, strname As String, emailto As String, emailfrom As String
'variables for the replacement of illegal characters
Dim sreplace As String, mychar As Variant, strdate As String
'mypath as variant when using browsefolder function (false is boolean and no string)
Dim mypath As Variant
'put active mail in this object holder
Set objItem = Outlook.ActiveExplorer.Selection.Item(1)
'check if it's an email
If objItem.Class = olMail Then
mypath = ""
'check on subject
If objItem.Subject <> vbNullString Then
strname = objItem.Subject
Else
strname = "No_Subject"
End If
'ask until a projectid is given
Do Until Right(mypath, 1) <> "\" And mypath <> vbNullString
mypath = "P:\Group\JOBDATA\" & InputBox("Give EXISTING projectID ...", "Saving to Project ...")
Loop
'add ending slash
mypath = mypath & "\"
'select if the selected mail is located in the inbox or sent items folder
Select Case objItem.Parent
Case Outlook.Session.GetDefaultFolder(olFolderInbox)
'change saving path accordingly
mypath = mypath & "Correspondence\Email.In\"
emailfrom = objItem.Sender
Case Outlook.Session.GetDefaultFolder(olFolderSentMail)
mypath = mypath & "Correspondence\Email.Out\"
emailto = objItem.To
End Select
strdate = objItem.ReceivedTime
'define the character that will replace illegal characters
sreplace = "_"
'create an array to loop through illegal characters (saves lines)
For Each mychar In Array("/", "\", ":", "?", Chr(34), "<", ">", "¦")
'do the replacement for each character that's illegal
If emailfrom <> vbNullString Then
emailfrom = Replace(emailfrom, mychar, sreplace)
End If
If emailto <> vbNullString Then
emailto = Replace(emailto, mychar, sreplace)
End If
strname = Replace(strname, mychar, sreplace)
strdate = Replace(strdate, mychar, sreplace)
Next mychar
If emailto <> vbNullString Then
'emailto not empty means outgoing mail
'strdate is based on the european date system (dd/mm/yyyy). splitting text gives an array
'starting with 0. In this case, we split on space to get date alone and not the time
'(2) before & contains the year
'(1) before & contains the month
'(0) before & contains the day
'
'the (0) before the , contains the first part of date and time of the string "21_11_2014 12_30_55"
'since we split the first time with the splitseparator space we get "21_11_2014"
'then we use the split with separator _ to get 3 parts of the date
objItem.SaveAs mypath & _
Split(Split(strdate, " ")(0), "_")(2) & "-" & _
Split(Split(strdate, " ")(0), "_")(1) & "-" & _
Split(Split(strdate, " ")(0), "_")(0) & " - " & _
Split(strdate, " ")(1) & " -- " & emailto & " -- " & strname & ".msg", olMSG
Else
'emailto empty means received email = inbox
objItem.SaveAs mypath & _
Split(Split(strdate, " ")(0), "_")(2) & "-" & _
Split(Split(strdate, " ")(0), "_")(1) & "-" & _
Split(Split(strdate, " ")(0), "_")(0) & " - " & _
Split(strdate, " ")(1) & " -- " & emailfrom & " -- " & strname & ".msg", olMSG
End If
'If you answer is yes on this question, the selected email will be deleted from the mailfolder
'in outlook.
If MsgBox("Delete saved email ?", vbYesNo, "Deleting saved email ?") = vbYes Then
objItem.Delete
End If
End If
End Sub

Charlize

[nathandavies]

Charlize,

Thanks for the code, i have just tried to save an email and the same error keeps coming up and i'm not sure why.

12526

[nathandavies]

This is the code that it keeps crashing on....

12527

[nathandavies]

12528

[Charlize]

The folders you specified in your initial request MUST exist. Otherwise the file can't be saved.

ex.
1. project 555 must be a subfolder of P:\Group\JOBDATA
2. P:\Group\JOBDATA\555 must have a correspondence folder
3. P:\Group\JOBDATA\555\Correspondence must have Email.In and Email.Out

If you want to autocreate those subfolders you need to check if those folders exist using dir command in vba.

When the folders are not present, use mkdir to make that subfolder.

Charlize

[nathandavies]

That's where the issue is! there is another variable before the Project number "13400-13499 " or "13500 - 13599" etc

if i change my code so that i have a range would that work also?


mypath = "P:\Group\JOBDATA\13400 - 13499" Or "P:\Group\JOBDATA\13500 - 13599" Or "P:\Group\JOBDATA\13600 - 13699" & InputBox("Give EXISTING projectID ...", "Saving to Project ...")
Loop

[Charlize]

Your extra subfolder must indeed be included. You can do that with a select case or an inputbox where you give 1. 2. 3. options. If you type 1 you get first subdivision of the project ...

Charlize

[nathandavies]

I'm not sure how you to create a select case for each folder and then subfolder.

This is a typical layout of our folder structure: "P:\Group\JOBDATA\13400 - 13499\13469 - ABB - Project Grange UK"

The issue i'm having is the string of words after the job number "13469"

[westconn1]

cross posted
http://www.vbforums.com/showthread.php?781509-Saving-Emails-to-a-network-folder-using-a-macro

[Charlize]

Don't crosspost anymore, please. I'll give you my idea about this problem. Since you don't have a fix range of numbers 0 - 100 is not the same as always 500 differance in range like 13000 - 13499 / 13500 - 13999 / 14000 - 14499 ...
- Assumption 1 : always a space - space in the numbers --> number space - space number
- using split you could separate the first starting number with the ending number of the range of project numbers
- with the dir statement, you could loop through the directories of P:\GROUP\JOBDATA\ (this directory has all the directories for the range of projects)
(123 - 999)
- so if you give a number, let's say 1000 , you compare the given project id with the splitted directory (start number - ending number)
- beginning number = 123 and ending number = 999
- since 1000 >= 123 and 1000 <= 999 isn't true, the code should pick the next directory to compare the given project id with your structure of directories
- 1000 - 1499 is next directory of projectnumbers
- since 1000 >= 1000 and 1000 <= 1499 is true because 1000 is in the range of beginning and ending number , you have found the directory of the sub division.

Charlize

[nathandavies]

I think the compare option would be the best route, based on the amount of folders i have.

so for instance is the project id was: "13469" it would loop through the folder comparing folder names until it found "13400 - 13499"

[nathandavies]

Charlize,

Apologies for cross posting also!

[Charlize]

This coding will look for any division, no matter what projectno you give. Well the folders must exist off course. It's not complete finished but it scans for the range of projectfolder you need. So when you type 13469 as input, it will find 13400 - 13499. Best to add ' before msgbox codings, cause otherwise you have lot's off clicking to do. If a certain folder doesn't have a - it it, it will report it to. This routine must be combined with the other routine to save. Maybe alter it to somekind of function or so where you pass the path, projectid as variables and this subroutine will do the necessary steps to save your email. Function would be better cause you have to get to the subfolder of the project in the projects subfolder.


Sub loop_dirs()
'loop through directory structure to get to sub folders of projects
'the diretory where the given projectid should be present
Dim mydir As String
'the path of all the projects
Dim mypath As String
'saved or not
Dim mysave As Boolean
'project id we look for
Dim projectid As Long
'path of all jobs
mypath = "P:\Group\JOBDATA\"
'get first directory
mydir = Dir(mypath, vbDirectory)
'not saved cause we begin the search
mysave = False
'give the id we look for
projectid = InputBox("Give Project ID : ", "Provide project ID ...")
'loop through the directory structure
Do While mydir <> vbNullString
'skip . and ..
If mydir <> "." And mydir <> ".." Then
'only look for directory's
If (GetAttr(mypath & mydir) And vbDirectory) = vbDirectory Then
'a popup , just put a ' infront of this line to make a comment of this line
MsgBox mydir
'look for - in the directory name
If InStr(1, mydir, "-") > 0 Then
MsgBox "character - was found in directory"
'check if given projectno belongs to the range we look for
'if beginning number is less or equal than projectid AND ending number is greater
'or equal of ending number then we found the needed directory
If Val(Split(mydir, "-")(0)) <= projectid And Val(Split(mydir, "-")(1)) >= projectid Then
MsgBox "Bingo, directory found to save :) "
'set boolean to true
mysave = True
Exit Do
End If
Else
'if no - is found, directory doesn't follow the naming conventions
MsgBox "This directory doesn't follow the naming conventions." & vbCrLf & _
mydir
End If
End If
End If
'next directory in list
mydir = Dir
Loop
If mysave = True Then
'boolean true = saved
MsgBox "Directory to save the email was found." & vbCrLf & _
"Now switch to the desired project directory inside this directory."
Else
'not saved
MsgBox "Directory to save email to wasn't found. Check directory structure !!!"
End If
End Sub
Charlize

[Charlize]

Switching would be easy if you didn't have a name after the number. You just needed mypath / mydir / projectid . But since you have - and then the name of the project or client or whatever you have to iterate through all the directories of mypath & mydir to find the directory that has the first part of the split with - . In this case it must be = . So val(split(mydir,"-")(0) = projectid will give the desired directory. In the resulting directory you would have correspondance and those email.in and email.out

Charlize

[nathandavies]

Thanks for that bit of code, think i have it in the wrong place as i keep getting msgboxes asking for folders, i will try again and let you know if it works

[Charlize]

Little warning, it's not a copy paste job with the codes I gave you. First one did the saving but initial request wasn't given with a correct situation.
2nd coding only shows how to look for directory that you need. Later on you need to incorporate 2nd coding into the first coding.
Maybe later I will try to combine them ... A day or three , if you can wait.

Charlize

[nathandavies]

Yeah that would be great if you could, i have tried to combine the two codes but not having much look at the moment. also having an issue with the string of text after the project id...

[Charlize]

This piece of coding should do what you want. No error checking if directories exist or not, so all folders have to be present (correspondance, email.in, email.out).

Sub SAVE_EMAIL_JOBDATA()
'*** stuff for getting the correct directory
'loop through directory structure to get to sub folders of projects
'mydir = the diretory where the given projectid should be present
'mypath = the path of all the projects
'mysave = saved or not
'projectid = project id we look for
Dim mydir As String, mypath As String, mysave As Boolean, projectid As Long
'*** end of stuff for getting correct directory
'*** stuff for using parts of the email to save
'the mail we want to process
Dim objItem As Outlook.MailItem
'question for saving, use subject to save
Dim strPrompt As String, strname As String, emailto As String, emailfrom As String
'variables for the replacement of illegal characters
Dim sreplace As String, mychar As Variant, strdate As String
'**** end of stuff for email
'path of all jobs
mypath = "P:\Group\JOBDATA\"
'get first directory
mydir = Dir(mypath, vbDirectory)
'not saved cause we begin the search
mysave = False
'give the id we look for
projectid = InputBox("Give Project ID : ", "Provide project ID ...")
'loop through the directory structure
Do While mydir <> vbNullString
'skip . and ..
If mydir <> "." And mydir <> ".." Then
'only look for directory's
If (GetAttr(mypath & mydir) And vbDirectory) = vbDirectory Then
'a popup , just put a ' infront of this line to make a comment of this line
MsgBox mydir
'look for - in the directory name
If InStr(1, mydir, "-") > 0 Then
MsgBox "character - was found in directory"
'check if given projectno belongs to the range we look for
'if beginning number is less or equal than projectid AND ending number is greater
'or equal of ending number then we found the needed directory
If Val(Split(mydir, "-")(0)) <= projectid And Val(Split(mydir, "-")(1)) >= projectid Then
MsgBox "Bingo, directory found to save :) "
'set boolean to true
mysave = True
'create correct path
mypath = mypath & mydir & "\"
Exit Do
End If
Else
'if no - is found, directory doesn't follow the naming conventions
MsgBox "This directory doesn't follow the naming conventions." & vbCrLf & _
mydir
End If
End If
End If
'next directory in list
mydir = Dir
Loop
If mysave = True Then
'boolean true = saved
MsgBox "Range of folderdirectory to save the email was found." & vbCrLf & _
"Now switch to the desired project directory inside this directory."
mydir = Dir(mypath, vbDirectory)
'not saved cause we begin the search for the project inside the range of projects
mysave = False
'loop through the directory structure
Do While mydir <> vbNullString
'skip . and ..
If mydir <> "." And mydir <> ".." Then
'only look for directory's
If (GetAttr(mypath & mydir) And vbDirectory) = vbDirectory Then
'a popup , just put a ' infront of this line to make a comment of this line
MsgBox mydir
'look for - in the directory name
If InStr(1, mydir, "-") > 0 Then
MsgBox "character - was found in directory"
'check if given projectno is same as number in name of projectdirectory
If Val(Split(mydir, "-")(0)) = projectid Then
MsgBox "Bingo, final directory found to save :) "
'set boolean to true
mysave = True
'set correct path
mypath = mypath & mydir & "\"
Exit Do
End If
Else
'if no - is found, directory doesn't follow the naming conventions
MsgBox "This projectdirectory doesn't follow the naming conventions." & vbCrLf & _
mydir
End If
End If
End If
'next directory in list
mydir = Dir
Loop
'put active mail in this object holder
Set objItem = Outlook.ActiveExplorer.Selection.Item(1)
'check if it's an email
If objItem.Class = olMail Then
'check on subject
If objItem.Subject <> vbNullString Then
strname = objItem.Subject
Else
strname = "No_Subject"
End If
'select if the selected mail is located in the inbox or sent items folder
Select Case objItem.Parent
Case Outlook.Session.GetDefaultFolder(olFolderInbox)
'change saving path accordingly
mypath = mypath & "Correspondence\Email.In\"
emailfrom = objItem.Sender
Case Outlook.Session.GetDefaultFolder(olFolderSentMail)
mypath = mypath & "Correspondence\Email.Out\"
emailto = objItem.To
End Select
strdate = objItem.ReceivedTime
'define the character that will replace illegal characters
sreplace = "_"
'create an array to loop through illegal characters (saves lines)
For Each mychar In Array("/", "\", ":", "?", Chr(34), "<", ">", "¦")
'do the replacement for each character that's illegal
If emailfrom <> vbNullString Then
emailfrom = Replace(emailfrom, mychar, sreplace)
End If
If emailto <> vbNullString Then
emailto = Replace(emailto, mychar, sreplace)
End If
strname = Replace(strname, mychar, sreplace)
strdate = Replace(strdate, mychar, sreplace)
Next mychar
If emailto <> vbNullString Then
'emailto not empty means outgoing mail
'strdate is based on the european date system (dd/mm/yyyy). splitting text gives an array
'starting with 0. In this case, we split on space to get date alone and not the time
'(2) before & contains the year
'(1) before & contains the month
'(0) before & contains the day
'
'the (0) before the , contains the first part of date and time of the string "21_11_2014 12_30_55"
'since we split the first time with the splitseparator space we get "21_11_2014"
'then we use the split with separator _ to get 3 parts of the date
objItem.SaveAs mypath & _
Split(Split(strdate, " ")(0), "_")(2) & "-" & _
Split(Split(strdate, " ")(0), "_")(1) & "-" & _
Split(Split(strdate, " ")(0), "_")(0) & " - " & _
Split(strdate, " ")(1) & " -- " & emailto & " -- " & strname & ".msg", olMSG
Else
'emailto empty means received email = inbox
objItem.SaveAs mypath & _
Split(Split(strdate, " ")(0), "_")(2) & "-" & _
Split(Split(strdate, " ")(0), "_")(1) & "-" & _
Split(Split(strdate, " ")(0), "_")(0) & " - " & _
Split(strdate, " ")(1) & " -- " & emailfrom & " -- " & strname & ".msg", olMSG
End If
'If you answer is yes on this question, the selected email will be deleted from the mailfolder
'in outlook.
If MsgBox("Delete saved email ?", vbYesNo, "Deleting saved email ?") = vbYes Then
objItem.Delete
End If
End If
Else
'not saved
MsgBox "Directory to save email to wasn't found. Check directory structure !!!"
End If
End Sub
Charlize

ps.: as extra / bonus you could search for the projectid in the body of the email and propose this number when you ask for projectid. Could be made possible if you have always the same structure for references. example : on a line something like :
projectid : 123456
and only this.
You could loop through all the lines of the email in search for keyword projectid : and filter the number to be used for the saving.

[nathandavies]

Charlize,

Thank you very much for putting the time in to look at this!

I have tested the code this morning and the only issue is its not finding the "correspondence" folder even though its located in every project i have tested, it just saves to the email to the directory.

I have tried to follow the code but i can see where the issue is.

I have also taken out all the message boxes for the "mydir" & "character - was found in directory" which has reduced the time and clicking.

[Charlize]

Mmmm, strange. I tested it for me (off course) and it worked fine (with a different base path, no p:\group\data but just on my c drive).
If your email isn't located in the inbox it doesn't adapt the path to the folder inside your project but saves the mail in the found projectfolder.
So not in p:\group\jobdata\range_of_jobs\the_job\correspondence\email.in
but it will save to
p:\group\jobdata\range_of_jobs\the_job

What's the name of the file ?

Because if you look at the select case argument for knowing if it's inbox or sent folder, the sender or recipient get's added to the filename.

Is correspondence written like that ? In your directory structure ?

Full coding attached to import into a codemodule. I assume you know how to add a module inside outlook.
Remove the module with the coding for this little project and import this file into a module. Extract the zip and you get a bas file.

Charlize

[nathandavies]

I have found the issue, i was trying to save emails from a folder within the inbox in outlook and not the Main inbox, when i move the emails to the inbox it saves them no problem.

I have added the .bas file to outlook at it works for any inbox/sent item fine, i still get the message boxes with the range but ill take them out myself.

[Charlize]

Only one or two msgbox 'es are still active :) unless I have missed some, my apologies than.

1. To let you know if a certain directory isn't according to the naming convention
2. To let you know the program has found your folder
3. If a project folder isn't found and the mail couldn't be saved.

Rest of messageboxes could be left out.

Anyway, hope you like this solution and mark this thread as solved.

Charlize

ps. seems you can click on a star to rate me :) . No obligation off course

[nathandavies]

My mistake! you have taken them out thanks!

This solution is great and thanks for your help!

I have one question,is it possible to change the code so it will see folders that are in the inbox?

Inbox Folder/13469-ABB Folder

[Charlize]

This code will check the folder in which the mailitem is located. You could think about something to get that number as a proposed value at the inputbox where you give the projectnumber. It's doable.
Needs some thinking beforehand.
- Need to check before I give inputbox if mail is located in subfolder yes or no
- Then I can propose the projectid when the inputbox comes up
- Or only give inputbox when no number is found ?

Private Sub get_folder_of_email()'declare a mapifolder
Dim myfolder As MAPIFolder
'declare mailitem
Dim myitem As MailItem
'put an email in this variable
Set myitem = Outlook.ActiveExplorer.Selection.Item(1)
'get folder of the mailitem
Set myfolder = myitem.Parent
'check if folder of this mailitem is subfolder (one level higher)
'of inbox. so the parent folder of myfolder must be inboxfolder
If myfolder.Parent = Outlook.Session.GetDefaultFolder(olFolderInbox) Then
MsgBox "Mailmessage is stored in subfolder of Inbox." & _
"Foldersname = " & myfolder
Else
'no inboxfolder as folder one level higher or no inboxfolder
MsgBox "Mailmessage isn't stored in subfolder of inbox."
End If
End Sub

...

Charlize

[nathandavies]

It doesn't need to be that complicated, its only for when its saving the email, so it realises that the email is in a sub folder of the inbox.

[Charlize]

A 'quick and dirty' solution for also saving into the project subfolders if you save an email that resides in a subfolder of the inbox ...
You need to replace the select case .... end case coding with the following code.
you have


'select if the selected mail is located in the inbox or sent items folder
Select Case objItem.Parent
Case Outlook.Session.GetDefaultFolder(olFolderInbox)
'change saving path accordingly
mypath = mypath & "Correspondence\Email.In\"
emailfrom = objItem.Sender
Case Outlook.Session.GetDefaultFolder(olFolderSentMail)
mypath = mypath & "Correspondence\Email.Out\"
emailto = objItem.To
End Select
must become


'select if the selected mail is located in the inbox or sent items folder
Select Case objItem.Parent
Case Outlook.Session.GetDefaultFolder(olFolderInbox)
'change saving path accordingly
mypath = mypath & "Correspondence\Email.In\"
emailfrom = objItem.Sender
Case Outlook.Session.GetDefaultFolder(olFolderSentMail)
mypath = mypath & "Correspondence\Email.Out\"
emailto = objItem.To
Case Else
mypath = mypath & "Correspondence\Email.In\"
emailfrom = objItem.Sender
End Select
Charlize

[nathandavies]

Charlize,

Thank you for your continued support and help!

that works a treat!

I have added rep!

Nathan