Automated Email VBA from Excel - Freezes before send

[ELeGault]

This may be a lot to ask of anyone to investigate. I have a Macro that I built up over a couple weeks that does exactly what I need. Refreshes my data, Creates an image of a range, Pastes that image into an email that is structured in the VBA and sends it to desired people with appropriate fields. Updates the last run time on the main sheet, Saves the open book, then saves it to a shared location without the macros, Then Closes.

Runs beautifully when I hit play. The issue comes when I allow windows task to run it for me at 1 in the morning. For some reason it is freezing before sending the paste command. I come in and the email is sitting open waiting to be sent without the image pasted!? Sometimes (Most of the time) the email will then send without the image before I have a chance to click/edit and/or close it.

My question is first blanketed without looking at the code - are there known causes of this behavior?
If not, or even if so... feel free to peruse through my code and poke holes in it so that it can be enhanced please.

Thanks,

So to start everything Windows has a task to open the document at 12:59a

Then I have in "ThisWorkbook" the following Private sub to run on time value XX

Private Sub Workbook_Open()
Application.OnTime TimeValue("01:00:00"), "Refresh"
Application.OnTime TimeValue("01:15:00"), "SendEmail"
Application.OnTime TimeValue("01:16:00"), "Save_Quit"
End Sub

Then in Module 1 is the macro list of actions as follows

Sub Refresh()
'Refreshing entire workbook which contains a query to MySQL
Windows("REPORTNAME.xlsm").Activate
    ActiveWorkbook.RefreshAll
End Sub
Sub SendEmail()
Dim EmailSubject As String
Dim SendTo As String
Dim EmailBody As String
Dim BccTo As String
Dim ccTo As String

'Disable screen updating so that I dont have to watch it jump around
    Application.ScreenUpdating = False

'I call on the sub to get and create an image out of a range in which we desire saving it to clipboard for later paste
    CreateImage

    EmailSubject = "REPORT update " & Date - 1
 
    SendTo = "WHOM I SEND IT TO"
    ccTo = ""
    BccTo = ""

'HTML body Blank VB line for paste in which comes later through SendKeys
    EmailBody = "Good Morning,<P> The REPORT has been updated for 10/01/2014 through " & Date - 1 & ".<br>" & vbNewLine & _
    "Please follow this link to review a copy of the <A HREF=LINK>FRIENDLY NAME</A><BR>" & vbNewLine & _
    "" & vbNewLine & _
    "<Br><BR><Br>****This Automated Message was ran at " & Now & "****" & vbNewLine & _
    "<p style='font-family:calibri;font-size:10;Color:gray'> The information in this e-mail is confidential and may be legally privileged. It is intended solely for the addressee and access to this e-mail by anyone else is unauthorized. If you are not the intended recipient, any disclosure, copying, distribution or any action taken or omitted to be taken in reliance on it, is prohibited and may be unlawful. The information contained herein and attached is and remains the property of COMPANY Scheme in whom, in addition to the aforesaid, copyright vests. If you are not the intended recipient, you are hereby notified to kindly and without any delay confirm that all copies of such information have been destroyed. </p>"
        
'Time to open outlook and input all fields
Set App = CreateObject("Outlook.Application")
Set Itm = App.CreateItem(0)
        
With Itm
    .Subject = EmailSubject
    .SentOnBehalfOfName = "FROMWHO"
    .To = SendTo
    .Cc = ccTo
    .Bcc = BccTo
    .HTMLBody = EmailBody
    'Display must happen for the paste of Send Keys, unless someone has a better way of pasting image over
    .Display
    'Wait gives the email time to update fields, then we wait again to allow paste update to happen
    Wait
    'Special commands are just sending the keys to the active window, in this case new email from outlook
    SendSpecialCommands
    Wait
    .Send
End With
Set App = Nothing
Set Itm = Nothing
    Sheets("FRONT PAGE").Select
    Application.ScreenUpdating = True

End Sub


Sub CreateImage()
    'The information for the email is on a hidden tab, so we unhide, select, copy, paste image, resize, copy (To Clipboard) delete the image and then hide the tab again
    Sheets("Email").Visible = True
    Sheets("Email").Select
    Range("G3:P28").Select
    Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    Range("E1").Select
    ActiveSheet.PasteSpecial Format:="Picture (Enhanced Metafile)", Link:=False _
        , DisplayAsIcon:=False
    Selection.ShapeRange.ScaleWidth 1.1, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.ScaleHeight 1.1, msoFalse, msoScaleFromTopLeft
    Selection.Copy
    Selection.Delete
    Sheets("Email").Select
    ActiveWindow.SelectedSheets.Visible = False
End Sub
Sub SendSpecialCommands()
'Modify to send the set of commands that work for your structured Email or file
        SendKeys "{down}"
        SendKeys "{down}"
        SendKeys "{down}"
        SendKeys "{down}"
        SendKeys "^v", True
End Sub
Sub Wait()
'I Set a delay of ten seconds, this is what I use for all my delays in hours, minutes and/or seconds
    newHour = Hour(Now())
    newMinute = Minute(Now())
    newSecond = Second(Now()) + 10
    waitTime = TimeSerial(newHour, newMinute, newSecond)
    Application.Wait waitTime
End Sub
Sub Save_Quit()
'Saving this workbook, marking the time it was ran, saving a copy without macros to shared location and then quitting
Application.DisplayAlerts = False
    Windows("REPORTNAME.xlsm").Activate
        MarkTime
    ActiveWorkbook.Save
        SaveCopy
    Application.Quit
