VBA Mails - Getting created, but not sent

[prabby25101981]

Hi Guys,

I have a code which sends the files from the computer to different vendors. The code works fine sometimes, but sometimes, the mails get created but are not sent. Can someone look at the code and let me know a way out of this problem?

Sub SendFinalReports()
Application.EnableEvents = False
Dim LRowMac, Choice As Long
Dim WB1, WB2 As Workbook
Dim Dt As Date
Dim MainPath, MainExt, MainName, TempName, DtInName, FileNameZIP As String
Dim SenderSign(4) As String
Dim OutApp As Object
Dim OutMail As Object
Dim sttime, endtime, tottime As Variant
sttime = Time
Choice = MsgBox("Do you really want to send the reports now?", 4)
If Choice = 7 Then
    MsgBox "Code Terminated"
    Exit Sub
End If
Dt = InputBox("Enter the date for which you want to send the report [MM/DD/YYYY format]")
DtInName = Format(Dt, "MM.DD.YYYY")
For n = 1 To 4
    SenderSign(n) = InputBox("Enter Signature Line" & n)
Next
Set WB1 = ActiveWorkbook
DefPath = WB1.Path
If Right(DefPath, 1) <> "\" Then
    DefPath = DefPath & "\"
End If
  
MainName = WB1.Sheets("MacroSupportSheet").Range("B2").Value
LRowMac = WB1.Sheets("MacroSupportSheet").Range("A65536").End(xlUp).Row
For i = 2 To LRowMac
    TempName = WB1.Sheets("MacroSupportSheet").Range("A" & i).Value
    FileNameZIP = DefPath & MainName & " " & DtInName & " MTD " & TempName & ".zip"
    'Set WB2 = Workbooks.Open(MainPath & "\" & MainName & " " & DtInName & " MTD " & TempName & MainExt)
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next
    With OutMail
        .To = WB1.Sheets("MacroSupportSheet").Range("I" & i).Value
        .CC = WB1.Sheets("MacroSupportSheet").Range("S" & i).Value
        .BCC = ""
        .Subject = Left(WB1.Name, Len(WB1.Name) - 4) & " " & TempName
        .Body = "Team," & vbNewLine & vbNewLine & "Attached is the report for " & TempName & "." _
            & vbNewLine & vbNewLine & "Thanks and Regards," & vbNewLine & SenderSign(1) & vbNewLine & SenderSign(2) _
            & vbNewLine & SenderSign(3) & vbNewLine & SenderSign(4) & vbNewLine
        .Attachments.Add FileNameZIP
        .Display
        Application.Wait (Now + TimeValue("0:00:02"))
        Application.SendKeys "%s"
        Application.Wait (Now + TimeValue("0:00:01"))
    End With
    Kill FileNameZIP
    Set OutMail = Nothing
    Set OutApp = Nothing
Next
FileNameZIP = DefPath & MainName & " " & DtInName & " MTD.zip"
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
    .To = WB1.Sheets("MacroSupportSheet").Range("I25").Value
    .CC = WB1.Sheets("MacroSupportSheet").Range("S25").Value
    .BCC = ""
    .Subject = Left(WB1.Name, Len(WB1.Name) - 4)
    .Body = "Team," & vbNewLine & vbNewLine & "Attached is the report." _
        & vbNewLine & vbNewLine & "Thanks and Regards," & vbNewLine & SenderSign(1) & vbNewLine & SenderSign(2) _
        & vbNewLine & SenderSign(3) & vbNewLine & SenderSign(4) & vbNewLine
    .Attachments.Add FileNameZIP
    .Display
    Application.Wait (Now + TimeValue("0:00:03"))
    Application.SendKeys "%s"
    Application.Wait (Now + TimeValue("0:00:01"))
End With
Kill FileNameZIP
WB2.Close SaveChanges:=False
Set OutMail = Nothing
Set OutApp = Nothing
MsgBox "All mails sent.  Please check Sent Items in Outlook and make sure you are connected to the network."
endtime = Time
tottime = endtime - sttime
MsgBox "Total Time Taken : " & Format(tottime, "hh:mm:ss")
Application.EnableEvents = True
End Sub

Thanks everyone for help!

 

[mvptomlinson]

My guess is the SendKeys commands are not hitting their mark, as is often the case with SendKeys. If something else takes focus or the e-mail isn't visible or ready to accept a Send command yet, the sendkeys will fail (or worse, send those keys to another application which could be bad).

You can avoid this by just sending it without displaying the e-mail. Change any instances of ".Display" to ".Send" and remove your Wait and SendKeys commands.