?
Solved

Send email while logged off with VBA, batch file, or scheduled task

Posted on 2011-05-04
8
Medium Priority
?
1,603 Views
Last Modified: 2012-05-11
Hi,

I have a scheduled task to open an excel file.  This file has a macro which runs on open.
The macro updates the Excel file with some data, and creates and sends an email of the output.

This work fine while logged on, but if the scheduled task runs when I am logged off it hangs when the macro tries to open Outlook.  When I come back to the PC the task is still running in the background.  I've tested it without the email portion, and it works fine when logged off.

Could someone help me get this macro to work, or perhaps assist with an alternative?  I was thinking there may be a way to get Excel to save an HTML version of the email, then set another scheduled task, or call a batch file to send the email out as a second step.

I have posted both the Excel macro and the portion that creates the email separately.

Thank you.
Option Explicit
Const CdoPR_ATTACH_MIME_TAG As Long = &H370E001E
Const olSave = 0

Sub Bitmap_to_email()

'// Dimension variables using Latebinding
Dim oOutlookApp As Object
Dim oOutlookMessage As Object
Dim oFSObj As Object
Dim strHTMLBody As String
Dim strTempFilePath_a As String
Dim strTempFilePath_b As String
Dim strTempFilePath_c As String
Dim oOutlookAppAttach As Object
Dim oOutlook_Att As Object
Dim strEntryID As String
Dim oSession As Object
Dim summary1 As String
Dim summary2 As String
Dim summary3 As String
Dim summary4 As String
Dim summary5 As String
Dim summary6 As String

'// Use late binding    'Reference CDO
Dim oMsg As Object      'MAPI.Message
Dim oAttachs As Object  'MAPI.Attachments
Dim oAttach_a As Object   'MAPI.Attachment
Dim oAttach_b As Object   'MAPI.Attachment
Dim oAttach_c As Object   'MAPI.Attachment
Dim colFields_a As Object 'MAPI.Fields
Dim colFields_b As Object 'MAPI.Fields
Dim colFields_c As Object 'MAPI.Fields
Dim oField_a As Object    'MAPI.Field
Dim oField_b As Object    'MAPI.Field
Dim oField_c As Object    'MAPI.Field

'// Sheet
Dim objPict As Object
Dim MyChart_a As Chart
Dim MyChart_b As Chart
Dim MyChart_c As Chart
Dim rgImgSend As Range

Sheets("report").Select
summary1 = Range("B21")
summary2 = Range("B22")
summary3 = Range("B23")
summary4 = Range("B24")
summary5 = Range("B25")
summary6 = Range("B26")
                    
'// Select the range to be sent
Set rgImgSend = Worksheets("report").Range("B2:AG19")


'// Set Range as an Image!
rgImgSend.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
Sheets("email").Select
Range("A1").Select
ActiveSheet.PasteSpecial Format:="Bitmap", Link:=False, DisplayAsIcon:=False

Set objPict = Selection

'// Get the Temp folder path
Set oFSObj = CreateObject("Scripting.FilesystemObject")

strTempFilePath_a = oFSObj.GetSpecialFolder(2) & "\MyImg_a.gif"

    
With objPict
    .Copy
    Set MyChart_a = ActiveSheet.ChartObjects.Add(1, 1, .Width, .Height).Chart
End With

'// Export the chart. We'll use it later
With MyChart_a
    .Paste
    .Export strTempFilePath_a
    .Parent.Delete
    objPict.Delete
End With

'*********************** same thing again for the 2nd range

'// Select the range to be sent
Set rgImgSend = Worksheets("report").Range("AL2:AV19")


'// Set Range as an Image!
rgImgSend.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
Sheets("email").Select
Range("A1").Select
ActiveSheet.PasteSpecial Format:="Bitmap", Link:=False, DisplayAsIcon:=False
Set objPict = Selection

'// Get the Temp folder path
Set oFSObj = CreateObject("Scripting.FilesystemObject")

strTempFilePath_b = oFSObj.GetSpecialFolder(2) & "\MyImg_b.gif"
    
With objPict
    .Copy
    Set MyChart_b = ActiveSheet.ChartObjects.Add(1, 1, .Width, .Height).Chart
End With

'// Export the chart. We'll use it later
With MyChart_b
    .Paste
    .Export strTempFilePath_b
    .Parent.Delete
    objPict.Delete
End With

'*********************** now for the chart

'// Select the range to be sent
Sheets("graphs").Select
ActiveSheet.ChartObjects("28_day_fallout").Activate
Set rgImgSend = Worksheets("graphs").Range("B2:N17")


