Enviar email quando Data de Envio for igual a Data Actual

Pretende-se com este código que quando a Data de Envio for igual a data em que nos encontramos é enviado um email ao destinatário.

O código pesquisa todos os registos e envia para cada email onde a condição da data for a data actual.

Código:

Public ws As Worksheet

Public iCount As Integer    ' String used to count exist records

Public lastrow As Long      ' String used to detect last used row to add next record

Private Sub cmdAdd_Click()

Dim TClientID As Integer

    

     iCount = Application.WorksheetFunction.CountIf(Range("A1:A10000"), "C*")

   

    With ws.UsedRange

        lastrow = .Rows(.Rows.Count).Row

    End With

    

    TClientID = ws.Range("A" & lastrow).Value

    

    'Select new row to add record

    ws.Range("A" & lastrow + 1).Select

    

    Me.Repaint

    Populate_Fields

    'Add next number to record

    Me.txtClientID = TClientID + 1

    

End Sub

Private Sub cmdClose_Click()

Application.DisplayAlerts = False

ActiveWorkbook.Save

Application.Quit

End Sub

Private Sub cmdSave_Click()

ActiveCell.Offset(0, 0).Value = Me.txtClientID.Text

ActiveCell.Offset(0, 1).Value = Me.txtName.Text

ActiveCell.Offset(0, 2).Value = Me.txtOrderedDate.Text

ActiveCell.Offset(0, 3).Value = Me.txtSendDate.Text

ActiveCell.Offset(0, 4).Value = Me.txtProduct.Text

ActiveCell.Offset(0, 6).Value = Me.txtEmail.Text

ActiveCell.Offset(0, 7).Value = Me.txtcontact.Text

MsgBox "Document Saved!", vbOKOnly

End Sub

Private Sub cmdSendEmail_Click()

    Dim ws As Worksheet

    Dim oApp As Object, MailApp As Object, SendMail As Object

    Dim strbody As String

    Dim deldate As Variant

    Dim email As Variant

    Dim i As Integer

    

    Set ws = Worksheets("sheet1")

    ws.Select

      

    'Set numrows = number of rows of data.

     NumRows = Range("A2", Range("A2").End(xlDown)).Rows.Count

     

    ' Select cell A2

    Range("A2").Select

    

    'Get Delivery date

    lin = 2

    col = 4

    deldate = ws.Cells(lin, col).Value

    

    'Get email

    lin = 2

    col = 7

    email = ws.Cells(lin, col).Value

    ' -1 because sheet have header

    For i = 1 To NumRows - 1

    

            If deldate = Date Then

    

                'Create Email

                Set MailApp = CreateObject("Outlook.Application")

                Set SendMail = MailApp.CreateItem(0)

                'Conteudo corpo da mensagem

                strbody = "Your require thing has been delivered ... " & vbNewLine & vbNewLine & _

                          "Thanks" & vbNewLine & _

                          "..."

        

                On Error Resume Next

                With SendMail

                    .To = email   '<- Email to send

                    .CC = ""

                    .BCC = ""

                    .Subject = "Your require thing has been delivered ..."

                    .Body = strbody '<- Body message

                    .Send ' .Display <- Before send email to client show

                             ' .send <- Send Email direct

                End With

                Else: Exit Sub

            End If

            ActiveCell.Offset(lin + i, 0).Select

            deldate = ws.Cells(lin + i, 4).Value

            email = ws.Cells(lin + i, 7).Value

    Next

         

    

End Sub

Private Sub UserForm_Initialize()

Set ws = Worksheets("sheet1")

Range("A2").Select

Populate_Fields

End Sub

Private Sub Populate_Fields()

Set ws = Worksheets("sheet1")

ws.Select

ActiveCell.Offset(0, 0).Select

Me.txtClientID.Text = ActiveCell.Offset(0, 0).Value

Me.txtOrderedDate = ActiveCell.Offset(0, 2).Value

Me.txtSendDate = ActiveCell.Offset(0, 3).Value

Me.txtName = ActiveCell.Offset(0, 1).Value

Me.txtProduct = ActiveCell.Offset(0, 4).Value

Me.txtEmail = ActiveCell.Offset(0, 6).Value

Me.txtcontact = ActiveCell.Offset(0, 7).Value

End Sub