Outlook 2010 Contact Macro

  • Thread starter Timothy Hays
  • Start date Views 811
T

Timothy Hays



I am not a VBscript expert but I have looked all over the Internet for a solution and I cannot find one.

My primary goal is to create code that will be on a Outlook Contact. The code will add some new lines to the very bottom of the NOTES section of the contact and put the date, time and current user there. Then set the focus to the NOTES section and place the cursor at the end of the newly added text. Although not required, it would be nice if this code could be executed with a keyboard shortcut.

I have tried to solve this by added the following macro as a Quick Access Toolbar button on an Outlook Contact.

Sub getTimeStamp()
Dim myInspector As Outlook.Inspector
Dim myItem As Outlook.ContactItem
Set myInspector = Application.ActiveInspector
If Not TypeName(myInspector) = "Nothing" Then
If TypeName(myInspector.CurrentItem) = "ContactItem" Then
Set myItem = myInspector.CurrentItem
myItem.Body = myItem.Body & vbCrLf & vbCrLf & Now() & " : " & Application.GetNamespace("MAPI").CurrentUser & " - T"

Else
MsgBox "The item is of the wrong type."
End If
End If
End Sub

There are some problems with this solution:

1. If there are attachments anywhere in the notes, the attachments get pulled out of the notes and placed at the very end AFTER the newly added text.
2. It doesn't scroll the text in the notes area to make the new added text visible.
3. It doesn't set the focus to the notes box.

Any help is appreciated. Thanks.

Tim Hays
 
M

Michael Bauer [MVP]



If this is for Outlook 2007 or higher, myInspector.WordEditor returns a word.Document object.

Add a ref on the Word library to your project via Tools/References, then use the object browser (f2). The Document object has methods to place the cursor where you want to.

I doubt there's any method to set the focus on it. Here's an example for how to do it for a MailItem object by using the Win32 API, which might give you a point to start at:
http://www.vboffice.net/smp

Michael Bauer
Category Manager - Easily share your categories
 
T

Timothy Hays



I have been using C# for the past 5 years, so my VBA is very rusty and I haven't really programmed using Win32 API, but I gave it a go. I am happy with the results except for 1 bug. The set focus functionality works fine if I step through my VBA code, but it doesn't work if I just let it run. I thought maybe it was a timing issue so I put a timer in to delay the process but it didn't seem to have any affect. I am pasting my code below. Any help is appreciated.

Option Explicit

''' This code is based on the code from
''' 1. http://www.vboffice.net/smp
''' 2. http://www.appspro.com/Tips/VBA%20Tips.htm
'''
''' I modified it to work with Outlook 2010.

' External Windows API declarations
Private Declare Function FindWindow Lib "USER32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) 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 Function GetWindow Lib "USER32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function SendMessage Lib "USER32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function EnumChildWindows Lib "USER32" (ByVal hWndParent As Long, ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Private Declare Function SetForegroundWindow Lib "USER32" (ByVal hwnd As Long) As Long
Private Declare Function GetParent Lib "USER32" (ByVal hwnd As Long) As Long
Private Declare Function SetScrollInfo Lib "USER32" (ByVal hwnd As Long, ByVal n As Long, lpcScrollInfo As SCROLLINFO, ByVal bool As Boolean) As Long
Private Declare Function GetScrollInfo Lib "USER32" (ByVal hwnd As Long, ByVal n As Long, lpScrollInfo As SCROLLINFO) As Long

Private Const SB_HORZ = 0
Private Const SB_VERT = 1
Private Const SIF_RANGE = &H1
Private Const SIF_PAGE = &H2
Private Const SIF_POS = &H4
Private Const SIF_DISABLENOSCROLL = &H8
Private Const SIF_TRACKPOS = &H10
Private Const SIF_ALL = (SIF_RANGE Or SIF_PAGE Or SIF_POS Or SIF_TRACKPOS)

Private Type SCROLLINFO
cbSize As Long
fMask As Long
nMin As Long
nMax As Long
nPage As Long
nPos As Long
nTrackPos As Long
End Type

' Used with GetWindow to specify child window
Private Const GW_CHILD = 5

' Used with GetWindow to specify next window
Private Const GW_HWNDNEXT = 2

' Used to send a message to the affected window.
Private Const WM_SETFOCUS = 7
Private Const EN_SETFOCUS = 256
Private Const EM_LINESCROLL = &HB6

' Used to store the class to search for in the EnumerateChildWindows
Private sChildClassToSearchFor As String

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' Comments: Removes any whitespace characters from the end of the notes
''' section of a contact. It then adds two carriage returns,
''' puts a timestamp, current users name and a " - T" in the bottom
''' of the notes section. It changes the text for the timestamp
''' and users name to blue.
'''
''' Date Developer Action
''' ------------------------------------------------------------------------ ''' 12/02/2010 Tim Hays Created
'''
Sub TimeStamp()
Dim objOL As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim objDoc As Word.Document
Dim objSel As Word.Selection
Dim strStamp As String
Dim strLeadIn As String
Dim TextSize As Integer