'// Set Range as an Image!
rgImgSend.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
Sheets("email").Select
Range("A1").Select
ActiveSheet.PasteSpecial Format:="Bitmap", Link:=False, DisplayAsIcon:=False
Set objPict = Selection

'// Get the Temp folder path
Set oFSObj = CreateObject("Scripting.FilesystemObject")

strTempFilePath_c = oFSObj.GetSpecialFolder(2) & "\MyImg_c.gif"
    
With objPict
    .Copy
    Set MyChart_c = ActiveSheet.ChartObjects.Add(1, 1, .Width, .Height).Chart
End With

'// Export the chart. We'll use it later
With MyChart_c
    .Paste
    .Export strTempFilePath_c
    .Parent.Delete
    objPict.Delete
End With



'// Create an instance of Outlook (or use existing instance if it already exists)
On Error Resume Next
Set oOutlookApp = GetObject(, "Outlook.Application")

If Err.Number <> 0 Then
    Set oOutlookApp = CreateObject("Outlook.Application")
    // We need the Application Open in order to NOT show as attachment
    Shell oOutlookApp, vbMaximizedFocus

******I think the above line is where it hangs*****
The rest of the macro does not run while logged off

'// Create a mail item
Set oOutlookMessage = oOutlookApp.CreateItem(0)
Set oOutlookAppAttach = oOutlookMessage.Attachments
'// add graphic as attachment to Outlook message
'// change path to graphic as needed
Set oOutlook_Att = oOutlookAppAttach.Add(strTempFilePath_a)
Set oOutlook_Att = oOutlookAppAttach.Add(strTempFilePath_b)
Set oOutlook_Att = oOutlookAppAttach.Add(strTempFilePath_c)

'// Lets save the msg, this is so that the EntryID property
'// is set.
oOutlookMessage.Close olSave

'// Lets get the unique entry ID of the object.
'// EntryID property corresponds to the MAPI property PR_ENTRYID.
'// MAPI systems assign a permanent, unique ID string when an object
'// is created that does not change from one MAPI session to another.
'// Also, the EntryID changes when an item is moved into another folder.
strEntryID = oOutlookMessage.EntryID

Set oOutlookMessage = Nothing
' *** POSITION CRITICAL *** you must dereference the
' attachment objects before changing their properties
' via CDO
Set oOutlookAppAttach = Nothing


'// initialize CDO session
On Error Resume Next
Set oSession = CreateObject("MAPI.Session")
oSession.Logon "", "", False, False
 
'// get the message created earlier
Set oMsg = oSession.GetMessage(strEntryID)

'// set properties of the attached graphic that make
'// it embedded and give it an ID for use in an <IMG> tag
Set oAttachs = oMsg.Attachments
Set oAttach_a = oAttachs.Item(1)
Set oAttach_b = oAttachs.Item(2)
Set oAttach_c = oAttachs.Item(3)
Set colFields_a = oAttach_a.Fields
Set colFields_b = oAttach_b.Fields
Set colFields_c = oAttach_c.Fields

'// Set oField_a = oFieldsColl.Add (name, Class [, value] [, PropsetID] )
Set oField_a = colFields_a.Add(CdoPR_ATTACH_MIME_TAG, "image/gif_a")
Set oField_a = colFields_a.Add(&H3712001E, "MyIdent_a")

'// Set oField_b = oFieldsColl.Add (name, Class [, value] [, PropsetID] )
Set oField_b = colFields_b.Add(CdoPR_ATTACH_MIME_TAG, "image/gif_b")
Set oField_b = colFields_b.Add(&H3712001E, "MyIdent_b")

'// Set oField_c = oFieldsColl.Add (name, Class [, value] [, PropsetID] )
Set oField_c = colFields_c.Add(CdoPR_ATTACH_MIME_TAG, "image/gif_c")
Set oField_c = colFields_c.Add(&H3712001E, "MyIdent_c")


oMsg.Fields.Add "{0820060000000000C000000000000046}0x8514", 11, True
oMsg.update

'// Here put any HTML you want - this is just an example

strHTMLBody = strHTMLBody & "<span style='color:#1F497D'><p class=MsoNormal>Good Morning, <span style='color:#1F497D'><o:p></o:p></span></p>"
strHTMLBody = strHTMLBody & "<IMG align=baseline border=0 hspace=0 SRC=cid:MyIdent_a><br><br>"
strHTMLBody = strHTMLBody & "<IMG align=baseline border=0 hspace=0 SRC=cid:MyIdent_b><br><br>"
strHTMLBody = strHTMLBody & "<span style='color:#1F497D'>"
strHTMLBody = strHTMLBody & summary1 & "<br>"
strHTMLBody = strHTMLBody & summary2 & "<br>"
strHTMLBody = strHTMLBody & summary3 & "<br>"
strHTMLBody = strHTMLBody & summary4 & "<br>"
strHTMLBody = strHTMLBody & summary5 & "<br><br>"
strHTMLBody = strHTMLBody & "<IMG align=baseline border=0 hspace=0 SRC=cid:MyIdent_c><br><br>"

'// Get the Outlook MailItem again
Set oOutlookMessage = oOutlookApp.GetNamespace("MAPI").GetItemFromID(strEntryID)

'// add HTML content -- the <IMG> tag
With oOutlookMessage
    .To = "sombody@somwhere.com"
    .HTMLBody = strHTMLBody
    .Subject = "Report for " & Format(Now(), "MMM, D, YYYY")
    .Close (olSave)
    .Display
    .Send
End With

'// cleanup
Set oFSObj = Nothing
Set oField_a = Nothing
Set oField_b = Nothing
Set oField_c = Nothing
Set colFields_a = Nothing
Set colFields_b = Nothing
Set colFields_c = Nothing
Set oMsg = Nothing
Set oAttachs = Nothing
Set oAttach_a = Nothing
Set oAttach_b = Nothing
Set oAttach_c = Nothing
Set colFields_a = Nothing
Set colFields_b = Nothing
Set colFields_c = Nothing

oSession.Logoff

Set oSession = Nothing
Set oOutlookApp = Nothing
Set oOutlookMessage = Nothing

Kill strTempFilePath_a
Kill strTempFilePath_b
Kill strTempFilePath_c

End Sub

Open in new window

Private Sub Workbook_Open()

'refreshes the data and pivot tables
ActiveWorkbook.RefreshAll

Sheets("28_day_new").Select
ActiveSheet.Cells.EntireRow.Hidden = False
    Range("A1").Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveCell.Rows("1:1").EntireRow.Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.EntireRow.Hidden = True

'Saves the file - any work past this point will be copied over to the daily\weekly\monthly file
'and should not be saved to the template
 ActiveWorkbook.Save
 
 Sheets("Report").Select

'Hardcodes the data
    Cells.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
 'sends the email
Application.Run "'Daily Template.xlsm'!Bitmap_to_email"
        
'renames the tab
Dim daynum
daynum = Day(Now())
Worksheets("report").Name = daynum

'finds the monthly report workbook
Dim monthnum
If Month(Now()) < 10 Then monthnum = "0" & Month(Now()) Else monthnum = Month(Now())
    Workbooks.Open Filename:= _
        "C:\Daily\Daily 2011_" & monthnum & ".xlsx"
           
'copies the tab
    Sheets("" & daynum).Copy After:=Workbooks("Daily 2011_" & monthnum & ".xlsx"). _
        Sheets(Workbooks("Daily 2011_" & monthnum & ".xlsx").Worksheets.Count)
                
'saves and closes the monthly file
Application.DisplayAlerts = False
Application.Workbooks("Daily 2011_" & monthnum & ".xlsx").RefreshAll
Application.Workbooks("Daily 2011_" & monthnum & ".xlsx").Save
Application.Workbooks("Daliy 2011_" & monthnum & ".xlsx").Close

'closes the template(without saving - b/c we hardcoded the data)
'closes Excel
Excel.Application.Quit


End Sub

The above code works great when logged off, with the exception of the bitmap to email macro call

Open in new window

0
Comment
Question by:TelMaco
  • 4
  • 3
8 Comments
 
LVL 9

Expert Comment

by:sshah254
ID: 35695358
Outlook 2007 should start into "offline" mode by default, if it is not connected.  But this does not seem to be happening for some reason in your case.

Use a condition to check if you are already logged in ... something like the presence of a file on the network, or a ping test or something.

If you are connected, then run the routine to send the email ... else, save the email, or do something else.

Another option is to not use Outlook.  Use some VB/SMTP add-on and use that to send emails using an external account like Yahoo / GMail.

Ss
0
 

Author Comment

by:TelMaco
ID: 35695392
It's not exaclty the same as being logged in.  If I am manually logged in, this works 100%.  Is there a way to set a scheduled task to log myself in?  That would work too,

