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

Oscar Mike

New Member
Outlook version
Outlook 2007
Email Account
POP3
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.
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
You'll start with this one - http://www.slipstick.com/developer/code-samples/save-rename-outlook-email-attachments/

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

to
DateFormat = InputBox("Your initials")

that will save with a file name like
dpdocumentname.docx

if you want documentnamedp.docx, you need to do a bit more tweaking:
Code:
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")
 

Oscar Mike

New Member
Outlook version
Outlook 2007
Email Account
POP3
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,
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
Try using
msgbox "saved as: " & saveFolder & newname
 

snhnic

New Member
Outlook version
Outlook 2010 32 bit
Email Account
Exchange Server 2010
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.
 

snhnic

New Member
Outlook version
Outlook 2010 32 bit
Email Account
Exchange Server 2010
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.
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
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:
Code:
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
Next

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.
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
This macro will add a number to the file name if it exists.


Code:
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
  Else
  x = x + 1
  End If
  Loop

NextAttach:
 Set objAtt = Nothing
  
 Next
  
 Next
  
 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
  Else
  FileExist = True
  End If

End Function
 

snhnic

New Member
Outlook version
Outlook 2010 32 bit
Email Account
Exchange Server 2010
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
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
you just need to change the two instances of FnName & x & fileext to FnName & " - " & x & fileext
 

Similar threads

Top