我想在访问中设置我的电子邮件提醒每两周一次

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

然后更改处理每个电子邮件地址时发生的情况：

Suggested new look of your program:

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

我想在访问中设置我的电子邮件提醒每两周一次

I want to set up my email reminder on a bi-weekly basis in access

ms-access

vba

ms-access-2010

ms-access-2013