Outlook is crashing when macro displays data from Excel in mails

[cosiek]

I am using for a longer time macro, that I managed to create with help of Internet community. It generally pick up data from Excel and populates in Outlook mails. As I have marked option DISPLAY, I want first check if content is good and then accept for sending.


It works fine, but lastly noticed some bug. Once I do send more that 100 records from Excel it creates all new windows with messages in Outlook, but after the while crashes and closes the Outlook.


Can you please check what is wrong in below code, as cannot figure it out?


Thank you for support.

Option Explicit

Sub Mail_Workbook(ToString As String, SubjectString As String, BodyString As String, _
    Optional CCString As String, Optional BCCString As String, Optional AttachmentName As String)
    Dim OutApp As Object
    Dim OutMail As Object
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next
   ' Change the mail address and subject in the macro before you run it.
    With OutMail
    .SentOnBehalfOfName = "abc@def.com"
        .To = ToString
        If CCString <> "" Then
            .CC = CCString
        End If
        If BCCString <> "" Then
            .BCC = BCCString
        End If
        .Subject = SubjectString
        .HTMLBody = BodyString
        If AttachmentName <> "" Then
            .Attachments.Add (AttachmentName)
        End If
        'Choose either Send or Display
        '.Send
        .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

TempFile = ThisWorkbook.Path & "\" & 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

Option Explicit

Sub SendNewMails()

    Dim clE As Range
    Dim shtA As Worksheet

   Set shtA = Sheets("MAKRO")
Dim SubjectString As String
   SubjectString = Range("Mail_Subject")
  
   For Each clE In Range("Table1[mail]")
    Dim ToString As String
    ToString = clE.Value
    Dim BodyString As String
    BodyString = shtA.Cells(clE.Row, "J")
Mail_Workbook ToString, SubjectString, BodyString
Next
End Sub