Range per Outlook versenden

Sub Mail_Selection_Range_Outlook_Body()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim tm, dt
tm = Format(Time, "Short Time")
dt = Format(Date, "Short Date")
Dim lngLetzte As Long
Range("B2").Select
lngLetzte = IIf(IsEmpty(Cells(Rows.Count, 6)), Cells(Rows.Count, 6).End(xlUp).Row, Rows. _
Count)
Set rng = Nothing
On Error Resume Next
Set rng = Range("A1:H" & lngLetzte)
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)
On Error Resume Next
With OutMail
.GetInspector
If ActiveCell.Value = "Tinahely" Then
.To = ""
.Cc = ""
End If
.Subject = "Collection report: " & " " & Range("A1") & " - " & ActiveCell()
If tm " & "" & "Good Morning " & "
" & "
" & " _
Attached you will find your requested Report for " & Range("A1") & "." & "
" & "
" & "Thank you." & RangetoHTML(rng) & vbCrLf & .HTMLBody
End If
If tm > "12:00" Then
'.HTMLBody = RangetoHTML(rng) & vbCrLf & .HTMLBody
.HTMLBody = "" & "" & "Good Afternoon " & "
" & "
" & " _
Attached you will find your requested Report for " & Range("A1") & "." & "
" & "
" & "Thank you." & RangetoHTML(rng) & vbCrLf & .HTMLBody
End If
.Display
'.Send   'or use .Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub