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
Reply With Quote
