VBA for Email with multiple Attachment

zlr1910

New Member
Joined
Nov 2, 2020
Messages
6
Office Version
  1. 2010
Platform
  1. Windows
I have Macro as below but this only allow a single attachment.
What can i add to insert multiple attachment

Sub sendEmailDestination()


Dim olApp As Object
Dim olMsg As Object
Dim i As Integer


Set olApp = CreateObject("Outlook.Application")
Set olMsg = olApp.CreateItem(0)


On Error GoTo errHandler


Dim vGetAttachment As String
'Change the default directory to that held in cell A1
ChDir Worksheets("Destination").Range("N1").Text
'Select the file to attach
vGetAttachment = Application.GetOpenFilename(Title:="Please select a file to attach")
'exit sub if no file selected
'If vGetAttachment = False Then Exit Sub
If vGetAttachment = False Then Exit Sub


Dim rng As Range
Set rng = Worksheets("Destination").Range("A1:K58")


'Create the email
With olMsg
.to = Worksheets("Destination").Range("N3").Text
.Subject = Worksheets("Destination").Range("N2").Text
.HTMLBody = RangetoHTML(rng)
.attachments.Add vGetAttachment
.Display
'.Send
End With

'Tidy up
Set olApp = Nothing
Set olMsg = Nothing


Exit Sub


errHandler:


If Err.Number = 76 Then
MsgBox "Cell A1 does not contain a valid path", vbCritical, "Error"
End If


End Sub




Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2010
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 Facts

Remove leading & trailing spaces
Save as CSV to remove all leading and trailing spaces. It is faster than using TRIM().
sorry this is the correct code that i am using currently

Sub sendEmailCFS()


Dim olApp As Object
Dim olMsg As Object


Set olApp = CreateObject("Outlook.Application")
Set olMsg = olApp.CreateItem(0)


On Error GoTo errHandler


Dim vGetAttachment As Variant
'Change the default directory to that held in cell A1
ChDir Worksheets("CFS").Range("N1").Text
'Select the file to attach
vGetAttachment = Application.GetOpenFilename(Title:="Please select a file to attach")
'exit sub if no file selected
If vGetAttachment = False Then Exit Sub


Dim rng As Range
Set rng = Worksheets("CFS").Range("A1:K58")


'Create the email
With olMsg
.To = Worksheets("CFS").Range("N3").Text
.Subject = Worksheets("CFS").Range("N2").Text
.HTMLBody = RangetoHTML(rng)
.attachments.Add vGetAttachment
.Display
.Send
End With

'Tidy up
Set olApp = Nothing
Set olMsg = Nothing


Exit Sub


errHandler:


If Err.Number = 76 Then
MsgBox "Cell A1 does not contain a valid path", vbCritical, "Error"
End If


End Sub




Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2010
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
 
Upvote 0
Please use VBA code tags.

Replace the GetOpenFileName line with:
VBA Code:
    vGetAttachment = Application.GetOpenFilename(Title:="Please select file(s) to attach", MultiSelect:=True)
Replace If vGetAttachment = False Then Exit Sub with:
VBA Code:
    If Not IsArray(vGetAttachment) Then Exit Sub
Replace .attachments.Add vGetAttachment with:
VBA Code:
        Dim file As Variant
        For Each file In vGetAttachment
            .Attachments.Add file
        Next
 
Upvote 0
Please use VBA code tags.

Replace the GetOpenFileName line with:
VBA Code:
    vGetAttachment = Application.GetOpenFilename(Title:="Please select file(s) to attach", MultiSelect:=True)
Replace If vGetAttachment = False Then Exit Sub with:
VBA Code:
    If Not IsArray(vGetAttachment) Then Exit Sub
Replace .attachments.Add vGetAttachment with:
VBA Code:
        Dim file As Variant
        For Each file In vGetAttachment
            .Attachments.Add file
        Next
Thanks... ths solve the issue.. really appreciate...
 
Upvote 0

Forum statistics

Threads
1,213,536
Messages
6,114,215
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top