Code to send Email wont send everytime

I have the following code to obtain details from a userform, and then email these details.

Sometimes the email will send, and sometimes the email just sits in the background and wont send.

Most of this code I have borrowed from other sources and tweaked to suit my needs.

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
Dim ws1 As Worksheet
Set ws1 = ThisWorkbook.Sheets("Fault Reporting")
Dim ws2 As Worksheet
Set ws2 = ThisWorkbook.Sheets("Sheet2")
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 = "hunxxxxxx@xxxx.com"
    .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

TimeOut 4
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
ws2.Activate
ws2.PrintOut Copies:=1, Collate:=True


ws1.Activate
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
Unload UserForm1
ActiveWorkbook.Close SaveChanges:=False
ElseIf response = vbNo Then

MsgBox ("This file will now close.")
With Application
   .DisplayFullScreen = False
   .CommandBars("Worksheet Menu Bar").Enabled = True
End With
Unload UserForm1
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
Function TimeOut(delayT As Long) 'or double/single? not sure which is more appropriate to use
    Dim tOut As Date
    tOut = Now() + delayT / 160000 'half-second-ish
    Do While Now < tOut
        DoEvents
    Loop
End Function

Any ideas why it doesnt work every time?

When the code runs, the email pops up and displays, then sends.

When it doesnt work, the email is created, but it stays behind excel, and doesnt send. It is then sendable when I exit excel, or switch to the email.

I understand that the email sending is dependant on the server, but I dont think the code is actually sending the email. It creates the email, but never actually sends it.

I think this peice of code is the line which sends the email but sometimes this doesnt seem to work.

SendKeys "%{s}", True

When the email is visible, this code sends the email. However, when the email isnt visible, this code is unable to send the email.

Thanks for your help Leith. I am not very good with VB and have no experience with error handling. Most of what you have seen I have taken from other sources.

Regarding the SendKeys method, I was using this because without it, there is a security message that pops saying that an email is trying to be sent. I wanted a way around the user having to deal with this security warning.

I could just insert a message box asking the user to click yes to this security message I suppose, but I wanted to avoid it.

Thanks again.