VBA Outlook mail attachment

[PhysicsGeek2022]

Hi All:

I am creating a spreadsheet that will send automatic email reminders to clients using a VBA Macros code. The code uses outlook. I have created the code and spreadsheet to do everything I'd like except attach individual files and keep my signature in my outlook e-mail. I know it can be done (attach files) as I have attached files this way in a previous version of the code. However, now with this new advanced code I can't get the files to attach. If I add the Attachment.Add function, no e-mail are sent at all. If I take the Attachment.Add function out then my e-mails send fine but without the attachment. I'm hoping someone can help me with this. Below is my code. Thank you!



Public Sub Send_Email_Automatically2()
Dim rngD, rngS, rngT, rngU As Range
Dim ob1, ob2 As Object
Dim LRow, x As Long
Dim l, strbody, rSendValue, mSub As String
On Error Resume Next
Set rngD = Range("P2", Range("p2").End(xlDown))
If rngD Is Nothing Then Exit Sub
Set rngS = Range("I2", Range("i2").End(xlDown))
If rngS Is Nothing Then Exit Sub
Set rngT = Range("S2", Range("s2").End(xlDown))
If rngT Is Nothing Then Exit Sub
Set rngU = Range("U2", Range("u2").End(xlDown))
If rngU Is Nothing Then Exit Sub
strFolder = "X:\Nuclear Medicine\NEW LEAD APRON EXCEL REPORTS\New Lead Apron Logs 11.2022"
LRow = rngD.Rows.Count
Set rngD = rngD(1)
Set rngS = rngS(1)
Set rngT = rngT(1)
Set rngU = rngU(1)
Set ob1 = CreateObject("Outlook.Application")
For x = 1 To LRow
rngDValue = ""
rngDValue = rngD.Offset(x - 1).Value
If rngDValue <> "" Then
If CDate(rngDValue) - Date < 0 Then
rngSValue = rngS.Offset(x - 1).Value
mSub = rngT.Offset(0, -1).Value
l = ""
strbody = ""
strbody = strbody & rngT.Offset(x - 1).Value & l
strbody = strbody
Set ob2 = ob1.CreateItem(0)
With ob2
.Subject = mSub
.To = rngS
.Body = strbody
'.Attachments.Add strFolder & "\" & rngU
.display
End With
Set ob2 = Nothing
End If
End If
Next
Set ob1 = Nothing
End Sub

 

[Anthony47]

My previous message meant two things:
1) to keep a signature, we should have been using the html format, rather then the text format, that is explicitly behind the "ob2.Body" instruction. But this makes a little bit more complex creating the "HTMLBody" of the email, since we have to respect the htm syntax
2) but we may append a text that mimics the signature using the codes I showed; and indeed I thought that your l="" was used just to add the signature that you had hid in the shared code.

ALSO, I was wrong in marking as useless the line strbody = ""
-since we are in a loop, that line clear the previous text, so it has to be kept

 

[PhysicsGeek2022]

My previous message meant two things:
1) to keep a signature, we should have been using the html format, rather then the text format, that is explicitly behind the "ob2.Body" instruction. But this makes a little bit more complex creating the "HTMLBody" of the email, since we have to respect the htm syntax
2) but we may append a text that mimics the signature using the codes I showed; and indeed I thought that your l="" was used just to add the signature that you had hid in the shared code.

ALSO, I was wrong in marking as useless the line strbody = ""
-since we are in a loop, that line clear the previous text, so it has to be kept

I ran the code again while in the office and I am receiving the same error.

 

[Anthony47]

Could you share the code you are now using?

 

[PhysicsGeek2022]

Could you share the code you are now using?

Public Sub Send_Email_Automatically2()
 Dim rngD, rngS, rngT, rngU As Range
 Dim ob1, ob2 As Object
 Dim LRow, x As Long
 Dim l, strbody, rSendValue, mSub As String
 Set rngD = Range("P2", Range("p2").End(xlDown))
 If rngD Is Nothing Then Exit Sub
 Set rngS = Range("I2", Range("i2").End(xlDown))
 If rngS Is Nothing Then Exit Sub
 Set rngT = Range("S2", Range("s2").End(xlDown))
 If rngT Is Nothing Then Exit Sub
 Set rngU = Range("U2", Range("u2").End(xlDown))
 If rngU Is Nothing Then Exit Sub
 LRow = rngD.Rows.Count
 Set rngD = rngD(1)
 Set rngS = rngS(1)
 Set rngT = rngT(1)
 Set ob1 = CreateObject("Outlook.Application")
 For x = 1 To LRow
 rngDValue = ""
 rngDValue = rngD.Offset(x - 1).Value
 If rngDValue <> "" Then
 If CDate(rngDValue) - Date < 0 Then
 rngSValue = rngS.Offset(x - 1).Value
 mSub = rngT.Offset(0, -1).Value
 l = vbCrLf & "Medical/Health Physics Technologist" & vbCrLf & "LVHN Imaging Physics & Radiation Safety" & vbCrLf & "(P) 484-224-1626"
 strbody = ""
 strbody = strbody & rngT.Offset(x - 1).Value & l
 Set ob2 = ob1.CreateItem(0)
 With ob2
 .Subject = mSub
 .To = rngS
 .Body = strbody
 MsgBox ("X=" & x & vbCrLf & rngU.Address(0, 0) & vbCrLf & rngU.Cells(x, 1))
 .Attachments.Add rngU.Cells(x, 1)
 .display
 End With
 Set ob2 = Nothing
 End If
 End If
 Next
 Set ob1 = Nothing
 End Sub

 

