VBA Display no attachment in Outlook

James-Grant · Sep 24th 2021

I have a code that sends a personalized email to clients on a list and attaches a customized excel spreadsheet to the email for each client. My Coworker wanted a line that would show all emails without attachments. The rest of the code works and sends everything correctly but the moment I inserted the Blue Section Below it crashed hard. I was wondering if anyone could help me with the display if no attachment part of the code.

Thank you.

Code

Sub Button1_Click()


Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range




With Application
.EnableEvents = False
.ScreenUpdating = False
End With


Set sh = Sheets("Sheet 1")


Set OutApp = CreateObject("Outlook.Application")


For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)


'Enter the path/file names in the C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")


If cell.Value Like "?*@?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)


With OutMail
.to = cell.Value
.CC = "Coworker Email Here"
.Subject = cell.Offset(0, 2).Value & "-Company Verbiage here...-" & cell.Offset(0, -1).Value
.Body = "Company Verbiage here..."






For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value


End If
End If
Next FileCell
If .Attachments.Count > 0 Then
.send
Else
.Display 1
End If
End With


Set OutMail = Nothing
End If
Next cell


Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub

Display More

rollis13 · Sep 24th 2021

Your macro works correctly for me, shows Outlook only when there is no attachment.

James-Grant · Sep 24th 2021

Thank you Rollis13 for testing it and confirming that it works.

rollis13 · Sep 24th 2021

Glad having been of some help.

For further information I would point out that I'am using Office 2016-32bit.

Anyway the code of your macro looks okay.

**royUK** · Sep 25th 2021

Welcome to the Forum. Please read the Forum Rules to understand how the Forum works and why I have added Code Tags to your post

All VBA code posted in the forum must be wrapped in code tags, which you omitted, including single-line code snippets.Be sure to use them in future posts.

How to use code tags

Just highlight all of the code and press the <> in the post menu above button to add the code tags.

Thanks.

**royUK** · Sep 25th 2021

You might find this a little better, especially the error handlers to prevent events remaining off in case of an error, events will not reset automatically.

Code

Sub Button1_Click()
    Dim OutApp As Object, OutMail As Object
    Dim cell As Range, FileCell As Range, rng As Range
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
        
        With Sheets("Sheet 1")
            Set OutApp = CreateObject("Outlook.Application")
            ''/// SpecialCells will raise an error if no cells matching the specified Type is found
            On Error Resume Next
            For Each cell In .Columns("B").Cells.SpecialCells(xlCellTypeConstants)
            On Error GoTo 0
                'Enter the path/file names in the C:Z column in each row
                Set rng = .Cells(cell.Row, 1).Range("C1:Z1")
                If cell.Value Like "?*@?*.?*" And _
                Application.WorksheetFunction.CountA(rng) > 0 Then
                    Set OutMail = OutApp.CreateItem(0)
                    With OutMail
                        .to = cell.Value
                        .CC = "Coworker Email Here"
                        .Subject = cell.Offset(0, 2).Value & "-Company Verbiage here...-" & cell.Offset(0, -1).Value
                        .Body = "Company Verbiage here..."
                        For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
                            If Trim(FileCell) <> "" Then
                                If Dir(FileCell.Value) <> "" Then
                                    .Attachments.Add FileCell.Value
                                End If
                            End If
                        Next FileCell
                        If .Attachments.Count > 0 Then
                            .send
                        Else
                            .Display 1
                        End If
                    End With
                    Set OutMail = Nothing
                End If
            Next cell
        End With
              
err_handler:
 Set OutApp = Nothing
        .EnableEvents = True
        ''/// not needed now
'        .ScreenUpdating = True
    End With
End Sub

Display More

VBA Display no attachment in Outlook

Participate now!

Share

Tags