Auto saving files and renaming file name. Genius needed.

[Putt4Dough]

Hello everyone.

Let me start by saying, please be gentle, I’m not a programmer but I’m a tech. Programming is not my area of expertise.

That being said, my users were using Eudora as a mail client. Eudora has an option to automatically save mail attachments to a distant folder. In our case the attachments are saved to a network folder. We are replacing Eudora with Outlook but unfortunately Outlook does not offer this option. I found multiple scripts on the web but most was just too complicated for my needs so I managed to simplify one and make it work. Here is the script:

[VBA]
Public Sub saveAttachtoDisk(itm As Outlook.MailItem)

Dim objAtt As Outlook.Attachment

Dim saveFolder As String
saveFolder = "c:\temp\"

For Each objAtt In itm.Attachments
objAtt.SaveAsFile saveFolder & "\" & objAtt.DisplayName
Set objAtt = Nothing
Next
End Sub
[/VBA]
Now the issue I have is that if I receive multiple emails with attachments that have the same name, witch is often the case here, the latest attachment will overwrite the older attachment without warning. What I’m trying to do in the script bellow is to rename the attachments when they come in by adding a decimal at the end of the file name. Unfortunately my script bellow does not work. It runs in a loop non stop and I have no clue what I’m doing thus no clue how to fix this or what is missing.

[VBA]
Public Sub saveAttachtoDisk(itm As Outlook.MailItem)

On Error Resume Next

Dim objAtt As Outlook.Attachment

Dim saveFolder As String
Dim stFileName As String
Dim i As Integer

saveFolder = "c:\temp"

For Each objAtt In itm.Attachments
stFileName = saveFolder & "\" & objAtt.DisplayName
i = 0
While FileLen(stFileName) > 0
If Err <> 0 Then Err = 0
i = i + 1
stFileName = saveFolder & "\" & Str(i) & objAtt.DisplayName
MsgBox stFileName
Wend
If Err <> 0 Then Err = 0
objAtt.SaveAsFile stFileName
Set objAtt = Nothing
Next
End Sub
[/VBA]
Is there a genius out here that can help me with this? PLEASE!!!!

Thanks a bundle.
Mike

[jumpjack]

Why reinventing the wheel?
Did you already try this, too?
http://code.google.com/p/lightlook/

Each message has its own folder created containing its attachments, which can be easily opened by clicking in the message itself.

[Putt4Dough]

Creating a folder for every email received is overkill for the users. They receive hundreds of emails per day. That makes for hundreds of additional double clicking and deleting folder that file renaming upon reception would prevent.

There is surely someone in here that can make this work. Anyone?

TY
Mike

[inxain]

Hi

I use the following variation of the same script in Outlook 2003 to insert the date and time stamp before the file extension (not very elegant but it works)

Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
saveFolder = "c:\a"
For Each objAtt In itm.Attachments
posr = InStrRev(objAtt.FileName, ".")
ext = Right(objAtt.FileName, Len(objAtt.FileName) - posr)
posl = InStr(objAtt.FileName, ".")
fname = Left(objAtt.FileName, posr - 1)
objAtt.SaveAsFile saveFolder & "\" & fname & "_" & Format(itm.ReceivedTime, "ddmmyyyy_hhmm") & "." & ext
Set objAtt = Nothing
Next
End Sub

[jumpjack]

Creating a folder for every email received is overkill for the users.

Why? they don't do anything, they just select the messages with attachments and they press a button. All the work is done by the macro: creating folders named like message subject followed by date+time, saving attachments into those folders, removing attachments from messages, inserting into messages links to saved attachments.

[Putt4Dough]

Hi

I use the following variation of the same script in Outlook 2003 to insert the date and time stamp before the file extension (not very elegant but it works)

Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
saveFolder = "c:\a"
For Each objAtt In itm.Attachments
posr = InStrRev(objAtt.FileName, ".")
ext = Right(objAtt.FileName, Len(objAtt.FileName) - posr)
posl = InStr(objAtt.FileName, ".")
fname = Left(objAtt.FileName, posr - 1)
objAtt.SaveAsFile saveFolder & "\" & fname & "_" & Format(itm.ReceivedTime, "ddmmyyyy_hhmm") & "." & ext
Set objAtt = Nothing
Next
End Sub

