'<Class: ThisOutlookSession>
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
    modJournalTelefonCall.Initialize Inspector
  End If
End Sub
'</Class: ThisOutlookSession>

'<Modul: modTimer>
Option Explicit
Private Declare Function SetTimer Lib "user32.dll" (ByVal hWnd As Long, _
  ByVal nIDEvent As Long, ByVal uElapse As Long, _
  ByVal lpTimerFunc As Long) As Long

Private Declare Function KillTimer Lib "user32.dll" (ByVal hWnd As Long, _
  ByVal nIDEvent As Long) As Long

Const WM_TIMER = &H113

Private hEvent As Long
Private m_oCallback As Object

Public Sub TimerProc(ByVal hWnd As Long, ByVal uMsg As Long, _
  ByVal wParam As Long, ByVal lParam As Long _
)
  If uMsg = WM_TIMER Then
    Call Timer
  End If
End Sub

Public Function EnableTimer(ByVal msInterval As Long, _
  oCallback As Object _
) As Boolean
  If hEvent <> 0 Then
    Exit Function
  End If
  hEvent = SetTimer(0&, 0&, msInterval, AddressOf TimerProc)
  Set m_oCallback = oCallback
  EnableTimer = CBool(hEvent)
End Function

Public Function DisableTimer()
  If hEvent = 0 Then
    Exit Function
  End If
  KillTimer 0&, hEvent
  hEvent = 0
  Set m_oCallback = Nothing
End Function
'</Modul: modTimer>

'<Class: OfficeButton>
Option Explicit

Public WithEvents Button As Office.CommandBarButton

Private Sub Button_Click(ByVal Ctrl As Office.CommandBarButton, _
  CancelDefault As Boolean _
)
  EnableTimer 100, Nothing
End Sub
'</Class: OfficeButton>

'<Modul: modJournalTelefonCall>
Option Explicit

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

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 Timer()
  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

  ' German
  DialogCaption = "Neuer Telefonanruf"
  CheckboxCaption = "Bei Anrufbeginn neuen &Journaleintrag erstellen"

  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
'</Modul: modJournalTelefonCall>