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.rondebruin.nl/win/winmail/Outlook/tips.htm
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("book1")

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
.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>"

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

.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

My columns in Excel are as follows:

  • Account Name
  • Email
  • File name

The "account name" and the "file name" (file I am linking to) is exactly the same.

Is it possible to add onto the existing macro a way in which that account name will automatically filter against a specified folder on Windows and add the links to the on the "file names" column automatically on the Excel sheet instead of manually going to change it? This will be changed every month.

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

1 Reply

Sort By
  • 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