发送提醒跟进时，在Excel中使用VBA的截止日期接近

Question

我得到了一个要求，通过excel使后续工作通过自动化进行，提醒电子邮件需要通过VBA脚本发送。我获得了所有信息，但通过单击Excel工作簿中的命令按钮发送自动电子邮件会引发错误。请帮我在这

Sub SendReminderMail() 
Dim OutLookApp As Object 
Dim OutLookMailItem As Object 
Dim iCounter As Integer 
Dim MailDest As String 

Set OutLookApp = CreateObject("Outlook.application") 
Set OutLookMailItem = OutLookApp.CreateItem(0) 

With OutLookMailItem 
MailDest = "" 
For iCounter = 1 To WorksheetFunction.CountA(Columns(13)) 
If MailDest = "" And Cells(iCounter, 13).Offset(0, -1) = "Send Reminder" Then 
MailDest = Cells(iCounter, 13).Value 
ElseIf MailDest <> "" And Cells(iCounter, 13).Offset(0, -1) = "Send Reminder" Then 
MailDest = MailDest & ";" & Cells(iCounter, 13).Value 
End If 
Next iCounter 

.BCC = MailDest 
.Subject = "Due date approaching" 
.Body = "Reminder: Your due date is near approaching . Please ignore if already paid." 
.Send 
End With 

Set OutLookMailItem = Nothing 
Set OutLookApp = Nothing 
End Sub 

我已经修改了我的剧本，因为这

Sub datesexcelvba() 
Dim myApp, mymail 
Dim mydate1 As Date 
Dim mydate2 As Long 
Dim datetoday1 As Date 
Dim datetoday2 As Long 

Dim x As Long 
lastrow = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row 
For x = 2 To lastrow 

mydate1 = Cells(x, 6).Value 
mydate2 = mydate1 

Cells(x, 9).Value = mydate2 

datetoday1 = Date 
datetoday2 = datetoday1 

Cells(x, 10).Value = datetoday2 

If mydate2 - datetoday2 = 3 Then 

Set myApp = CreateObject(Outlook.Application) 
Set mymail = myApp.CreateItem(olMailItem) 
mymail.To = Cells(x, 5).Value 

With mymail 
.Subject = "Payment Reminder" 
.Body = "Your credit card payment is due." & vbCrLf & "Kindly ignore if already paid." & vbCrLf & "Dinesh Takyar" 
.Display 
‘.Send 
End With 

Cells(x, 7) = "Yes" 
Cells(x, 7).Interior.ColorIndex = 3 
Cells(x, 7).Font.ColorIndex = 2 
Cells(x, 7).Font.Bold = True 
Cells(x, 8).Value = mydate2 - datetoday2 
End If 
Next 
Set myApp = Nothing 
Set mymail = Nothing 

End Sub 

这表明没有错误，但因为我无法发送电子邮件。我也在VB工具 - >参考 - > Microsoft Outlook 12.0对象库中进行了检查，但它不起作用。请帮助

Answer 1

该代码已被修改并正常工作。 单击Excel中的Visual Basic代码环境

首先从Tools - > References - > Microsoft outlook 12.0库或任何其他版本的Outlook库中选择outlook库。

Sub Email() 
'Dim OutlookApp As Outlook.Application 
Dim OutlookApp 
Dim objMail 
Dim mydate1 As Date 
Dim mydate2 As Long 
Dim datetoday1 As Date 
Dim datetoday2 As Long 
Dim x As Long 
lastrow = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row 
For x = 2 To lastrow 

mydate1 = Cells(x, 6).Value 
mydate2 = mydate1 

Cells(x, 9).Value = mydate2 

datetoday1 = Date 
datetoday2 = datetoday1 

Cells(x, 10).Value = datetoday2 

If mydate2 - datetoday2 = 1 Then 

'Set OutlookApp = New Outlook.Application 
Set OutlookApp = CreateObject("Outlook.Application") 
Set objMail = OutlookApp.CreateItem(olMailItem) 
objMail.To = Cells(x, 5).Value 
k 
With objMail 
.Subject = "Payment Reminder" 
.Body = "Your payment is due." & vbCrLf & "Kindly ignore if already paid." & vbCrLf & "Hari" 
'.Display 
.send 
End With 

Cells(x, 7) = "Yes" 
Cells(x, 7).Interior.ColorIndex = 3 
Cells(x, 7).Font.ColorIndex = 2 
Cells(x, 7).Font.Bold = True 
Cells(x, 8).Value = mydate2 - datetoday2 
End If 
Next 
Set OutlookApp = Nothing 
Set objMail = Nothing 

End Sub 

Answer 2

用这个替换您构建MailDest变量的代码的相关部分。

MailDest = vbNullString 
For iCounter = 1 To WorksheetFunction.CountA(Columns(13)) 
    If Cells(iCounter, 13).Offset(0, -1) = "Send Reminder" Then 
     If Not CBool(InStr(1, .to, Chr(64))) Then 
      .to = Cells(iCounter, 13).Value 
     ElseIf Not CBool(InStr(1, MailDest, Chr(64))) Then 
      MailDest = Cells(iCounter, 13).Value 
     Else 
      MailDest = MailDest & ";" & Cells(iCounter, 13).Value 
     End If 
    End If 
Next iCounter 

第一个收件人将进入邮件项目的.To。随后的收件人将进入MailDest var，然后将其放入.BCC。