Excel VBA Module won't create new e-mail in Outlook when logged out

mssbass

Active Member
Joined
Nov 14, 2002
Messages
253
Platform
  1. Windows
I have a scheduled tasks that opens a batch file that runs an Excel module which runs through some calculations then sends an outlook e-mail. The e-mail, attaches some info to the body and displays, rather than sends, in order for the user to validate and the e-mail before sending. When logged in during the day, the module runs fine and does what it's supposed to do as all calculations are run and the e-mail pops up with the correct data; however, at night, the batch shows Excel ran all the calculations but the e-mail never pops up. So it's not interacting with Outlook when logged out. I'm on an Aruba system and have set up all the Windows settings to turn off display never, power & sleep turn off (never) and I don't log off at night (just switch my screen off) in hopes it doesn't log me out; however, in the morning, it has me log back in again. Is there anyway around the logoff that is happening or is there a way to force the module to communicate with outlook?

Here's the code that sends the e-mail:

VBA Code:
Sub Mail_Selection_Range_Outlook_Body4()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim StrBody2 As String
Dim StrDate As String
txtdate = Format(Now, "mm") & "_" & Format(Now, "dd") & "_" & Format(Now, "yyyy")
strbody = "Link to file:" & vbCrLf & vbCrLf & "<a href=""[URL='https://sharepoint.abc.com/sites/Shared%20Documents/Report_']https://sharepoint.abc.com/sites/Shared Documents/Report_[/URL]" & txtdate & "%204pm.xlsx?Web=1"">FILE</a>"

Set rng = Nothing
On Error Resume Next
'You can also use a fixed range if you want
Set rng = ThisWorkbook.Sheets("Email").Range("A1:B16").SpecialCells(xlCellTypeVisible)
On Error GoTo 0

If rng Is Nothing Then
    MsgBox "The selection is not a range or the sheet is protected" & _
    vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If

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

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

On Error Resume Next
With OutMail
    .Display
    .To = "Cag, Michelle <[EMAIL]Michelle.Cag@abc.com[/EMAIL]>"
    .CC = ""
    .BCC = ""
    .Subject = "4PM Report"
    .HTMLBody = strbody & RangetoHTML(rng) & .HTMLBody
    .Display   'or use .Send
End With
On Error GoTo 0

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

    Set OutMail = Nothing
    Set OutApp = Nothing
Call SaveBucketsFile4
End Sub

Function RangetoHTML(rng As Range)

    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function
 
Last edited by a moderator:

Excel Facts

Remove leading & trailing spaces
Save as CSV to remove all leading and trailing spaces. It is faster than using TRIM().
Try adding some waits here and there:
Code:
Set OutApp = CreateObject("Outlook.Application")
Application.Wait (Now + TimeValue("0:00:02"))
Set OutMail = OutApp.CreateItem(0)
Application.Wait (Now + TimeValue("0:00:02"))
'''''' On Error Resume Next                           '<<< WHY IS (was) IT THERE?
With OutMail
    .Display
    .To = "Cag, Michelle <[EMAIL]Michelle.Cag@abc.com[/EMAIL]>"
    .CC = ""
    .BCC = ""
    .Subject = "4PM Report"
    .HTMLBody = strbody & RangetoHTML(Rng) & .HTMLBody
    .Display   'or use .Send
End With
'''''''On Error GoTo 0
Application.Wait (Now + TimeValue("0:00:01"))
With Application
    .EnableEvents = True
Also I removed that OnErrorResumeNext: you shouldn't expect any error in that section, and maybe you'll catch an error message that explains what is the problem

Bye
 
Upvote 0
Try adding some waits here and there:
Code:
Set OutApp = CreateObject("Outlook.Application")
Application.Wait (Now + TimeValue("0:00:02"))
Set OutMail = OutApp.CreateItem(0)
Application.Wait (Now + TimeValue("0:00:02"))
'''''' On Error Resume Next                           '<<< WHY IS (was) IT THERE?
With OutMail
    .Display
    .To = "Cag, Michelle <[EMAIL]Michelle.Cag@abc.com[/EMAIL]>"
    .CC = ""
    .BCC = ""
    .Subject = "4PM Report"
    .HTMLBody = strbody & RangetoHTML(Rng) & .HTMLBody
    .Display   'or use .Send
End With
'''''''On Error GoTo 0
Application.Wait (Now + TimeValue("0:00:01"))
With Application
    .EnableEvents = True
Also I removed that OnErrorResumeNext: you shouldn't expect any error in that section, and maybe you'll catch an error message that explains what is the problem

Bye
Waits aren't the issue - it's not triggering the Outlook email at all.
 
Upvote 0
And, after removing On Error Resume Next, does the macro trigger any error?
 
Upvote 0
Don't know what an Aruba system is based on?


In Windows 10 there is an additional settings in
Windows 10 Settings>Accounts>Sign-in Options, which requires the user log back in every x minutes after being away. This can be set to never.

Also can be accessed via Control Panel > User Accounts
Make changes to my account in PC Settings
Sign in Option - Never
 
Upvote 0
Since I don't have admin rights, I'm going to put in a ticket to see if they can either give me rights to run the scheduled task with highest privileges or make changes to the user account's sign in options. Since we're a medical company, I doubt they will want the laptop permanently logged in though.
 
Upvote 0
Add Stop in this position:
Code:
Set OutMail = OutApp.CreateItem(0)
Stop
'next instructions
Remove any OnErrorResumeNext after the Sop

Then logout from Outlook
Use TaskManager, tab Processes, to check if you have any "Outlook" or "Microsoft Outlook" process (you shouldn't have one)

Then start the macro; it will halt on the "Stop" line
Check again in TaskManager if you have any "Outlook" or "Microsoft Outlook" process: you should now have one

If you have the Outlook process, use the key F8 to step through the code, one instruction each F8. Take note of what happens.
After you execute ".Display" then the email form should be visible
Try stepping till End Sub. In case you receive an error take a snapshot of the screen

Tell us what happens during this process
 
Upvote 0

Forum statistics

Threads
1,223,098
Messages
6,170,106
Members
452,302
Latest member
TaMere

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top