Sicherheitswarnung von Outlook übergehen

Sicherheitswarnung von Outlook beim Senden einer E-Mail per VBA bestätigen

Beispieldatei (CloseOutlookSecurity.zip 67 kB)

Wer kennt das nicht?

Man steht vor der Aufgabe, per VBA eine Mappe oder einen Bereich automatisiert zu versenden. Den Code dazu hat man recht schnell im Internet gefunden, also steht dem Anliegen eigentlich nichts mehr im Wege. Aber wenn man glaubt, bereits am Ziel zu sein, schlägt Outlook als E-Mailclient zurück und unterbindet das, indem es dem Versenden eine lästige Sicherheitsabfrage zwischenschaltet. Das Anliegen selbst ist ja lobenswert, damit sollen Massenmails, ausgelöst von Würmern, Trojanern und Viren unterbunden werden. Glücklicherweise gibt es für den legitimen Nutzer kleine, meist kostenpflichtige Helferlein, welche die Sicherheitsabfrage automatisiert bestätigen.

Jemanden, der einem Firmennetzwerk angehört und dessen Rechner von einer IT-Abteiung administriert wird, helfen solche Programme aber meist nicht weiter. Neben der Kostenfrage erlauben es die Fachabteilungen einfach nicht, dass fremde Programme installiert werden. Sogar das Ausführen von nichtsignierten Makros wird meistens verhindert. Dem kann man ja noch abhelfen, indem man sich selbst ein Zertifikat ausstellt und seine eigenen VBA-Projekte digital signiert. Ist diese Hürde überwunden, kann man auch per VBA das erledigen, was die angesprochenen kleinen Tools leisten.

Ein paar kleinere Probleme müssen dazu aber noch aus dem Weg geräumt werden. Erst einmal ist es so, dass beim Versenden per VBA die weitere Ausführung von VBA-Code gestoppt wird. Man kann also auch nicht aus der eigenen Mappe heraus den Warnhinweis bestätigen. Was liegt da näher, als eine andere Excelmappe in einer anderen Excelinstanz zu starten, welche das erledigt. Diese muss gestartet werden, bevor man an das Senden gehen kann. Um sicherzustellen, dass auch tatsächlich eine andere Instanz gestartet wird, benutzt man die späte Bindung via CreateObjekt zum Starten einer neuen Instanz. In dieser neuen Instanz wird dann die gewünschte Mappe mit dem relevanten Code geöffnet.

Auch bei diesem Beispiel gilt, dass man den Code frei benutzen kann. Eine Veröffentlichung des Codes oder Teilen davon, womöglich noch unter anderem Namen, sollte aber unterbleiben.

Folgendermaßen wird das Senden einer E-Mail angestoßen:

Private Sub cmdSendRange_Click()
   BereichSenden
End Sub
Private Sub cmdSendSheet_Click()
   SendWorksheet
End Sub

Private Sub BereichSenden()
   Dim objExcel      As Object
   Dim blnVisible    As Boolean
   On Error Goto ErrorHandler

   If Selection.Cells.Count = 1 Then Exit Sub
   blnVisible = ActiveWorkbook.EnvelopeVisible
   ActiveWorkbook.EnvelopeVisible = True

   With ActiveSheet.MailEnvelope
      ' Umschlag ausfüllen
      .Introduction = "Einleitung"
      .Item.To = "To@NoRealDomain.de"
      .Item.CC = "CC@NoRealDomain.de"
      .Item.Subject = "Betreff"

      ' Mappe zum automatischen Bestätigen des Dialogs in einer
      ' neuen Excel-Instanz öffnen. Ausführen von Makros muss
      ' aktiviert sein, eventuell digital signieren.
      Set objExcel = CreateObject("Excel.Application")
' objExcel.Visible = True
      objExcel.Workbooks.Open ActiveWorkbook.Path & "\CloseOutlookSecurity.xlsm"
      Set objExcel = Nothing

      ' Versenden
      .Item.Send

   End With

   ActiveWorkbook.EnvelopeVisible = blnVisible

   Exit Sub