End Sub
Sub MarkTime()
'Note the last run time within the sheet
    Sheets("FRONT PAGE").Select
    Range("D2").Value = Now
End Sub
Sub SaveCopy()
'Saving a copy of the workbook to a shared location for other to open with Read only prompt
ActiveWorkbook.SaveAs Filename:= _
    "FILEPATH\REPORTNAME.xlsx" _
    , FileFormat:=51, ReadOnlyRecommended:=True, CreateBackup:=False
    End Sub

[ELeGault]

Let me know if you have questions about any of the Sub's within that code - should be straight forward and I added some comments within it so shouldn't have any but always glad to answer questions. Just hoping someone here will have a finger to point at what I did wrong that would cause the full automation to fail/freeze like it does. Like I said it runs beautifully when I force run the macros, which is why I cannot wrap my head around why it keeps failing..

[ELeGault]

Someone has got to know VBA enough to see the issue with that. I know it is a working model, but something is killing the automation and I myself just cannot see it. Even if your throwing noodles at the wall, please share your thoughts!

Thanks

[cory0789]

May I ask why you are using sendkeys??? is the data that is going into the email not in excel??? I will continue looking at your code to see what is going on.. I am trying to get it to run on my computer now...

I think it is the sendkeys or the image that is causing it to run poorly automated... not positive until I see the workbook I would try using the code I provided and instead of copying and pasting using sendkeys just let vba do all of the sending... if you must create an image make the image on a new sheet and hide the sheet like you do with the other one and simply call the image to be pasted into the BODY section of the email below... not sure if this helps

TempFilePath = Environ$("temp") & "\"
    TempFileName = "Open Order " & iDate & " South"

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

    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
        With OutMail
            .to = "WHO YOU ARE SENDING IT TOOOOOO"
            .CC = ""
            .BCC = ""
            .Subject = "ENTER SUBJECT DATA HERE" & iDate
            .Body = "BODY DATA HERE... "
            .Attachments.Add Destwb.FullName
            'You can add other files also like this
            '.Attachments.Add ("C:\test.txt")
            .Send   'or use .Display
        End With
        On Error GoTo 0
        .Close savechanges:=False
    End With

    'Delete the file you have send
    Kill TempFilePath & TempFileName & FileExtStr

    Set OutMail = Nothing
    Set OutApp = Nothing

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With

I really need your document to figure out why you are using images and all of that... it is really confusing the way you have it setup unless we can see what exactly you are trying to do...

[ELeGault]

Absolutely - Let me scrub the doc so it is not any company specific so I don't get in trouble then I can share the actual file - Will change save paths to a Folder on desktop so that it can run fine. The send keys are to paste on the fourth line of the email body. And I make the image of the range so that when some of our execs read it on their different mobile devices they can zoom without it playing games and wrapping odd like it does with a straight range paste. The send keys was my answer as well as getting it to paste on the fourth line in the middle of the HTML body.

[ELeGault]

Here's hoping you find an error in the way I code this. It's technically the first actual VBA I wrote without recording. so I would not be shocked if there are issues with it and/or if there are better approaches.

Thanks

TEST.xlsm

[ELeGault]

Will be in and out throughout the day to see if you have had a chance to play with the file. Let me know if it does not run on your pc... Should (As long as you update the save path in the SaveCopy Sub).

Thanks

[cory0789]

sorry wrong post reply I will look more into later

[ELeGault]

NOOO lol got me all excited - cool cool, thanks Cory

[cory0789]

So the only thing I can find is it doesnt like the copy picture command when running from task scheduler... why I have no idea... I will continue to try to help you out but hopefully someone with a little more knowledge of this can chime in.

[ELeGault]

Awesome, well glad it worked after scrubbing for you, I love how it functions as it can inject the image to the right line... just hate that it is locking up under an automated run... About to test running a separate workbook to see if task scheduler can launch a "Schedule book" to then open up another sheet and run from there...

Fingers crossed, Thanks again for taking a look, if you have recommendations on any of my code feel free to put it on blast. Anything to make it more efficient is always great.

[cory0789]

TEST.xlsm


Try that out, you will have to edit your email into the send email portion and uncomment out your other stuff in the workbook open part but I think this will do what you are wanting...

You can resize the picture that is sent also...

Let me know if it works or not for you

[ELeGault]

So it failed (My Schedule run utilizing a second sheet)

Your version this chart (While it does seem to run), I have/had a working model of this setup as well, the visuals when it came to a mobile device was less than optimal in an email body. There has to be a way to use an actual image or send that to an email body... The next step or option I think is to preform the email in Outlook and make a macro pull the image after excel exports/saves a copy of it. I have not created VBA in outlook yet so that will be fun...but may be the last resort answer.

[ELeGault]

gah still racking my brain... coming to the conclusion that it cannot be done as an actual Image file and they are going to have to deal with a blurry chart... still hopeful someone will have a workaround and/or know why task scheduler differs from force running the macro

[ELeGault]

So I am utilizing the SendRange to HTML through temp file until I can figure this out... - Still not ideal as this looks bad on the Mobile devices -

Hopeful that someone here has faced this or a similar situation and will have a solution for inserting an actual IMAGE into the body of an email (Not through Chart Objects) -

[ELeGault]

There is a method to take a clipboard and save it to image (Essentially export your range as an image file) - worked out for 32 or 64 bit Office - see here