1. Welcome to Chandoo.org Forums. Short message for you

    Hi Guest,

    Thanks for joining Chandoo.org forums. We are here to make you awesome in Excel. Before you post your first question, please read this short introduction guide. When posting or responding to questions please remember our values at Chandoo.org are: Humility, Passion, Fun, Awesomeness, Simplicity, Sharing Remember that we have people here for whom English is not there first language and we need to allow for this in our dealings.

    Yours,
    Chandoo
  2. Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  3. When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Please Help: need to send the mail along with attachment and also same paste in mail body :

Discussion in 'VBA Macros' started by Mohammad Shafaat, Oct 9, 2018.

  1. Mohammad Shafaat

    Mohammad Shafaat New Member

    Messages:
    6
    Please help and edit VB Code to send the mail along with attachment and same paste on mail body also: thanks in advance.

    Code (vb):
    Sub sendmail()
    '
    ' sendmail Macro
    '

    Dim dte As Date
    Dim mon As Integer
    Dim yr As Integer
    Dim mailcount As Integer
    Dim filtercol As Integer
    Dim Maildb As Object
    Dim MailDoc As Object
    Dim attachME As Object
    Dim Session As Object
    Dim EmbedObj1 As Object
    Dim UserName As String
    Dim MailDbName As String
    Dim recipient As String
    Dim ccRecipient As String
    Dim bccRecipient As String
    Dim subject As String
    Dim finlsub As String
    Dim stSignature As String
    Dim addname As String
    Dim bodytext As String
    Dim Attachment1 As String
    Dim Attachment2 As String
    Dim FilName As String
    Application.DisplayAlerts = False
    dte = Date
    mon = Month(dte)
    yr = Year(dte)
    Attachment2 = Range("F15").Value
    Sheets("MAIL-ID").Activate
    Range("AG2").Value = 0
    mailcount = Range("AG14").Value
    subject = Range("F2").Value
    bodytext = Range("H2").Value & Chr(10) & Range("F7").Value & Chr(10) & Range("H3").Value & Chr(10) & Range("H4").Value & Chr(10) & Range("H5").Value & Chr(10)
    addname = Range("F12").Value
    If mon <= 12 Then GoTo validated 'Else If mon >= 12 Then GoTo exitsub
    exitsub: If UCase(Environ$("USERDOMAIN")) <> "domain" Then MsgBox "This is not your copy of Filtermails " & Chr(10) & "You are an UNAUTHORISED USER ", vbCritical
    Exit Sub
    validated: If mailcount = 0 Then MsgBox "There are no recepients in your list.", vbCritical, "WHAT ARE YOU DOING?"
    For x = 0 To (mailcount - 1)
    Sheets("MAIL-ID").Select
    Range("AG2").Value = x + 1
    FilName = (Environ$("cpinfo")) & "\cpinfo.xls"
    If Dir(FilName) <> "" Then
    Kill FilName
    End If
    filtercol = Range("G2").Value
    Range("AG4").Select
    Selection.Copy
    Range("AG7").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
      :=False, Transpose:=False
    Application.CutCopyMode = False
    recipient = Range("AG7").Value
    Range("AG5").Select
    Selection.Copy
    Range("AG8").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
      :=False, Transpose:=False
    Application.CutCopyMode = False
    ccRecipient = Range("AG8").Value
    If ccRecipient = "0" Then
    ccRecipient = ""
    End If
    Range("AG6").Select
    Selection.Copy
    Range("AG9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
      :=False, Transpose:=False
    Application.CutCopyMode = False
    bccRecipient = Range("AG9").Value
    If bccRecipient = "0" Then
    bccRecipient = ""
    End If
    Range("AG3").Select
    Selection.Copy
    Range("AG11").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
    Application.CutCopyMode = False
    Range("AG11").Copy (Sheets("DATA").Range("O60000"))
    Sheets("DATA").Select
    If addname = "YES" Then
    finlsub = subject & " ( " & Range("O60000").Value & " )"
    finlbody = "Dear " & Range("O60000").Value & Chr(10) & Chr(10) & bodytext
    End If
    If addname = "NO" Then
    finlsub = subject
    finlbody = bodytext
    End If
    Range("A1").Select
    If Range("a1") = "" Then
    MsgBox "NO or Wrong arrangement of Data in DATA Sheet", vbCritical
    Exit For
    End If
    Selection.AutoFilter
    Selection.AutoFilter field:=filtercol, Criteria1:= _
    Range("O60000").Value
    Range("A1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Workbooks.Add
    ActiveSheet.Paste
    Cells.Select
    Cells.EntireColumn.AutoFit
    ActiveWorkbook.SaveAs Filename:="C:\Users\Desktop\Extra\Data.xls", FileFormat:= _
    xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
      , CreateBackup:=False
    ActiveWorkbook.Close

    Dim OlApp As New Outlook.Application
    Dim myNameSp As Outlook.Namespace
    Dim myInbox As Outlook.MAPIFolder
    Dim myExplorer As Outlook.Explorer
    Dim NewMail As Outlook.MailItem
    Dim OutOpen As Boolean


      OutOpen = True
      Set myExplorer = OlApp.ActiveExplorer
      If TypeName(myExplorer) = "Nothing" Then
      OutOpen = False
      Set myNameSp = OlApp.GetNamespace("MAPI")
      Set myInbox = myNameSp.GetDefaultFolder(olFolderInbox)
      Set myExplorer = myInbox.GetExplorer
      End If
      'myExplorer.Display ' You don't have to show Outlook to use it

      ' Create a new mail message item.
     Set NewMail = OlApp.CreateItem(olMailItem)
      With NewMail
      '.Display ' You don't have to show the e-mail to send it
    .To = recipient
    .CC = ccRecipient
    .BCC = bccRecipient
    .subject = finlsub
    .body = finlbody & vbCrLf & vbCrLf & stSignature
    .Attachments.Add ("C:\Users\Desktop\Extra\Data.xls")

      End With

      NewMail.Send
      If Not OutOpen Then OlApp.Quit

      'Release memory.
     Set OlApp = Nothing
      Set myNameSp = Nothing
      Set myInbox = Nothing
      Set myExplorer = Nothing
      Set NewMail = Nothing
      recipient = ""
      ccRecipient = ""
      bccRecipient = ""
      finlsub = ""
      FilName = ""

    'finlsub = Null
    finlbody = Null
    Next
    Sheets("MAIL-ID").Activate
    Range("A1").Select
    MsgBox "Thank you for using this MACRO"
    End Sub

    Attached Files:

    Last edited by a moderator: Oct 10, 2018
  2. Mohammad Shafaat

    Mohammad Shafaat New Member

    Messages:
    6
    Please help i shall be highly obliged ..

    Thanks in advanced....

Share This Page