Question

我想知道是否有人可以帮助我。

我正在尝试编写一个脚本，该脚本会在电子表格中向收件人发送多封电子邮件，其中包含各种其他信息。

我已经开始使用Ron de Bruin的解决方案（见下文）。

Sub Email()
  Dim OutApp As Object
  Dim OutMail As Object
  Dim cell As Range
  Dim Src As Worksheet

  Application.ScreenUpdating = False
  Set OutApp = CreateObject("Outlook.Application")
  Set Src = ThisWorkbook.Sheets("List")        
  On Error GoTo cleanup

  Src.Select
  For Each cell In Columns("C").Cells.SpecialCells(xlCellTypeConstants)
    If cell.Value Like "?*@?*.?*" Then        
      Set OutMail = OutApp.CreateItem(0)
      On Error Resume Next
      With OutMail
        .To = cell.Value
        .Subject = "Splunk Access"
        .Body = "Hi " & Cells(cell.Row, "A").Value _
                & vbNewLine & vbNewLine & _
                "I have created an account: Production." & _
                vbNewLine & vbNewLine & _
                "Your username and password for this environment is:" & _
                vbNewLine & vbNewLine & _
                "Username: " & Cells(cell.Row, "B").Value & _
                vbNewLine & _
                "Password: " & Cells(cell.Row, "E").Value & _
                vbNewLine & vbNewLine & _
                "Please log in at your earliest convenience and change your password to a more secure one. " & _
                vbNewLine & vbNewLine & _
                "You can do this by clicking on your name on the top menu and select ‘Edit Account’." & _
                vbNewLine & vbNewLine & _
                "You can use this link to get to the log in page for this environment: " & _
                vbNewLine & vbNewLine & _
                "PROD: right/en-US/account/logout " & _
                vbNewLine & vbNewLine & _
                "Many thanks and kind regards"
        .send
      End With
      On Error GoTo 0
      Set OutMail = Nothing
    End If
  Next cell

cleanup:
  Set OutApp = Nothing
  Application.ScreenUpdating = True
End Sub

这个脚本有效，但我接收了＆＃39; Outlook＆＃39;安全，消息，超过100个收件人，持续按下＆＃34; Ok＆＃34;发送电子邮件。

因此，我进行了更多研究后改变了：

.send

到

.Display
Application.Wait (Now + TimeValue("0:00:01"))
Application.SendKeys "%"

但我遇到的问题是电子邮件已创建，但尚未发送。继续按下＆＃34;发送＆＃34;再次不实用超过100个用户。

然后我尝试了一个CDO解决方案，但我遇到了SMTP地址的问题，因为我使用的是我的作品Microsoft Exchange，我不是管理员，所以没有任何问题。 SMTP详细信息。

我只是想知道是否有人能够看到这个，并提供一些关于如何创建宏以自动运行的指导。

非常感谢和亲切的问候

克里斯

Answer 1

全部，

我设法使用以下内容：

Sub Email()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    Dim Src As Worksheet

    Application.ScreenUpdating = False

    Set OutApp = CreateObject("Outlook.Application")
    Set Src = ThisWorkbook.Sheets("List")

    On Error GoTo cleanup

    Src.Select
    For Each cell In Columns("C").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" Then

            Set OutMail = OutApp.CreateItem(0)
            On Error Resume Next
            With OutMail
                .To = cell.Value
                .Subject = "Access"
                .Body = "Hi " & Cells(cell.Row, "A").Value _
                    & vbNewLine & vbNewLine & _
                        "I have created an account for you" & _
                    vbNewLine & vbNewLine & _
                        "Your username and password for this environment is:" & _
                    vbNewLine & vbNewLine & _
                        "Username: " & Cells(cell.Row, "B").Value & _
                    vbNewLine & _
                        "Password: " & Cells(cell.Row, "E").Value & _
                    vbNewLine & vbNewLine & _
                        "Please log in at your earliest convenience and change your password to a more secure one. " & _
                    vbNewLine & vbNewLine & _
                        "You can do this by clicking on your name on the top menu and select 'Edit Account'." & _
                    vbNewLine & vbNewLine & _
                        "You can use this link to get to the log in page for this environment: " & _
                    vbNewLine & vbNewLine & _
                        "PROD: https://right/en-US/account/logout " & _
                    vbNewLine & vbNewLine & _
                        "Many thanks and kind regards"
'                    .send

                    .Display
            Application.Wait (Now + TimeValue("0:00:02"))
            Application.SendKeys "%s"
            Application.SendKeys "+o"
           End With
            On Error GoTo 0
            Set OutMail = Nothing
        End If
        Next cell

cleanup:
            Set OutApp = Nothing
            Application.ScreenUpdating = True

End Sub

我通过进一步测试发现，当发送＆＃39;发送时会自动弹出。按钮被这个命令单击了Application.SendKeys＆＃34;％s＆＃34;，所以我添加了Application.SendKeys＆＃34; + o2，自动点击＆＃34; OK＆＃34;。

亲切的问候

克里斯

Answer 2

试

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual

这当然是使用.Send

确保在子

结束时重新打开它们

通过VBA发送多封电子邮件

2 个答案: