Saving Attachments to folder on disk and adding Initials to end of file name

Not open for further replies.

Oscar Mike

New Member
Outlook version
Email Account
Hi everyone,

I hear this is the place to come to solve your Outlook woes so I hope someone can help me with mine.

I'm using Outlook 2007 so a macro is my preferred option here.

Basically, I would like a macro that when clicked will take a copy of the attachment from the email, save it to a specified folder on the drive and have an InputBox that prompts users for their initials and adds that to the end of the filename.

I've seen a few code examples that take the attachment and put it into a folder, and others that add date prefixes to the filename. So it certainly gives me hope that this is achievable.

Thanks in advance for your help.
You'll start with this one -

Change this line:
DateFormat = Format(oldName.DateLastModified, "yyyy-mm-dd ")

DateFormat = InputBox("Your initials")

that will save with a file name like

if you want documentnamedp.docx, you need to do a bit more tweaking:
Dim fileExt As String, fName As String
fileExt = Right(oldName, Len(oldName) - InStrRev(oldName, ".") + 1)
fName = Left(objAtt.DisplayName, Len(objAtt.DisplayName) - Len(fileExt))

DateFormat = InputBox("Your initials")
newName = fName & DateFormat & fileExt

To avoid confusion, do a search and replace on DateFormat - change it to it initials or something that makes more sense.

if you want a space before the initials, use
DateFormat = "_" & InputBox("Your initials")
Diane, this is perfect thank you!

One small question, is there anyway of creating a MsgBox that on successful saving will display "Saved to [Directory Name]?

Kind Regards,
Try using
msgbox "saved as: " & saveFolder & newname
That is working, but now I get a message after every save attachement. I would like a message that counts all the saved attachements when it is done saving them all. Also I like to have a msg box when no mail with a attachement has been selected.
yet another question in state of initials, I would like the attachemnt to be saved with the origal name and when there is another attachement with the same name that there will be add a number? just lik windows does filename(1).pdf filename(2).pdf and so on.
Counting is not a problem - put the msgbox after the loop so it only fires once. If you want to list all of the file name, you'll need to add them to a string then display the string in the message box.

this is one way:
i = 1
For Each objAtt In itm.Attachments
file = saveFolder & objAtt.DisplayName
objAtt.SaveAsFile file
'Get the file name
Set oldName = fso.GetFile(file)
DateFormat = Format(oldName.DateLastModified, "yyyy-mm-dd ")
newName = DateFormat & objAtt.DisplayName
oldName.Name = newName
Set objAtt = Nothing

i = i +1

msgbox "saved as: " & saveFolder & " Attachments saved: " &  i

Adding a number to make an attachment name unique is easy - checking for matching filenames and only incrementing those is more difficult, because you need to check the current names. I don't have any code samples that do that.
This macro will add a number to the file name if it exists.

Public Sub saveAttachtoDisk()
Dim itm As Outlook.MailItem
Dim currentExplorer As Explorer
Dim Selection As Selection
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim fso As Object
Dim oldName
Dim file As String
Dim DateFormat As String
Dim newName As String
Dim enviro As String
enviro = CStr(Environ("USERPROFILE"))
saveFolder = enviro & "\Documents\"
Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection
Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
For Each itm In Selection
 For Each objAtt In itm.Attachments
 file = saveFolder & objAtt.DisplayName
 objAtt.SaveAsFile file
'Get the file name
 Set oldName = fso.GetFile(file)
  x = 1
  Saved = False

 DateFormat = Format(oldName.DateLastModified, "yyyy-mm-dd ")
 newName = DateFormat & objAtt.DisplayName
 'Test to see if file name already exists
If FileExist(saveFolder & newName) = False Then
 oldName.Name = newName
GoTo NextAttach
End If
'Need a new filename
  Do While Saved = False
  Count = InStrRev(newName, ".")
  FnName = Left(newName, Count - 1)
  fileext = Right(newName, Len(newName) - Count + 1)
  If FileExist(saveFolder & FnName & x & fileext) = False Then
  oldName.Name = FnName & x & fileext
  Saved = True
  x = x + 1
  End If

 Set objAtt = Nothing
 Set fso = Nothing
 End Sub

Function FileExist(FilePath As String) As Boolean

Dim TestStr As String
  On Error Resume Next
  TestStr = Dir(FilePath)
  On Error GoTo 0
'Determine if File exists
  If TestStr = "" Then
  FileExist = False
  FileExist = True
  End If

