How to send an email via macro

excelthong

Active Member
Joined
Jul 13, 2006
Messages
313
hi

may i know what is the best way for excel to alert me when i am in office in the mean time my home pc is still runnning live data? i hope that excel can give me a call or something like that is this possible?

the more reasonable way i can think off is to send me an email to my mobile, so can it be done?

hope you guys can post some comments/solution.

thank you
 

Excel Facts

Excel motto
Not everything I do at work revolves around Excel. Only the fun parts.

hatman

Well-known Member
Joined
Apr 8, 2005
Messages
2,664
Well, the basic Excel Object Model allows you to send an entire workbook as an attachment to an E-mail. Or you can automate Outlook and send a message having any content you like. But either way, the security protocols of the system are such that the action is not intended be able to be completed without the user accepting the fact that a program is attempting to access your Address Book (which is a hallmark of many viruses). It may be possible to use WINAPI function calls to dismiss the security window without user intervention, but that can be a pain.

Alternatively, I have made some inraods automating Internet Explorer, which potentially provides the option of using a WebMail program, thus circumventing the basic office Security protections.

i have also heard tell that Instant Messenger can be automated without raising security issues...
 

excelthong

Active Member
Joined
Jul 13, 2006
Messages
313
hi hatman

thanks for your reply..

so what can i do if i just want excel to send an email,with the simple title "alert" alert to my mobile?

and may i know what is the code also?

thank you
 

hatman

Well-known Member
Joined
Apr 8, 2005
Messages
2,664
Well, what I was trying to communicate is that there are several options, each with pros and cons. And you may be limited by the software you have available.

Do you have Outlook installed on your computer? Using Outlook migt be considered the most universal method, but it also poses the most challenges. Here is a thread with code to automate outlook.

Do you have Instant Messaenger installed on your computer? I have never used IM to do this, but have read somewhere here (can't find the thread) that it provides the easiest method, though I don't know what sort of fidelity it provides...

Do you have a WebMail account (Yahoo, Gmail, Etc)? Here is a link to a thread where I started discussing this... the code is still unfinished, but I have learned enough since then to have a shot at completing it... assuming that you would be using Yahoo.
 

excelthong

Active Member
Joined
Jul 13, 2006
Messages
313

ADVERTISEMENT

hi hatman

thanks for your reply...unfortunately when i try to run the codees it has error saying that 'user defined type not defined' and it hightlight the error at Dim OutApp As Outlook.Application

i try to go to tools and get 'reference' but seems like i cant find this option...any thought?

by the way i am using outlook2003 and excel 2003. hope you can give me a hand again.

thank you
 

excelthong

Active Member
Joined
Jul 13, 2006
Messages
313
hi hatman,

have found the Microsoft outlook 11.0 object library and microsoft office outlook view control

then try to run the code again it prompt this error
run time error '-1248395261(b5970003)':automation error.

any thought?
 

excelthong

Active Member
Joined
Jul 13, 2006
Messages
313

ADVERTISEMENT

Oh Hatman,

how stupid i am@@ thanks very much it works (run time error because i do not have the attachement file with me)

however i stilll have a final question, as i said previously i need this email to be sent automatically ...but i see a message contents 'an application is trying to access Outlook, it may be a virus, do you want to continue?'

how can i get rid of this message or how can i make it to automatically click yes for me so that it can send the mail automatically?

thank you again..its awesome
 

hatman

Well-known Member
Joined
Apr 8, 2005
Messages
2,664
however i stilll have a final question, as i said previously i need this email to be sent automatically ...but i see a message contents 'an application is trying to access Outlook, it may be a virus, do you want to continue?'

how can i get rid of this message or how can i make it to automatically click yes for me so that it can send the mail automatically?

thank you again..its awesome

Ahh, now you come to the crux of the matter. Since I last visited this subject, I have come across what I believe to be a similar issue on a completely project. Here is the thread where Right_Click gave me some code to close a security dialog in Internet Explorer. I believe that with a little bit of tweaking, it can probably be used to close the security dialog that appears when Excel tries to access Outlook.

Give it a shot, if you have a tough time with it, let me know and I will try to help you through it. I am not 100% certain that this is gonna work in this situation, but it's the best answer I have at my fingertips.
 

hatman

Well-known Member
Joined
Apr 8, 2005
Messages
2,664
BOOKMARK ME NOW!!! I am useful.

I had a chance to play with this for a little bit this afternoon, and I see now that my initial assumption was incorrect. I assumed that the code would continue to execute after the Security dialog popped up, just like when I was manipulating Internet Explorer, which would allow me to find the Handle of the Dialog, and close it. But apparently Microsoft has tried to close a loop-hole for viruses by HALTING code execution until the .Send method is completed... and that hangs until the user dismisses the security dialog...

Hmph... doesn't Microsoft TRUST us?

So the only other thing I could think of was to .Display the new message window, and then insert the appropriate keystrokes into the data stream to send the message (Alt, F, E seemed easiest).

This is a bit ugly, but it seems pretty bullet-proof:

Rich (BB code):
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
'remember that these are Hexadecimal values...
Private Const VK_E = &H45 'E key
Private Const VK_F = &H46 'F 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

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)
    
    'this code comes from here: http://www.allapi.net/apilist/SendInput.shtml
    '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

    Dim GInput(0 To 1) As GENERALINPUT
    Dim KInput As KEYBDINPUT
    
    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)))
