CODEWITHSUNDEEP
excelvbaemailoutlooksendkeys
Bilbo
Bilbo

Reputation: 3

Apply SendKeys in a loop to send email

I have an Excel workbook with business contacts. I need to send emails to some of them.

Outlook is in an Enterprise environment with User permissions. I cannot make changes to the Macro or Object Model options in Outlook's Trust Center.

In a locked down Outlook installation:
.Send failed in Group Policy environment.
I set up a folder to send with an event driven .AddItem which failed in Group Policy environment.

Both were tested on an enabled Outlook installation to confirm the code worked.

I found code here to use SendKeys targeted to a specific window. It works one time. The second email sits there.
I click any open Excel window (workbook or VBE) the second email sends, the next email opens.
I click any open Excel window (workbook or VBE) the third email sends, the next email opens.
And so on.

There is a controller workbook.
The Controller contains the operational code and some parameters.
The Controller opens a source data workbook (>107K records) and adds some columns.
I build an ADODB recordset containing the records I want.
I use the recordset to build an email, and display it.
This is where it pauses.
It should send it and start over.
There are no errors.

Something I just noticed. If I run the code from the VBE, it builds but doesn't send the first email.

Modified version of the code.

Declare PtrSafe Function GetDesktopWindow Lib "USER32" () As LongPtr
Declare PtrSafe Function GetWindow Lib "USER32" (ByVal hwnd As LongPtr, ByVal wCmd As Long) As LongPtr
Declare PtrSafe Function GetWindowText Lib "USER32" Alias "GetWindowTextA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal cch As LongPtr) As Long

Sub ProcessDataToEmail()

'MsgBox "ProcessDataToEmail"

    Counter_Sent = 0

    Set obj_ADODB_rsData = GetOLEDBRecordSetFromExcel(obj_XL_WS_Params.Range("OLEDB_Query").Value & obj_XL_WS_Params.Range("OLEDB_Query").Offset(1, 0).Value)
    
    Do While Not obj_ADODB_rs.EOF
        If Counter_Sent = 50 Then Exit Do
        
        If IsNull(obj_ADODB_rs.Fields(Col_Sent - 1).Value) Then
            BuildEmail
            MsgBox "Going to Send Keys"
            SendKeysToWindow obj_OL_MailItem.Subject
            MsgBox "Back from Send Keys"
'            ManageOutlookObjects False, "OL_MailItemNew", , , , , , , obj_OL_MailItem
            
            obj_XL_WS_Data.Cells(obj_ADODB_rs.Fields("ID").Value + 1, Col_Sent).Value = Now()
            Counter_Sent = Counter_Sent + 1
            obj_XL_WS_Params.Range("Sent_Counter").Value = Counter_Sent
        End If
        obj_ADODB_rs.MoveNext
    Loop

    obj_ADODB_rsData.Close
    Set obj_ADODB_rsData = Nothing

End Sub

Sub BuildEmail()

    MsgBox "Entering: BuildEmail"

    ManageOutlookObjects True, "OL_MailItemNew", , obj_OL_App, , , , , obj_OL_MailItem
    
    obj_OL_MailItem.To = obj_ADODB_rs.Fields(Col_Email - 1).Value
    obj_OL_MailItem.Subject = BuildEmailSubject
    obj_OL_MailItem.BodyFormat = olFormatHTML
    obj_OL_MailItem.HTMLBody = obj_XL_WS_Params.Range("Salutation").Value & " " & obj_XL_WS_Params.Range("Email_Body_1").Value & " " & obj_ADODB_rs.Fields(Col_LastName - 1).Value & "," & _
                    "<P>" & obj_XL_WS_Params.Range("Email_Body_2").Value & _
                    "<P>" & obj_XL_WS_Params.Range("Email_Body_3").Value & " " & obj_ADODB_rs.Fields(Col_City - 1).Value & _
                    " " & obj_XL_WS_Params.Range("Email_Body_4").Value & _
                    "<P>" & obj_XL_WS_Params.Range("Email_Body_5").Value & _
                    obj_XL_WS_Params.Range("Email_Signature_1").Value
    obj_OL_MailItem.Display

End Sub

Sub SendKeysToWindow(CaptionWindowsString As String)
Dim DesktopWindowHandle As LongPtr
Dim WindowHandle As LongPtr
Dim str_Buffer As String * 255
Dim str_Text As String

    DesktopWindowHandle = GetDesktopWindow
    WindowHandle = GetWindow(DesktopWindowHandle, 5)

    Do While (WindowHandle <> 0)

        str_Buffer = String$(255, Chr$(0))
        GetWindowText WindowHandle, str_Buffer, 255
        str_Text = String$(100, Chr$(0))
        WindowHandle = GetWindow(WindowHandle, 2)

        If InStr(str_Buffer, CaptionWindowsString) <> 0 Then
            AppActivate str_Buffer, True
            DoEvents
            SendKeys "%S", True
            DoEvents
            Exit Do
        End If

    Loop

End Sub

I tried to add a recursive "SendKeysToWindow" targeted at the Controller window (without the sendkey step).

I added MsgBoxes to see how far the code gets.

The last MsgBox dialog is

Entering: BuildEmail

It does not throw the MsgBox dialog

Back from Send Keys

Since the email becomes visible (obj_OL_MailItem.Display) and it isn't hung or crashed, it must be pausing during or just after this line.

Upvotes: 0

Views: 65

Answers (1)

Bilbo
Bilbo

Reputation: 3

So I didn't actually "fix" the issue.

But I did manage to work around it as follows.

I removed the code that initiated the SendKeys ('SendKeysToWindow') after each email was created. This left all the emails completed and open (unsent) on the desktop.

Then, after all emails are completed, I reinserted a modified version of the 'SendKeysToWindow.'

The modification was to remove the Exit Do line that caused the process to end after a single email received the keys to be sent. Instead I used the existing SentCounter to count down to zero. in this way, the sub processes through all the open windows looking for the matching subject line and sends each one it find until the counter = 0. Then the code flow exits this sub.

This works well but isn't the desired solution as it gets pretty resource hungry to open and leave open 25-30 emails on the desktop before sending them all at once.

Anyway, it's working and I can press on but it anyone has any ideas as to what's actually happening with he above original code, I'd love to hear it.

Upvotes: 0

Related Questions