I have the following code to obtain info from a userform and send an email with the details. The issue I have is that from time to time, the email will not send and just sits there waiting while the rest of the code completes, but the email never sends. Does anyone have an idea why this might be, or have any suggestions as to how to make sure it sends everytime?
Code
Sub Mail_Fault_Number()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim eAddr As String
Dim eSubject As String
Dim response As String
Set rng = Nothing
On Error Resume Next
Set rng = Sheets("Sheet1").Range("a1:b3").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "There is no data to be sent." & vbNewLine & "Please correct & 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)
On Error Resume Next
With OutMail
.To = "sxxxxxxxxco.uk"
.CC = ""
.BCC = ""
.Subject = Sheets("Sheet1").Range("a5").Value
.HTMLBody = RangetoHTML(rng)
'.Send
.display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
Application.Wait (Now + TimeValue("0:00:2"))
SendKeys "%{s}", True
response = MsgBox("Your email has now been sent." & vbNewLine & vbNewLine & "Do you wish to print a Yellow Tag?", vbYesNo)
If response = vbYes Then
MsgBox ("Please select your printer, from the following selection.")
Application.Dialogs(xlDialogPrinterSetup).Show
Application.ScreenUpdating = False
Sheets("Sheet2").Visible = True
Sheets("Sheet2").Select
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
ActiveWindow.SelectedSheets.Visible = False
Sheets("Fault Reporting").Select
MsgBox "Your 'Yellow Tag' label is now printing." & vbNewLine & vbNewLine & "This file will now close."
With Application
.DisplayFullScreen = False
.CommandBars("Worksheet Menu Bar").Enabled = False
End With
ActiveWorkbook.Close
ElseIf response = vbNo Then
MsgBox ("This file will now close.")
With Application
.DisplayFullScreen = False
.CommandBars("Worksheet Menu Bar").Enabled = True
End With
ActiveWorkbook.Close SaveChanges:=False
End If
End Sub
Function RangetoHTML(rng As Range)
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"
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
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
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=")
TempWB.Close SaveChanges:=False
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Display More
Any help would be greatly appreciated.