StartDownloadsServiceSamplesWorkshopsContact DeutschEnglish
 
Samples
General
Outlook®
 
Awarded by
Microsoft since 2005:
mvp logo
VBOffice Info
Visitors1827620
Impressions6856140
Links
Imprint
Privacy Policy
Contact
Journal: Create automatically new entries for calls
Author: Michael BauerHomepage
Date: 22.11.2007Accessed: 21785
  
Description

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 and call them 'modJournalTelefonCall' and 'modTimer'. Then add a class module called 'OfficeButton'. Then copy the code into the corresponding modules. (Sample: The code between the tags <Class: ThisOutlookSession> belongs into the module 'ThisOutlookSession').

The sample has been tested with Outlook 2003 and works for opened contacts.

NOTE: The sample was created for a German Outlook version. For another language you must edit two values in the function 'GetHandle_CmdCreateJournalEntry':

- 'DialogCaption' must be the caption of the dialer.

- 'CheckboxCaption' must be the one of the checkbox that we want to click by code. Also look which character the underlined character is: E.g. if an 'a' is the underlined character you must write the caption as '&a'.

'<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>
 
 

ReplyAll alerts you before unintentionally replying all, or if you are a confidential BCC recipient of the ... [more]

 

Access the master category list in the blink of an eye, share your categories in a network, get a reminder service, and ... [more]

 

SAM automatically sets the sender, signature, and folder for sent items, for instance based on the recipient ... [more]

 

OLKeeper reliably prevents users from closing their Outlook window and thus possibly missing reminders or ... [more]