ErrorHandler:
   MsgBox Err.Description
End Sub

Private Sub SendWorksheet()
   Dim rngOld        As Range
   Dim objExcel      As Object
   Dim blnVisible    As Boolean
   On Error Goto ErrorHandler

   ' Aktuell selektierten Bereich merken
   Set rngOld = Application.Selection
   ' Eine einzige Zelle aktivieren
   Me.Range("A1").Activate
   blnVisible = ActiveWorkbook.EnvelopeVisible
   ActiveWorkbook.EnvelopeVisible = True

   With ActiveSheet.MailEnvelope
      ' Umschlag ausfüllen
      .Introduction = "Einleitung"
      .Item.To = "To@NoRealDomain.de"
      .Item.CC = "CC@NoRealDomain.de"
      .Item.Subject = "Betreff"

      ' Mappe zum automatischen Bestätigen des Dialogs in einer
      ' neuen Excel-Instanz öffnen. Ausführen von Makros muss
      ' aktiviert sein, eventuell digital signieren.
      Set objExcel = CreateObject("Excel.Application")
' objExcel.Visible = True
      objExcel.Workbooks.Open ActiveWorkbook.Path & "\CloseOutlookSecurity.xlsm"
      Set objExcel = Nothing

      ' Versenden
      .Item.Send

   End With

   ActiveWorkbook.EnvelopeVisible = blnVisible
   rngOld.Select

   Exit Sub
ErrorHandler:
   MsgBox Err.Description
   rngOld.Select
End Sub
Option Explicit

Ist man nun der Meinung, man könnte nun sofort damit anfangen, das Dialogfenster zu suchen und gleichzeitig auch das Senden anzustoßen, der irrt. Auch hier wird die weitere Ausführung von Code in der aufrufenden Prozedur angehalten, bis der AutoOpen-Code in der aufgerufenen Mappe abgearbeitet ist. Erfolgversprechend ist das Benutzen der OnTime-Methode, die es zulässt, dass zu einer bestimmten Zeit die VBA-Prozedur ausgeführt wird, welche das Outlook-Meldungsfenster sucht. Das Ausführen der OnTime-Methode hält den Codeablauf nicht an, so dass man in der aufrufenden Prozedur die Verbindung zur erzeugten Excel-Instanz lösen kann und anschließend das Senden anstößt.

Private Sub Workbook_Open()
   ' Nicht sofort ausführen, da sonst die aufrufende Prozedur
   ' auf das Ende wartet. Es werden auch Argumente an die
   ' Prozedur SecurityBoxClose übergeben, hier Buttonname
   ' und Timeoutzeit in Sekunden eintragen.
   Application.OnTime Now + TimeSerial(0, 0, 1), _
      "'SecurityBoxClose ""Erteilen"", ""10"" '"
End Sub

Kommen wir nun zur eigentlichen Aufgabe, nämlich dem Suchen des Meldungsfensters und dem Betätigen des gewünschten Buttons.

Der mit der OnTime-Methode aufgerufenen Prozedur SecurityBoxClose werden mehrere optionale Parameter mitgegeben. Das ist zum Einen der Text des Buttons, der betätigt werden soll. Standardmäßig ist der Text "Erteilen" vorgegeben. Zum Anderen kann man noch eine Timeoutzeit in Sekunden übergeben, als Standard werden 120 Sekunden verwendet.

Damit man die Mappe auch ohne Probleme bearbeiten kann, ohne explizit die Ausführung von Makros auszuschalten, erfolgt zu Beginn eine Abfrage, ob das Bearbeiten erfolgen soll, ist das der Fall, wird die Prozedur beendet. Aufgerufen wird diese Abfrage, wenn man die Mappe ganz normal öffnet, die Applikation also sichtbar (Application.Visible) ist.

