Option Explicit
Private Declare Function FindWindow _
Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function SetForegroundWindow _
Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function SendInput _
Lib "user32.dll" _
(ByVal nInputs As Long, _
pInputs As GENERALINPUT, _
ByVal cbSize As Long) As Long
Private Declare Sub CopyMemory _
Lib "kernel32" _
Alias "RtlMoveMemory" _
(pDst As Any, _
pSrc As Any, _
ByVal ByteLen As Long)
Private Declare Function GetWindow _
Lib "user32.dll" _
(ByVal hwnd As Long, _
ByVal wCmd As Long) As Long
Private Declare Function GetWindowText _
Lib "user32" Alias "GetWindowTextA" _
(ByVal hwnd As Long, _
ByVal lpString As String, _
ByVal cch As Long) As Long
Private Declare Function GetWindowTextLength _
Lib "user32" Alias "GetWindowTextLengthA" _
(ByVal hwnd As Long) As Long
Private Type KEYBDINPUT
wVk As Integer
wScan As Integer
dwFlags As Long
time As Long
dwExtraInfo As Long
End Type
Private Type GENERALINPUT
dwType As Long
xi(0 To 23) As Byte
End Type
'virtual key codes are here: http://msdn.microsoft.com/library/d...en-us/wceddk/html/wceddkVirtual_Key_Codes.asp
'Nope, MSDN moved it and I can't find it... here is another place to get them: http://www.math.msu.su/~vfnik/WinApi/other/virtualkeycodes.html
'remember that these are Hexadecimal values...
Private Const VK_E = &H45 'E key
Private Const VK_F = &H46 'F key
Private Const VK_I = &H49 'I key
Private Const VK_MENU = &H12 'ALT key
'constants for SendKey
Private Const KEYEVENTF_KEYUP = &H2
Private Const INPUT_KEYBOARD = 1
'constants for Get_Window_Handle
Private Const GW_HWNDFIRST = 0 ' Get first Window handle
Private Const GW_HWNDNEXT = 2 ' Get next window handle
Function Get_Outlook_Application(OutApp As Object) As Boolean
Set OutApp = Nothing
Get_Outlook_Application = False
'ignore any errors
On Error Resume Next
'attempt to capture an existing instance of Outlook
Set OutApp = GetObject(, "Outlook.Application")
're-set to stop on errors
On Error GoTo 0
'test to see if we successfully captured an existing instance of Outlook
If OutApp Is Nothing Then
'if no instance of outlook was found, try to create one
On Error Resume Next
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo 0
'remember that we created a new instance of outlook
Get_Outlook_Application = True
End If
End Function
Private Function Get_Window_Handle(winTEXT As String)
Dim hwnd As Long
Dim hwndTask As Long
Dim sClass As String
Dim ThisWindowText As String
'get any old window from the system...
hwnd = FindWindow(vbNullString, vbNullString)
'using a good handle, get the handle of the very first window in the zOrder of the system
hwndTask = GetWindow(hwnd, GW_HWNDFIRST)
'keep getting new window handles until there are no more
Do While hwndTask
'create a null-terminated string to hold the name of the current window handle
ThisWindowText = String(GetWindowTextLength(hwndTask) + 1, Chr$(0))
'get the name of the current window handle
GetWindowText hwndTask, ThisWindowText, Len(ThisWindowText)
'see if this name contains the text we are lookng for
If InStr(1, ThisWindowText, winTEXT, vbTextCompare) > 0 Then
'if the name of the current window contians the text we are looking
'for, then assign this window handle to our function, and 22-skidoo
Get_Window_Handle = hwndTask
Exit Do
End If
'grab the handle of the next window of the zOrder of the system
hwndTask = GetWindow(hwndTask, GW_HWNDNEXT)
Loop
End Function
Private Sub SendKey(bKey As Byte, Optional bAlt As Boolean)
'this code comes from here: http://www.allapi.net/apilist/SendInput.shtml
'Huh, this site seems to have been hijacked by a Bot... don't know
'if there is a mirror somewhere.
'Note that this can be used to insert Mouse events and Hardware events into
'data stream also, but I lobotomized it, since the code seemed incomplete,
'and we didn't need that functionality anyway
'also added the ability to hold the Shift Key, to get CAPS and secondary characters
Dim GInput() As GENERALINPUT
Dim KInput As KEYBDINPUT
If Not bAlt Then
'resize the array for a single keypress
ReDim GInput(0 To 1)
KInput.wVk = bKey 'the key we're going to press
KInput.dwFlags = 0 'press the key
'copy the structure into the input array's buffer.
GInput(0).dwType = INPUT_KEYBOARD ' keyboard input
CopyMemory GInput(0).xi(0), KInput, Len(KInput)
'do the same as above, but for releasing the key
KInput.wVk = bKey ' the key we're going to realease
KInput.dwFlags = KEYEVENTF_KEYUP ' release the key
GInput(1).dwType = INPUT_KEYBOARD ' keyboard input
CopyMemory GInput(1).xi(0), KInput, Len(KInput)
'send the input now
Call SendInput(2, GInput(0), Len(GInput(0)))
Else
'resize the array to hold 2 keypresses
ReDim GInput(0 To 3)
KInput.wVk = VK_MENU 'alt Key
KInput.dwFlags = 0 'press the key
'copy the structure into the input array's buffer.
GInput(0).dwType = INPUT_KEYBOARD ' keyboard input
CopyMemory GInput(0).xi(0), KInput, Len(KInput)
KInput.wVk = bKey 'the key we're going to press
KInput.dwFlags = 0 'press the key
'copy the structure into the input array's buffer.
GInput(1).dwType = INPUT_KEYBOARD ' keyboard input
CopyMemory GInput(1).xi(0), KInput, Len(KInput)
'do the same as above, but for releasing the key we pressed
KInput.wVk = bKey ' the key we're going to realease
KInput.dwFlags = KEYEVENTF_KEYUP ' release the key
'copy the structure into the input array's buffer.
GInput(2).dwType = INPUT_KEYBOARD ' keyboard input
CopyMemory GInput(2).xi(0), KInput, Len(KInput)
'do the same as above, but for releasing the SHIFT key
KInput.wVk = VK_MENU 'alt Key
KInput.dwFlags = KEYEVENTF_KEYUP ' release the key
'copy the structure into the input array's buffer.
GInput(3).dwType = INPUT_KEYBOARD ' keyboard input
CopyMemory GInput(3).xi(0), KInput, Len(KInput)
'send the input now
Call SendInput(4, GInput(0), Len(GInput(0)))
End If
End Sub
Function Send_New_Mail(xTo As String, xSubject As String, xBody As String, Optional xCC As String, Optional xAttach, Optional xVotingOptions, Optional xFlagRequest As String, Optional olCategory As String) As Date
'for support contact paul.sasur@hs.utc.com
'tools->references->Microsoft Outlook 11.0 Object Library
'xvotingoptions must be a Semi-Colon delimited string
Const Dwell As Single = 10
Const olMailItem As Integer = 0
Const olFolderSentMail As Integer = 5
Dim OutApp As Object 'Outlook.Application
Dim OutMail As Object 'Outlook.MailItem
Dim myNamespace As Object 'Namespace
Dim myfolder As Object 'MAPIFolder
Dim myMessage As Object 'MailItem
Dim RecipName As String
Dim OLbCreated As Boolean
Dim newMsgHwnd As Long
Dim Attchmnts As Boolean
Dim Voting As Boolean
Dim Item As Variant
Dim Attach_Array As Variant
Dim Voting_Array As String
Dim flag As Boolean
Dim Tmr As Single
Dim RetDate As Date
Dim SpellChecker_Handle As Long
OLbCreated = Get_Outlook_Application(OutApp)
If OutApp Is Nothing Then
Send_New_Mail = 0
Exit Function
End If
'determine if attachements were queued
If Not (IsMissing(xAttach)) Then
'if there are attachments, then set my flag to true
Attchmnts = True
'determine if ther eis an array of attachements
If IsArray(xAttach) Then
'map the array of attachements into the local array variable
Attach_Array = xAttach
'look at each file/pathname to see it it is real
For Each Item In xAttach
'if there is a bad file/pathname, then don't attach anything...
If Dir(Item) = "" Then
Attchmnts = False
Exit For
End If
Next Item
Else
'even though there is only one attachment, I need to map it into the local array of attachements
Attach_Array = Array(xAttach)
'if the filepathname does not exist, then don't send any attachments
If Dir(xAttach) = "" Or xAttach = "" Then
Attchmnts = False
End If
End If
End If
'determine if Votingoptions were queued
If Not (IsMissing(xVotingOptions)) Then
'if there are Voting Options, then set my flag to true
Voting = True
End If
'create a new mail item (message)
Set OutMail = OutApp.CreateItem(olMailItem)
'set properties of the New Mail Item (Message)
With OutMail
.To = xTo
.CC = xCC
.BCC = ""
.Subject = xSubject
.Body = xBody
.FlagRequest = xFlagRequest
If olCategory <> "" Then
.Categories = olCategory
End If
If Voting Then
.VotingOptions = xVotingOptions
End If
'add files as attachments, if they exist
If Attchmnts Then
For Each Item In Attach_Array
.Attachments.Add Item
Next Item
End If
'we need to display the new message window... note that the User's
'screen will momentarily flicker as this happens
.display
'loop until the the New message window appears, and we find the handle
newMsgHwnd = 0
Do Until newMsgHwnd <> 0
newMsgHwnd = Get_Window_Handle(xSubject)
Loop
'the new message window had BETTER be in the foreground, so
'do NOT attempt to step through this code in break mode: it won't work
SetForegroundWindow newMsgHwnd
DoEvents
'WEIRD. When Outlook is instantiated by this routine, sometimes
'the code outpaces the ability for the system to refresh the screen.
'For that situation, I did what I HATE to do: I added a fixed wait period.
If OLbCreated Then
Tmr = Timer
Do Until Timer - Tmr >= 0.1
Loop
End If
'send the appropriate key strokes to the window to send the message
SendKey VK_MENU
SendKey VK_F
SendKey VK_E
On Error GoTo err_handler
'Wait for the window to disappear
Do
DoEvents
SpellChecker_Handle = 0
SpellChecker_Handle = Get_Window_Handle("Spelling: English (U.S.)")
If SpellChecker_Handle <> 0 Then
SetForegroundWindow SpellChecker_Handle
SendKey VK_I, True
End If
.Subject = .Subject
If flag Then Exit Do
Loop
End With
'look for the new message in the Sent Items folder
'I actually WAIT for it to show up there, and harvest the Sent Time
Set myNamespace = OutApp.GetNamespace("MAPI")
Tmr = Timer
again:
Set myfolder = myNamespace.GetDefaultFolder(olFolderSentMail)
On Error Resume Next
Set myMessage = myfolder.Items(xSubject)
On Error GoTo 0
If Not myMessage Is Nothing Then
Send_New_Mail = myMessage.ReceivedTime
Else
If Timer - Tmr < Dwell Then
GoTo again
Else
Send_New_Mail = Now
MsgBox "I could not confirm that " & xSubject & " was actually sent, please verify that it showed up in your Sent Items Folder. If you have problems, please contact paul Sasur at X2506", vbCritical, "Folder Disconnected"
End If
End If
'quit Outlook if we created a new instance, and reset object and item to nothing
If OLbCreated Then OutApp.Quit
Set myfolder = Nothing
Set myNamespace = Nothing
Set OutMail = Nothing
Set OutApp = Nothing
Exit Function
err_handler:
flag = True
Resume Next
End Function
Sub SAMPLE_CALL()
Dim yBody As String
Dim yTo As String
Dim ySubject As String
Dim yatt
Dim yCC As String
Dim yVoting As String
Dim Sent_Mail_Time As Date
yTo = "paul.sasur@hs.utc.com"
yCC = "paul.sasur@hs.utc.com"
yBody = "Spell some wrds wrong in bdy to test teh dismissel of the spellcheckerr wndow <mailto:paul.sasur@hs.utc.com &subject=reply subject here &body=reply body here &cc=paul.sasur@hs.utc.com>"
ySubject = "Subject"
yVoting = "Completed"
Sent_Mail_Time = Send_New_Mail(yTo, ySubject, yBody)
End Sub
