VBA Save All Outlook Attachments

VBA to save all outlook email attachments.  Change Set myFolder = myNamespace.Folders.Item("Dylan.Gregory@vba-market.com").Folders("Inbox") to your outlook email folder path.
.

 

Dim myAttachments As Outlook.Attachments
Set myOlApp = CreateObject("Outlook.Application")
Set myNamespace = myOlApp.GetNamespace("MAPI")
Set myFolder = myNamespace.Folders.Item("Dylan.Gregory@vba-market.com").Folders("Inbox")
'myFolder.Display

itemsCount = myFolder.Items.Count
i = 0
For i = 1 To itemsCount
Set myItem = myFolder.Items(i)
myItem.Display

Set myAttachments = myItem.Attachments
If myItem.Attachments.Count > 0 Then
ipath = "Z:\Dylan\attachments\"
On Error Resume Next
myAttachments.Item(i).SaveAsFile ipath & myAttachments.Item(i).DisplayName
' MsgBox myAttachments.Item(i).DisplayName & " has been saved to " & ipath
On Error GoTo 0

End If

VBA to add all files in a folder to an email

Add all files in folder to an email

VBA that will add all files in folder to an email.  Loops the folder and attaches each file to the email.

 

Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
With OutMail
 .To = "Dylan.Gregory@vba-market.com"
 .CC = "CC@email.com"
 .Subject = "Subject Line"
 .HTMLBody = "Add all attachements in folder … "
 strPath = "Z:\My Documents\tempFolder\"
 StrFile = Dir(strPath & "*.*")
 Do While Len(StrFile) > 0
 .Attachments.Add strPath & StrFile
 StrFile = Dir
 Loop

.display
End With

Excel VBA insert Excel table into body of email message

 

*Update the rng to be the range of the table

 Set rng = Range(Cells(1, 1), Cells(rws, cols))

*Update your email details

 With OutMail
 .To = ""
 .CC = ""
 .BCC = ""
 .Subject = "This is the Subject line"

 

Range to HTML - Insert Excel table into body of email

Sub Mail_Selection_Range_Outlook_Body()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Don't forget to copy the function RangetoHTML in the module.
'Working in Excel 2000-2016
 Dim rng As Range
 Dim OutApp As Object
 Dim OutMail As Object

Set rng = Nothing
 On Error Resume Next
 'Only the visible cells in the selection
 rws = ActiveSheet.UsedRange.Rows.Count
 cols = ActiveSheet.UsedRange.Columns.Count
 Set rng = Range(Cells(1, 1), Cells(rws, cols))
 rng.Select
 'You can also use a fixed range if you want
 'Set rng = Sheets("YourSheet").Range("D4:D12").SpecialCells(xlCellTypeVisible)
 On Error GoTo 0

If rng Is Nothing Then
 MsgBox "The selection is not a range or the sheet is protected" & _
 vbNewLine & "please correct and try again.", vbOKOnly
 Exit Sub
 End If

With Application
 .EnableEvents = False
 .ScreenUpdating = False
 End With

Set OutApp = CreateObject("Outlook.Application")
 Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
 With OutMail
 .To = ""
 .CC = ""
 .BCC = ""
 .Subject = "This is the Subject line"
 .HTMLBody = RangetoHTML(rng)
 .Display
 End With
 On Error GoTo 0

With Application
 .EnableEvents = True
 .ScreenUpdating = True
 End With

Set OutMail = Nothing
 Set OutApp = Nothing
End Sub



Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
 Dim fso As Object
 Dim ts As Object
 Dim TempFile As String
 Dim TempWB As Workbook

TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

'Copy the range and create a new workbook to past the data in
 rng.Copy
 Set TempWB = Workbooks.Add(1)
 With TempWB.Sheets(1)
 .Cells(1).PasteSpecial Paste:=8
 .Cells(1).PasteSpecial xlPasteValues, , False, False
 .Cells(1).PasteSpecial xlPasteFormats, , False, False
 .Cells(1).Select
 Application.CutCopyMode = False
 On Error Resume Next
 .DrawingObjects.Visible = True
 .DrawingObjects.Delete
 On Error GoTo 0
 End With

'Publish the sheet to a htm file
 With TempWB.PublishObjects.Add( _
 SourceType:=xlSourceRange, _
 Filename:=TempFile, _
 Sheet:=TempWB.Sheets(1).Name, _
 Source:=TempWB.Sheets(1).UsedRange.Address, _
 HtmlType:=xlHtmlStatic)
 .Publish (True)
 End With

'Read all data from the htm file into RangetoHTML
 Set fso = CreateObject("Scripting.FileSystemObject")
 Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
 RangetoHTML = ts.readall
 ts.Close
 RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
 "align=left x:publishsource=")

'Close TempWB
 TempWB.Close savechanges:=False

'Delete the htm file we used in this function
 Kill TempFile

Set ts = Nothing
 Set fso = Nothing
 Set TempWB = Nothing
End Function

Excel VBA get File Attached to Outlook Email

Save Outlook Attachment from 1 email

This VBA will connect to an Outlook folder and save the attachment to a folder.

*Update ipath to filepath where you want to save the attachment to

*Update .Item("BoxName").Folders("Inbox") with your Outlook Folders name.

*Update .Items(1) to be the email number of the email your trying to grab

Dim myAttachments As Outlook.Attachments
 
Set myOlApp = CreateObject("Outlook.Application")
Set myNamespace = myOlApp.GetNamespace("MAPI")
Set myFolder = myNamespace.Folders.Item("BoxName").Folders("Inbox")
'myFolder.Display

Set myItem = myFolder.Items(1)
myItem.Display

Set myAttachments = myItem.Attachments
ipath = "Z:\Dylan\"
myAttachments.Item(1).SaveAsFile ipath & myAttachments.Item(1).DisplayName

MsgBox myAttachments.Item(1).DisplayName & " has been saved to " & ipath

 

Save All Outlook Email Attachments from Folder

If you want to save the attachments of all emails in the folder then just add a for loop replacing items(1) with items(i).

Dim myAttachments As Outlook.Attachments
 
Set myOlApp = CreateObject("Outlook.Application")
Set myNamespace = myOlApp.GetNamespace("MAPI")
Set myFolder = myNamespace.Folders.Item("BoxName").Folders("Inbox")
'myFolder.Display

itemsCount = myFolder.Items.Count
i = 0
For i = 1 To itemsCount

Set myItem = myFolder.Items(i)
myItem.Display

Set myAttachments = myItem.Attachments
If myItem.Attachments.Count > 0 Then
 ipath = "Z:\Dylan\attachments\"
 On Error Resume Next
 myAttachments.Item(i).SaveAsFile ipath & myAttachments.Item(i).DisplayName
 ' MsgBox myAttachments.Item(i).DisplayName & " has been saved to " & ipath
 On Error GoTo 0
End If