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

 

[PhysicsGeek2022]

Ok
Your current code

Set rngU = Range("U2", Range("u2").End(xlDown))                                                '1
'..
strFolder = "X:\Nuclear Medicine\NEW LEAD APRON EXCEL REPORTS\New Lead Apron Logs 11.2022"     '2
'..
'..
Set rngU = rngU(1)                                                                             '3
'..
'..
'..
.Attachment.Add strFolder & "\" & rngU                                                         '4

Since in column U you have the complete path and filename, in line 4 you don't have to use strForder & rngU
In line 3 you destroy the list of attachments and associate to rngU only the first one

So:
-remove lines 2 and 3
-try modifying line 4 to

.Attachment.Add rngU.Cells(X,1)

I tried what you suggested and got this error

 

[Anthony47]

On which line?

 

[PhysicsGeek2022]

On which line?

It doesn't say. I removed the error code, I removed lines 2 & 3 from your suggestion and I update line 4 to your suggestion. When I run the code I get the error stated above.

 

[Anthony47]

Press Debug on the error message and the failing line will be highlighted

 

[PhysicsGeek2022]

Press Debug on the error message and the failing line will be highlighted

The error is on the line .Attachment.Add rngU.Cells (X,1)

 

[Anthony47]

Add (for testing) this MsgBox line in this position:

.Body = strbody
MsgBox ("X=" & x & vbCrLf & rngU.Address(0, 0) & vbCrLf & rngU.Cells(x, 1))          '<<<<
.Attachment.Add rngU.Cells(X,1)

Run the macro and share a picture of the msgbox. Conferm that, after acknowledging the msgbox (ok) you immediately get the error

To prevent misunderstandings, could you share also the updated code you are now using?

 

[Anthony47]

NB: I edited the message

 

[PhysicsGeek2022]

Add (for testing) this MsgBox line in this position:

.Body = strbody
MsgBox ("X=" & x & vbCrLf & rngU.Address(0, 0) & vbCrLf & rngU.Cells(x, 1))          '<<<<
.Attachment.Add rngU.Cells(X,1)

Run the macro and share a picture of the msgbox. Conferm that, after acknowledging the msgbox (ok) you immediately get the error

To prevent misunderstandings, could you share also the updated code you are now using?

This is the message I received based on your suggestion

This is the code I am 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 = ""
strbody = ""
strbody = strbody & rngT.Offset(x - 1).Value & l
strbody = strbody
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))
.Attachment.Add rngU.Cells(x, 1)
.display
End With
Set ob2 = Nothing
End If
End If
Next
Set ob1 = Nothing
End Sub

 

[Anthony47]

Grrrr....
It has to be
.Attachments.Add rngU.Cells(X,1)

 

[PhysicsGeek2022]

Grrrr....
It has to be
.Attachments.Add rngU.Cells(X,1)

I tried that as well as that is what I thought it should be but I get the same error message. I tried it a bunch of different ways.