On Error Resume Next
Set objOL = Application
' Only use if editor type is WordEditor
If objOL.ActiveInspector.EditorType = olEditorWord Then
' Set variables
Set objDoc = objOL.ActiveInspector.WordEditor
Set objNS = objOL.Session

' Create text
strStamp = Now & " - " & objNS.CurrentUser.Name
strLeadIn = " - T"

' Deletes Trailing spaces at the end of the notes area.
TrimTrailingSpaces objDoc
' Create Selection object and select all text
Set objSel = objDoc.Windows(1).Selection
objSel.WholeStory

' Gets size of text for use later.
TextSize = objSel.Characters.Count

' move cursor to the end of the text
objSel.Collapse (Word.WdCollapseDirection.wdCollapseEnd)
objSel.Move wdStory, 1

' Inserts the new timestamp
If TextSize < 2 Then
objSel.InsertAfter (strStamp & strLeadIn)
Else
objSel.InsertAfter (vbCrLf & vbCrLf & strStamp & strLeadIn)
End If

' Sets the color of the new timestamp to blue.
Set objSel = objDoc.Windows(1).Selection
objSel.Find.ClearFormatting
objSel.Find.Text = strStamp
objSel.Find.Replacement.ClearFormatting
objSel.Find.Replacement.Font.ColorIndex = wdBlue
objSel.Find.Replacement.Text = ""
objSel.Find.Forward = True
objSel.Find.Wrap = wdFindContinue
objSel.Find.Execute Replace:=wdReplaceAll

' Moves the cursor to the end of the text.
Set objSel = objDoc.Windows(1).Selection
objSel.WholeStory
objSel.Collapse (Word.WdCollapseDirection.wdCollapseEnd)
objSel.Move wdStory, 1
End If

' Set Focus to the Notes section
SetFocusOnNotes Application.ActiveInspector.Caption

' Clears memory because VBA doesn't do it automatically
Set objSel = Nothing
Set objDoc = Nothing
Set objNS = Nothing
Set objOL = Nothing
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' Comments: Starts at the end of the notes section of the contact and
''' erases whitespace characters so that new timestamps have a
''' consistent look.
'''
''' Arguments: objDoc [in] The Word.Document representing the notes
''' section of the contact.
'''
''' Date Developer Action
''' ------------------------------------------------------------------------ ''' 12/02/2010 Tim Hays Created
'''
Private Sub TrimTrailingSpaces(objDoc As Word.Document)
Dim objSel As Word.Selection
Dim x As Integer

' Create a Selection object and selects all text.
Set objSel = objDoc.Windows(1).Selection
objSel.WholeStory

' Get the number of characters.
x = objSel.Characters.Count

' Go backwards through the characters removing whitespaces characters until
' we find one that doesn't need removed or until we reach the first letter.
Do While (x > 0) And (NeedsDeleted(Asc(objSel.Characters(x))) = True)
objSel.Characters(x).Delete
x = x - 1
Loop

' Clears memory because VBA doesn't do it automatically
Set objSel = Nothing
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' Comments: Evaluates a character to determine if it should be deleted or
''' not.
'''
''' Arguments: CurrentChar [in] An Integer representing the ASCII code of
''' the character to evaluate
'''
''' Returns: Boolean Returns true or false indicating whether the
''' current ASCII character should be deleted.
'''
''' Date Developer Action
''' ------------------------------------------------------------------------ ''' 12/02/2010 Tim Hays Created
'''
Private Function NeedsDeleted(CurrentChar As Integer) As Boolean
Dim ReturnValue As Boolean

