Create Automatically New Journal Items for Calls

The Code in ThisOutlookSession

You can call a contact from within Outlook. There's a checkbox in the dialer dialog; if it is checked, a journal entry will be created as soon as the call begins. If you want to record every call in the journal, you wish the box would be checked by default. That saves one mouse click, and you never would forget to check it. This sample demonstrates how to achieve that.

Add two new modules to your VBA project via Insert/Module, and press F4 to be able to name the modules. Call the first one 'modJournal', the other one 'modTimer'. Then add a class module, and call it 'OfficeButton'.

The sample has been tested with Outlook 2003 and works until Outlook 2010.

First copy the following code to the ThisOutlookSession module:

  How to add macros to Outlook

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 and OfficeButton

Get here the code for the timer and copy it to modTimer: API-Timers. And copy the following lines to the OfficeButton class modul:

Public WithEvents Button As Office.CommandBarButton

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

modJournal

Here comes the code for the modJournal modul. See the comment at the top before the Sub Initialize(), if you're not running an English version of Outlook, you need to adjust both variables:

1. m_DialogCaption: This is the caption of the dialog that comes up when you click Call / New Call on a contact.
2. m_CheckboxCaption: This is the caption of the checkbox on the aforementioned dialog. There must be one character underlined, which marks the accelerator. In English and German the accelerator is the 'J' of the word 'Journal' so we have to enter '&Journal' . If you don't see the underlined character, press ALT to make it visible.

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

'English names. Adjust for other languages if necessary
Private Const m_DialogCaption As String = "New Call"
Private Const m_CheckboxCaption As String = "Create new &Journal Entry when starting new call"

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