Bulk Email Sender runs slowly [closed]

This code sends emails in bulk based on unique email addresses. I have unique email addresses from each of the primary key stored in column B.

The code sends notification to those who have payments pending as a reminder.

I wish to understand why this is running so slowly. I added a timer and it is taking about 22 seconds per email. Earlier it used to take only 1-2 seconds.

Sub Customer_Email()
    Dim StartTime As Double
    Dim MinutesElapsed As String

    Dim cell As Range
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    StartTime = Timer

    Sheet3.Activate
    Range("AI2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    Range("P8").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Range("AI1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Range("AI1").Select
    Range(Selection, Selection.End(xlDown)).RemoveDuplicates Columns:=1, Header:= _
        xlNo
    Range("AL1").Select

    Range(Range("Extract"), Range("Extract").End(xlDown)).ClearContents

    For Each cell In Range("Table4[]")
        [valEmail] = cell.Value
        Range("myList").AdvancedFilter Action:=xlFilterCopy, _
            CriteriaRange:=Range("Criteria"), CopyToRange:=Range("Extract"), Unique:=False
        Range("R8").CurrentRegion.BorderAround xlContinuous
        Range("R8").CurrentRegion.Borders.LineStyle = xlContinuous
        Range("R8").CurrentRegion.Borders.Weight = xlThin
        Range("R8").CurrentRegion.Borders.ColorIndex = xlAutomatic

        alignment
        Send_Email_To_Customer
        Range(Range("Extract"), Range("Extract").End(xlDown)).ClearContents

    Next cell

    Sheet4.Delete

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

    'Determine how many minutes code took to run
      MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")

    'Notify user in seconds
    MsgBox "This code ran successfully in "& MinutesElapsed & " minutes", vbInformation

    MsgBox "Emails sent"

End Sub


Sub Send_Email_To_Customer()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String
    Dim EmailBody1 As Range
    Dim LastRow2 As Range
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set rng = Nothing
    Set rng = ActiveSheet

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

    On Error Resume Next
    Range("R8").Activate
    Dim r As Range
    Set r = Range(Range("Extract"), Range("Extract").End(xlDown))
    Set range1 = Cells(LastRow, "K").Value

    Dim t As Date

    Set Today = Today

    With OutMail
        .Display
        .To = Sheet3.Range("valEmail").Value
        .CC = ""'Sheet3.Range("valEmailCC").Value
        .BCC = ""
        .ReadReceiptRequested = False
        .Importance = 2
        .Subject = Worksheets("Working").Range("F6")

        '.Attachments.Add ("C:\Users\rarajput\Desktop\Raj\POWR - How To Use-IN-v8.pdf")
        '"& Format(Date, "dd/mm/yyyy") &
        .HTMLBody
        .HTMLBody
        .HTMLBody = "</head><font face='Calibri' size='3' color='#000000'>Dear Sir/Madam,"& "<Br><Br>"& _
                    "Please find below the details of Pending PI's for your Orders."& _
                    "<font face='Calibri' size='3' color='#000000'> You are requested to check the PI before confirmation and payment.</font>"& "<Br><Br>"& _
                    "<font face='Calibri' size='3' color='#000000'> If there are any discrepancies in the PI, please revert to us. Kindly arrange the payment for the PI & send us the payment details. </font></p>"& "<Br>"& _
                    "<font face='Calibri' size='3' color='#000000'> Based on finance confirmation on the receipt of payments, we will proceed with the invoice.</font></p>"& "<Br>"& _
                    "<font face='Calibri' size='3' color='#000000'> Note- If the PI is not confirmed and payment is not received within 5 working days , then PI will be deleted and order will stand cancel and you will have to place new order. </font></p>"& "<Br>"& _
                    "<font face='Calibri' size='3' color='#000000'> Please contact me for any concerns/queries."& LastRow1 & RangetoHTML(r) & _
                    .HTMLBody
        .Display
    End With

    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing

End Sub


Function RangetoHTML(rng As Range)

    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim tempWB As Workbook
    Dim LastRow As Long
    Dim LastRow1 As Long
    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

        LastRow = Range("A1").End(xlDown).Row
        Cells(LastRow + 1, "I").Formula = "=SUM(I1:I"& LastRow & ")"
        Cells(LastRow + 1, "J").Formula = "=SUM(J1:J"& LastRow & ")"
        Cells(LastRow + 1, "K").Formula = "=SUM(K1:K"& LastRow & ")"

        LastRow1 = Range("I"& Rows.Count).End(xlUp).Row
        Range("I"& LastRow1, "K"& LastRow1).Borders(xlEdgeTop).Weight = xlThick
        Range("I"& LastRow1, "K"& LastRow1).Borders(xlEdgeBottom).Weight = xlThick

        Range("I"& LastRow1, "K"& LastRow1).HorizontalAlignment = xlCenter
        Range("I"& LastRow1, "K"& LastRow1).Interior.Color = RGB(255, 255, 0)

        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


Sub allignment()

    Worksheets("Working").Activate
    'Worksheets("Working").Range("A8").Columns.AutoFit

    On Error Resume Next
    For Each sht In ThisWorkbook.Worksheets
        sht.Cells.SpecialCells(xlCellTypeVisible).EntireColumn.AutoFit
    Next sht
    On Error GoTo 0

End Sub