How to save all attachments from multiple emails to folder

in Outlook?

VBA code

Option Explicit

'Retrieves a handle to the top-level window whose class name and window name match
the specified strings.
'This function does not search child windows. This function does not perform a case-
sensitive search.
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" _

(ByVal lpClassName As String, ByVal lpWindowName As String) As Long

'Retrieves a handle to a window whose class name and window name match the specified
strings.
'The function searches child windows, beginning with the one following the specified
child window.
'This function does not perform a case-sensitive search.
Public Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
(ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long

'Brings the thread that created the specified window into the foreground and activates
the window.
'Keyboard input is directed to the window, and various visual cues are changed for the
user.
'The system assigns a slightly higher priority to the thread that created the foreground
'window than it does to other threads.
Public Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As
Long

'Sends the specified message to a window or windows. The SendMessage function calls
the window procedure
'for the specified window and does not lParenturn until the window procedure has
processed the message.

Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" _

(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As
Long

'Places (posts) a message in the message queue associated with the thread that created
the specified
'window and lParenturns without waiting for the thread to process the message.
Public Declare Function PostMessage Lib "user32.dll" Alias "PostMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As
Long) As Long

'Constants used in API functions.

Public Const WM_SETTEXT = &HC
Public Const VK_RETURN = &HD
Public Const WM_KEYDOWN = &H100

Private Sub OpenPDF(strPDFPath As String, strPageNumber As String, strZoomValue As

String)

'Opens a PDF file to a specific page and with a specific zoom

'using Adobe Reader Or Adobe Professional.
'API functions are used to specify the necessary windows
'and send the page and zoom info to the Adobe window.

'By Christos Samaras

'https://myengineeringworld.net/////

Dim strPDFName As String

Dim lParent As Long
Dim lFirstChildWindow As Long
Dim lSecondChildFirstWindow As Long
Dim lSecondChildSecondWindow As Long
Dim dtStartTime As Date

'Check if the PDF path is correct.

If FileExists(strPDFPath) = False Then
MsgBox "The PDF path is incorect!", vbCritical, "Wrong path"
Exit Sub
End If

'Get the PDF file name from the full path.

On Error Resume Next
strPDFName = Mid(strPDFPath, InStrRev(strPDFPath, "") + 1, Len(strPDFPath))
On Error GoTo 0

'The following line depends on the apllication you are using.

'For Word:
'ThisDocument.FollowHyperlink strPDFPath, NewWindow:=True
'For Power Point:
'ActivePresentation.FollowHyperlink strPDFPath, NewWindow:=True
'Note that both Word & Power Point pop up a security window asking
'for access to the specified PDf file.
'For Access:
'Application.FollowHyperlink strPDFPath, NewWindow:=True
'For Excel:
ThisWorkbook.FollowHyperlink strPDFPath, NewWindow:=True
'Find the handle of the main/parent window.
dtStartTime = Now()
Do Until Now() > dtStartTime + TimeValue("00:00:05")
lParent = 0
DoEvents
'For Adobe Reader.
'lParent = FindWindow("AcrobatSDIWindow", strPDFName & " - Adobe Reader")
'For Adobe Professional.
lParent = FindWindow("AcrobatSDIWindow", strPDFName & " - Adobe Acrobat Pro")
If lParent <> 0 Then Exit Do
Loop

If lParent <> 0 Then

'Bring parent window to the foreground (above other windows).

SetForegroundWindow (lParent)

'Find the handle of the first child window.

dtStartTime = Now()
Do Until Now() > dtStartTime + TimeValue("00:00:05")
lFirstChildWindow = 0
DoEvents
lFirstChildWindow = FindWindowEx(lParent, ByVal 0&, vbNullString,
"AVUICommandWidget")
If lFirstChildWindow <> 0 Then Exit Do
Loop

'Find the handles of the two subsequent windows.

If lFirstChildWindow <> 0 Then
dtStartTime = Now()
Do Until Now() > dtStartTime + TimeValue("00:00:05")
lSecondChildFirstWindow = 0
DoEvents
lSecondChildFirstWindow = FindWindowEx(lFirstChildWindow, ByVal 0&,
"Edit", vbNullString)
If lSecondChildFirstWindow <> 0 Then Exit Do
Loop

If lSecondChildFirstWindow <> 0 Then

'Send the zoom value to the corresponding window.

SendMessage lSecondChildFirstWindow, WM_SETTEXT, 0&, ByVal
strZoomValue
PostMessage lSecondChildFirstWindow, WM_KEYDOWN, VK_RETURN, 0

dtStartTime = Now()
Do Until Now() > dtStartTime + TimeValue("00:00:05")
lSecondChildSecondWindow = 0
DoEvents
'Notice the difference in syntax between lSecondChildSecondWindow and
lSecondChildFirstWindow.
'lSecondChildSecondWindow is the handle of the next child window after
lSecondChildFirstWindow,
'while both windows have as parent window the lFirstChildWindow.
lSecondChildSecondWindow = FindWindowEx(lFirstChildWindow,
lSecondChildFirstWindow, "Edit", vbNullString)
If lSecondChildSecondWindow <> 0 Then Exit Do
Loop
If lSecondChildSecondWindow <> 0 Then

'Send the page number to the corresponding window.

SendMessage lSecondChildSecondWindow, WM_SETTEXT, 0&, ByVal
strPageNumber
PostMessage lSecondChildSecondWindow, WM_KEYDOWN, VK_RETURN, 0
 End If

End If

End If

End If

End Sub

Function FileExists(strFilePath As String) As Boolean

'Checks if a file exists.

'By Christos Samaras

'https://myengineeringworld.net/////

On Error Resume Next

If Not Dir(strFilePath, vbDirectory) = vbNullString Then FileExists = True
On Error GoTo 0

End Function

Sub TestPDF()

OpenPDF ThisWorkbook.Path & "" & "Sample File.pdf", 6, 143

End Sub

Code results

The short video below demonstrates how the above VBA code can be used
with Access, Word, Power Point and Excel 2010.

Sample files

The rar file contains the following files:

1. A folder with two VBA modules with the above code for Adobe Reader and Adobe
Professional. You can import them to any office application you want.
2. A folder which contains an Access database, a Word document, a Power Point
presentation and an Excel workbook, as well as a PDF sample that are used to
demonstrate the usage of the same VBA code in different applications (see the
video above).
3. Similar to 2, but the files are for office 2003.

Download it from here

These files can be opened with Office 2007 – 2010, as well as with Office 2003.
Please, remember to enable macros before using them.

As usual, when you receive messages with multiple attachments and you want to save these
attachments to a specific folder, you need to save them one by one with some annoying
operations. Do you want to get rid of that time-consuming operations and directly save the
multiple attachments at once? Please look at the following tutorials.

Save all attachments from multiple emails to folder with VBA code

Several clicks to save all attachments from multiple emails to folder with Kutools for
Outlook

Easily save all attachments from multiple selected emails to folder:

With the Detach All attachments utility of Kutools for Excel, you can easily save all
attachments from multiple selected emails to specified folder in Outlook as below
screenshot showed.
Kutools for Outlook: with more than 40 handy Outlook add-ins, free to try
with no limitation in 45 days. Download and free trial Now!

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.

Save all attachments from multiple emails to folder with VBA code

1. Firstly, you should create a folder for saving the attachments in your computer. The
saving path just like the following screenshot shows, Lj is the user name of the computer,
and the Attachments is the folder which you should finally create.

2. After creating the folder, press Alt + F11 to open the Microsoft Visual Basic for
Applications window.

3. Then click Insert > Module to open the Module window, and then copy and paste the
following VBA code to the window.
 VBA code for saving attachments

1
2
3 Public Sub SaveAttachments()
4 'Update 20141121
5 Dim objOL As Outlook.Application
6 Dim objMsg As Outlook.MailItem
Dim objAttachments As Outlook.Attachments
7 Dim objSelection As Outlook.Selection
8 Dim i As Long
9 Dim lngCount As Long
10 Dim strFile As String
11 Dim strFolderpath As String
Dim strDeletedFiles As String
12 strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
13 Set objOL = CreateObject("Outlook.Application")
14 Set objSelection = objOL.ActiveExplorer.Selection
15 strFolderpath = strFolderpath & "\Attachments\"
For Each objMsg In objSelection
16
Set objAttachments = objMsg.Attachments
17 lngCount = objAttachments.Count
18 strDeletedFiles = ""
19 If lngCount > 0 Then
20 For i = lngCount To 1 Step -1
strFile = objAttachments.Item(i).FileName
21 strFile = strFolderpath & strFile
22 objAttachments.Item(i).SaveAsFile strFile
23'objAttachments.Item(i).Delete()
24 If objMsg.BodyFormat <> olFormatHTML Then
25 strDeletedFiles = strDeletedFiles & vbCrLf & "<Error!
Hyperlink reference not valid.>"
26 Else
27 strDeletedFiles = strDeletedFiles & "<br>" & "<a
28href='file://" & _
29 strFile & "'>" & strFile & "</a>"
End If
30 Next i
31 If objMsg.BodyFormat <> olFormatHTML Then
32 objMsg.Body = vbCrLf & "The file(s) were saved to " &
33 strDeletedFiles & vbCrLf & objMsg.Body
34 Else
objMsg.HTMLBody = "<p>" & "The file(s) were saved to
35" & strDeletedFiles & "</p>" & objMsg.HTMLBody
36 End If
37 objMsg.Save
38 End If
Next
39 ExitSub:
40 Set objAttachments = Nothing
41 Set objMsg = Nothing
42 Set objSelection = Nothing
43 Set objOL = Nothing
End Sub
44
45
46

Note: This VBA code will permanently remove the attachment from the email.
 4. Go to Outlook Mail section to select the emails with attachments which you want to
save the attachments.

5. Return to the Microsoft Visual Basic for Applications window, and click button to
run the code.

6. When a prompt box showing up, click Allow to save the attachment. Note: The prompt
box’s showing frequencies depend on how many emails you have selected. If you have
selected two emails with attachments, the prompt box will show up twice and you need to
click Allow twice to finish all savings.

7. After finish all savings, you will see the result as shown in the below screenshots. You
can go to find the saved attachments according to the saving path or open the attachment
directly by just click on the saving path.

Save all attachments from multiple emails to folder with Kutools for Outlook (just
several clicks)

This section will introduce the Detach All utility of Kutools for Outook. With this utility,
you can quickly save attachments from multiple emails at once in Outlook.

Kutools for Outlook : with more than 20 handy Outlook add-ins, free to try with no
limitation in 45 days.

1. Get into the email folder and select the multiple emails with attachments in mail list by
holding the Ctrl key.
2. Then click Kutools > Detach All. See screenshot:

3. Then a Please select a folder dialog box pops up, please click the Browse button to
select a folder to save the detached attachments, check the Create subfolders in he
following style box, and then specify a folder style from the drop-down list. Finally click
the OK button. See screenshot:

4. In the opening Detach All dialog box, please click the Yes button.

5. Then a Kutools for Outlook dialog box displays to tell you how many attachments are
detached successfully, please click the OK button:
 If you want to have a free trial of this utility, please go to free download the software first,
and then go to apply the operation according above steps.

Demo: Save all attachments from multiple emails to folder with Kutools for Outlook

Kutools for Outlook includes 20+ powerful features and tools for Microsoft Outlook. Free
to try with no limitation in 45 days. Download the free trial now!

Related articles:

 How to remove all attachments from email in Outlook?

 How to keep attachments when replying in Outlook?
 How to rename attachments in Outlook window without saving to disc?