Quantcast
Channel: Excel Help Forum - Excel Programming / VBA / Macros
Viewing all articles
Browse latest Browse all 50068

Changing From Email Address in Excel Macro

$
0
0
Hi All,

Here is the code that i am currently using to send emails with file name in column A to Email address in column B and
File path in column C.

Is there a way I can add from email address to this code. I have to change the Email address manually because i cant use
my email address while sending these emails. I have to use the Admin email in outlook.

Also can I have a Msgbox which comes up if any file is not attached but if I enable it the code runs too slow. any help on that.

Code:

Sub Send_Files()
    Dim OutApp As Outlook.Application
    Dim OutMail As Outlook.MailItem
    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("Sheet1")

    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(olMailItem)
            With OutMail
                .to = cell.Value
                .Subject = "Open and Overdue - " & cell.Offset(0, -1).Value
                .Body = "Good Morning," & vbNewLine & vbNewLine & _
             
                For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
                    If Trim(FileCell) <> "" Then
                        If Dir(FileCell.Value) <> "" Then
                            .Attachments.Add FileCell.Value
                            Else
                            MsgBox "Error: Some Files Not Attached" & MyLF & "Check Emails Before Sending", vbOKOnly + vbCritical, "Email"
                       
                        End If
                    End If
                Next FileCell

                .Display 'Or use Send
            End With

            Set OutMail = Nothing
        End If
    Next cell

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


Viewing all articles
Browse latest Browse all 50068

Trending Articles