email body text

[redspanna]

Hi all

I have following code that sends email using VBA

Sub send()


 Dim aOutlook As Object
 Dim aEmail As Object
 Recip = Sheets("email info").Range("A15").Value
 
 Set aOutlook = CreateObject("Outlook.Application")
 Set aEmail = aOutlook.CreateItem(0)
 'Set Subject
 aEmail.Subject = Recip
 'Set Body for mail
 aEmail.Body = "test"
 'Set Recipient
 aEmail.To = "xxxxxx@hotmail.com"
 'Send Mail
 aEmail.send
 MsgBox "Email has been sent"
End Sub

How can the Email Body field be changed so instead of showing "test" it copies a range found in Sheets("info").Range("A1:A15") ??

thanks in advance

 

[MrJoosten]

Try:

Dim count as range
Dim strbody as string
Dim strbody2 as string
Set count = Sheets("Info").Range("A1:A15").specialcells(xlcelltypevisible)

strbody = "Dear all, "
strbody2 = "this is my message"

With outmail
        .To = ""
        .CC = ""
        .BCC = ""
        .Subject = "Recip"
        .HTMLBody = strbody & "
" & "
" & strbody2 & RangetoHTML(count)
        .Attachments.Add ""
        .Display
End With

end sub

'function to get range to mail
Function RangetoHTML(count As Range)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    'Copy the range and create a new workbook to past the data in
    count.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
    'Close TempWB
    TempWB.Close savechanges:=False
    'Delete the htm file we used in this function
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

Got the function from the WWW.

Hope it helps.

 

[redspanna]

Hi MrJoosten - thanks for your help
The function code above produces a separate workbook to enable the data range to be copied to an email - I simply want a range used from Sheets("info").Range("A1:A15") - is there no simpler way?

thanks

 

[redspanna]

I got this to work which is great -

Sub Send_Range()
   
   ' Select the range of cells on the active worksheet.
   Sheets("email info").Select
   ActiveSheet.Range("A1:A14").Select
   
   ' Show the envelope on the ActiveWorkbook.
   ActiveWorkbook.EnvelopeVisible = True
   
      With ActiveSheet.MailEnvelope
      .Introduction = Sheets("email info").Range("A16").Value
      .Item.To = "xxxxxxx@hotmail.com"
      .Item.Subject = "staff Lateness alert"
      .Item.send
   End With
End Sub

Thanks for help though