使用VBA在Excel中臨近到期日期時發送提醒跟進

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

以此替換在其中構建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變量，該變量隨后放入.BCC 。

Answer 2

該代碼已被修改並且可以正常工作。 單擊excel中的Visual Basic代碼環境

首先，從“工具”->“參考”->“ 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