[Anthony47]

So you get the msgbox and immediately after the error, with line .Attachments.Add rngU.Cells(x, 1) highlighted. Correct?

Could please also list what is in columns P, I, and S? I don't ask for the text in those columns but what type of information they contain

 

[PhysicsGeek2022]

So you get the msgbox and immediately after the error, with line .Attachments.Add rngU.Cells(x, 1) highlighted. Correct?

Could please also list what is in columns P, I, and S? I don't ask for the text in those columns but what type of information they contain

Yes. .Attachments.Add rngU.Calls (x,1) is highlighted after the text box.

Column P is the due date (When I want the e-mail sent... that date or if the date has passed).
Column I is The e-mail address I'd like the e-mail sent to
Column S is the Body of the e-mail.

I have it set up so that as things change in the excel file everything else will update including the body of the letter.

 

[Anthony47]

I get the same error, need to run some testing on an older version (now I use Office 365, as you do)

 

[Anthony47]

We MUST use

.Attachments.Add rngU.Cells(x, 1).Value

 

[Anthony47]

There are few lines that needs to be modified.
My suggestion is that you replace the main For x /Next x loop as follows:

 For x = 1 To LRow
'''     rngDValue = ""
     rngDValue = rngD.Offset(x - 1).Value
     If rngDValue <> "" Then
         If CDate(rngDValue) - Date < 0 Then
'''             rngSValue = rngS.Offset(x - 1).Value
             mSub = rngT.Offset(x - 1, -1).Value
             l = vbCrLf & "Medical/Health Physics Technologist" & vbCrLf & "LVHN Imaging Physics & Radiation Safety" & vbCrLf & "(P) 484-224-1626"
             strbody = ""
             strbody = strbody & rngT.Offset(x - 1).Value & l
             Set ob2 = ob1.CreateItem(0)
             With ob2
                .Subject = mSub
                .To = rngS.Cells(x, 1)
                .Body = strbody
            '    MsgBox ("X=" & x & vbCrLf & rngU.Address(0, 0) & vbCrLf & rngU.Cells(x, 1))
                .Attachments.Add rngU.Cells(x, 1).Value
                .Display
             End With
             Set ob2 = Nothing
         End If
     End If
 Next x

If it works then I shall ask for the meaning of other instructions...

 

[PhysicsGeek2022]

There are few lines that needs to be modified.
My suggestion is that you replace the main For x /Next x loop as follows:

 For x = 1 To LRow
'''     rngDValue = ""
     rngDValue = rngD.Offset(x - 1).Value
     If rngDValue <> "" Then
         If CDate(rngDValue) - Date < 0 Then
'''             rngSValue = rngS.Offset(x - 1).Value
             mSub = rngT.Offset(x - 1, -1).Value
             l = vbCrLf & "Medical/Health Physics Technologist" & vbCrLf & "LVHN Imaging Physics & Radiation Safety" & vbCrLf & "(P) 484-224-1626"
             strbody = ""
             strbody = strbody & rngT.Offset(x - 1).Value & l
             Set ob2 = ob1.CreateItem(0)
             With ob2
                .Subject = mSub
                .To = rngS.Cells(x, 1)
                .Body = strbody
            '    MsgBox ("X=" & x & vbCrLf & rngU.Address(0, 0) & vbCrLf & rngU.Cells(x, 1))
                .Attachments.Add rngU.Cells(x, 1).Value
                .Display
             End With
             Set ob2 = Nothing
         End If
     End If
 Next x

If it works then I shall ask for the meaning of other instructions...

Ok when I change the attachment code to

.Attachments.Add rngU (x,1).Value

It creates the e-mail with the dental van attachment but not the other files or e-mails that should be created; there should be at least one more created. I also still get this error message

and this one

When I run the debug it says the problem is with the attachment code. I should have more time this afternoon I just have a very busy morning. I appreciate all your help! I really really do!