Auto send email when cell reaches date range

micko1

Registered User.
Local time
Tomorrow, 01:24
Joined
Jun 11, 2011
Messages
16
Extreme Newby, This is my first attempt at building an access database. I have done some work in excel and now need to migrate my stuff to access. In excel I had a data base of vehicles and registration dates. The spreadsheet on open would check todays date against the date rego due field and if it is within the set date range lets say a month it would auto send an email, and then place todays date in a cell so the email would not send again. Just wondering if the same thing can be done in access. I have built a table with all vehicles and rego due dates in it.
Any help would be greatly appreciated.
 
I was going to say a bit confused but thats wrong, I would say a lot confused. I am not sure where to start with programming etc to achieve this. Can you lead me in the right direction. What I need is code etc to look at each record, check the "date rego DUE" column and if it falls within the time frame lets say a month then send an email to the mailing address in Column "Email Addresses" with the recipients name in the column called "Manager". The code I used in excel goes like this.
Thanks again for your time.


Code:
Sub Rego_Due_1Months()
Dim rngCell As Range
    Dim rngMyDataSet As Range
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim EmailSubject As String
    Dim EmailSendTo As String
    Dim MailBody As String
    Dim EmailRecipient As String
    Dim SigString As String
    Dim Signature As String
    Dim wksht As Worksheet
    Dim wb As Workbook
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim TempFilePath As String
    Dim TempFileName As String
   TempFilePath = Environ$("temp") & "\"
With Application
   .ScreenUpdating = False
   .EnableEvents = False
End With
 
    With ActiveSheet
    If .FilterMode Then .ShowAllData
 
    Set rng = .Range("A7", .Cells(.Rows.Count, 1).End(xlUp))
  End With
 
    For Each rngCell In rng
    If rngCell.Offset(0, 12) > 0 Then
 
'Rego Due 30 days from Due date
 
          ElseIf rngCell.Offset(0, 6) > Evaluate("Today() +7") And _
          rngCell.Offset(0, 6).Value <= Evaluate("Today() +30") Then
                rngCell.Offset(0, 12) = Date
                Set wksht = Worksheets(rngCell.Offset(0, 5).Value)
      wksht.Copy
     Set wb = ActiveWorkbook
      TempFileName = wksht.Name
 wb.ActiveSheet.UsedRange.Value = wksht.UsedRange.Value
    FileExtStr = ".xls": FileFormatNum = 56
      With wb
         .SaveAs TempFilePath & TempFileName & FileExtStr
         On Error Resume Next
         For i = 1 To 3
 
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
 
    strbody = "Dear  " & rngCell.Value & vbNewLine & vbNewLine & _
              "Vehicle " & rngCell.Offset(0, 5).Value & " registration is due for renewal on " & rngCell.Offset(0, 6).Value & " please arranged inspection at your earliest convenience." & vbNewLine & vbNewLine & vbNewLine & _
              "Thank you for your co-operation in this matter." & vbNewLine & vbNewLine & vbNewLine & _
              "CONFIDENTIALITY CAUTION"
 
 
    EmailSendTo = Replace(rngCell.Hyperlinks(1).Address, "mailto:", "")
    EmailSubject = "Vehicle Registrations Due for Renewal"
    EmailRecipient = rngCell.Value
 
 
    On Error Resume Next
    With OutMail
        .To = EmailSendTo
        .cc = 
        .BCC = ""
        .Subject = EmailSubject
        .Body = strbody
        .Attachments.Add ActiveWorkbook.FullName
 
        .Display   'or use .Send
    End With
    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing
 If Err.Number = 0 Then Exit For
         Next i
         On Error GoTo 0
         .Close SaveChanges:=False
      End With
 
      Kill TempFilePath & TempFileName & FileExtStr
   End If
   If rngCell.Offset(0, 12) > 0 Then
   ElseIf rngCell.Offset(0, 6) > Evaluate("Today() +7") And _
          rngCell.Offset(0, 6).Value <= Evaluate("Today() +30") Then
                rngCell.Offset(0, 12) = Date
 
End If
Next rngCell
With Application
   .ScreenUpdating = True
   .EnableEvents = True
End With
End Sub
 

Users who are viewing this thread

Back
Top Bottom