' Assume character doesn't need deleted
ReturnValue = False

' If character is space (32), carriage return(13), line feed(10), vertical tab(11) or horizontal tab(9) then
' we want to delete it.
If CurrentChar = 32 Or CurrentChar = 13 Or CurrentChar = 10 Or CurrentChar = 11 Or CurrentChar = 9 Then
ReturnValue = True
End If
' Set return value
NeedsDeleted = ReturnValue
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' Comments: There is no way in VBA to directly set focus to a control
''' in Outlook 2010. So the windows API must be used to find
''' the appropriate window and set focus on it. This subroutine
''' does just that. Outlook 2010 Contacts can be in stylized
''' form or in Windows Forms 2.0 mode. This deals with both.
''' by using the EnumerateChildWindows function to search for
''' the WordEditor class ("_WwG").
'''
''' Arguments: ContactCaption [in] The caption at the top of the contact
''' item for the contact we want to set the focus
''' for.
'''
''' Date Developer Action
''' ------------------------------------------------------------------------ ''' 12/02/2010 Tim Hays Created
'''
Public Sub SetFocusOnNotes(ContactCaption As String)
Dim lResourceHwnd As Long
' Get window handle for the contact item.
lResourceHwnd = FindWindow("rctrl_renwnd32", ContactCaption)
If lResourceHwnd > 0 Then
' Direct child of parent resource
lResourceHwnd = FindDirectChildByClassName(lResourceHwnd, "AfxWndW") ' Form Body
If lResourceHwnd > 0 Then
' Direct child of parent resource
lResourceHwnd = FindDirectChildByClassName(lResourceHwnd, "AfxWndW") ' Form Body Child
If lResourceHwnd > 0 Then
' Direct child of parent resource
lResourceHwnd = FindDirectChildByClassName(lResourceHwnd, "#32770") ' Dialog Body
If lResourceHwnd > 0 Then
' The "_WwG" may be in multiple places depending on the version of the form being
' used so we use EnumerateChildWindows to search for it.
EnumerateChildWindows lResourceHwnd, "_WwG" ' WordEditor
End If
End If
End If
End If
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' Comments: This function will find a child window with the given class
''' name that is a direct decendant of the given window handle.
'''
''' Arguments: lHwnd [in] The handle for the parent window.
''' item for the contact we want to set the focus
''' for.
''' sClassName [in] The name of the child class we are looking
''' for.
'''
''' Returns: Long The handle of the child window that has the
''' given class name.
'''
''' Date Developer Action
''' ------------------------------------------------------------------------ ''' 12/02/2010 Tim Hays Created
'''
Private Function FindDirectChildByClassName(ByVal lHwnd As Long, sClassName As String) As Long
Dim lRes As Long
' Get the first child of the given window
lRes = GetWindow(lHwnd, GW_CHILD)
' Only continue if we have a handle for the child window
If lRes Then
' Loop until we run out of child windows
Do
' Check if the current child window handle has a class name that matches the
' one we are looking for.
If GetClassNameEx(lRes) = sClassName Then
' Return the handle to the current child window.
FindDirectChildByClassName = lRes

' Exit this function
Exit Function
End If

' Get the next child window
lRes = GetWindow(lRes, GW_HWNDNEXT)
Loop While lRes <> 0
End If
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' Comments: Begins the process of enumerating child windows by locating
''' the window handle of the specified parent window and calling
''' the EnumChildWindows API.
'''
''' Arguments: sParentWindowClass [in] The class name of the parent window
''' whose children we need to search.
''' sParentWindowTitle [in] The title of the parent window whose
''' children we need to search.
'''
''' Date Developer Action
''' ------------------------------------------------------------------------ ''' 12/02/2010 Tim Hays Created from http://www.appspro.com/Tips/VBA%20Tips.htm
'''
Public Sub EnumerateChildWindows(ByVal lParentHwnd As Long, ByVal sClassToSearchFor As String)
' Set the class to search For
sChildClassToSearchFor = sClassToSearchFor

