Creating A macro to send emails for specific dates and information

**Brian_D** · 06-07-2013, 04:26 PM

Hello guys,

I just recently joined and am completly new to trying to create VBA/Macros.

I am currently working on a spreadsheet for my permitting process. I have permits that require different inspections/renewals througout the year, and get quite over burdened on the sheer amount of information I have to keep up on.

My boss would like to have our department notified by email when dates are coming up and I was wondering is it possible to do this?

I saw one that Leith had put together, but that is not exactly what I am looking for.

I am brand new to all this and it does give me a serious headache trying to understand it.

Or would it be possible to create a ticker that would automatically update on due dates within 15 days?

Any and all help would be greatly appreciated.

Thank you,

Brian

**Tinbendr** · 06-07-2013, 09:50 PM

1. What information do you want sent? Be specific.
2. Do you want the info in the body of the e-mail?
3. How will you determine WHO gets the email? A list of people? A single person? Will you choose?
4. Do you have Outlook?

**Brian_D** · 06-10-2013, 11:51 AM

Sorry for the delayed response.

I am wanting to basically automate emails based on a 30 day notice of renewal.

So say I have three units due on july 18th I'd like the information of those three units sent out to a list of three people and this list will not change. As my department is a department of three.

Though there is another application I am needing for this that will be notifying serveral different people for another department once I can figure this all out.

Yes I have outlook.

**Tinbendr** · 06-12-2013, 04:17 PM

Try this. See attachment.

**Brian_D** · 06-14-2013, 12:26 PM

PHP Code:


Sub Email30dayNotice() 
Dim bStarted As Boolean 
Dim oOutlookApp As Outlook.Application 
Dim oItem As Outlook.MailItem 
Dim MyPath As String 
Dim WholeMessage$ 
Dim eCaption$, eCaptionTmp$ 
Dim eHeader$, eHeaderTmp$ 
Dim AddMessage$, AddMessageTmp$ 
Dim A As Long 
Dim ColHeaders As Variant 
Dim Ctr As Long 
 
On Error Resume Next 
 
  If Len(ActiveWorkbook.Path) = 0 Then 
    MsgBox "Workbook needs to be saved first" 
    Exit Sub 
  End If 
 
 
Application.StatusBar = "Starting Outlook..." 
 
  Set oOutlookApp = GetObject(, "Outlook.Application") 
  If Err <> 0 Then 
    Set oOutlookApp = CreateObject("Outlook.Application") 
    bStarted = True 
  End If 
 
  Set oItem = oOutlookApp.CreateItem(olMailItem) 
 
  With oItem 
    .To = "" 
    .CC = "" 
    .Subject = "Inspections due within 30 days" 
 
Application.StatusBar = "Building table..." 
ColHeaders = Split("Equipment,ST.Serial number,Expiration Date,Serial Number", ",") 
 
        eCaption$ = "<TR>" & _ 
        "<TH colspan=" & Chr$(34) & UBound(ColHeaders) + 1 & Chr$(34) & _ 
        "scope=" & Chr$(34) & "colgroup" & Chr$(34) & ">" & _ 
        "Inspections due within 30 days" & _ 
        "</TH></TR>" 
 
