The first code allows to send multiple emails from excel
The second code allows to send multiple emails from excel, but include range of cells picked via autofilter in outook as HTML format, based on two dimensions arrays
The First Code
Sub SendMultipleEmails1()
Dim Mail_Object, OutApp As Variant
With ActiveSheet
lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row ' counts how many rows sheet has
End With
For i = 2 To lastRow 'takes data from 2nd row to last row
Set Mail_Object = CreateObject("Outlook.Application")
Set OutApp = Mail_Object.CreateItem(0)
With OutApp
.Subject = Cells(i, 1).Value 'subject will be taken from 1st column and 2nd row in the first loop
.Body = "Good morning!" & vbNewLine & "Your Pine code is: " & Cells(i, 12).Value & vbNewLine & "Best Regards" 'Pin code will taken from 12th column and 2nd row in the first loop
.To = Cells(i, 11).Value ' receiver will be taken from 11th column 2nf row, email address should be placed in excel fe. name.surname@gmail.com
.Attachments.Add Cells(i, 13).Value 'you can add attachment - path in excel should be like this: C:\Users\name.surname\Documents\My_File.docx
.Display ' or .Send
End With
Next i
debugs:
If Err.Description <> "" Then MsgBox Err.Description
End Sub
The Second Code
needed references:
Sub excel_html_outlook()
Number = ActiveSheet.UsedRange.Rows.Count
ActiveSheet.UsedRange.Sort Key1:=Range("A1:A" & Number), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
Dim a() As Variant
Dim b() As Variant
Row1 = 1
ReDim Preserve a(Row1)
ReDim Preserve b(Row1)
Row1 = 0
Row = 2
For Row = 2 To Number
If Cells(Row - 1, 1) <> Cells(Row, 1) Then
a(Row1) = Cells(Row, 1)
b(Row1) = Cells(Row, 5)
Row1 = Row1 + 1
ReDim Preserve a(Row1)
ReDim Preserve b(Row1)
Else
End If
Next Row
For i = 0 To UBound(a) - 1
ActiveSheet.UsedRange.AutoFilter Field:=1, Criteria1:=a(i)
ActiveSheet.UsedRange.Select
ws = ActiveWorkbook.ActiveSheet.Name
aFile = "C:\Programy\MyHtmlFile.htm"
If Len(Dir$(aFile)) > 0 Then
Kill aFile
End If
With ActiveWorkbook.PublishObjects.Add(xlSourceAutoFilter, "C:\Programy\MyHtmlFile.htm", ws, "", xlHtmlStatic, "", "")
.Publish (True)
.AutoRepublish = False
End With
strFile = "C:\Programy\MyHtmlFile.htm"
Dim tsTextIn As Scripting.TextStream
Dim strTextIn As String
Set fso = New Scripting.FileSystemObject
'read html
Set tsTextIn = fso.OpenTextFile(strFile)
strTextIn = tsTextIn.ReadAll
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = b(i)
.CC = ""
.BCC = ""
.Subject = "Subject "
'.Attachments.Add "C:\Programy\MyHtmlFile.htm", olByValue, 0
.BodyFormat = olFormatHTML
.BodyFormat = olFormatHTML
' Important = remove question tags "?" from .HTMLBody
.HTMLBody = "<b?r>Good Morning!<b?r>" _
& "<b?r>Dear Sirs!<b?r>" _
& strTextIn & "<b?r><?B>Best Regards, <b?r>Ilearn.com.pl"
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Set tsTextIn = Nothing
Next i
Erase a
Erase b
aFile = "C:\Programy\MyHtmlFile.htm"
If Len(Dir$(aFile)) > 0 Then
Kill aFile
End If
'ActiveSheet.ShowAllData
ActiveSheet.Cells.AutoFilter
End Sub
You can change html file into JPEG file