' Enumerate all child windows
EnumChildWindows lParentHwnd, AddressOf lEnumChildProc, 0&
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' Comments: This callback function is called once by the EnumChildWindows
''' API for each child window it locates.
'''
''' Arguments: hWnd [in] The window handle of the current child window.
''' lParam [in] An optional value that can be passed to this
''' procedure by the EnumChildWindows API call. Not
''' used in this application.
'''
''' Returns: Long A value of 1 if the enumeration process should
''' continue or a value of 0 to stop enumeration.
'''
''' Date Developer Action
''' ------------------------------------------------------------------------ ''' 12/02/2010 Tim Hays Created from http://www.appspro.com/Tips/VBA%20Tips.htm
'''
Public Function lEnumChildProc(ByVal hwnd As Long, ByVal lParam As String) As Long
' Set buffer size
Const lBUFFER_LENGTH As Long = 256
Dim lReturn As Long
Dim sChildClassName As String

' A return value of 1 means continue enumerating.
lReturn = 1

' Get the class name of the current child window.
sChildClassName = GetClassNameEx(hwnd)

' Check if the class name matches the window class we're looking for.
If sChildClassName = sChildClassToSearchFor Then
' Send a message to the control to set focus to it.
MsgBox CBool(SetForegroundWindow(hwnd))
SendMessage hwnd, WM_SETFOCUS, 0, 0
'SendMessage hwnd, EN_SETFOCUS, 0, 0
' Return 0 to stop enumerating windows.
lReturn = 0
End If

lEnumChildProc = lReturn
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' Comments: The GetClassName ARI call returns a padded string. This
''' function leave plenty of room to collect the name and then
''' trims off excess padding.
'''
''' Arguments: hWnd [in] The handle of the window to get the class
''' name for.
'''
''' Returns: String The class name of the window with the given handle.
'''
''' Date Developer Action
''' ------------------------------------------------------------------------ ''' 12/02/2010 Tim Hays Created from http://www.appspro.com/Tips/VBA%20Tips.htm
'''
Private Function GetClassNameEx(ByVal lHwnd As Long) As String
' Create a variable use to check if we successfully
' retrieved a class name.
Dim lRes As Long

' Create Buffer to hold the name
Dim sBuffer As String * 256

' Get the class name
lRes = GetClassName(lHwnd, sBuffer, 256)

' Check if we successfully retrieve a class name
If lRes <> 0 Then
' Trim and return the class name.
GetClassNameEx = Left$(sBuffer, lRes)
End If
End Function

Tim Hays
 
T

Timothy Hays



I wanted to post my final code in case anyone ever needs it in the future. It is probably not the most efficient code but it works.

Option Explicit

''' This code is based on the code from
''' 1. http://www.vboffice.net/smp
''' 2. http://www.appspro.com/Tips/VBA%20Tips.htm
'''
''' I modified it to work with Outlook 2010.

' External Windows API declarations
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) 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 Function GetWindow Lib "user32" (ByVal hWnd As Long, ByVal wCmd As Long) As Long
Private Declare Function EnumChildWindows Lib "user32" (ByVal hWndParent As Long, ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Private Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
Private Declare Function SetCursorPos Lib "user32.dll" (ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Public Declare Sub Sleep Lib "kernel32" (ByVal Milliseconds As Long)

' Constants used by the GetSystemMetrics function
Const SM_CXSCREEN As Long = 0
Const SM_CYSCREEN As Long = 1
Const SM_CXVIRTUALSCREEN As Long = 78
Const SM_CYVIRTUALSCREEN As Long = 79

' Constants for use with the Mouse_Event function
Private Const MOUSEEVENTF_ABSOLUTE = &H8000 ' absolute move 32768
Private Const MOUSEEVENTF_LEFTDOWN = &H2 ' left button down 2
Private Const MOUSEEVENTF_LEFTUP = &H4 ' left button up 4
Private Const MOUSEEVENTF_MIDDLEDOWN = &H20 ' middle button down 32
Private Const MOUSEEVENTF_MIDDLEUP = &H40 ' middle button up 64
Private Const MOUSEEVENTF_MOVE = &H1 ' mouse move 1
Private Const MOUSEEVENTF_RIGHTDOWN = &H8 ' right button down 8
Private Const MOUSEEVENTF_RIGHTUP = &H10 ' right button up 16

' Used with GetWindow to specify child window
Private Const GW_CHILD = 5

' Used with GetWindow to specify next window
Private Const GW_HWNDNEXT = 2

' Used to send a message to the affected window.
Private Const WM_SETFOCUS = &H7

' Type used for various Mouse functions
Private Type POINTAPI
X As Long
Y As Long
End Type

' Type used for various mouse_event function
' to store click information.
Public Type MOUSEINPUT
dx As Integer
dy As Integer
mouseData As Integer
dwFlags As Integer
dwtime As Integer
dwExtraInfo As Integer
End Type

' Type used by the GetWindowRect funciton
Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

'Type to hold the Windows message information
Private Type MSG
hWnd As Long
'the window handle of the app
message As Long
'the type of message (e.g. keydown)
wParam As Long
'the key code
lParam As Long
'not used
time As Long
'time when message posted
pt As POINTAPI
'coordinate of mouse pointer
End Type
' Used to store the class to search for in the EnumerateChildWindows
Private sChildClassToSearchFor As String

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' Comments: Removes any whitespace characters from the end of the notes
''' section of a contact. It then adds two carriage returns,
''' puts a timestamp, current users name and a " - T" in the bottom
''' of the notes section. It changes the text for the timestamp
''' and users name to blue.
'''
''' Date Developer Action
''' ------------------------------------------------------------------------ ''' 12/02/2010 Tim Hays Created
'''
Sub TimeStamp()
Dim objOL As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim objDoc As Word.Document
Dim objSel As Word.Selection
Dim strStamp As String
Dim strLeadIn As String
Dim TextSize As Integer
Dim OriginalCursorPosition As POINTAPI

' Because the ALT key is used to start the macro
' it causes the research text to show when the
' macro runs. So we pause 200ths of a second
' so the user can take their hand off the ALT
' key.
Pause 0.2

On Error Resume Next
Set objOL = Application
' Only use if editor type is WordEditor
If objOL.ActiveInspector.EditorType = olEditorWord Then
' Set variables
Set objDoc = objOL.ActiveInspector.WordEditor
Set objNS = objOL.Session

' Save current cursor position
GetCursorPos OriginalCursorPosition

' Set Focus to the Notes section
SetFocusOnNotes Application.ActiveInspector.Caption

' Need to make sure the control is clicked before we preceed.
DoEvents

' Create text
strStamp = Now & " - " & objNS.CurrentUser.Name
strLeadIn = " - T"

' Deletes Trailing spaces at the end of the notes area.
TrimTrailingSpaces objDoc
' Create Selection object and select all text
Set objSel = objDoc.Windows(1).Selection
objSel.WholeStory

' Gets size of text for use later.
TextSize = objSel.Characters.Count

' move cursor to the end of the text
objSel.Collapse (Word.WdCollapseDirection.wdCollapseEnd)
objSel.Move wdStory, 1

' Inserts the new timestamp
If TextSize < 2 Then
objSel.InsertAfter (strStamp & strLeadIn)
Else
objSel.InsertAfter (vbCrLf & vbCrLf & strStamp & strLeadIn)
End If

' Sets the color of the new timestamp to blue.
Set objSel = objDoc.Windows(1).Selection
objSel.Find.ClearFormatting
objSel.Find.Text = strStamp
objSel.Find.Replacement.ClearFormatting
objSel.Find.Replacement.Font.ColorIndex = wdBlue
objSel.Find.Replacement.Text = ""
objSel.Find.Forward = True
objSel.Find.Wrap = wdFindContinue
objSel.Find.Execute Replace:=wdReplaceAll

' Moves the cursor to the end of the text.
Set objSel = objDoc.Windows(1).Selection
objSel.WholeStory
objSel.Collapse (Word.WdCollapseDirection.wdCollapseEnd)
objSel.Move wdStory, 1

' Restore cursor back to its original position
SetCursorPos OriginalCursorPosition.X, OriginalCursorPosition.Y
End If

