Weird Issue with Send Mail VBA

[deanz]

I have been using Ron De Bruin's code for sending email for a number of years with absolute success. In the past 6 months, something strange happened. When i click the button and my macro runs, it creates the email just fine.. everything looks as normal until i hover my mouse icon over the send button. (i use .display because i have validation that needs to be done).

Click Here for Screenshot

These random text boxes pull up over the send button area and won't allow me to click send. I have included a screenshot. There is no error message. The only thing i can do is save the email to my drafts folder and then either send it from there or double click it from drafts and then its normal again. My partner at work is having the same issue (Windows 10, Office 365 Outlook 2016)

I don't understand why it started doing this and i can't find any documentation (probably because i can't find the right search terms to search for) in the past couple of months over google search or on any of the major forums.

Can anyone help?

Email Code (Supplied by Ron De Bruin)

Sub Mail_Selection_Range_Outlook_Body_DTW()' You need to use this module with the RangetoHTML subroutine.
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
  
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim SigString As String
    Dim Signature As String
    
    EmailTo = Worksheets("DTW").Range("B1")
    EmailCC = Worksheets("DTW").Range("B2")
    SubjectLine = Worksheets("DTW").Range("B3")
    Attach = Worksheets("DTW").Range("M1")
    
    
  
    
    Set rng = Nothing
    
    
    On Error Resume Next
    ' You can also use a range with the following statement.
      Set rng = Sheets("DTW").Range("B6:O15").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0


    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected. " & _
               vbNewLine & "Please correct and try again.", vbOKOnly
        Exit Sub
    End If


    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With


    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    SigString = Environ("appdata") & _
                "\Microsoft\Signatures\Reply.htm"


    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If


    
    On Error Resume Next
    With OutMail
        .SentOnBehalfOfName = <operationsreports@somewhere.com>"""SC Reports"" <operationsreports@somewhere.com>"
        .To = EmailTo
        .CC = EmailCC
        .BCC = ""
        .Subject = SubjectLine
        .htmlBody = RangetoHTML(rng) & Signature
        .Attachments.Add (Attach)
        
        
        ' In place of the following statement, you can use ".Display" to
        ' display the e-mail message.
        .Display
    End With
    On Error GoTo 0


    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With


    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

Functions:

Function RangetoHTML(rng As Range)' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2013
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    Dim r 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
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
        For r = 1 To rng.Rows.Count
            .Rows(r).RowHeight = rng.Rows(r).RowHeight
        Next r
    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
Function GetBoiler(ByVal sFile As String) As String
'**** Kusleika
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function

</operationsreports@somewhere.com>

 

[paulxmw]

hi im not sure how much this will help but you could put a delay in the sending of the emails which would give you time to validate the content without the need to send them individually

Add Dim Delay As String
HH:MM
Then add Delay = Now + TimeValue("00:05")

'just before
On Error Resume Next
With OutMail

 

[deanz]

hi im not sure how much this will help but you could put a delay in the sending of the emails which would give you time to validate the content without the need to send them individually

Add Dim Delay As String
HH:MM
Then add Delay = Now + TimeValue("00:05")

'just before
On Error Resume Next
With OutMail

Thanks Paul... that may be indeed a solution. I will test that. Thanks for the suggestion. I would still like to know how to fix the .display though as well... as its worked so well for so long now.

Dean