Attachment Management Depending on Subject

[senamike]

Good morning all,

I will start by saying I'm new to programming and therefore I apologize upfront for any gross mistakes I might be doing.

We are trying to come up with a way to store email attachments to specific folders on a network drive based on an email subject vs database crosscheck.



The access or excel database would contain a table with project codes/labels (something like xxx-xxxxx) and would be updated when new project codes are assigned/created (manually)
When an email drops on the outllook inbox the script would read the email subject, search for the project code
A folder would be created on the network drive with the project code (don't know if this is possible)
Email attachments would be saved on the specific project folder according to the code on the email subject


Since project codes are constantly being created, this script would avoid having to create/change outlook subject rules.

So far I've been able to save the attachments I want with this code:


Public Sub saveAttachtoDisk(itm As Outlook.MailItem)Dim objAtt As Outlook.Attachment
Dim saveFolder As String
saveFolder = "I:\Folder"
For Each objAtt In itm.Attachments
If InStr(objAtt.DisplayName, ".pdf") Or InStr(objAtt.DisplayName, ".PDF") Or InStr(objAtt.DisplayName, ".docx") Or InStr(objAtt.DisplayName, ".DOCX") Or InStr(objAtt.DisplayName, ".xlsm") Or InStr(objAtt.DisplayName, ".XLSM") Or InStr(objAtt.DisplayName, ".xls") Or InStr(objAtt.DisplayName, ".xlsx") Or InStr(objAtt.DisplayName, ".doc") Or InStr(objAtt.DisplayName, ".docm") Then
objAtt.SaveAsFile saveFolder & "\" & objAtt.DisplayName
Set objAtt = Nothing
End If
Next
End Sub

Can you provide any guidance on how to solve this problem?

I appreciate your time!

Thanks in advance,
Miguel

[gmayor]

If you create an Excel workbook with Sheet1 having a header row and a single column containing the codes (here called "C:\Path\Forum\Codes.xlsx") and the network drive is mapped to a drive letter - here "R:\" - then the following should do the job provided you have write access to the network drive (you can add a path to the Drive letter if you want the folders to be created in a sub folder). The Excel function reads the worksheet to an array which is used to check against the subject text. If the subject text contains a matching string, then the folder is created (if not already present) and the attachment files saved into it. I have made no allowance for duplicated filenames. If you want that, investigate the FileNameUnique function on my web site.

The code may work with the network address, but it certainly does with a mapped drive.


Option Explicit

Sub Test()
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
SaveAttachToDisk olMsg
lbl_Exit:
Exit Sub
End Sub


Public Sub SaveAttachToDisk(olItem As Outlook.MailItem)
'An Outlook macro by Graham Mayor
Dim objAtt As Outlook.Attachment
Dim strSubject As String
Dim strFolder As String
Dim strName As String
Dim arr() As Variant
Dim i As Long
Dim bFound As Boolean
Const strWorkbook As String = "C:\Path\Forum\Codes.xlsx"
Const strSheet As String = "Sheet1"
Const strRootPath As String = "R:\" 'Mapped network drive

strSubject = olItem.Subject
arr = xlFillArray(strWorkbook, strSheet)
For i = 0 To UBound(arr, 2) ' Second array dimension is columns.
If InStr(1, strSubject, arr(0, i)) > 0 Then
strFolder = strRootPath & arr(0, i) & "\"
CreateFolders strFolder
bFound = True
Exit For
End If
Next i
If Not bFound Then GoTo lbl_Exit
For Each objAtt In olItem.Attachments
strName = objAtt.FileName
Select Case LCase(Mid(strName, InStr(1, strName, Chr(46))))
Case ".pdf", ".doc", ".docx", ".docm", ".xls", ".xlsx", ".xlsm"
objAtt.SaveAsFile strFolder & objAtt.FileName
Case Else
End Select
Next objAtt
lbl_Exit:
Set objAtt = Nothing
Exit Sub
End Sub

Private Function xlFillArray(strWorkbook As String, _
strWorksheetName As String) As Variant
'An Office macro by Graham Mayor
Dim RS As Object
Dim CN As Object
Dim iRows As Long

strWorksheetName = strWorksheetName & "$]"
Set CN = CreateObject("ADODB.Connection")
CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strWorkbook & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=YES"";"

Set RS = CreateObject("ADODB.Recordset")
RS.Open "SELECT * FROM [" & strWorksheetName, CN, 2, 1

With RS
.MoveLast
iRows = .RecordCount
.MoveFirst
End With
xlFillArray = RS.GetRows(iRows)
If RS.State = 1 Then RS.Close
Set RS = Nothing
If CN.State = 1 Then CN.Close
Set CN = Nothing
lbl_Exit:
Exit Function
End Function

Private Function FolderExists(fldr) As Boolean
'An Outlook macro by Graham Mayor
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If (fso.FolderExists(fldr)) Then
FolderExists = True
Else
FolderExists = False
End If
lbl_Exit:
Exit Function
End Function

Private Function CreateFolders(strPath As String)
'An Outlook macro by Graham Mayor
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
vPath = Split(strPath, "\")
strPath = vPath(0) & "\"
For lngPath = 1 To UBound(vPath)
strPath = strPath & vPath(lngPath) & "\"
If Not FolderExists(strPath) Then MkDir strPath
Next lngPath
lbl_Exit:
Exit Function
End Function

[senamike]

Dear Graham,

I really don`t know how to thank you! You are clearly a 5 stars person!

I have ran the following tests on your script:

1. Check if it does not save the *.png PASSED
2. Check if folder with MIAS Code is created PASSED
3. Check if it does not create another folder with the MIAS Code PASSED
4. Check if it does the same with the MIAS on different places on the email subject PASSED
5. Check if it includes the project name on the folder name FAILED

a. Include a solution where it also writes the name of the project included on the second column of the excel database, on the folder name, even if the project name is not stated on the subject of the email
6. Check if it saves in the network if the MIAS Codes.xlsx is on the network file PASSED
7. Check if it does not overwrite files FAILED

a. include FileNameUnique script
8. Check if it works when MIAS Code is written on the subject like –XXX-XXXXX- instead of having spaces before and after PASSED

I am very happy with what I have at the moment, and also feel bad with what I'm going to ask next, but... could you help me with items No. 5 and 7?

Again, thank you very much for everything!
Miguel

[gmayor]

Can you clarify '5'. Reading the second column is easy enough. What is in the second column and how does it relate to the folder name?
I will probably be unavailable until Saturday. If you want to send me the information to my web site contact page, I'll pick it up when I next log in.

[senamike]

Hi Graham,

The second column contains text "Project name". In the end the folder to be created should be named as "xxx-xxxxx Project Name". So in excel cell A2 has xxx-xxxx and cell B2 has Project Name. The email subject only contains the xxx-xxxxx (cell A1), so the script should match with cell A1 (it already does that perfectly), but should also put the text of cell B2 on the folder name.

Thank you very much and have a nice weekend!

Miguel

[gmayor]

OK I didn't have to go out as early as I thought so I had time to add in the extra bits of code. I would have thought that "Project Name xxx-xxxxx" would have been more logical, but it's your filking system :). If you with to follow my suggestion then change the line
strFolder = strRootPath & arr(0, i) & Chr(32) & arr(1, i) & "\" to
strFolder = strRootPath & arr(1, i) & Chr(32) & arr(0, i) & "\"


This version replaces the previous code and should do what you asked. The various functions used are available from my web site: http://www.gmayor.com/useful_vba_functions.htm.


Option Explicit

Sub Test()
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
SaveAttachToDisk olMsg
lbl_Exit:
Exit Sub
End Sub


Public Sub SaveAttachToDisk(olItem As Outlook.MailItem)
'An Outlook macro by Graham Mayor
Dim objAtt As Outlook.Attachment
Dim strSubject As String
Dim strFolder As String
Dim strName As String
Dim strExt As String
Dim arr() As Variant
Dim i As Long
Dim bFound As Boolean
Const strWorkbook As String = "C:\Path\Forum\Codes.xlsx"
Const strSheet As String = "Sheet1"
Const strRootPath As String = "R:\" 'Mapped network drive

strSubject = olItem.Subject
arr = xlFillArray(strWorkbook, strSheet)
For i = 0 To UBound(arr, 2) ' Second array dimension is columns.
If InStr(1, strSubject, arr(0, i)) > 0 Then
strFolder = strRootPath & arr(0, i) & Chr(32) & arr(1, i) & "\"
CreateFolders strFolder
bFound = True
Exit For
End If
Next i
If Not bFound Then GoTo lbl_Exit
For Each objAtt In olItem.Attachments
strName = objAtt.FileName
MsgBox strName
strExt = LCase(Mid(strName, InStr(1, strName, Chr(46)) + 1))
MsgBox strExt
strName = FileNameUnique(strFolder, strName, strExt)
MsgBox strName
Select Case strExt
Case "pdf", "doc", "docx", "docm", "xls", "xlsx", "xlsm"
objAtt.SaveAsFile strFolder & strName
Case Else
End Select
Next objAtt
lbl_Exit:
Set objAtt = Nothing
Exit Sub
End Sub

Private Function xlFillArray(strWorkbook As String, _
strWorksheetName As String) As Variant
'An Office macro by Graham Mayor
Dim RS As Object
Dim CN As Object
Dim iRows As Long

strWorksheetName = strWorksheetName & "$]"
Set CN = CreateObject("ADODB.Connection")
CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strWorkbook & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=YES"";"

Set RS = CreateObject("ADODB.Recordset")
RS.Open "SELECT * FROM [" & strWorksheetName, CN, 2, 1

With RS
.MoveLast
iRows = .RecordCount
.MoveFirst
End With
xlFillArray = RS.GetRows(iRows)
If RS.State = 1 Then RS.Close
Set RS = Nothing
If CN.State = 1 Then CN.Close
Set CN = Nothing
lbl_Exit:
Exit Function
End Function

Private Function FolderExists(fldr) As Boolean
'An Office macro by Graham Mayor
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If (fso.FolderExists(fldr)) Then
FolderExists = True
Else
FolderExists = False
End If
lbl_Exit:
Exit Function
End Function

Private Function FileExists(filespec) As Boolean
'An Office macro by Graham Mayor
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(filespec) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function

Private Function CreateFolders(strPath As String)
'An Office macro by Graham Mayor
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
vPath = Split(strPath, "\")
strPath = vPath(0) & "\"
For lngPath = 1 To UBound(vPath)
strPath = strPath & vPath(lngPath) & "\"
If Not FolderExists(strPath) Then MkDir strPath
Next lngPath
lbl_Exit:
Exit Function
End Function

Private Function FileNameUnique(strPath As String, _
strFileName As String, _
strExtension As String) As String
'An Office macro by Graham Mayor
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(strFileName) - (Len(strExtension) + 1)
strFileName = Left(strFileName, lngName)
Do While FileExists(strPath & strFileName & Chr(46) & strExtension) = True
strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
FileNameUnique = strFileName & Chr(46) & strExtension
lbl_Exit:
Exit Function
End Function

[senamike]

Good morning Graham,

Again thanks for the help. The reason why the project code comes first in only for folder organization purposes. Your code is working at 100%, I only removed the message boxes and now that you taught me how to do it, I added more columns on the excel and added them to the folder name.

Cheers,
Miguel

[gmayor]

I was a bit short of time this morning and forgot about the message boxes, which I had inserted to check that the naming was correct. :(
When filling your worksheet, don't leave any empty cells in the data range.

[senamike]

Indeed, already learned that the "hard way".

Have a nice day

[senamike]

Hi Graham,

I have another problem. Scripts do not run on server based rules in outlook... The issue is when the computer is not connected, attachments are not stored on the network, info is lost.

To overcome this problem I taught of run it on 3 different computers with a delay on the script and only if the message is unread. I have been trying to implement this using the codes bellow, but I cannot get it to work.

Application.Wait(Now + TimeValue("0:05:00"))

olRuleExecuteUnreadMessages = 2

Can you help me with this?