With ActiveWorkbook.Worksheets(1) 
        'Header for Table - OANum, Date, Part Number, SerNum, Decription, Defect 
        eHeaderTmp$ = "<TR><TH>" 
         
        For A = 0 To UBound(ColHeaders) 
            eHeaderTmp$ = eHeaderTmp$ & ColHeaders(A) & "</TH><TH>" 
        Next 
        eHeaderTmp$ = Left(eHeaderTmp$, Len(eHeaderTmp$) - 4) 
        'Debug.Print eHeaderTmp$ 
         
        eHeaderTmp$ = eHeaderTmp$ & "</TR>" 
 
    For A = 18 To 22 
        If .Range("B" & A) <> "" Then 
            If .Range("B" & A) > Now - 30 Then 
                AddMessageTmp$ = AddMessageTmp$ & "<TR>" & _ 
                    "<TD>" & .Range("A16") & "</TD>" & _ 
                    "<TD>" & .Range("A" & A) & "</TD>" & _ 
                    "<TD>" & .Range("B" & A) & "</TD>" & _ 
                    "<TD>" & .Range("C" & A) & "</TD></TR>" 
                Ctr = Ctr + 1 
            End If 
        End If 
    Next 
 
    If Ctr > 0 Then 
        eHeader$ = eHeader$ & eHeaderTmp$ 
        eHeaderTmp$ = "" 
        AddMessage$ = AddMessage$ & AddMessageTmp$ 
        AddMessageTmp$ = "" 
        Ctr = 0 
    End If 
     
    For A = 27 To 31 
        If .Range("B" & A) <> "" Then 
            If .Range("B" & A) > Now - 30 Then 
                AddMessageTmp$ = AddMessageTmp$ & "<TR>" & _ 
                    "<TD>" & .Range("A25") & "</TD>" & _ 
                    "<TD>" & .Range("A" & A) & "</TD>" & _ 
                    "<TD>" & .Range("B" & A) & "</TD>" & _ 
                    "<TD>" & .Range("C" & A) & "</TD></TR>" 
                Ctr = Ctr + 1 
            End If 
        End If 
    Next 
 
    If Ctr > 0 Then 
        eHeader$ = eHeader$ & eHeaderTmp$ 
        eHeaderTmp$ = "" 
        AddMessage$ = AddMessage$ & AddMessageTmp$ 
        AddMessageTmp$ = "" 
        Ctr = 0 
    End If 
     
    For A = 34 To 36 
        If .Range("B" & A) <> "" Then 
            If .Range("B" & A) > Now - 30 Then 
                AddMessageTmp$ = AddMessageTmp$ & "<TR>" & _ 
                    "<TD>" & .Range("A32") & "</TD>" & _ 
                    "<TD>" & .Range("A" & A) & "</TD>" & _ 
                    "<TD>" & .Range("B" & A) & "</TD>" & _ 
                    "<TD>" & .Range("C" & A) & "</TD></TR>" 
                Ctr = Ctr + 1 
            End If 
        End If 
    Next 
 
    If Ctr > 0 Then 
        eHeader$ = eHeader$ & eHeaderTmp$ 
        eHeaderTmp$ = "" 
        AddMessage$ = AddMessage$ & AddMessageTmp$ 
        AddMessageTmp$ = "" 
        Ctr = 0 
    End If 
 
End With 
 
WholeMessage$ = "<HTML><BODY>" & _ 
    "<TABLE border=""1""cellpadding=""2""cellspacing=""2"">" & _ 
    eCaption$ & eHeader$ & AddMessage$ & "</TABLE></BODY></HTML>" 
    'Debug.Print WholeMessage$ 
    .HTMLBody = WholeMessage$ 
    .Display 
  End With 
 
  If bStarted Then 
    oOutlookApp.Quit 
  End If 
 
  Set oItem = Nothing 
  Set oOutlookApp = Nothing 
 
End Sub

Having Trouble. It wont let me run this application it is highlighting Sub Email30dayNotice()it is giving me a compile error: User-Defined type not defined.

Also thank you for this! It will be amazing to get it working.

Now what if i need to change the cell locations? What would I need to edit on this macro?

**Tinbendr** · 06-14-2013, 01:09 PM

You'll have to add the reference. in the VBE, choose Tools->References. Scroll until you see Microsoft Outlook. Be sure to click the box. Click OK, then save workbook.

change the cell locations?

This was part of the details you were supposed to include. You never said anything about moving ranges. If you want that option to be dynamic, then it's going to get a lot more complicated. If you're just talking about rows changing, then change the For-Next counters. These represent the row numbers.