My HR department receives hundreds of email daily with employee code in subject line they wanted to save all email to local drive having employee code so that any one can access email offline without providing mail access to whole team..
Their requirement was to read subject line of each email & check for employee code and save email so received employee folder in local drive with same subject line. If there is no folder then new folder to be created automatic, all employee code is like VB12345 & all email to save in C:\EmpPersonal\.
Copy and paste below code in outlook in ThisOutlookSession module:
Public WithEvents olItems As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set olItems = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub olItems_ItemAdd(ByVal Item As Object)
On Error GoTo ErrorHandler
Dim msg As Outlook.MailItem
Dim endOfSubject As String
Dim destFolder As String
Dim myCode As String
Dim sName As String
Dim regEx As Object
Dim matches
sName = Item.Subject
ReplaceCharsForFileName sName, "_"
If TypeName(Item) = "MailItem" Then
Set msg = Item
' check if subject field contains CODE
Set regEx = CreateObject("VBScript.RegExp")
With regEx
.Pattern = "\w+\d{5}"
.IgnoreCase = True
.Global = True
End With
If regEx.Test(Item.Subject) Then
Set matches = regEx.Execute(Item.Subject)
myCode = matches(0)
Else
Exit Sub
End If
destFolder = "C:/EmpPersonal/"
destFolder = destFolder & myCode
' if subfolder doesn't exist, create it
If Dir(destFolder, vbDirectory) = "" Then
MkDir destFolder
End If
' Copy msg to local folder
Item.SaveAs destFolder & "/" & sName & ".msg", olMSG
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Private Sub ReplaceCharsForFileName(sName As String, _
sChr As String _
)
sName = Replace(sName, "/", sChr)
sName = Replace(sName, "\", sChr)
sName = Replace(sName, ":", sChr)
sName = Replace(sName, "?", sChr)
sName = Replace(sName, Chr(34), sChr)
sName = Replace(sName, "<", sChr)
sName = Replace(sName, ">", sChr)
sName = Replace(sName, "|", sChr)
End Sub
Do post your feedback on this.....
Cheers!!
