Question

这是更新。代码工作正常，但一旦我进入路径它停止运作，这让我觉得路径不正确？我不知道还能做什么，我应该改变它在我的文档或桌面中的位置吗？

Sub BLS()
Dim wkbReminderList As Workbook
Dim wksReminderList As Worksheet
Dim lngNumberOfRowsInReminders As Long
Dim i As Long
Dim strEmail As String, strSubject As String, strBody As String
Dim sAttcmnt1 As String, sAttcmnt2 As String, sAttcmnt3 As String
Set wkbReminderList = ActiveWorkbook
Set wksReminderList = ActiveWorkbook.ActiveSheet

lngNumberOfRowsInReminders = _
         wksReminderList.Cells(Rows.Count, "A").End(xlUp).Row

For i = 2 To lngNumberOfRowsInReminders

    If wksReminderList.Cells(i, 7) = "" And _
       wksReminderList.Cells(i, 3) <= Date Then

            strEmail = wksReminderList.Cells(i, 6).Value
            strSubject = "Your BLS Certification is Expiring within 60 Days"
            strBody = "Hello," & vbCrLf & _
      " Your BLS Certification is expiring within 60 days."

        sAttcmnt1 = "C:\Keycodes.pdf"

           If SendAnOutlookEmail(strEmail, _
                      strSubject, _
                      strBody, _
                      sAttcmnt1, _
                      sAttcmnt2, _
                      sAttcmnt3) Then
                wksReminderList.Cells(i, 7) = Date
            End If

    ElseIf wksReminderList.Cells(i, 8) = "" And _
           wksReminderList.Cells(i, 4) <= Date Then

            strEmail = wksReminderList.Cells(i, 6).Value
            strSubject = "BLS is Expiring in 30 Days!!!"
            strBody = "other text here..."
            If SendAnOutlookEmail(strEmail, strSubject, strBody) Then
                wksReminderList.Cells(i, 8) = Date
            End If
    End If

Next i

End Sub

Private Function SendAnOutlookEmail(strAddress As String, _
                                    strSubject As String, _
                                    strBody As String, _
                                    Optional sAtt1 As String, _
                                    Optional sAtt2 As String, _
                                    Optional sAtt3 As String) As Boolean
SendAnOutlookEmail = False

Set OutApp = CreateObject("Outlook.Application")
OutApp.session.Logon "Outlook"
Set OutMail = OutApp.CreateItem(0)
On Error GoTo ErrorOccurred
 With OutMail
    .To = strAddress
    .Subject = strSubject
    .Body = strBody
    If sAtt1 <> "" Then .Attachments.Add = sAtt1
    If sAtt2 <> "" Then .Attachments.Add = sAtt2
    If sAtt3 <> "" Then .Attachments.Add = sAtt3
    .Send
End With
SendAnOutlookEmail = True

Continue:
    On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Exit Function

ErrorOccurred:
    Resume Continue
End Function

Answer 1

这是你在尝试什么？（ TIRED AND TESTED ）

Sub Sample()
    Dim strEmail As String, strSubject As String, strBody As String
    Dim sAttcmnt1 As String, sAttcmnt2 As String, sAttcmnt3 As String

    '
    '~~> Set values of variables here
    '
    strEmail = "Sid@sid.com"
    strSubject = "Blah Blah"
    strBody = "Blah Blah"
    sAttcmnt1 = "C:\Test.txt"
    '
    ' ~~> and so on
    '

    If SendAnOutlookEmail(strEmail, _
                          strSubject, _
                          strBody, _
                          sAttcmnt1, _
                          sAttcmnt2, _
                          sAttcmnt3) Then
        '
        '~~> Do Something
        '
    End If
End Sub

Private Function SendAnOutlookEmail(strAddress As String, _
                                    strSubject As String, _
                                    strBody As String, _
                                    Optional sAtt1 As String, _
                                    Optional sAtt2 As String, _
                                    Optional sAtt3 As String) As Boolean
    '
    '~~> Rest of the code
    '
    With OutMail
        .To = strAddress
        .Subject = strSubject
        .Body = strBody
        If sAtt1 <> "" Then .Attachments.Add sAtt1
        If sAtt2 <> "" Then .Attachments.Add sAtt2
        If sAtt3 <> "" Then .Attachments.Add sAtt3
        .Send
    End With

    '
    '~~> Rest of the code
    '
End Function

添加附件到VBA

1 个答案: