Using VBA to automatically save attachment to network folder - OVERWRITE HELP!!

[MCC]

Hello everyone

I use the following VBA to automatically save all attachments in outlook to our network folder

Public Sub SaveAttachmentsToDisk(MItem As Outlook.MailItem)
Dim oAttachment As Outlook.Attachment
Dim sSaveFolder As String
sSaveFolder = "\\Dck-server-02\g\00 Uploads\"
For Each oAttachment In MItem.Attachments
oAttachment.SaveAsFile sSaveFolder & oAttachment.DisplayName
Next
End Sub

I then create a rule within outlook to have all messages with attachments from a specific sender to run the above VBA

My issue is, the attachments that i will be receiving are 100% likely to have the same filename and i have noticed on test runs that the most recent attachment will overwrite the previous one when saved into the directed network folder.
Is there an edit to the VBA that anyone can suggest that will append a number or something similar to the end of the attachment filename??
For example,
If the filename was 'site inspection' would it be possible to edit the VBA to save the attachments as 'site inspection-1' 'site inspection-2' 'site inspection-3' etc...

Please, if anyone is able to help with this issue it would be greatly appreciated!!

[gmayor]

The following will append a number to the saved file when the name exists.


Public Sub SaveAttachments(olItem As MailItem)
'Graham Mayor - http://www.gmayor.com - Last updated - 26 May 2017
Dim olAttach As Attachment
Dim strFname As String
Dim strExt As String
Dim j As Long
Const strSaveFldr As String = "\\Dck-server-02\g\00 Uploads\" 'Folder must exist

On Error GoTo lbl_Exit
If olItem.Attachments.Count > 0 Then
For j = 1 to olItem.Attachments.Count
Set olAttach = olItem.Attachments(j)
If Not olAttach.fileName Like "image*.*" Then
strFname = olAttach.fileName
strExt = Right(strFname, Len(strFname) - InStrRev(strFname, Chr(46)))
strFname = FileNameUnique(strSaveFldr, strFname, strExt)
olAttach.SaveAsFile strSaveFldr & strFname
End If
Next j
olItem.Save
End If
lbl_Exit:
Set olAttach = Nothing
Set olItem = Nothing
Exit Sub
End Sub

Private Function FileNameUnique(strPath As String, _
strFileName As String, _
strExtension As String) As String
'An Outlook 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

Private Function FileExists(filespec) As Boolean
'An Outlook 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



Test it with


Sub ProcessAttachments()
'An Outlook macro by Graham Mayor
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
SaveAttachments olMsg
lbl_Exit:
Exit Sub
End Sub

[MCC]

GMayor

Thank you so much for helping me out, it looks like you put 100000% effort into that script for me!!

I am having a bit difficulty though, i apologise but i am absolute beginner at this stuff and i need a bit of help.
Was there anything within the code that i needed to remove or change?? Am i just copying and pasting the whole thing into one window of the VB editor??

Thank you again!

[gmayor]

I can't say that I created the code specifically for you. I have posted variations of it before. I just changed it a little to suit your requirement. :)

As long as the named folder (taken from your original) exists, the code should work without alteration.

It all goes in one module. Add a new module to the project and paste it there.

The first line of that module should be


Option Explicitwhich forces the declaration of variables.

If you encounter problems with Outlook security - see
http://www.gmayor.com/create_and_employ_a_digital_cert.htm (http://www.gmayor.com/create_and_employ_a_digital_cert.htm)

[MCC]

https://vimeo.com/219324142

https://vimeo.com/219324142

I have included a video that shows exactly what i am doing...
Hopefully someone might be able to point out what i am missing?

Many thanks!

[MCC]

I will post the link to the video below so you can watch in full screen

[MCC]

Post 4

[MCC]

https://vimeo.com/219324142

[gmayor]

To test the process, select the message and run the ProcessAttachments macro which runs the main macro on the selected message. The main script associated with the rule acts on messages as they arrive in the inbox.

[MCC]

Hi Gmayor,

I generally test the rule with an incoming mail item instead of 'run rule now'
I only used 'run rule now' for the purpose of the video

Any other tips?

[gmayor]

Did you do as I said?
Did it create the saved item?
If it did, then so will the rule when in runs on a message arriving that meets the rule criteria.

[MCC]

Did you do as I said?
Did it create the saved item?
If it did, then so will the rule when in runs on a message arriving that meets the rule criteria.

I did but unfortunately it doesn't create the saved item at all :(

[gmayor]

In that case there is an issue with how you have installed the macros or the folder you are saving to does not exist. Your video shows that the named sub folders (\g\00 Uploads\) don't exist. Those folders must exist. The process doesn't create them.

I have tested this code (copied directly from the message) this morning using a similar path on my network with a message selected that has an attachment and it works as described.

Add an apostrophe to the start of the line - 'On Error GoTo lbl_Exit in the main macro and see if the process gives you an error message that might indicate the problem.

19347

To overcome the potential issue that the folder doesn't exist, the following (complete code to replace the code that you have) will create the folder tree if it doesn't exist, provided the root folder exists (in this case the network location) and you have write access to that location. Again I have tested this on my network and it works as described.


Option Explicit

Sub ProcessAttachments()
'An Outlook macro by Graham Mayor
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
SaveAttachments olMsg
lbl_Exit:
Exit Sub
End Sub

Public Sub SaveAttachments(olItem As MailItem)
'Graham Mayor - http://www.gmayor.com - Last updated - 31 May 2017
Dim olAttach As Attachment
Dim strFname As String
Dim strExt As String
Dim j As Long
Const strSaveFldr As String = "\\Dck-server-02\g\00 Uploads\"
CreateFolders strSaveFldr
If olItem.Attachments.Count > 0 Then
For j = 1 To olItem.Attachments.Count
Set olAttach = olItem.Attachments(j)
If Not olAttach.fileName Like "image*.*" Then
strFname = olAttach.fileName
strExt = Right(strFname, Len(strFname) - InStrRev(strFname, Chr(46)))
strFname = FileNameUnique(strSaveFldr, strFname, strExt)
olAttach.SaveAsFile strSaveFldr & strFname
End If
Next j
olItem.Save
End If
lbl_Exit:
Set olAttach = Nothing
Set olItem = Nothing
Exit Sub
End Sub

Private Function FileNameUnique(strPath As String, _
strFileName As String, _
strExtension As String) As String
'An Outlook 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

Private Function FileExists(filespec) As Boolean
'An Outlook 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)
'Graham Mayor - http://www.gmayor.com - Last updated - 31 May 2017
'Creates the full path 'strPath' if missing or incomplete
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
Dim oFSO As Object
Dim i As Integer
Set oFSO = CreateObject("Scripting.FileSystemObject")
vPath = Split(strPath, "\")
If Left(strPath, 2) = "\\" Then
strPath = "\\" & vPath(2) & "\"
For lngPath = 3 To UBound(vPath)
strPath = strPath & vPath(lngPath) & "\"
If Not oFSO.FolderExists(strPath) Then MkDir strPath
Next lngPath
Else
strPath = vPath(0) & "\"
For lngPath = 1 To UBound(vPath)
strPath = strPath & vPath(lngPath) & "\"
If Not oFSO.FolderExists(strPath) Then MkDir strPath
Next lngPath
End If
lbl_Exit:
Set oFSO = Nothing
Exit Function
End Function

[MCC]

You wouldn't believe it...

For some reason, macros were turned off in outlook!!!!!!!!!!!!!!
I only came across this while just doing a google search for VBA outlook 2010 basics and it suggested that macros be switch on first and i figured 'well its worth checking thats not turned off for some reason' and guess what!
I cannot thank you enough for all your help GMayor!!!!!!!!!!!!!

[gmayor]

You may experience security issues with Outlook VBA, in which case see
http://www.gmayor.com/create_and_employ_a_digital_cert.htm (http://www.gmayor.com/create_and_employ_a_digital_cert.htm)