End Sub

Sub Send_New_Mail(xTo As String, xSubject As String, xBody As String, Optional xAttach)
    'for support contact paul.sasur@hs.utc.com
    'tools->references->Microsoft Outlook 11.0 Object Library
    
    Dim OutApp As Outlook.Application
    Dim OutMail As Outlook.MailItem
    Dim RecipName As String
    Dim OLbCreated As Boolean
    Dim newMsgHwnd As Long
    Dim Attchmnts As Boolean
    Dim Item As Variant
    Dim Attach_Array As Variant
    Dim Flag As Boolean
    
    '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) = "" Then
            
                Attchmnts = False
                
            End If
        
        End If
        
    End If
    
    '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, create one
        Set OutApp = CreateObject("Outlook.Application")
        'remember that we created a new instance of outlook
        OLbCreated = 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 = ""
        .BCC = ""
        .Subject = xSubject
        .body = xBody
        
        '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(.Subject)
            
        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
        
        'send the appropriate key strokes to send the message
        SendKey VK_MENU
        SendKey VK_F
        SendKey VK_E
        
        On Error GoTo err_handler
        
        Do
        
            newMsgHwnd = Get_Window_Handle(.Subject)
            
            If Flag = True Then
            
                Exit Do
                
            End If
            
        Loop
        
        On Error GoTo 0
    
    End With
    
        
    'quit Outlook if we created a new instance, and reset object and item to nothing
    If OLbCreated Then OutApp.Quit
    Set OutMail = Nothing
    Set OutApp = Nothing
    
err_handler:
    
    Flag = True
    
End Sub

Sub SAMPLE_CALL()

    Dim yBody As String
    Dim yTo As String
    Dim ySubject As String
    Dim yatt
    
    yTo = "paul.sasur@hs.utc.com"
    yBody = "TEST"
    ySubject = "SUBJECT"
    yatt = Array("U:\versions.txt", "U:\Check_version.xla")
    
    Send_New_Mail yTo, ySubject, yBody, yatt
    

End Sub

EDIT: the code was not as robust as I liked, and I also wanted to encapsulate this so it would be more portable... anyway, if you had my previous code, ditch it, this is better.

EDIT 2: Okay, so i noticed that you wanted to send an attachment, and the new encapsulated code did NOT have any provisiona for that... so I tweaked it again to allow attachments... send a single file/pathname a s aparameter, or send an array of file/pathnames. Will not attach anything if ANY file/pathname does not exist.

EDIT 3: With large attachments or slow data connections, it was possible for Outlook to receive quit command before outbox was empty... added a check to loop until the message window disappears...
 

hatman

Well-known Member
Joined
Apr 8, 2005
Messages
2,664
Notice to anyone who stumbles upon this thread:

I have been using the above code in several projects for the better part of 5 years, and several things have plagued me with it. 1) Version support, I chose to bind early when I originally built this, which was a mistake. 2) Spellchecker: I never found a good way to dismiss teh spellchecker if there was a spelling error in the message. 3) handling of machines that don;t have ANY outlook installed on them at all

So here is an update that accounts for all of that:

Rich (BB code):
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
 

Forum statistics

Threads
1,136,269
Messages
5,674,743
Members
419,525
Latest member
helensesc

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top