Cookies help us deliver our services. By using our services, you agree to our use of cookies.
Tip: Other languages are Google-Translated. You can visit the English version of this link.
Log in
x
or
x
x
Register
x

or

How to rename and save attachments of the email in a folder in Outlook?

In outlook, you may receive messages with attachments usually, and do you try to rename the attachments of the message and save them in a folder as below screenshot shown? Obviously, you can save them into a folder and rename them one by one, but actually, I have a VBA code can quickly rename all attachments with same name then save in one folder.
doc rename save attach 1

Rename and save attachments with same name in a folder

Rename and save attachments in a folder with Kutools for Outlook


Reply message with original attachments in outlook

As we all known, the attached attachments will be removed from the original message when you replying a message to the recipient in Outlook. If you want to reply massage with keeping attachments, you can try Kutools for Outlook's Reply with Attachment function, it can reply one message with the original attachments, also work for all messafe.    Click for full future 45 days free trial!
 
doc reply with attach
 
Kutools for Outlook: with dozens of handy Outlook add-ins, free to try with no limitation in 45 days.
 
 
 
 
Kutools for Outlook: 100+ New Advanced Tools for Outlook.
Office Tab: Enable Tabbed Editing and Browsing in Office, Just Like Chrome, Firefox, IE 8/9/10.
Classic Menu: Bring Old Menus and Toolbars Back to Office 2007, 2010, 2013, 2016 and 2019.

Rename and save attachments with same name in a folder

1. Select the message which you want to save its attachments and rename to the same name.

2. Press Alt + F11 keys, then in the Project1 pane, double click ThisOutlookSession to create a new blank script in right section, then copy and paste the code to it.

VBA: Rename and save attachments

Public Sub SaveAttachsToDisk()
'UpdatebyExtendoffice20180521
Dim xItem As Object  'Outlook.MailItem
Dim xSelection As Selection
Dim xAttachment As Outlook.Attachment
Dim xFldObj As Object
Dim xSaveFolder As String
Dim xFSO As Scripting.FileSystemObject
Dim xFile As File
Dim xFilePath As String
Dim xNewName, xTmpName As String
Dim xExt As String
Dim xCount As Integer
On Error Resume Next
Set xFldObj = CreateObject("Shell.Application").browseforfolder(0, "Select a Folder", 0, 16)
Set xFSO = New Scripting.FileSystemObject
If xFldObj Is Nothing Then Exit Sub
xSaveFolder = xFldObj.Items.Item.Path & "\"
Set xSelection = Outlook.Application.ActiveExplorer.Selection
xNewName = InputBox("Attachment Name:", "Kutools for Outlook", xNewName)
If Len(Trim(xNewName)) = 0 Then Exit Sub
For Each xItem In xSelection
    For Each xAttachment In xItem.Attachments
        xFilePath = xSaveFolder & xAttachment.FileName
        xAttachment.SaveAsFile xFilePath
        Set xFile = xFSO.GetFile(xFilePath)
        xCount = 1
        Saved = False
        xExt = "." & xFSO.GetExtensionName(xFilePath)
        xTmpName = xNewName
        xNewName = xTmpName & xExt
        If xFSO.FileExists(xSaveFolder & xNewName) = False Then
            xFile.Name = xNewName
            xNewName = xTmpName
        Else
            xTmpName = Left(xNewName, Len(xNewName) - Len(xExt))
            While Saved = False
                xNewName = xTmpName & xCount & xExt
                If xFSO.FileExists(xSaveFolder & xNewName) = False Then
                    xFile.Name = xNewName
                    xNewName = xTmpName
                    Saved = True
                Else
                    xCount = xCount + 1
                End If
            Wend
        End If
    Next
Next
Set xFSO = Nothing
End Sub

doc rename save attachments in a folder 2

3. Click Tools > References, in the popping dialog, check Microsoft Script Runtime checkbox.