It's connecting to my network with my creditials for sure.  If I take out the Outlook portion of the code, it work no problem.  Even while logged off.

There is actually more to it where it moves the Excel file to an LAN folder, confirming that I'm connected ok.

I can't even save the email.  The code hangs here:

    Set oOutlookApp = CreateObject("Outlook.Application")
    Shell oOutlookApp, vbMaximizedFocus

Which is before the email is even created, so there is nothing to save.

I'll have to use my Outlook account, external accounts will not be an option for me.

0
 

Author Comment

by:TelMaco
ID: 35699019
I have good news,

I tested this while the PC was logged on and locked.  It works perfectly.

So the only problem is when I'm fully logged off.  I can leave the PC on and locked, but there are some automatic updates which can force my PC to restart overnight.

If I could set a rule on the PC to that would auto login on restart this would work.  Thoughts?

Thanks!
0
Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
LVL 10

Accepted Solution

by:
ReneGe earned 2000 total points
ID: 35701436
Try this batch file.

You can download the "blat" email command line utility here:
http://sourceforge.net/projects/blat/files/Blat%20Full%20Version/Blat%20v2.6.2/blat262.full.zip/download

Dont forget to customize the variables as needed.

Cheers

 
@ECHO OFF
SET Emailer=blat.exe
SET EmailTo=user@emailaddress.com
SET EmailFrom=sysadmin@emailaddress.com
SET EmailSubject=TESTING
SET EmailServer=smtp.server.com
SET EmailBody=THIS IS A TEST

"%Emailer%" -body "%EmailBody%" -to "%EmailTo%" -f "%EmailFrom%" -s "%EmailSubject% %time%" -server "%EmailServer%" -debug -timestamp -log "Email.log" >NUL

Open in new window

0
 

Author Comment

by:TelMaco
ID: 35804628
I can't get this to work:  SET EmailServer=smtp.server.com

I'm getting the server name from Outlook->Tools->Account Settings -> Change:
It shows the Microsoft Exchange Server name there as:
"server.xxxx.xxx"
Nothing i try gets a response from that server though...

This is from within a corp environment & I guess it's blocked somehow.  I just can't get the server to respond.

I think I'm giving up on this one...I did find a workaround (sort of).  
I have set Outlook to open when Windows starts, so it's always running.  
I have a macro in Outlook that will send me an email when Outlook shutsdown.
Since Outlook will only shutdown if the PC is restarting / turned off - I at least get an email to my phone that lets me know things were shutdown, and that I'll have to log it back in once it boots up.

Thanks for the suggestions though.

I'm pretty sure ReneGe's suggestion would work if I could actually connect to the server.  There are a number of similar approaches floating around on the 'net that seem to have worked for others, I think it;s just the corporate security settings that are stopping it from working for me.
0
 
LVL 10

Expert Comment

by:ReneGe
ID: 35804693
Well actually, you could most likely send it directly to your ISP SMTP server, unless you have a blocking firewall rule.
0
 

Author Comment

by:TelMaco
ID: 35925658
I got it working, thank you.

once Blat was installed to:
C:\WINNT\System32

I had to open cmd prompt and do this:

Blat -Install Smtp.Servername.com userid@Domain.com
I then tried to run the batch file you suggested but got an error msg:
"Failed to open registry key for Blat profile..."

So I did this:
Blat -Install mailhost userid@Domain.com

and tried the batch file again - it worked!

Thank you
0
 
LVL 10

Expert Comment

by:ReneGe
ID: 35925844
Happy I could help, and thanks for sharing your solution.

Cheers,
Rene
0

Featured Post

Get free NFR key for Veeam Availability Suite 9.5

Veeam is happy to provide a free NFR license (1 year, 2 sockets) to all certified IT Pros. The license allows for the non-production use of Veeam Availability Suite v9.5 in your home lab, without any feature limitations. It works for both VMware and Hyper-V environments

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

In real business world data are crucial and sometimes data are shared among different information systems. Hence, an agreeable file transfer protocol need to be established.
The core idea of this article is to make you acquainted with the best way in which you can export Exchange mailbox to PST format.
Many of my clients call in with monstrous Gmail overloading issues with Outlook. A quick tip is to turn off the All Mail and Important folders from synching. Here is a quick video I made to show you how to turn off these and other folders in Gmail s…
A short tutorial showing how to set up an email signature in Outlook on the Web (previously known as OWA). For free email signatures designs, visit https://www.mail-signatures.com/articles/signature-templates/?sts=6651 If you want to manage em…
Suggested Courses

850 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question