' Clears memory because VBA doesn't do it automatically
Set objSel = Nothing
Set objDoc = Nothing
Set objNS = Nothing
Set objOL = Nothing
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' Comments: Starts at the end of the notes section of the contact and
''' erases whitespace characters so that new timestamps have a
''' consistent look.
'''
''' Arguments: objDoc [in] The Word.Document representing the notes
''' section of the contact.
'''
''' Date Developer Action
''' ------------------------------------------------------------------------ ''' 12/02/2010 Tim Hays Created
'''
Private Sub TrimTrailingSpaces(objDoc As Word.Document)
Dim objSel As Word.Selection
Dim X As Integer

' Create a Selection object and selects all text.
Set objSel = objDoc.Windows(1).Selection
objSel.WholeStory

' Get the number of characters.
X = objSel.Characters.Count

' Go backwards through the characters removing whitespaces characters until
' we find one that doesn't need removed or until we reach the first letter.
Do While (X > 0) And (NeedsDeleted(Asc(objSel.Characters(X))) = True)
objSel.Characters(X).Delete
X = X - 1
Loop

' Clears memory because VBA doesn't do it automatically
Set objSel = Nothing
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' Comments: Evaluates a character to determine if it should be deleted or
''' not.
'''
''' Arguments: CurrentChar [in] An Integer representing the ASCII code of
''' the character to evaluate
'''
''' Returns: Boolean Returns true or false indicating whether the
''' current ASCII character should be deleted.
'''
''' Date Developer Action
''' ------------------------------------------------------------------------ ''' 12/02/2010 Tim Hays Created
'''
Private Function NeedsDeleted(CurrentChar As Integer) As Boolean
Dim ReturnValue As Boolean

' Assume character doesn't need deleted
ReturnValue = False

' If character is space (32), carriage return(13), line feed(10), vertical tab(11) or horizontal tab(9) then
' we want to delete it.
If CurrentChar = 32 Or CurrentChar = 13 Or CurrentChar = 10 Or CurrentChar = 11 Or CurrentChar = 9 Then
ReturnValue = True
End If
' Set return value
NeedsDeleted = ReturnValue
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' Comments: There is no way in VBA to directly set focus to a control
''' in Outlook 2010. So the windows API must be used to find
''' the appropriate window and set focus on it. This subroutine
''' does just that. Outlook 2010 Contacts can be in stylized
''' form or in Windows Forms 2.0 mode. This deals with both
''' by using the EnumerateChildWindows function to search for
''' the WordEditor class ("_WwG").
'''
''' Arguments: ContactCaption [in] The caption at the top of the contact
''' item for the contact we want to set the focus
''' for.
'''
''' Date Developer Action
''' ------------------------------------------------------------------------ ''' 12/02/2010 Tim Hays Created
'''
Public Sub SetFocusOnNotes(ContactCaption As String)
Dim lResourceHwnd As Long
' Get window handle for the contact item.
lResourceHwnd = FindWindow("rctrl_renwnd32", ContactCaption)

If lResourceHwnd > 0 Then
' Direct child of parent resource
lResourceHwnd = FindDirectChildByClassName(lResourceHwnd, "AfxWndW") ' Form Body
If lResourceHwnd > 0 Then
' Direct child of parent resource
lResourceHwnd = FindDirectChildByClassName(lResourceHwnd, "AfxWndW") ' Form Body Child
If lResourceHwnd > 0 Then
' Direct child of parent resource
lResourceHwnd = FindDirectChildByClassName(lResourceHwnd, "#32770") ' Dialog Body
If lResourceHwnd > 0 Then
' The "_WwG" may be in multiple places depending on the version of the form being
' used so we use EnumerateChildWindows to search for it.
EnumerateChildWindows lResourceHwnd, "_WwG" ' WordEditor
End If
End If
End If
End If
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' Comments: This function will find a child window with the given class
''' name that is a direct decendant of the given window handle.
'''
''' Arguments: hWnd [in] The handle for the parent window.
''' item for the contact we want to set the focus
''' for.
''' sClassName [in] The name of the child class we are looking
''' for.
'''
''' Returns: Long The handle of the child window that has the
''' given class name.
'''
''' Date Developer Action
''' ------------------------------------------------------------------------ ''' 12/02/2010 Tim Hays Created
'''
Private Function FindDirectChildByClassName(ByVal hWnd As Long, sClassName As String) As Long
Dim lRes As Long
' Get the first child of the given window
lRes = GetWindow(hWnd, GW_CHILD)
' Only continue if we have a handle for the child window
If lRes Then
' Loop until we run out of child windows
Do
' Check if the current child window handle has a class name that matches the
' one we are looking for.
If GetClassNameEx(lRes) = sClassName Then
' Return the handle to the current child window.
FindDirectChildByClassName = lRes