doc rename save attachments in a folder 3 doc arrow right doc rename save attachments in a folder 4

4. Click OK, press F5 key to run the code, a Browse For Folder dialog pops out for selecting or creating a folder to place attachments.
doc rename save attachments in a folder 5

5. Click OK, then give a name for the attachments.
doc rename save attachments in a folder 6

6. Click OK, now the attachments are renamed with same name, if there are duplicates, the duplicate ones will be added numbers as the suffix.


Rename and save attachments in a folder with Kutools for Outlook

Actually, there is a feature in Kutools for Outlook -- a handy addin tool of Outlook can rename all attachments before saving or sending.

Kutools for Outlook , Includes 100+ powerful features and tools for Microsoft Outlook 2016, 2013, 2010 and Office 365.

Free install Kutools for Outlook, and then do as below steps:

1. Activate the email in nagative pane or in the Message box as you like, click Kutools > Rename All.
doc rename save attach 2

2. In the popping dialog, type the new name you use for each attachment. Click OK, the attachments have been renamed with new names.
doc rename save attach 3
doc rename save attach 4

3.  Right click at one attachment, select Save All Attachments, click OK and select a folder to save the attachments as you need. Then the renamed attachments have been saved in a folder.
doc rename save attach 5



Kutools for Outlook

More than 100 Advanced Functions for Outlook 2010, 2013, 2016, 2019 and 365

screen shot kutools for outlook tiny for banner 201812

More Features  |  Free Download  |  Only $39.00 for hundreds of functions

Say something here...
symbols left.
You are guest ( Sign Up? )
or post as a guest, but your post won't be published automatically.
Loading comment... The comment will be refreshed after 00:00.
  • To post as a guest, your comment is unpublished.
    Lipe · 2 months ago
    Hey there! Do you know how we can improve the below code to rename the file when saved?

    Public Sub UnzipFileInOutlook(itm As Outlook.MailItem)
    Dim objAtt As Outlook.Attachment
    Dim saveFolder As String
    saveFolder = "C:\Users\acheng\Desktop"
    For Each objAtt In itm.Attachments
    objAtt.SaveAsFile saveFolder
    Set objAtt = Nothing
    Next
    End Sub
    • To post as a guest, your comment is unpublished.
      Sunny · 27 days ago
      Hello, Lipe, may be this code can help you.

      Private Sub CopyToDefaultCalendarFld(ByVal Item As Object)
      Dim xCopiedAppointment As Outlook.AppointmentItem
      Dim xMovedAppointment As Outlook.AppointmentItem
      Dim xMeeting As MeetingItem
      Dim xApoint As AppointmentItem
      On Error Resume Next
      If Item.Class = olAppointment Then
      Set xApoint = Item
      Set xCopiedAppointment = xApoint.Copy
      Set xMovedAppointment = xCopiedAppointment.Move(GMovedCalendarFolder)
      If xApoint.Subject <> xMovedAppointment.Subject Then
      If InStr(1, xMovedAppointment.Subject, "Copy: ") > 0 Then
      xMovedAppointment.Subject = VBA.Replace(xMovedAppointment.Subject, "Copy: ", "", 1, 1)
      xMovedAppointment.Save
      End If
      End If
      ElseIf Item.Class = olMeetingRequest Then
      Set xMeeting = Item
      Set xCopiedAppointment = xMeeting.GetAssociatedAppointment(True).Copy
      Set xMovedAppointment = xCopiedAppointment.Move(GMovedCalendarFolder)
      If xMeeting.Subject <> xMovedAppointment.Subject Then
      If InStr(1, xMovedAppointment.Subject, "Copy: ") > 0 Then
      xMovedAppointment.Subject = VBA.Replace(xMovedAppointment.Subject, "Copy: ", "", 1, 1)
      xMovedAppointment.Save
      End If
      End If
      xCopiedAppointment.Delete
      End If
      Set xCopiedAppointment = Nothing
      End Sub