Can I automatically send a monthly email with Excel VBA?

The simple answer is yes.

It is a bit more complex that you think, but it is possible.

First you will need to create a log. Where would you want to save that? Possible in the same folder as your Personal Excel Workbook.#

Do you know what your personal Excel workbook is?

Then you would need to create two macros in your personal workbook.

One to run hourly and to send your email if it is the first of the month and your log is empty

The other to run when you open excel and to send the email if the log is empty.

I will create something for you.

Ok this is still work in progress.

Paste this code into your personal workbook.

Replace "*************" with your email address.


Then run SheduleLog.

When run the Macro will look for the Schedule Log in the Folder housing your Excel Startup Folder.
It will not find it so it will create it.

I have set it up to create three Schedule Entries. Two of which are set to run.

Running the Macro a second time will send you Two Emails.

I have set it to send you a copy of the Schedule as both an attachment and also posted into the body of the email.

Changing the File name in the Schedule Log would result in another file being sent.

Running the Macro UpdateShedule will open the Schedule for you to Edit.
But remember to delete the mart of the main macro that is filling it with dummy data.

Public HeaderText1, HeaderText2 As String

Dim RngBody As Range
Dim SourceFile As Object
Dim OutlookApp As Object
Dim OutlookMessage As Object
Dim TempFileName, MyArray As Variant

Sub SheduleLog()

'Application.ScreenUpdating = False

MyPath = Left(ThisWorkbook.Path, InStrRev(ThisWorkbook.Path, "\"))

If Dir(MyPath & "Schedule Log.xlsx") = "" Then
Workbooks.Add

    Range("A1").FormulaR1C1 = "Full Path Name"
    Range("B1").FormulaR1C1 = "Target Email Day"
    Range("C1").FormulaR1C1 = "Last Email Date"
    Range("D1").FormulaR1C1 = "Title"
    Range("E1").FormulaR1C1 = "Text"
    
'Dummy Data
'++++++++++++++++++++++++++++++++++++++++++

    Range("A2:A4").FormulaR1C1 = MyPath & "Schedule Log.xlsx"
    Range("B2:B4").FormulaR1C1 = "4"
    Range("C2:C4").FormulaR1C1 = "1/4/2016"
    Range("D2:D4").FormulaR1C1 = "Test Message"
    Range("E2:D4").FormulaR1C1 = "This is a test"
    

    Range("B3").FormulaR1C1 = "27"
    Range("C3").FormulaR1C1 = "1/4/2016"

'++++++++++++++++++++++++++++++++++++++++++
    
ActiveWorkbook.SaveAs Filename:=MyPath & "Schedule Log.xlsx"

Else

Workbooks.Open Filename:=MyPath & "Schedule Log.xlsx"

LR = Cells(Rows.Count, 1).End(xlUp).Row

Range("F2:F" & LR).FormulaR1C1 = _
        "=IF(AND(DATE(YEAR(TODAY()),MONTH(TODAY()),RC[-4])>RC[-3],TODAY()>DATE(YEAR(TODAY()),MONTH(TODAY()),RC[-4])),1,0)"
Range("F2:F" & LR).Value = Range("F2:F" & LR).Value

MyArray = Range("A1:F" & LR).Value

For Count = 2 To LR
t = MyArray(Count, 6)
If MyArray(Count, 6) = 1 Then Emailer (Count)
Next

End If

ActiveWindow.Close False
        
Application.ScreenUpdating = True
End Sub

'****************************************************************************************************************************

Sub UpdateShedule()
MyPath = Left(ThisWorkbook.Path, InStrRev(ThisWorkbook.Path, "\"))
Workbooks.Open Filename:=MyPath & "Schedule Log.xlsx"
End Sub



'****************************************************************************************************************************

Private Sub Emailer(Pos As Integer)

'Email A File
'This is the file to be attached

TempFileName = MyArray(Pos, 1)

'Optimize Code
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.DisplayAlerts = False


'Create Instance of Outlook
  On Error Resume Next
    Set OutlookApp = GetObject(class:="Outlook.Application") 'Handles if Outlook is already open
  Err.Clear
    If OutlookApp Is Nothing Then Set OutlookApp = CreateObject(class:="Outlook.Application") 'If not, open Outlook
    
    If Err.Number = 429 Then
      MsgBox "Outlook could not be found, aborting.", 16, "Outlook Not Found"
      GoTo ExitSub
    End If
  On Error GoTo 0
  
'This Part Of The Workbook Is Copied Into The Email.
With ActiveSheet
LR = .Cells(Rows.Count, 1).End(xlUp).Row
Set RngBody = .Range("A1:F" & LR)
End With

'This is the Email Header Text
HeaderText1 = "Dear Sam"
HeaderText2 = MyArray(Pos, 5)

'This is your Signature Text
Signature = vbNewLine & vbNewLine & "Kind Regards" & vbNewLine & vbNewLine & "Peter"

'Create a new email message
  Set OutlookMessage = OutlookApp.CreateItem(0)

'Create Outlook email with attachment
  On Error Resume Next
    With OutlookMessage
    .SentOnBehalfOfName = "*************"@hotmail.com"
     .to = "*************@hotmail.com"
     .CC = ""
     .BCC = ""
     .Subject = MyArray(Pos, 4)
    .HTMLBody = RangetoHTML(RngBody)
    .Body = .Body & Signature
     .Attachments.Add TempFileName
     '.Display       Displays the email so you can edit and then send
     .Send ' Sends the email without human interaction
    End With
  On Error GoTo 0

'If you display before sending then this would paste a range into mail body
'Range(Range("A1:F" & LR).copy
'Paste Clipboard into Outlook
'SendKeys "^({v})", True
    
'Clear Memory
  Set OutlookMessage = Nothing
  Set OutlookApp = Nothing
  
'Optimize Code
ExitSub:
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  Application.DisplayAlerts = True

End Sub
Sub UpdateShedule()
MyPath = Left(ThisWorkbook.Path, InStrRev(ThisWorkbook.Path, "\"))
Workbooks.Open Filename:=MyPath & "Schedule Log.xlsx"
End Sub

Function RangetoHTML(rng As Range)
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    
    t = rng.Address

    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
 
    ' Copy the range and create a workbook to receive the data.
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1, 1) = HeaderText1
        .Cells(3, 1) = HeaderText2
        .Cells(5, 1).PasteSpecial Paste:=8
        .Cells(5, 1).PasteSpecial xlPasteValues, , False, False
        .Cells(5, 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 an .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 the RangetoHTML subroutine.
    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.
    Kill TempFile
 
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function