Journaleintrag automatisch bei Anruf erstellen

Code in DieseOutlookSitzung

Die Outlook Wählhilfe ermöglicht es, einen Kontakt anzurufen. Im sich dann öffnenden Dialog gibt es eine Checkbox; ist die markiert, wird bei Anrufbeginn automatisch ein neuer Journaleintrag erstellt. Wer alle Anrufe im Journal prokollieren möchte, wünscht sich, dass diese Checkbox standardmäßig ausgewählt ist. Das spart einen Mausklick, und das Auswählen wird nicht mehr vergessen. Das folgende umfangreiche Beispiel demonstriert, wie Sie genau das erreichen.

Fügen Sie dem VBA-Projekt zwei neue Standardmodule über Einfügen/Modul hinzu. Drücken Sie dann f4, um die Module zu benennen. Das erste soll 'modJournal' und das zweite 'modTimer' heißen. Dann fügen Sie noch ein Klassenmodul hinzu und benennen es 'OfficeButton'.

Das Beispiel wurde mit Outlook 2003 getestet und funktioniert bis Outlook 2010. Seit Outlook 2013 werden die Office-Commandbars leider nicht mehr unterstützt.

Kopieren Sie zunächst folgenden Code ins Modul DieseOutlookSitzung:

  So fügen Sie Makros in Outlook ein

Private WithEvents m_Inspectors As Outlook.Inspectors

Private Sub Application_Startup()
  Set m_Inspectors = Application.Inspectors
End Sub

Private Sub m_Inspectors_NewInspector(ByVal Inspector As Inspector)
  If TypeOf Inspector.CurrentItem Is Outlook.ContactItem Then
    modJournal.Initialize Inspector
  End If
End Sub

modTimer und OfficeButton

Ins Modul modTimer kopieren Sie den Code des API-Timers. Und die folgenden Code-Zeilen kopieren Sie ins Klassenmodul OfficeButton:

Public WithEvents Button As Office.CommandBarButton

Private Sub Button_Click(ByVal Ctrl As Office.CommandBarButton, _
  CancelDefault As Boolean _
)
  EnableTimer 100, Nothing
End Sub

modJournal

Hier nun der Code fürs Modul modJournal. Beachten Sie den Kommentar oben vor Sub Initialize(), wenn Sie keine deutsche Outlookversion haben, müssen Sie die beiden Variablen anpassen:

1. m_DialogCaption: Das ist der Titel des Dialogs, der angezeigt wird, wenn Sie im Kontakt auf Anruf / Neuer Telefonanruf klicken.
2. m_CheckboxCaption: Das ist die Beschriftung der Checkbox im zuvor genannten Dialogs. Da muss ein unterstrichener Buchstabe sichtbar sein für den Schnellzugriff. Bei deutschen und englischen Versionen ist das das 'J' im Wort 'Journal', deswegen wird bei der Variable '&Journal' eingetragen. Wenn Sie den unterstrichenen Buchstaben nicht sehen, drücken Sie die ALT-Taste.

Private Declare Function GetDesktopWindowA Lib "user32" _
  Alias "GetDesktopWindow" () As Long
