Copy attachment contents into body of email !

Hi all.

I have the following code that is being used to send an attachment via email.

IS there something I can add to the code that will allow the contents of a sheet to be copied and pasted into the body of the email.

Any help would be much appreciated

Option Explicit


Sub Button1_Click()

    Dim lErrorNo    As Long
    Dim OutMail     As Object
    Dim myEmail     As String
    Dim OutApp      As Object
    Dim xNmae       As Object

    If ThisWorkbook.Saved = True Then

          Set OutApp = CreateObject("Outlook.Application")
          Set OutMail = OutApp.CreateItem(0)
          Set xNmae = OutApp.GetNamespace("MAPI")

          myEmail = xNmae.Session.CurrentUser.AddressEntry. _
                          GetExchangeUser.PrimarySmtpAddress

          With OutMail

              .To = "XXXX;XXXXX"
              .CC = myEmail
              .BCC = ""
              .Subject = "Ad Hoc Report Request"
              .Body = "Hi. Please find attached my ad hoc request form."
              .Attachments.Add ActiveWorkbook.FullName

              On Error Resume Next
                  .Send
'                 Record the number of any error which may have occurred
                  lErrorNo = Err.Number
              On Error GoTo 0

'             Display a "Success" or "Failure" message as appropriate
              If lErrorNo = 0 Then
                    MsgBox "Your request has succesfully been sent by email.You may now close the workbook", vbInformation
              Else: MsgBox "An error occurred - the email was NOT sent", vbCritical
              End If

          End With

    Else: MsgBox "Please save the workbook first..", vbInformation

    End If

    Set OutMail = Nothing
    Set OutApp = Nothing
    Set xNmae = Nothing

End Sub

How about this:

                Dim rng As Range
                
                Set rng = Sheets("Sheet1").Range("A41:A62")
                '  .Body = "Hi. Please find attached my ad hoc request form." 'If needed
                For Each r In rng
                 .Body = .Body & r
                Next r

Instead of

.Body = "Hi. Please find attached my ad hoc request form."

You wanted to put some range values in e-mail body?

So you also need to edit this range and set what you trying to insert:

Set rng = Sheets("Sheet1").Range("A41:A62")

So does it work?

Here, try this:

Option Explicit


Sub Button1_Click()

    Dim lErrorNo    As Long
    Dim OutMail     As Object
    Dim myEmail     As String
    Dim OutApp      As Object
    Dim xNmae       As Object
    Dim rng As Range, R As Variant

    If ThisWorkbook.Saved = True Then

          Set OutApp = CreateObject("Outlook.Application")
          Set OutMail = OutApp.CreateItem(0)
          Set xNmae = OutApp.GetNamespace("MAPI")

          myEmail = xNmae.Session.CurrentUser.AddressEntry. _
                          GetExchangeUser.PrimarySmtpAddress

          With OutMail

              .To = "XXXX;XXXXX"
              .CC = myEmail
              .BCC = ""
              .Subject = "Ad Hoc Report Request"

               Set rng = Sheets("Sheet1").Range("A41:A62")
                  .Body = "Hi. Please find attached my ad hoc request form." 'If needed
                For Each R In rng
                 .Body = .Body & R
               Next R

              .Attachments.Add ActiveWorkbook.FullName

              On Error Resume Next
                  .Send
'                 Record the number of any error which may have occurred
                  lErrorNo = Err.Number
              On Error GoTo 0

'             Display a "Success" or "Failure" message as appropriate
              If lErrorNo = 0 Then
                    MsgBox "Your request has succesfully been sent by email.You may now close the workbook", vbInformation
              Else: MsgBox "An error occurred - the email was NOT sent", vbCritical
              End If

          End With

    Else: MsgBox "Please save the workbook first..", vbInformation

    End If

    Set OutMail = Nothing
    Set OutApp = Nothing
    Set xNmae = Nothing

End Sub