The following VB script on outlook will move the email
to a subfolder, detach the attachments, save them on the hard drive and embed
the link on your receiving email. Tried and tested with MS Outlook 2007/2010 and
worked perfectly fine but amend as necessary and use it at your own risk.
- Task 1: Create an MS Access database and a table as described on database section
- Task 2: copy and paste the code into Outlook Visual Basic Editor (Alt+F11), under Microsoft Office Outlook Objects, ThisOutlookSession.
- Task 3: change the ConnectStr path to reflect the location of your Access Database and ensure the user has the necessary right on that folder.
Assumption
Inbox subfolder in Outlook has to be created
beforehand.
Network share folders where the
attachments are saved must be created and assigned necessary permissions beforehand.
Network share folders name (FsFolder)
on the database table must end with “\”
e.g. if sharename is \\FileServer\Users\Someone,
sharename must be entered as \\FileServer\Users\Someone\
in the FsFolder field.
Script Logic
Database: EmailContacts.accdb
Table: Email
ID
|
Auto Number
|
EmailAddress
|
Text
|
SubFolder
|
Text
|
FsFolder
|
Text
|
Option Explicit
Dim SFolder As String
Dim SaveLocation As String
Private Sub
Application_NewMailEx(ByVal EntryIDCollection As String)
'Check
the sender email address and move the mail to corresponding folder
Dim InboundEmails
Dim Email
Dim i As Integer
Dim DestFolder As Outlook.MAPIFolder
Dim olAttachments As
Outlook.Attachments
Dim olAttachFile As Outlook.Attachment
Dim AttachCount As Integer
Dim intIndex As Integer
Dim FilePath As String
Dim FileLink As String
SFolder = "Service"
InboundEmails =
Split(EntryIDCollection, ",")
'loop
all incoming email items
For
i = 0 To UBound(InboundEmails)
Set Email =
Application.Session.GetItemFromID(InboundEmails(i))
If
CheckAddress(Email.SenderEmailAddress) Then
‘MsgBox "You Just have recieved a mail from " &
Email.SenderEmailAddress & "." & Chr(13) & Chr(10)
& "and he said : " & Email.Subject
AttachCount = Email.Attachments.Count
If AttachCount > 0 Then
‘MsgBox "This email has " & AttachCount & "
attachments."
For intIndex =
AttachCount To 1 Step -1
Set olAttachFile =
Email.Attachments.Item(intIndex)
Dim ReNameFile As String
ReNameFile = Time
ReNameFile = Replace(ReNameFile,
Chr(58), Chr(46))
ReNameFile = ReNameFile &
"." & olAttachFile.FileName
FilePath = SaveLocation &
ReNameFile
olAttachFile.SaveAsFile
FilePath
FileLink = FileLink & Chr(34)
& FilePath & Chr(34) & Chr(32) & vbCrLf
olAttachFile.Delete
Next
Email.Body = Email.Body & vbCrLf & vbCrLf & "Removed
Attachments" & vbCrLf & vbCrLf & FileLink
Email.Save
End If
Set DestFolder =
Outlook.Application.Session.GetDefaultFolder(olFolderInbox).Folders(SFolder)
Email.Move DestFolder
End If
Next
Set Email = Nothing
Set InboundEmails = Nothing
End Sub
Function CheckAddress(ByVal eAddress
As String) As Boolean
Dim Connect As New ADODB.Connection
Dim Cmd As New ADODB.Command
Dim RecSet As New ADODB.Recordset
Dim ConnectStr As String
ConnectStr = "Driver={Microsoft
Access Driver (*.mdb, *.accdb)};" & _
"DBQ=C:\Documents and
Settings\N Awn\My Documents\EmailContacts.accdb;" & _
"DefaultDir=C:\Documents and
Settings\N Awn\My Documents;" & _
"UID=admin;"
On Error Resume Next
Connect.ConnectionString = ConnectStr
Connect.Open
'Set RecSet =
Connect.Execute("SELECT EmailAddress FROM Email")
Cmd.ActiveConnection = Connect
Cmd.CommandText = "SELECT
EmailAddress, SubFolder, FsFolder FROM Email"
Set RecSet = Cmd.Execute
Dim Sender As String
Do While Not RecSet.EOF
Sender = Trim(RecSet("EmailAddress"))
If eAddress = Sender Then
CheckAddress = True
SFolder = Trim(RecSet("SubFolder"))
SaveLocation = Trim(RecSet("FsFolder"))
RecSet.Close
Set RecSet = Nothing
Connect.Close
Connect.ConnectionString = ""
Exit Function
Else
CheckAddress = False
End If
RecSet.MoveNext
Loop
RecSet.Close
Set RecSet = Nothing
Connect.Close
Connect.ConnectionString =
""
End Function
'coded By Naw Awn 24/02/2013. Amended
on 31/03/2013
|
