outlook mail with multiple attachments

[Veeru106]

Hi, I have a code to send outlook mail with a attachment and it is working fine but how can I improve it and send 2 or multiple excels in same folder ..Please suggest

Sub attachment()
Dim strlocation As String
Dim outapp As Object
Dim outmail As Object
Set outapp = CreateObject("outlook.application")
Set outmail = outapp.createitem(0)
strlocation = "C:\Users\ah0118261\Desktop\Goals 2016-FPM Team.pptx"
With outmail
.To = ""
.CC = ""
.BCC = ""
.Subject = "Training Structure"
.Body = "Please write your content"
.Attachments.Add (strlocation)
.display
End With
Set outmail = Nothing
Set outapp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

 

[Logit]

Option Explicit

Dim mainWB As Workbook
Sub sumit()             'The SEND EMAIL button is connected to this macro.
On Error Resume Next
    Dim SendID
    Dim CCID
    Dim Subject
    Dim Body
    Dim AttachFile
    Dim otlApp As Object
    Dim olMailItem As Variant
    Dim olMail As Variant
    Dim WrdRng As Variant
    Dim Doc As Variant
    Dim i As Integer
    Dim atch As Variant
   
    Set otlApp = CreateObject("Outlook.Application")    'Connects to Outlook Mail
    Set olMail = otlApp.CreateItem(olMailItem)          'Same as starting an email in Outlook
    Set Doc = olMail.GetInspector.WordEditor
    Set mainWB = ActiveWorkbook

    SendID = mainWB.Sheets("Mail").ComboBox1.Value 'Range("C15").Value
    CCID = mainWB.Sheets("Mail").Range("B2").Value  'CC in C16
    Subject = mainWB.Sheets("Mail").Range("B3").Value   'Subject Line listed in C17
    Body = mainWB.Sheets("Mail").Range("B9").Value      'Body of email ext in C18
    AttachFile = mainWB.Sheets("Mail").Range("B4").Value    'starts identifying and acquiring the attachments listed in C18:22
    With olMail
        .To = SendID
        If CCID <> "" Then
          .CC = CCID
        End If
        .Subject = Subject
        .Body = Body
        Body = WrdRng
     
        Set WrdRng = Sheets("Mail").Range("B9")
        '.Display
        For i = 4 To 8
          atch = mainWB.Sheets("Mail").Range("B" & i).Value  'the i identifies all of the attachments listed in C18:C22
          If atch <> "" Then
            .Attachments.Add atch
          End If
        Next
        '.Send      'uncomment to have emails send automatically without review
        .Display    'uncomment to have emails display for review prior to sending
    End With
    MsgBox ("Your Mail has been sent to " & SendID) 'Notifies user the email was sent and who to
End Sub
Function browse(rng)        'This section calls the Open/Save File subwindow enabling selection of attachments
    Dim FSO As Object
    Dim blnOpen
    Dim mainWB As Workbook
    Dim strFileToOpen As Variant
    Set mainWB = ActiveWorkbook
    strFileToOpen = Application.GetOpenFilename(Title:="Please choose a file to open")
    If strFileToOpen = False Then
        MsgBox "No file selected.", vbExclamation, "Sorry!"
        Exit Function
    Else
        mainWB.Sheets("Mail").Range(rng).Value = strFileToOpen
    End If
End Function
Sub browse1()       'First attachment in C18
    browse ("B4")
End Sub
Sub browse2()       'Second attachment in C19
    browse ("B5")
End Sub
Sub browse3()       'Third attachment in C20
    browse ("B6")
End Sub
Sub browse4()       'Fourth attachmentin C21
    browse ("B7")
End Sub
Sub browse5()       'Fifth attachment in C22
    browse ("B8")
End Sub

Sub CommandButton8_Click()  'Clears all fields in form
    Dim ComboBox1 As Object
    Sheets("Mail").ComboBox1.Value = ""
    Sheets("Mail").Range("B1:B9").ClearContents
    Sheets("Mail").Range("B1").Select
End Sub

 

[Veeru106]

Thanks for the code....but can we have something modified in above code pasted by me...This code is too heavy and I need to create a separate sheet altogether to get it work....Thanks

 

[Logit]

Option Explicit

Sub attachment()
Dim strlocation As String
Dim outapp As Object
Dim outmail As Object
Dim mainWB As Workbook
Dim atch As Variant
Dim i As Integer

Set outapp = CreateObject("outlook.application")
Set outmail = outapp.createitem(0)
Set mainWB = ActiveWorkbook
   
With outmail
    .To = "me@yahoo.com"
    .CC = "you@yahoo.com"
    .BCC = "ok@yahoo.com"
    .Subject = "Training Structure"
    .Body = "Please write your content"
   
        For i = 2 To 8   ' 'the i identifies all of the attachments listed in B
            atch = mainWB.Sheets("Sheet1").Range("B" & i).Value  
                      
            If atch <> "" Then
                .Attachments.Add atch
            End If
           
        Next
   
    .display

End With

Set outmail = Nothing
Set outapp = Nothing

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

 

[Veeru106]

Yes this is working...Great and thank you

 

[Logit]

You are welcome