Forum Discussion

DrishM's avatar
DrishM
Copper Contributor
Dec 21, 2020
Solved

Macro used to send automatic emails

I am using the Ron de Bruin macro to send automatic emails to various users and that is working perfectly. As below: Sub Send_Files() 'Working in Excel 2000-2016 'For Tips see: http://www.ron...
excel
Formulas and Functions
Macros and VBA
office 365
  • HansVogelaar's avatar
    HansVogelaar
    Dec 21, 2020

    DrishM 

    Make sure that the file names in column C include the extension (e.g. Report.pdf, not Report).

    See if this does what you want:

     

    Sub Send_Files()
    'Working in Excel 2000-2016
    'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm

    ' *** Change as needed, keep trailing backslash ***
    Const Folder = "C:\Attachments\"

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

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

    Set OutApp = CreateObject("Outlook.Application")

    Set sh = Sheets("book1")
    For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" Then
            Set OutMail = OutApp.CreateItem(0)

            With OutMail
                .To = cell.Value
                .Subject = "Attachments for Account - " & cell.Offset(0, -1).Value
                .BodyFormat = 1
                .HTMLBody = "<HTML><body> Good day, <p> Please find attached document for your attention. </p> " & _
                    "<p> Thank you. </p> <p> Regards. </p> </body></HTML>"

                Set FileCell = cell.Offset(0, 1)
                If Trim(FileCell.Value) <> "" Then
                    If Dir(Folder & FileCell.Value) <> "" Then
                        .Attachments.Add Folder & FileCell.Value
                    End If
                End If

                .Send 'Or use .Display
            End With

            Set OutMail = Nothing
        End If
    Next cell

    Set OutApp = Nothing
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub
HansVogelaar's avatar
HansVogelaar
MVP
Dec 21, 2020

DrishM 

Make sure that the file names in column C include the extension (e.g. Report.pdf, not Report).

See if this does what you want:

 

Sub Send_Files()
    'Working in Excel 2000-2016
    'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm

    ' *** Change as needed, keep trailing backslash ***
    Const Folder = "C:\Attachments\"

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

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

    Set OutApp = CreateObject("Outlook.Application")

    Set sh = Sheets("book1")
    For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" Then
            Set OutMail = OutApp.CreateItem(0)

            With OutMail
                .To = cell.Value
                .Subject = "Attachments for Account - " & cell.Offset(0, -1).Value
                .BodyFormat = 1
                .HTMLBody = "<HTML><body> Good day, <p> Please find attached document for your attention. </p> " & _
                    "<p> Thank you. </p> <p> Regards. </p> </body></HTML>"

                Set FileCell = cell.Offset(0, 1)
                If Trim(FileCell.Value) <> "" Then
                    If Dir(Folder & FileCell.Value) <> "" Then
                        .Attachments.Add Folder & FileCell.Value
                    End If
                End If

                .Send 'Or use .Display
            End With

            Set OutMail = Nothing
        End If
    Next cell

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

Resources