Im weiteren Verlauf setzt man eine Variable auf die Timeautzeit, bei der auf jeden Fall der Programmablauf beendet werden soll. Nun startet man eine Do ... Loop -Schleife, in welcher man bei jedem Durchlauf durch den Aufruf der Funktion FindChildWindowFromText das Dialogfenster gesucht wird. Ist das gefunden, sucht man wiederum durch den Aufruf der Funktion FindChildWindowFromText das Handle des dort zu betätigenden Buttons.

Ist man im Besitz dieses Handles, wird die Schleife verlassen und eine andere gestartet. In diesem Schleifenkörper wird nun mit der API GetWindowRect die Position des Buttons ermittelt, anschließend holt man das Dialogfenster mit der API SetForegroundWindow in den Vordergrund, was aber bereits der Fall sein sollte. Nun positioniert man den Cursor mit der API SetCursorPos auf den Button und löst mit mouse_event einen Mausklick darauf aus.

Der Prozedur FindChildWindowFromText werden mehrere, zum Teil optionale Parameter übergeben. Das ist zum Einen das Handle des Elternfensters, wird als erster Parameter Null übergeben, holt man sich mit GetDesktopWindow das Desktopfenster und verwendet dieses als Elternfenster. Der zweite ist der oder ein Teil des Fenstertextes des gesuchten Fensters. Der dritte, optionale Parameter ist der Klassenname. Da beim Vergleich mit dem Like-Operator das Rautezeichen Probleme bereitet, es gilt als Ersatzzeichen einer beliebigen Ziffer, wird es kurzerhand durch einen Stern ersetzt. Besonders die Klassennamen von Dialogen beginnen mit solch einem Zeichen.

Mit GetWindow wird nun das erste Kindfenster gesucht, der Klassenname und der Fenstertext ausgelesen und diese mit den Suchkriterien verglichen. Beim Fenstertext werden noch die Kaufmännischen UND-Zeichen entfernt, welche bei einem Button den unterstrichenen Buchstaben angeben. Bei Übereinstimmung liefert man das Handle als Funktionsergebnis zurück und verlässt die Prozedur. Andernfalls wird mit GetWindow das nächste Fenster auf gleicher Ebene geholt und es wird wiederum verglichen. Das geht so lange, bis ein Fenster gefunden wurde, oder alle auf dieser Ebene abgearbeitet wurden. Auf ein rekursives Suchen der untergeordneten Fenster habe ich aber dabei verzichtet.

Option Explicit
Private Type RECT
  left As Long
  top As Long
  right As Long
  bottom As Long
End Type
Private Declare Function GetDesktopWindow _
   Lib "user32" () As Long
Private Declare Function GetWindow _
   Lib "user32" ( _
   ByVal hwnd As Long, _
   ByVal wCmd As Long _
   ) As Long
Private Declare Function IsWindow _
   Lib "user32" ( _
   ByVal hwnd As Long _
   ) As Long
Private Declare Function GetWindowText _
   Lib "user32" Alias "GetWindowTextA" ( _
   ByVal hwnd As Long, _
   ByVal lpString As String, _
   ByVal cch As Long _
   ) As Long
Private Declare Function GetClassName _
   Lib "user32" Alias "GetClassNameA" ( _
   ByVal hwnd As Long, _
   ByVal lpClassName As String, _
   ByVal nMaxCount As Long _
   ) As Long
Private Declare Sub Sleep _
   Lib "kernel32" ( _
   ByVal dwMS As Long)
Private Declare Function SetForegroundWindow _
   Lib "user32" ( _
   ByVal hwnd As Long _
   ) As Long
Private Declare Sub mouse_event _
   Lib "user32.dll" ( _
   ByVal dwFlags As Long, ByVal dx As Long, _
   ByVal dy As Long, ByVal dwdata As Long, _
   ByVal dwExtraInfo As Long)
Private Declare Function SetCursorPos _
   Lib "user32" ( _
   ByVal X As Long, ByVal Y As Long _
   ) As Long
Private Declare Function GetWindowRect _
   Lib "user32.dll" ( _
   ByVal hwnd As Long, _
   lpRect As RECT _
   ) As Long
