SendKeysToWindow 可以工作一次但不会重复

Question

我有一个 Excel 工作簿，其中包含很多业务联系人。 我需要向一些人发送电子邮件，但不是全部。 Outlook 处于企业环境中，并且只有用户权限，我无法更改 Outlook 信任中心设置中的宏或对象模型选项。

最初，我确实尝试使用 .Send （在组策略环境中失败），然后设置一个文件夹以通过事件驱动的 .AddItem 以编程方式发送（在组策略环境中失败）。 两者都经过测试 - 最初在启用的 Outlook 安装上进行测试，以确认代码确实有效。 它做了 然后是关于锁定 Outlook 安装的后记，但失败了。

我来这里是为了研究使用SendKeys的前景来解决上述无法使用的问题。 我在这里发现了一个非常有用的线程，其中包含一些专门针对特定窗口使用 SendKeys 的代码。有用。一度。第二封电子邮件就放在那里（不发送）。并且代码没有进展。如果我单击任何打开的 Excel 窗口（任何工作簿或 VBE），电子邮件就会发送，下一封电子邮件将打开，它就在那里。 直到我再次单击任何 Excel 窗口（任何工作簿或 VBE），第二封电子邮件就会发送，而第三封电子邮件就会保留在那里。等等等等。

我唯一的辩护是代码确实有效。我确实测试过。 但仅限于发送一封电子邮件。我只需要在 Outlook 中发送基本需求的证明。 我可以。但一次只能发送一封电子邮件。 除非我坐在那里不断点击 Excel 窗口来继续编写代码。

在我看来，单击任何 Excel 窗口都会继续执行代码（代码正在运行但正在等待），这确实很重要。 但我似乎无法弄清楚。 “它”是，代码连续运行到最后，而无需我单击 Excel 窗口。

有一个控制器工作簿。 控制器包含操作代码和一些参数。 控制器打开源数据工作簿（>107K 记录）并添加一些列。 我构建了一个仅包含我想要的记录的 ADODB 记录集。 我使用记录集构建电子邮件并显示它。 这是它暂停的地方。 它应该发送并重新开始。 没有错误。

我应该添加一些我刚刚注意到的内容。 如果我直接从 VBE 运行代码，它甚至不会发送第一封电子邮件。 它构建得很好，但不发送它。

我在下面的代码中包含了我稍微修改过的版本。

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

我尝试添加一个针对控制器窗口的递归“SendKeysToWindow”（没有 sendkey 步骤）， 我添加了几个

MsgBox

来查看代码进展到什么程度。 它抛出的最后一个对话框是

MsgBox "Entering: BuildEmail"

。 它不会抛出 MsgBox“从发送键返回”

由于电子邮件确实变得可见（

obj_OL_MailItem.Display

）并且没有挂起或崩溃，因此它必须在该行期间或之后“暂停”。

Answer 1

但我确实设法解决了这个问题，如下。

我删除了创建每封电子邮件后启动 SendKeys ('SendKeysToWindow') 的代码。 这使得所有已完成并打开（未发送）的电子邮件都在桌面上。

然后，在完成所有电子邮件后，我重新插入了“SendKeysToWindow”的修改版本。

修改是删除 Exit Do 行，该行导致在单个电子邮件收到要发送的密钥后进程结束。相反，我使用现有的 SentCounter 倒数至零。通过这种方式，子进程通过所有打开的窗口寻找匹配的主题行，并发送它找到的每个窗口，直到计数器 = 0。然后代码流退出该子进程。

这很有效，但不是理想的解决方案，因为在一次性发送所有电子邮件之前，在桌面上打开并保留 25-30 封电子邮件会非常消耗资源。

无论如何，它正在工作，我可以继续，但如果任何人对上面的原始代码实际发生了什么有任何想法，我很想听听。