Auto-Schedule Macros to Run, vba send E-mail without Outlook error message, getting around Access queries with parameters

[staceykw]

Hi there,

I just wanted to share some code on here that I have found, after spending several days trying to get around a few problems with some Excel macros I was running. Firstly, I wanted to set up a macro to query an Access database with parameters and import the results into an Excel file so that I could format and manipulate it. Then, I wanted to e-mail the data from the Excel file in the body of the e-mail. Finally, I wanted this process to run automatically every day at 9:00am (i.e. so the e-mail would go out even on the weekends etc.).

The first problem I ran into was with the database query (getting around the parameter problem. Also, I did not have administrator access to the database).The 3 parameters were Start Date, End Date, and Store Code.
The first thing I had to do was make sure that I had the following References checked (Visual Basic Editor -> Tools -> References...):
1. Microsoft ActiveX Data Objects Recordset 2.8 Library
2. Microsoft DAO 3.6 Object Library

Then, I used the code below to import my query:

Private Sub ImportQuery()

Dim MyDatabase As DAO.Database
Dim MyQueryDef As DAO.QueryDef
Dim MyRecordset As DAO.Recordset

Sheets("Query Result").Select
ActiveSheet.Range("A2:L20000").ClearContents

Set MyDatabase = DBEngine.OpenDatabase("[COLOR="red"]C:\MyDatabase.mdb[/COLOR]")
Set MyQueryDef = MyDatabase.QueryDefs("[COLOR="Red"]QueryName[/COLOR]")

With MyQueryDef
.Parameters("[Date Start]") = [COLOR="red"]Sheets("Set-Up").Range("C1").Value [/COLOR]
.Parameters("[Date End]") = [COLOR="red"]Sheets("Set-Up").Range("C2").Value[/COLOR]
.Parameters("[Store Code]") = [COLOR="red"]Sheets("Set-Up").Range("C3").Value[/COLOR]
End With

Set MyRecordset = MyQueryDef.OpenRecordset

Sheets("Query Result").Select
ActiveSheet.Range("A2").CopyFromRecordset MyRecordset

End Sub

The second problem I had was when I tried to send the e-mail using VBA, an annoying pop-up would appear in Outlook saying "A program is trying to automatically send e-mail on your behalf. Do you want to allow this?" Unless I clicked "yes", the e-mail would not be sent. After much research, I tried using CDO to try and get around this security feature in Outlook, but I had problems with that too (maybe because of firewalls or blocked ports?). So, my solution was to save the e-mail as a draft instead, using the code below:

Private Sub SaveDraftEmail()

    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object

    Set rng = Sheets("E-mail").Range("A1:F19").SpecialCells(xlCellTypeVisible)
                 
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

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

    On Error Resume Next
    With OutMail
        .To = [COLOR="red"]Sheets("Set-Up").Range("B5").Value[/COLOR]
        .From = "[COLOR="red"]me@email.com[/COLOR]"
        .CC = [COLOR="red"]Sheets("Set-Up").Range("B6").Value[/COLOR]
        .BCC = ""
        .Subject = [COLOR="red"]Sheets("Set-Up").Range("B8").Value[/COLOR]
        .HTMLBody = RangetoHTML(rng)
        .Save
    End With
    On Error GoTo 0

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

    Set OutMail = Nothing
    Set OutApp = Nothing

End Sub

Function RangetoHTML(rng As Range)

[COLOR="SeaGreen"]'This function converts the data in the Excel spreadsheet to HTML to put in the body of the e-mail[/COLOR]

    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"
    
    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
 
    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
 
    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=")
 
    TempWB.Close savechanges:=False
 
    Kill TempFile
 
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
    
End Function

The following code is used to run the query, send it to e-mail drafts, and then save and close the workbook.

Sub ImportAndEmail()

With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
End With

ImportQuery
SaveDraftEmail

With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
End With

ActiveWorkbook.Save
Application.Quit

End Sub

Finally, I wanted to schedule this process to occur at 9:00 am every day (and also send out the e-mail which I had saved as a draft!). First, I had to change the macro security in Outlook to allow macros to run (Tools -> Macro -> Security -> Low)

I then entered the following code under "ThisOutlookSession" in Outlook Visual Basic Editor:

Public Sub SendDrafts()

Dim lDraftItem As Long
Dim myOutlook As Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim myFolders As Outlook.Folders
Dim myDraftsFolder As Outlook.MAPIFolder

Set myOutlook = Outlook.Application
Set myNameSpace = myOutlook.GetNamespace("MAPI")
Set myFolders = myNameSpace.Folders

Set myDraftsFolder = myFolders("[COLOR="red"]Mailbox - My Name[/COLOR]").Folders("Drafts")

For lDraftItem = myDraftsFolder.Items.Count To 1 Step -1

If myDraftsFolder.Items.Item(lDraftItem).Subject Like "[COLOR="red"]My Daily E-mail for*[/COLOR]" Then

myDraftsFolder.Items.Item(lDraftItem).Send

End If
Next lDraftItem

Set myDraftsFolder = Nothing
Set myNameSpace = Nothing
Set myOutlook = Nothing

End Sub

Then, I used Scheduler (Control Panel -> Scheduled Tasks) to run the following code at 9:00 am each day:

Set xl = CreateObject("Excel.application")

xl.Application.Workbooks.Open "[COLOR="red"]C:\My sample.xls[/COLOR]"
xl.Application.Visible = True
xl.Application.run "'My sample.xls'!Module1.ImportAndEmail"

Set xl = Nothing

Set app = CreateObject("Outlook.application")
Call app.SendDrafts

*This was my first time using scheduler and vbscript, so for other first-timers: I pasted the code above into notepad and saved it as "RunDaily.vbs" (make sure it doesn't have .txt on the end of the name). Then in Scheduled Tasks (in your Control Panel), go to "Add Scheduled Tasks", Browse for your .vbs file, and enter your scheduling options.

I am fairly new to VBA but it has helped me a TON in speeding up some of my daily work activities. I'm excited to start using some new tools (scheduler, VBscript etc.) now. I hope that these examples help other newbies too, because I spent a lot of time trying to find simple solutions to these problems! If anyone has any additional input on how I could improve this process, I'd love to hear it too!

I am using Microsoft Office 2003.

Thanks!

-staceykw

I cannot remember where I got the original code for the Access Query (I think it was here: http://datapigtechnologies.com/blog/index.php/running-an-access-parameter-query-from-excel/).
This is where I got the code for Outlook: http://www.pcreview.co.uk/forums/program-trying-send-e-mail-your-behalf-bypass-message-t2091096.html

 

[Trevor G]

Welcome to the Forum Stacey,

You obviously have spent a lot of time working this out and to actually post VBA and a solution for your first thread is very commendable.

To get around the Outlook message you can use a third party software this link provides the download.

http://www.contextmagic.com/express-clickyes/

 

[Derek Brown]

Hello and welcome to The Board.
This is a good post and I am sure it will be useful to others (I will make a note of it to pass on to others should the need arise).
I have used a similar process for the management of my fully-automated Data Warehouse system. That is controlled using VB code (not VBA) and Task Scheduler together with Outlook code. The system runs on a dedicated server with Windows Server 2008 R2 and Office 2007 (previously ran on dedicated PC running XP and Office 2003).
Some recommendations:
1. Avoid setting macro security too Low. Using a Self-signed Certificate should allow you to set it higher. http://www.howto-outlook.com/howto/selfcert.htm
With this I could send the email directly from Excel, instead of saving etc., on the XP/2003 system. However, I found that on the Windows Server/Office 2007 system other security settings made that difficult so implemented a save/send process similar to yours.
See also: http://www.mrexcel.com/forum/showthread.php?t=110793
2. When running from VB/Task Scheduler, it is important to make sure that all objects are released at the end to avoid the other application (e.g. Excel) remaining in memory until the PC/Server was restarted or the application abandoned from Task Manager. Here is an example of the code that I currently use:

Imports System.IO
Module Module1

Public Sub Main()

RunMyWorkbook()

End Sub

Sub RunMyWorkbook()
Const strControlFileName As String = "P:\MyFolder\MyWorkbook.xlsm"
Dim oExcel As Microsoft.Office.Interop.Excel.Application
Dim oBook As Microsoft.Office.Interop.Excel.Workbook
Dim oBooks As Microsoft.Office.Interop.Excel.Workbooks
Dim strFilenameCheck As String
Dim strMacroName As String
Try
strMacroName = "RunMyWorkbook"
oExcel = CType(CreateObject("Excel.Application"), Microsoft.Office.Interop.Excel.Application)
oExcel.Visible = False
oBooks = CType(oExcel.Workbooks(), Microsoft.Office.Interop.Excel.Workbooks)
strFilenameCheck = Dir(strControlFileName)
If strFilenameCheck <> "" Then
oBook = CType(oBooks.Open(strControlFileName), Microsoft.Office.Interop.Excel.Workbook)
oExcel.DisplayAlerts = False
oExcel.Run(strMacroName)
oExcel.DisplayAlerts = True
Else
Dim sw As New StreamWriter(Application.StartupPath & "\MyWorkbook_error.log", True)
sw.WriteLine(Now() & " - '" & strControlFileName & "' could not be accessed.")
sw.Close()
End
End If
'
Catch ex As Exception
Dim sw As New StreamWriter(Application.StartupPath & "\MyWorkbook_Error.log", True)
sw.WriteLine(Now() & " - " & ex.Message)
sw.Close()
Finally
oBook.Close(False)
System.Runtime.InteropServices.Marshal.ReleaseComObject(oBook)
oBook = Nothing
System.Runtime.InteropServices.Marshal.ReleaseComObject(oBooks)
oBooks = Nothing
oExcel.Quit()
System.Runtime.InteropServices.Marshal.ReleaseComObject(oExcel)
oExcel = Nothing
GC.Collect()
End Try
End Sub
End Module

Note the use of Garbage Collector (GC) at the end of the code.
3. You may find http://www.outlookcode.com/article.aspx?ID=40 useful