Microsoft Outlook 2007: Vorhandensein des Anhanges vor dem Absenden prüfen

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
  If Item.Class = olMail Then
    Cancel = CheckAttachment(Item)
  End If
End Sub

Private Function CheckAttachment(oMail As Outlook.MailItem) As Boolean
  Dim Result As Boolean
  Dim HasAttachments As Boolean
  Dim strMsg As String

  Result = False
  If NeedsAttachment(oMail.Body) Then
    HasAttachments = True
    If TypeName(oMail.Attachments) = "Nothing" Then
      HasAttachments = False
    End If
    If oMail.Attachments.Count = 0 Then
      HasAttachments = False
    End If
    If Not HasAttachments Then
      strMsg = "Ihre Nachricht hat keinen Anhang." & vbCrLf & "Nachricht ohne Anhang versenden?"
      'strMsg = "Your message has no attachment." & vbCrLf & "Send message without attachment?"
      Result = (MsgBox(strMsg, vbYesNo + vbQuestion, "Kein Anhang") = vbNo)
      'Result = (MsgBox(strMsg, vbYesNo + vbQuestion, "No attachment") = vbNo)
    End If
  End If
  CheckAttachment = Result
End Function

Private Function NeedsAttachment(ByVal text As String) As Boolean
  Dim Phrases As Variant
  Dim MailBody As String
  Dim Result As Boolean
  Dim i As Integer, j As Integer
  
  Phrases = Array("anhang", "anlage", "anhängend", "angehängt", "angefügt", _
                  "beigefügt", "anbei", "attached", "attachment")
  
  MailBody = LCase(text)
  Result = False
  j = UBound(Phrases)
  For i = 0 To j
    If InStr(MailBody, Phrases(i)) <> 0 Then
      Result = True
      Exit For
    End If
  Next
  NeedsAttachment = Result
End Function