Я хочу настроить свое напоминание по электронной почте раз в две недели при доступе

Question

Мне нужна помощь в создании кода, который будет отправлять напоминания по электронной почте каждые две недели. У меня уже есть код, который отправляет напоминания по электронной почте, но он отправляет электронные письма один раз в день. Это может быть очень раздражает пользователей

Вот мой код VBA от доступа:

Function GenerateEmail(MySQL As String) 
'On Error GoTo Exit_Function: 
    Dim oOutLook As Outlook.Application 
    Dim oEmailAddress As MailItem 
    Dim MyEmpName As String 
    Dim MyEquip As String 
    Dim MyModel As String 
    Dim MyAsset As String 
    Dim MySerial As String 
    Dim rs As Recordset 
    Set rs = CurrentDb.OpenRecordset(MySQL) 
If rs.RecordCount > 0 Then 
rs.MoveFirst 
Do Until rs.EOF 
If IsNull(rs!EmailAddress) Then 
     rs.MoveNext 
Else 
If oOutLook Is Nothing Then 
Set oOutLook = New Outlook.Application 
End If 
Set oEmailAddressItem = oOutLook.CreateItem(olMailItem) 
With oEmailAddressItem 

      MyEmpName = DLookup("EmpName", "Employees", "[EmpID]= " & rs!EmpName) 
      MyEquip = rs!EquipmentType 
      MyModel = rs!ModelNo 
      MyAsset = rs!AssetNo 
      MySerial = rs!SerialNo 
      .To = "another@.com;another@.com;another@.com" 
      .Subject = "Calibration that's due between 1 to 11 months" 
      .Body = "Calibration ID: " & rs!RecordID & vbCr & _ 
        "Location: " & rs!CalLocation & vbCr & _ 
        "Requirement: " & rs!CalRequirement & vbCr & _ 
        "Employee: " & MyEmpName & vbCr & _ 
        "Name: " & MyEquip & vbCr & _ 
        "Serial No.: " & MySerial & vbCr & _ 
        "Model No.: " & MyModel & vbCr & _ 
        "Asset No.: " & MyAsset & vbCr & _ 
        "Due Date : " & rs!CalUpcomingDate & vbCr & vbCr & _ 
        "This email is auto generated. Please Do Not Replay!" 
      'MyEmpName = DLookup("EmpName", "Employees", "[EmpID]= " & rs!EmpName) 
      '.To = rs!EmailAddress 
      '.Subject = "Task due in between 1st and 11th month reminder for " & MyEmpName 
      '.Body = "Task ID: " & rs!RecordID & vbCr & _ 
        '"Task Name: " & rs!TaskName & vbCr & _ 
        '"Employees: " & MyEmpName & vbCr & _ 
        ' "Task Due: " & rs!CalUpcomingDate & vbCr & vbCr & _ 
        '"This email is auto generated from Task Database. Please Do Not Replay!" 
      .Display 
      '.Send 
      ' rs.Edit 
      ' rs!DateEmailSent = Date 
      ' rs.Update 
     End With 
     Set oEmailAddressItem = Nothing 
     Set oOutLook = Nothing 
     rs.MoveNext 
    End If 
Loop 
Else 
'do nothing 
End If 
rs.Close 
Exit_Function: 
Exit Function 
End Function 

Answer 1

Похоже, что вы имели правильное представление один раз - и @Gustav отметил решение.

Сначала необходимо раскомментировать из строки:

' rs.Edit 
' rs!DateEmailSent = Date 
' rs.Update 

Затем изменить то, что происходит, когда вы обрабатываете каждый адрес электронной почты:

Похожие новый вид вашей программы:

rs.MoveFirst 
Do Until rs.EOF 

    If Not IsNull(rs!EmailAddress) Then 

     ' Only Send Emails if never been sent before - or past 14 days since last one' 
     If (IsNull(rs!DateEmailSent)) Or DateDiff("d", rs!DateEmailSent, Date) >= 14 Then 

      If oOutLook Is Nothing Then 
       Set oOutLook = New Outlook.Application 
      End If 
      Set oEmailAddressItem = oOutLook.CreateItem(olMailItem) 

      ' ... rest of email processing ' 
      ' .................... ' 

      .Display 
      .Send 

      ' Make sure to record that reminder was sent ' 
      rs.Edit 
      rs!DateEmailSent = Date 
      rs.Update 

      ' Only do this if this has been set ' 
      Set oEmailAddressItem = Nothing 
     End If 
    End If 

    rs.MoveNext 
Loop 

' Do this at end ' 
Set oOutLook = Nothing