Fehler im Detail: Abstrurz nach ertsmaligem Start?

Sub Mail_Vorlage_füllen()
Sheets("Arbeitsauftragsbuch").Select
Dim Status&
On Error Resume Next
If GetObject(, "OUTLOOK.Application") Is Nothing Then
Status = Shell("outlook.exe", 1)
Else
End If
On Error GoTo 0
Sheets("Arbeitsauftragsbuch").Select
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "Hi there" & vbNewLine & vbNewLine & _
"This is line 1" & vbNewLine & _
"This is line 2" & vbNewLine & _
"This is line 3" & vbNewLine & _
"This is line 4"
On Error Resume Next
With OutMail
.To = "verwaltung@gemeinde.de"
.CC = ""
.BCC = ""
ActiveCell.Rows("1:1").EntireRow.Select
ActiveCell.Activate
Selection.Copy
Sheets("Kopie").Visible = True
Sheets("Kopie").Select
Sheets("Kopie").Select
Rows("4:4").Select
ActiveSheet.Paste
.Subject = Range("M1")
Sheets("Kopie").Visible = False
Sheets("Arbeitsauftragsbuch").Select
ActiveSheet.Unprotect
Cells.Select
.Attachments.Add AttachmentFile
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Sheets("Arbeitsauftragsbuch").Select
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
AllowFormattingRows:=True, AllowInsertingHyperlinks:=True, AllowFiltering _
:=True
Application.CutCopyMode = False
End Sub