This script works but for us it’s more work. The clients send us a huge amount of emails per day. All these attachments have long file names. Adding the date and time to every file gives them more work since when the attachment is translated it need to be returned to the client with the original file name. With this script, the user needs to delete the added date and time. All this is additional work.

What I need is to rename an attachment only if a file with the same name already exists in the folder. Let say I have a file “autosave.doc” in my C:\attachment\ folder and I receive a new email with a file named autosave.doc. I would like the script to check if a file with that name already exists, if so, rename it autosave1.doc.

I’m sure that this is possible but I’m not a programmer and have no clue on how configure it.

TY
Mike

[sagnik_pal]

This should work I guess:

saveFolder = "C:\attachment"
For Each objAtt In itm.Attachments
stFileName = saveFolder & "\" & objAtt.DisplayName
i = 0
JumpHere:
If Dir(stFileName) = "" then
objAtt.SaveAsFile stFileName
else
i=i+1
stFileName = saveFolder & "\" & i & " - " & objAtt.DisplayName
goto Jumphere
end if
Set objAtt = Nothing
Next

Reg
Sagnik

[Putt4Dough]

Perfect. That is exactly what I was looking for. Tried and tested and it works perfectly. Thanks a bunch.

[Putt4Dough]

Look at the en for the code I use now. Change the saveFolder = path to your needs.

In Outlook press on Alt-F11. On the left pane click on Project1, Microsoft office outlook, ThisOutllokSession then paste the code in the right pane. Save and the click on Debug, Compile project1. Close MS VB.

You will then need to create a rule in Outlook to run the script for incoming mail. Tools, Rules and Alerts, New rules, Start from a blank rule, Check message when they arrive, Through a specific account, run a script, next and finish.

[VBA]
Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
saveFolder = "k:\download"
For Each objAtt In itm.Attachments
stFileName = saveFolder & "\" & objAtt.DisplayName
i = 0
JumpHere:
If Dir(stFileName) = "" Then
objAtt.SaveAsFile stFileName
Else
i = i + 1
stFileName = saveFolder & "\" & i & " - " & objAtt.DisplayName
GoTo JumpHere
End If
Set objAtt = Nothing
Next

End Sub
[/VBA]

[Prex]

Hi,

Thank you for this code. This worked perfect for me except...the emailsbeing sent to me contain multiple sub-email attachments (items) with the .csvfiles I need! In other words, I have one email that contains multiple email attachments(see att), and each of those email attachments contains the file I need. Is itpossible to extract those files to a folder? I don't need the emails, just thefiles (they happen to be .csv files each one named the same thing so I thinkthe current code will handle renaming them to a sequential file name).


Please don't yell at me , I did not ask for this set up but that's the way I'm getting it sent to me! Please help if you can.

[Prex]

.....to illustrate further here is an example of one of the sub emails opened up. Each .csv file is named "Invoice".

[BobRPC]

[BrianMH]

This is what works for me. I've been using it for years. Just pass the mail object and the folder path you want to save the attachments to the sub and it will save all the attachments for you and if there are multiples of the same name it will add a file number like windows does when it makes copies. IE filename(1).csv

