Outlook Macro to send attachments

[praf007]

i want to create a macro where I can attach a pdf file to emails
Probably 150 emails some may have more then one attachment
beginner in macros so glad if you can help

 

[herofox]

First This Post It Must To be In VBA Dep.
hi ... You can to Use this Code

Option Explicit

Sub SendMail()
 
    Dim olApp As Outlook.Application
    Dim olMail As Outlook.MailItem
    Dim blRunning As boolean
 
     'get application
    blRunning=True
    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If olApp Is Nothing Then
        Set olApp = New Outlook.Application
        blRunning=False
    End If
    On Error Goto 0
 
    Set olMail = olApp.CreateItem(olMailItem)
    With olMail
         'Specify the email subject
        .Subject = "My email with attachment"
         'Specify who it should be sent to
         'Repeat this line to add further recipients
        .Recipients.Add "name@host.com"
         'specify the file to attach
         'repeat this line to add further attachments
        .Attachments.Add "c:\test.txt"
         'specify the text to appear in the email
        .Body = "Here is an email"
         'Choose which of the following 2 lines to have commented out
        .Display 'This will display the message for you to check and send yourself
         '.Send ' This will send the message straight away
    End With
 
    If Not blRunning Then olApp.Quit
 
    Set olApp=Nothing
    Set olMail=Nothing
 
End Sub

and elso You can to See This Site
Send Email from Excel with PDF

 

[praf007]

Thank you. Will try it

 

[Logit]

Option Explicit

Sub PC_Email()
    
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String
    Dim MailAttachments As String
    Dim cell As Variant '                             Not previously DIM'd
    
    Sheets("Sheet1").Select '                         Edit as required
    Range("A1").Select
    
    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")
    
 
   On Error GoTo cleanup
    If WorksheetFunction.CountA(Range("K2:K100")) = 0 Then
        MsgBox "To send email, please enter an X in Column K.", vbCritical, "Missing Entry"
        Exit Sub
    End If
    For Each cell In Columns("C").Cells
        If cell.Value Like "?*@?*.?*" And _
        LCase(Cells(cell.Row, "K").Value) <> "" Then
    
    Set OutMail = OutApp.CreateItem(0)
        
            On Error Resume Next
                              
            With OutMail
            
              strbody = "Please Delete Any Previous Emails Related To This Period" & vbNewLine & vbNewLine & _
                        "Number " & Cells(cell.Row, "F") & " timesheets covering the period WC " & Cells(cell.Row, "A") & " WE " & Cells(cell.Row, "G") & " and to be paid " & Cells(cell.Row, "G") + 90 & " ." & vbNewLine & vbNewLine & _
                        "Good Morning, " & vbNewLine & vbNewLine & _
                        "Please find attached applicable time sheet / expense's / receipts for WC: " & Cells(cell.Row, "A") & vbNewLine & vbNewLine & _
                        "Number : " & Cells(cell.Row, "F") & " timesheets to be paid " & Cells(cell.Row, "G") + 90 & vbNewLine & vbNewLine & _
                        "KR" & vbNewLine & vbNewLine & _
                        "TMcL"
              
                .To = Cells(cell.Row, "C").Value
                .CC = Cells(cell.Row, "D").Value
                .BCC = Cells(cell.Row, "E").Value
                .Subject = "WC " & Cells(cell.Row, "A").Value
                .Body = strbody
              
                '.Attachments.Add Application.ActiveWorkbook.FullName
                .Attachments.Add ActiveSheet.Cells(cell.Row, "H").Value
                .Attachments.Add ActiveSheet.Cells(cell.Row, "I").Value
                .Attachments.Add ActiveSheet.Cells(cell.Row, "J").Value
                
                .Display  'Or use .Send
                  
                
            End With
            On Error GoTo 0
            Set OutMail = Nothing
        End If
    Next cell


cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
    
End Sub

Sub ClrMailToSend()
    Sheets("Sheet1").Range("K2:K100").Value = ""
End Sub

Sub GetFilePath()
Dim dialogBox As FileDialog
Set dialogBox = Application.FileDialog(msoFileDialogOpen)

'Set the display properties - these are optional
'All the settings must be applied before the .Show command

'Do not allow multiple files to be selected
dialogBox.AllowMultiSelect = True

'Set the title of of the DialogBox
dialogBox.Title = "Select a file"

'Set the initial path to the C:\ drive.
 dialogBox.InitialFileName = "C:\Users\work3\OneDrive\timesheets as from May2018\"

'Show the dialog box and output full file path and file name
If dialogBox.Show = -1 Then
   ActiveCell.Value = dialogBox.SelectedItems(1)
End If
End Sub