' Exit this function
Exit Function
End If

' Get the next child window
lRes = GetWindow(lRes, GW_HWNDNEXT)
Loop While lRes <> 0
End If
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' Comments: Begins the process of enumerating child windows by locating
''' the window handle of the specified parent window and calling
''' the EnumChildWindows API.
'''
''' Arguments: sParentWindowClass [in] The class name of the parent window
''' whose children we need to search.
''' sParentWindowTitle [in] The title of the parent window whose
''' children we need to search.
'''
''' Date Developer Action
''' ------------------------------------------------------------------------ ''' 12/02/2010 Tim Hays Created from http://www.appspro.com/Tips/VBA%20Tips.htm
'''
Public Sub EnumerateChildWindows(ByVal lParentHwnd As Long, ByVal sClassToSearchFor As String)
' Set the class to search For
sChildClassToSearchFor = sClassToSearchFor

' Enumerate all child windows
EnumChildWindows lParentHwnd, AddressOf lEnumChildProc, 0&
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' Comments: This callback function is called once by the EnumChildWindows
''' API for each child window it locates.
'''
''' Arguments: hWnd [in] The window handle of the current child window.
''' lParam [in] An optional value that can be passed to this
''' procedure by the EnumChildWindows API call. Not
''' used in this application.
'''
''' Returns: Long A value of 1 if the enumeration process should
''' continue or a value of 0 to stop enumeration.
'''
''' Date Developer Action
''' ------------------------------------------------------------------------ ''' 12/02/2010 Tim Hays Created from http://www.appspro.com/Tips/VBA%20Tips.htm
'''
Public Function lEnumChildProc(ByVal hWnd As Long, ByVal lParam As String) As Long
' Set buffer size
Const lBUFFER_LENGTH As Long = 256
Dim lReturn As Long
Dim sChildClassName As String

' A return value of 1 means continue enumerating.
lReturn = 1

' Get the class name of the current child window.
sChildClassName = GetClassNameEx(hWnd)

' Check if the class name matches the window class we're looking for.
If sChildClassName = sChildClassToSearchFor Then
' Click on the control to set focus there
ClickTheLeftMouseHwd (hWnd)
' Return 0 to stop enumerating windows.
lReturn = 0
End If

lEnumChildProc = lReturn
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' Comments: The GetClassName ARI call returns a padded string. This
''' function leave plenty of room to collect the name and then
''' trims off excess padding.
'''
''' Arguments: hWnd [in] The handle of the window to get the class
''' name for.
'''
''' Returns: String The class name of the window with the given handle.
'''
''' Date Developer Action
''' ------------------------------------------------------------------------ ''' 12/02/2010 Tim Hays Created from http://www.appspro.com/Tips/VBA%20Tips.htm
'''
Private Function GetClassNameEx(ByVal hWnd As Long) As String
' Create a variable use to check if we successfully
' retrieved a class name.
Dim lRes As Long

' Create Buffer to hold the name
Dim sBuffer As String * 256

' Get the class name
lRes = GetClassName(hWnd, sBuffer, 256)

' Check if we successfully retrieve a class name
If lRes <> 0 Then
' Trim and return the class name.
GetClassNameEx = Left$(sBuffer, lRes)
End If
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' Comments: Clicks the left mouse button on the window with the given
''' hwnd handle.
'''
''' Arguments: hWnd [in] The handle of the window to to click on.
'''
''' Date Developer Action
''' ------------------------------------------------------------------------ ''' 12/03/2010 Tim Hays Created
'''
Private Sub ClickTheLeftMouseHwd(hWnd As Long)
Dim ControlCoordinates As RECT
Dim ClickPoint As POINTAPI

' Get the coordinates of our the notes area.
GetWindowRect hWnd, ControlCoordinates

