Automatic Email and Save macro

[beginner88]

Hello,

Currently using the following macros to automatically email a spreadsheet out at 9am. For some reason it sends the email more than once at times (at the same time). I'm also looking to have it email at two different times in the day (9am and 1pm), but only once each time.

Sub Email_And_Save()
'Working in Excel 2000-2016
'Mail a changed copy of the ActiveWorkbook with another file name
    Dim wb1 As Workbook
    Dim wb2 As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String
    Dim OutApp As Object
    Dim OutMail As Object


    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With


    Set wb1 = ActiveWorkbook


    'Make a copy of the file/Open it/Edit it/Mail it/Delete it
    'If you want to change the file name then change only TempFileName
    TempFilePath = Environ$("temp") & "\"
    TempFileName = " Daily Report & " & Format(Now, "dd-mmm-yy h-mm-ss")
    FileExtStr = "." & LCase(Right(wb1.Name, Len(wb1.Name) - InStrRev(wb1.Name, ".", , 1)))


    wb1.SaveCopyAs TempFilePath & TempFileName & FileExtStr
    Set wb2 = Workbooks.Open(TempFilePath & TempFileName & FileExtStr)




    '**************Add code to edit the file here********************
    'Insert a text and Date in cell A1 of the first sheet in the workbook.
    'Other things you can think of are for example, delete a whole sheet or a range.
    wb2.Worksheets(1).Range("A1").Value = "Created on " & Format(Date, "dd-mmm-yyyy")


    'Save the file after we changed it with the code above
    wb2.Save




    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)


    On Error Resume Next
    With OutMail
        .To = ""
        .CC = ""
        .BCC = ""
        .Subject = "Daily Report"
        .Body = "Here is Today's Report"
        .Attachments.Add wb2.FullName
        'You can add other files also like this
        '.Attachments.Add ("C:\test.txt")
        .Send   'or use .Display
    End With
    On Error GoTo 0
    wb2.Close savechanges:=False


    'Delete the file
    Kill TempFilePath & TempFileName & FileExtStr


    Set OutMail = Nothing
    Set OutApp = Nothing


    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    
    Application.OnTime TimeValue("09:10:00"), "AutoRun"
   
   
End Sub

Sub AutoRun()
    
    Application.Wait (Now + TimeValue("00:00:05"))
    Application.OnTime TimeValue("09:00:00"), "Email_And_Save"


End Sub

 

[yky]

The Email_And_Save sends one copy of the email. It then calls AutoRun which in turn calls Email_And_Save. Thus, another copy of the email is sent. You need to comment out the line that calls AutoRun.

    With OutMail
        .To = ""
        .CC = ""
        .BCC = ""
        .Subject = "Daily Report"
        .Body = "Here is Today's Report"
        .Attachments.Add wb2.FullName
        'You can add other files also like this
        '.Attachments.Add ("C:\test.txt")
        .Send   'or use .Display   '<- here, the email is sent
    End With
   ......
   ......
       
    Application.OnTime TimeValue("09:10:00"), "AutoRun" '<- here, AutoRun is called to send the email again. Comment out this line.
   
   
End Sub