複数のメールをVBA経由で送信

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 

このスクリプトは動作しますが、私はその後、100以上の受信者に、電子メールを送信するために「OK」を押し続けることは現実的ではないのOutlookのセキュリティ、メッセージを受信します。

だからより多くの研究以下の私が変更されました：

.send 

を

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

にしかし、私が持っている問題は、電子メールが作成されていることですが、送信されません。再び100人以上のユーザーに「送信」を押し続けるのは現実的ではありません。

私はCDOソリューションを試しましたが、管理者ではない私のMicrosoft Exchangeを使用しているため、SMTPアドレスに問題が発生しました。そのためSMTPの詳細はありません。

私はちょうど誰かがこれを見ることができるかもしれないかどうか疑問に思っていました。自動的にマクロを作成する方法についていくつか指導します。

多くの感謝と種類について

クリスは

Answer 1

が、これは、サブ

の最後に背面にそれらを有効にしてください

.Send

を使用して、もちろんです

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

を試してみてください

Answer 2

すべて、

は、私は、これは以下の作業を取得するために管理：

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 

私は、「送信」ボタンが、このコマンドApplication.SendKeys「％sの」によってクリックされた際に自動ポップアップが現れていること、さらにテストで見つかりました、そこで私はApplication.SendKeys "+ o2を追加して" OK "を自動的にクリックしました。

種類が

クリス