Private Declare Function GetWindow Lib "user32" _
  (ByVal hWnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetWindowRectA Lib "user32" _
  Alias "GetWindowRect" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function GetWindowTextA Lib "user32" _
  (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetClientRect Lib "user32" _
  (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function GetCursorPos Lib "user32" _
  (lpPoint As POINTAPI) As Long
Private Declare Sub MouseEvent Lib "user32" Alias "mouse_event" _
  (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, _
  ByVal cButtons As Long, ByVal dwExtraInfo As Long)

Private Const GW_CHILD = 5
Private Const GW_HWNDNEXT = 2

Private Const MOUSEEVENTF_LEFTDOWN = &H2
Private Const MOUSEEVENTF_LEFTUP = &H4
Private Const MOUSEEVENTF_MIDDLEDOWN = &H20
Private Const MOUSEEVENTF_MIDDLEUP = &H40
Private Const MOUSEEVENTF_MOVE = &H1
Private Const MOUSEEVENTF_ABSOLUTE = &H8000
Private Const MOUSEEVENTF_RIGHTDOWN = &H8
Private Const MOUSEEVENTF_RIGHTUP = &H10

Private Type RECT
  left As Long
  top As Long
  right As Long
  bottom As Long
End Type

Private Type POINTAPI
  x As Long
  y As Long
End Type

Private m_OfficeButtons As VBA.Collection

'Deutsche Namen. Passen Sie das bei Bedarf für andere Sprachen an
Private Const m_DialogCaption As String = "Neuer Telefonanruf"
Private Const m_CheckboxCaption As String = "Bei Anrufbeginn neuen &Journaleintrag erstellen"

Public Sub Initialize(Inspector As Outlook.Inspector)
  Set m_OfficeButtons = New VBA.Collection
  GetCommandbarButtons Inspector.CommandBars
End Sub

Private Sub GetCommandbarButtons(Bars As Office.CommandBars)
  Dim Bar As Office.CommandBar
  Dim Popup As Office.CommandBarPopup
  Dim Controls As Office.CommandBarControls
  Dim Ctrl As Office.CommandBarControl
  Dim Btn As OfficeButton
  Dim i&, y&

  Set Bar = Bars("Standard")
  Set Popup = Bar.FindControl(, 568)

  If Not Popup Is Nothing Then
    Set Controls = Popup.Controls

    For i = 1 To Controls.Count
      Set Ctrl = Controls(i)

      If TypeOf Ctrl Is Office.CommandBarButton Then
        Set Btn = New OfficeButton
        Set Btn.Button = Ctrl
        m_OfficeButtons.Add Btn

      ElseIf TypeOf Ctrl Is Office.CommandBarPopup Then
        Set Popup = Ctrl

        For y = 1 To Popup.Controls.Count
          Set Ctrl = Popup.Controls(y)
          If TypeOf Ctrl Is Office.CommandBarButton Then
            Set Btn = New OfficeButton
            Set Btn.Button = Ctrl
            m_OfficeButtons.Add Btn
          End If
        Next
      End If
    Next
  End If
End Sub

Public Sub TimerEvent()
  DisableTimer
  PushButton_CreateJournalEntryForNewCall
End Sub

Public Sub PushButton_CreateJournalEntryForNewCall()
  Dim lHnd As Long

  lHnd = GetHandle_CmdCreateJournalEntry
  If lHnd Then
    SendMouseClick lHnd, 1
  End If
End Sub

Private Function GetHandle_CmdCreateJournalEntry() As Long
  Dim lHndDesktop As Long
  Dim lHndDlg As Long
  Dim lHndCmd As Long
  Dim DialogCaption As String
  Dim CheckboxCaption As String

  DialogCaption = m_DialogCaption
  CheckboxCaption = m_CheckboxCaption

  lHndDesktop = GetDesktopWindowA
  If lHndDesktop Then
    lHndDlg = FindChildWindowText(lHndDesktop, DialogCaption)
    If lHndDlg Then
      lHndCmd = FindChildWindowText(lHndDlg, CheckboxCaption)
      GetHandle_CmdCreateJournalEntry = lHndCmd
    End If
  End If
End Function

Private Function FindChildWindowText(ByVal lHwnd As Long, _
  sFind As String _
) As Long
  Dim lRes As Long
  Dim sFindLC As String

  lRes = GetWindow(lHwnd, GW_CHILD)
  If lRes Then
    sFindLC = LCase$(sFind)
    Select Case InStr(sFindLC, "*")
    Case Is > 0
      Do
        If LCase$(GetWindowText(lRes)) Like sFindLC Then
          FindChildWindowText = lRes
          Exit Function
        End If
        lRes = GetWindow(lRes, GW_HWNDNEXT)
      Loop While lRes <> 0

    Case Else
      Do
        If LCase$(GetWindowText(lRes)) = sFindLC Then
          FindChildWindowText = lRes
          Exit Function
        End If
        lRes = GetWindow(lRes, GW_HWNDNEXT)
      Loop While lRes <> 0
    End Select
  End If
End Function

Private Function GetWindowText(ByVal lHwnd As Long) As String
  Const STR_SIZE As Long = 256
  Dim sBuffer As String * STR_SIZE
  Dim lSize As Long

  sBuffer = String$(STR_SIZE, vbNullChar)
  lSize = GetWindowTextA(lHwnd, sBuffer, STR_SIZE)
  If lSize > 0 Then
    GetWindowText = left$(sBuffer, lSize)
  End If
End Function

Private Sub SendMouseClick(ByVal hWnd As Long, _
   eButton As Long _
)
  On Error Resume Next
  Dim tpRect As RECT
  Dim tpCursor As POINTAPI
  Dim x As Single
  Dim y As Single
  Dim dwFlag As Long
  Dim dx As Long
  Dim dy As Long

  ' current cursor position
  GetCursorPos tpCursor

  If GetWindowRectA(hWnd, tpRect) Then
    With tpRect
      x = .left + ((.right - .left) / 2)
      y = .top + ((.bottom - .top) / 2)
    End With

    If GetClientRect(GetDesktopWindowA, tpRect) Then

      ' Move cursor to the control
      dwFlag = MOUSEEVENTF_ABSOLUTE Or MOUSEEVENTF_MOVE
      dx = x * (65535 / (tpRect.right))
      dy = y * (65535 / (tpRect.bottom))
      MouseEvent dwFlag, dx, dy, 0, 0

      ' Click the control
      Select Case eButton
      Case 1 'vbLeftButton
        MouseEvent MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
        MouseEvent MOUSEEVENTF_LEFTUP, 0, 0, 0, 0

      Case 4 'vbMiddleButton
        MouseEvent MOUSEEVENTF_MIDDLEDOWN, 0, 0, 0, 0
        MouseEvent MOUSEEVENTF_MIDDLEUP, 0, 0, 0, 0

      Case 2 'vbRightButton
        MouseEvent MOUSEEVENTF_RIGHTDOWN, 0, 0, 0, 0
        MouseEvent MOUSEEVENTF_RIGHTUP, 0, 0, 0, 0
      End Select

      ' Move cursor back
      dx = tpCursor.x * (65535 / (tpRect.right))
      dy = tpCursor.y * (65535 / (tpRect.bottom))
      MouseEvent dwFlag, dx, dy, 0, 0
    End If
  End If
End Sub