End Function
Super works great. Thanks your a life saver.

October project1.xlsm
October project2.xlsm

Now all I need is. Tht should be simple. But I can't figure it out.

October project-1.xlsm
October project-2.xlsm
you just need to change the two instances of FnName & x & fileext to FnName & " - " & x & fileext
Not open for further replies.
Similar threads
Thread starter Title Forum Replies Date
J Saving attachments from specific sender (phone number) to specific folder on hard drive Using Outlook 3
S Not saving attachments in the Sent Folder Using Outlook 2
R Saving Emails and Attachments as .msg file Using Outlook 3
I Saving attachments from multiple emails and updating file name Outlook VBA and Custom Forms 0
D Saving Selected Emails as PDF and saving Attachments Outlook VBA and Custom Forms 6
R Quick Access view in File Explorer when saving attachments Using Outlook 0
N Saving And Deleting Outlook Attachments with Unknown Error Message Outlook VBA and Custom Forms 1
C Saving Outlook attachments and links to attachments with VBA Outlook VBA and Custom Forms 2
T Saving Outlook 2010 email with attachments but read the email without Outlook Using Outlook 2
D Remove extension while saving attachments Using Outlook 1
D Saving outlook emails in html and attachments Using Outlook 4
T Outlook 2007 alters date when saving attachments, windows 7. Using Outlook 5
S Automate saving of attachments on new incoming emails Outlook VBA and Custom Forms 3
J Saving Attachments Outlook VBA and Custom Forms 1
Rupert Dragwater Background colors not saving in Outlook 365 Using Outlook 15
CWM550 Saving Data: Don't check certain folders Using Outlook 2
M Saving emails using Visual Basic - Selecting folder with msoFileDialogFolderPicker Outlook VBA and Custom Forms 6
D Outlook 2016 Outlook not saving Sent Items Using Outlook 4
I Error saving screenshots in a custom form in outlook 2016, outlook 365 - ok in outlook 2013, outlook 2010 Outlook VBA and Custom Forms 5
M Adding Subject to this Link-Saving VBA Outlook VBA and Custom Forms 5
L Attachment saving and tracking - PLEASE help! Outlook VBA and Custom Forms 5
B Saving items under a folder Using Outlook 3
V Saving attachment from outlook in My Documents Outlook VBA and Custom Forms 14
M Dialog called up multiple times when saving emails from macro Outlook VBA and Custom Forms 2
A saving attachement to folder named the same as rule name Outlook VBA and Custom Forms 0
T Saving all email to file folder in Windows Using Outlook 2
Kevin H Remotely saving emails Using Outlook 1
R Outlook 2010 Modify Style "Do not check spelling or grammar" not saving Outlook VBA and Custom Forms 0
R Outlook Office 365 not saving addresses Using Outlook 0
A Keep color categories when saving vCards Using Outlook 1
P Saving All Messages to the Hard Drive Using VBA Outlook VBA and Custom Forms 5
e_a_g_l_e_p_i question about saving my .pst so I can import it to my Outlook after I build a new system Using Outlook 10
S Editing an email with notes and saving it for record using Macro Outlook VBA and Custom Forms 3
J Outlook 2013 crashes saving VBA & clicking tools | digital signature Outlook VBA and Custom Forms 1
bifjamod Saving sent email to specific folder based on category with wildcard Outlook VBA and Custom Forms 1
N Saving .msg as sent item on send Outlook VBA and Custom Forms 1
erichamion Changes to meeting body not properly saving Outlook VBA and Custom Forms 4
A ItemAdd on Imap Folder get endless loop after saving item Using Outlook 5
T From Field Blank when saving to folder other than Sent items Using Outlook 2
L Outlook DST (Daylight Saving Time) problem Using Outlook 0
F Using Outlook 2007 as an IMAP Mail Station Without Saving Data Locally Using Outlook 2
E Saving Changes To Edited E-Mail Received Message Using Outlook 0
D File Lock issue when saving message from Outlook to new folder Using Outlook 1
K Printing & Saving Outlook Contacts Using Outlook 3
S trouble with Outlook 2010 saving sent emails Using Outlook 2
W Default Saving a message as text Using Outlook 2
R Outlook 2007 QAT buttons not saving Using Outlook 2
C Exchange 2003 - Outlook 2003 - Calendar entries saving over each other Using Outlook 2
J Saving Published Outlook Form as msg Using Outlook 1
J Saving recent colors used for fonts in an email? Using Outlook 1

Similar threads