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

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

1 个答案: