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
 

Some videos you may like

Excel Facts

Create a chart in one keystroke
Select the data and press Alt+F1 to insert a default chart. You can change the default chart to any chart type

zlr1910

New Member
Joined
Nov 2, 2020
Messages
6
Office Version
  1. 2010
Platform
  1. Windows
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
 

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
6,524
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
 

zlr1910

New Member
Joined
Nov 2, 2020
Messages
6
Office Version
  1. 2010
Platform
  1. Windows
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...
 

Watch MrExcel Video

Forum statistics

Threads
1,118,134
Messages
5,570,364
Members
412,320
Latest member
sixnine0312
Top