[VBA]Sub downloadmail(myMailItem, strPath As String)
Dim strFileName As String
Dim strNewName As String
Dim strPre As String
Dim strExt As String
Dim myolAttachments As Attachments
Dim myolAtt As Attachment
Dim intExtlen As Integer
Dim w As Integer
Dim fs
Set fs = CreateObject("Scripting.FileSystemObject")
If myMailItem.Attachments.Count <> 0 Then
Set myolAttachments = myMailItem.Attachments
For Each myolAtt In myolAttachments
strFileName = myolAtt.DisplayName
'find out if the file exists in the download location already and if so rename
'to a filename including a number eg. file(1).xls
If fs.fileexists(strPath & "\" & strFileName) = True Then
strNewName = strFileName
'get the length of the extension including the .
intExtlen = Len(strFileName) - InStrRev(strFileName, ".") + 1
'check there is actually a file extension and if not set extension to blank
'and set strPre to the full file name
If InStrRev(strFileName, ".") > 0 Then
strExt = Right(strFileName, intExtlen)
strPre = Left(strFileName, Len(strFileName) - intExtlen)
Else
strExt = ""
strPre = strFileName
End If
'increase the file number (w) until the file name no longer exists file(1).ext to file(2).ext etc
'strpre = filename before extension strext = extension w=file number
While fs.fileexists(strPath & "\" & strNewName) = True
w = w + 1
strNewName = strPre & Chr(40) & w & Chr(41) & strExt
Wend
'set the new filename
strFileName = strNewName
w = 0
End If
myolAtt.SaveAsFile strPath & "\" & strFileName
AttachmentCount = AttachmentCount + 1
Set myolAtt = Nothing
Next
End If
myMailItem.UnRead = False
End Sub[/VBA]

[Prex]

Thank you!

[Madmartigan]

This is what works for me. I've been using it for years. Just pass the mail object and the folder path you want to save the attachments to the sub and it will save all the attachments for you and if there are multiples of the same name it will add a file number like windows does when it makes copies. IE filename(1).csv

I was wondering if I could get some assistance with your code.

I have successfully used this code:

[VBA]
Public Sub SaveAttachments()
'Note, this assumes you are in the a folder with e-mail messages when you run it.
'It does not have to be the inbox, simply any folder with e-mail messages

Dim App As New Outlook.Application
Dim Exp As Outlook.Explorer
Dim Sel As Outlook.Selection

Dim AttachmentCnt As Integer
Dim AttTotal As Integer
Dim MsgTotal As Integer

Set Exp = App.ActiveExplorer
Set Sel = Exp.Selection
'Loop thru each selected item in the inbox
For cnt = 1 To Sel.Count
'If the e-mail has attachments...
If Sel.Item(cnt).Attachments.Count > 0 Then
MsgTotal = MsgTotal + 1
AttTotal = AttTotal + Sel.Item(cnt).Attachments.Count
'For each attachment on the message...
For AttachmentCnt = 1 To Sel.Item(cnt).Attachments.Count
'Get the attachment
Dim att As Attachment
Set att = Sel.Item(cnt).Attachments.Item(AttachmentCnt)
'Save it to disk
att.SaveAsFile ("H:\Attachments\" + att.FileName)
Next
End If
Next

'Clean up
Set Sel = Nothing
Set Exp = Nothing
Set App = Nothing

'Let user know we are done
Dim doneMsg As String
doneMsg = "Completed saving " + Format$(AttTotal, "#,0") + " attachments in " + Format$(MsgTotal, "#,0") + " Messages."
MsgBox doneMsg, vbOKOnly, "Save Attachments"

Exit Sub

ErrorHandler:
Dim errMsg As String
errMsg = "An error has occurred. Error " + Err.Number + " " + Err.Description
Dim errResult As VbMsgBoxResult
errResult = MsgBox(errMsg, vbAbortRetryIgnore, "Error in Save Attachments")
Select Case errResult
Case vbAbort
Exit Sub

Case vbRetry
Resume

Case vbIgnore
Resume Next

End Select

End Sub

[/VBA]


But I would like to integrate the code that adjusts for files of the same name (by adding a number at the end of the file). Where in my code do I insert the code you posted above?

Thank you for the help.

[jonathonalle]

Does anyone know how to change the attachment name to match that of the email's subject?

[kinglouie212]

Looking to do a couple of things here:
1. I have multiple attachments coming in per email, how can i edit my code to pick up attachments? (code below)

ElseIf (UCase(Msg.Subject) = "SAMPLE") Then
attPath = "PATH ON HD"
Set myAttachments = oItem.Attachments
Att = myAttachments.item(1).DisplayName
myAttachments.item(1).SaveAsFile attPath & Att

2. Is it possible to entirely rename all attachments coming in regardless of their current name? (names of attachments will change daily)

[westconn1]

2. Is it possible to entirely rename all attachments coming in regardless of their current name? (names of attachments will change daily)

yes just change the name for the destination file

for each att in oitem.attachments
   att.saveasfile "path\filename.ext" 
next

of course you need to have some dynamic destination filename, else you would only end up keeping the last attachment, as each would overwrite the previous, it may be simpler to save each attachment with it's displayname, then rename as required after saving

[kinglouie212]

Sorry i dont understand. Can you give me an example

[westconn1]

Sorry i dont understand.

what is it that you do not understand?
i would have though the example i posted, based on the amount of information you provided, would have been enough to get you started