Microsoft Outlook 2007: Überprüfungen vor dem Absenden kombinieren

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

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

  Result = False
  If oMail.Subject = "" Then
    strMsg = "Ihre Nachricht hat keinen Betreff." & vbCrLf & "Nachricht ohne Betreff versenden?"
    'strMsg = "Your message has no subject." & vbCrLf & "Send message without subject?"
    Result = (MsgBox(strMsg, vbYesNo + vbQuestion, "Kein Betreff") = vbNo)
    'Result = (MsgBox(strMsg, vbYesNo + vbQuestion, "No subject") = vbNo)
  End If
  CheckSubject = Result
End Function

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

Private Function CheckMailSize(oMail As Outlook.MailItem) As Boolean
  Dim Result As Boolean
  Dim MailSize As Long
  Const MaxMailSize As Long = 1048576 ' Maximum message size: 1 MB
  Dim strMsg As String

  Result = False
  If oMail.Attachments.Count Then
    oMail.Save
    MailSize = oMail.Size
    If MailSize > MaxMailSize Then
      strMsg = "Ihre Nachricht hat " & MailSize & " Bytes." & vbCrLf & "Senden der Nachricht abbrechen?"
      'strMsg = "Your message has " & MailSize & " bytes." & vbCrLf & "Abort sending of the message?"
      Result = (MsgBox(strMsg, vbYesNo + vbQuestion, "Maximale Nachrichtengröße überschritten") = vbYes)
      'Result = (MsgBox(strMsg, vbYesNo + vbQuestion, "Message size exceeded") = vbYes)
    End If
  End If
  CheckMailSize = Result
End Function