' Convert Control Coordinates to PointAPI Type
' We add some units because the conversion process
' in the next step isn't exact.
ClickPoint.X = ControlCoordinates.Left + 30
ClickPoint.Y = ControlCoordinates.Top + 30

' Set the click point
ClickPoint = ConvertScreenCoordinatesToAbsoluteCoordinates(ClickPoint)

' Move the mouse to the correct position
mouse_event MOUSEEVENTF_MOVE + MOUSEEVENTF_ABSOLUTE, ClickPoint.X, ClickPoint.Y, 0&, 0&

' Click the mouse
mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' Comments: The mouse_event function accepts mouse coordinates in Absolute
''' coordinates. This means that each monitor has its vertical
''' and horizontal resolution divided into 65,000 units. So in
''' order to use the mouse_event, you have to convert screen
''' coordinates to absolute coordinates.
'''
''' Arguments: Position [in] A point containing the coordinates to
''' convert. The coordinates need to be in
''' screen coordinates.
'''
''' Date Developer Action
''' ------------------------------------------------------------------------ ''' 12/03/2010 Tim Hays Created
Private Function ConvertScreenCoordinatesToAbsoluteCoordinates(Position As POINTAPI) As POINTAPI
Dim ScreenX As Long
Dim ScreenY As Long
Dim DesktopX As Long
Dim DesktopY As Long
Dim UnitsPerPixelX As Single
Dim UnitsPerPixelY As Single
Dim ReturnResult As POINTAPI


' It is possible for someone to have multiple monitors.
' The only way to determin this is to compare the
' Screen resolution (which is monitor 1) with the
' virtual desktop.
ScreenX = GetSystemMetrics(SM_CXSCREEN)
ScreenY = GetSystemMetrics(SM_CYSCREEN)
DesktopX = GetSystemMetrics(SM_CXVIRTUALSCREEN)
DesktopY = GetSystemMetrics(SM_CYVIRTUALSCREEN)
' Now convert position to Absolute Units
' In absolute units, each monitor
' width is divided into 65,000 units.
' The same for the monitor height.
' Determine Units Per Pixel
If ScreenX = DesktopX Then
UnitsPerPixelX = 65000 / DesktopX
Else
UnitsPerPixelX = (65000 * (DesktopX / ScreenX)) / DesktopX
End If
If ScreenY = DesktopY Then
UnitsPerPixelY = 65000 / DesktopY
Else
UnitsPerPixelY = (65000 * (DesktopY / ScreenY)) / DesktopY
End If

' Convert the coordinates
ReturnResult.X = CLng(Position.X * UnitsPerPixelX)
ReturnResult.Y = CLng(Position.Y * UnitsPerPixelY)
ConvertScreenCoordinatesToAbsoluteCoordinates = ReturnResult
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' Comments: Pauses for the number of seconds specified. Seconds can be
''' specified down to 1/100 of a second. When using this set of
''' macros, the ALT key is used. For some unknown reason the ALT
''' key being held down is passed on to Outlook after the macro
''' is started. Outlook then brings up the SEARCH capability that
''' is normally done when you hold down the ALT key and click a word.
''' to bypass this, I pass the macro.
'''
''' Arguments: Seconds [in]The time in seconds to sleep.
'''
''' Date Developer Action
''' ------------------------------------------------------------------------ ''' 12/03/2010 Tim Hays Created
Public Sub Pause(ByVal Seconds As Single)
Const MaxSystemSleepInterval = 25
Const MinSystemSleepInterval = 1

Dim ResumeTime As Double
Dim Factor As Long
Dim SleepDuration As Double

Factor = CLng(24) * 60 * 60

ResumeTime = Int(Now) + (Timer + Seconds) / Factor

Do
SleepDuration = (ResumeTime - (Int(Now) + Timer / Factor)) * Factor * 1000
If SleepDuration > MaxSystemSleepInterval Then SleepDuration = MaxSystemSleepInterval
If SleepDuration < MinSystemSleepInterval Then SleepDuration = MinSystemSleepInterval
Sleep SleepDuration
Loop Until Int(Now) + Timer / Factor >= ResumeTime
End Sub

Tim Hays
 

Top