Private Const GW_CHILD              As Long = 5
Private Const GW_HWNDNEXT           As Long = 2
Private Const MOUSEEVENT_LEFTDOWN   As Long = &H2
Private Const MOUSEEVENT_LEFTUP     As Long = &H4

Public Sub SecurityBoxClose( _
   Optional ButtonText As String = "Erteilen", _
   Optional TimeoutSeconds As Long = 120)
   Dim lngHwnd          As Long
   Dim dteTimeout       As Date
   Dim udtPos           As RECT
   On Error Resume Next

   If Application.Visible Then
      If MsgBox("Wollen Sie die Mappe bearbeiten?", vbYesNo) = _
         vbYes Then Exit Sub
   End If

   dteTimeout = Now + TimeSerial(0, 0, TimeoutSeconds)

   Do
   ' So lange durchlaufen, bis das gesuchte Fenster gefunden, oder
   ' Timeoutzeit abgelaufen ist

      If Now > dteTimeout Then Exit Do

      ' Handle der Dialogbox von Outlook suchen
      lngHwnd = FindChildWindowFromText(0, "Outlook", "#32770")
      If lngHwnd <> 0 Then

         ' Handle der Schaltfläche suchen
         lngHwnd = FindChildWindowFromText(lngHwnd, ButtonText)

      End If

   Loop While lngHwnd = 0

   If lngHwnd <> 0 Then

      dteTimeout = Now + TimeSerial(0, 0, TimeoutSeconds)

      Do While CBool(IsWindow(lngHwnd))
      ' So lange durchlaufen, wie Fenster existiert

         GetWindowRect lngHwnd, udtPos

         ' Box in den Vordergrund bringen
         SetForegroundWindow lngHwnd

         ' Mausklick simulieren
         SetCursorPos udtPos.left + 10, udtPos.top + 10
         mouse_event MOUSEEVENT_LEFTDOWN, 0, 0, 0, 0
         mouse_event MOUSEEVENT_LEFTUP, 0, 0, 0, 0

         If Now > dteTimeout Then Exit Do

         ' 1 Sekunde warten
         Sleep 1000

      Loop

   End If

   Application.DisplayAlerts = False
   Application.Quit

End Sub

Private Function FindChildWindowFromText( _
   ByVal HwndParent As Long, _
   ByVal Caption As String, _
   Optional ByVal ClassName As String _
   ) As Long
   Dim lngHwnd          As Long
   Dim lngRet           As Long
   Dim strCaption       As String
   Dim strClass         As String

   On Error Resume Next
   If HwndParent = 0 Then HwndParent = GetDesktopWindow

   ClassName = Replace(ClassName, "#", "*")

   ' Ein Handle auf ein Kindfenster holen
   lngHwnd = GetWindow(HwndParent, GW_CHILD)

   ' Original Fenstertext ohne Kaufmännisches UND
   ' (Unterstr. Buchstabe bei Buttons)
   Caption = Replace(Caption, "&", "")

   Do

      'Buffer für Fenstertext anlegen
      strCaption = String(255, 0)

      'Fenstertext holen
      lngRet = GetWindowText(lngHwnd, strCaption, 250)
      strCaption = left(strCaption, lngRet)
      strCaption = Replace(strCaption, "&", "")

      'Buffer für Klassenname anlegen
      strClass = String(255, 0)

      'Klassenname holen
      lngRet = GetClassName(lngHwnd, strClass, 250)
      strClass = left(strClass, lngRet)

      If LCase(strCaption) Like "*" & LCase(Caption) & "*" Then

         If ClassName <> "" Then
            If LCase(strClass) Like "*" & LCase(ClassName) & "*" Then
               ' Gesuchte Schaltfläche gefunden
               FindChildWindowFromText = lngHwnd
               Exit Function
            End If
         Else
            ' Gesuchte Schaltfläche gefunden
            FindChildWindowFromText = lngHwnd
            Exit Function
         End If
      End If

      'Nächstes Fenster auf gleicher Ebene holen
      lngHwnd = GetWindow(lngHwnd, GW_HWNDNEXT)

   Loop While lngHwnd <> 0

End Function