Data from other sheet to copy into email

P

Patriot2879

Well-known Member
Joined
Feb 1, 2018
Messages
1,231
Office Version
  1. 2010
Platform
  1. Windows
Hi wondering if you can help me please with the code in BOLD, i am trying to grab the data from 'Work Issue' sheet from A1 to I then down to last, but it doesnt seem to be grabbing it and pasting into my email, everything else works apart from the little bit of code in bold, please can you help me? thanks for your time

HTML: 
Private Sub CommandButton1_Click()

    Const PR_SECURITY_FLAGS = "http://schemas.microsoft.com/mapi/proptag/0x6E010003"
    
    Dim aOutlook As Object
    Dim aEmail As Object
    Dim ulFlags As Integer
    Dim rngeAddresses As Range, rngeCell As Range, strRecipients As String
    Dim rngDataToEmail As Range
    
    Set aOutlook = CreateObject("Outlook.Application")
    Set aEmail = aOutlook.CreateItem(0)
    
        With Sheets("Work Issue")
        Set rngDataToEmail = .Range("A1:I" & .Range("A" & Rows.Count).End(xlUp).Row)
    End With
    
    ulFlags = ulFlags Or &H1 ' SECFLAG_ENCRYPTED
    
    aEmail.PropertyAccessor.SetProperty PR_SECURITY_FLAGS, (ulFlags)


          aEmail.HTMLBody = "<html>******>" & _
                            "<p>Hi " & Me.TextBox35.Value & "</p>" & _
                            "<p>" & Me.TextBox33.Value & "</p>" & _
                            "<p>" & Me.TextBox17.Value & "</p>" & _
                            "<table border=""1"", cellpadding=""10"", style=background:""#a6bbde"" >" & _
                "<tr>" & _
                            "<th>Date:</th>" & _
                            "<td>" & Me.TextBox18.Text & "</td><td>" & Me.TextBox19.Text & "</td>" & _
                            "<td>" & Me.TextBox21.Text & "</td><td>" & Me.TextBox23.Text & "</td>" & _
                            "<td>" & Me.TextBox25.Text & "</td><td>" & Me.TextBox26.Text & "</td>" & _
                            "</tr>" & _
                "<tr>" & _
                            "<th>Area:</th>" & _
                            "<td>" & Me.TextBox9.Value & "</td><td>" & Me.TextBox20.Value & "</td>" & _
                            "<td>" & Me.TextBox22.Value & "</td><td>" & Me.TextBox24.Value & "</td>" & _
                            "<td>" & Me.TextBox29.Value & "</td><td>" & Me.TextBox30.Value & "</td>" & _
                            "</tr>" & _
                            "</table>" & _
                "<br><br><br><br><br><br>" & _
                "<p>Many Thanks</p>" & _
                "<p>Complex Team</p>" & _
                "</body></html>"


        aEmail.Recipients.Add (UserForm1.TextBox36.Value)
        aEmail.CC = (UserForm1.TextBox37.Value)
        aEmail.BCC = ""
        aEmail.Subject = "Weekly " & Range("D2").Value & (UserForm1.TextBox39.Value)
        aEmail.Display
        
[code]
[/code]
       
Unload Me

End Sub
 
Sort by date Sort by votes
Hi good morning, please can you help with the code you provided i have added in
Code: 
aHTMLBody = rngDataToEmai
but where do i add
Code: 
       With Sheets("Work Issue")
        Set rngDataToEmail = .Range("A1:I" & .Range("A" & Rows.Count).End(xlUp).Row)
    End With
if you can advise me please? thank you for your time
 
Upvote 0

Excel Facts

Who is Mr Spreadsheet?
Author John Walkenbach was Mr Spreadsheet until his retirement in June 2019.
Hi this is what my code looks like now, but still doesnt put in the info
HTML: 
Private Sub CommandButton1_Click()

    Const PR_SECURITY_FLAGS = "http://schemas.microsoft.com/mapi/proptag/0x6E010003"
    
    Dim aOutlook As Object
    Dim aEmail As Object
    Dim ulFlags As Integer
    Dim rngeAddresses As Range, rngeCell As Range, strRecipients As String
    Dim rngDataToEmail As Range
    
    Set aOutlook = CreateObject("Outlook.Application")
    Set aEmail = aOutlook.CreateItem(0)
    
        With Sheets("Work Issue")
        Set rngDataToEmail = .Range("A1:I" & .Range("A" & Rows.Count).End(xlUp).Row)
    End With
    
    ulFlags = ulFlags Or &H1 ' SECFLAG_ENCRYPTED
    
    aEmail.PropertyAccessor.SetProperty PR_SECURITY_FLAGS, (ulFlags)


          aEmail.HTMLBody = "******>" & _
                            "Hi " & Me.TextBox35.Value & "
" & _
                            "" & Me.TextBox33.Value & "
" & _
                            "" & Me.TextBox17.Value & "
" & _
                            """1"", cellpadding=""10"", style=background:""#a6bbde"" >" & _
                "" & _
                            "" & _
                            "" & _
                            "" & _
                            "" & _
                            "" & _
                "" & _
                            "" & _
                            "" & _
                            "" & _
                            "" & _
                            "" & _
                            "Date:" & Me.TextBox18.Text & "" & Me.TextBox19.Text & "" & Me.TextBox21.Text & "" & Me.TextBox23.Text & "" & Me.TextBox25.Text & "" & Me.TextBox26.Text & "Area:" & Me.TextBox9.Value & "" & Me.TextBox20.Value & "" & Me.TextBox22.Value & "" & Me.TextBox24.Value & "" & Me.TextBox29.Value & "" & Me.TextBox30.Value & "" & _
                "" & _
                "Many Thanks
" & _
                "Complex Team
" & _
                ""


        aEmail.Recipients.Add (UserForm1.TextBox36.Value)
        aEmail.CC = (UserForm1.TextBox37.Value)
        aEmail.BCC = ""
        aEmail.Subject = "Weekly " & Range("D2").Value & (UserForm1.TextBox39.Value)
aHTMLBody = rngDataToEmail
        aEmail.Display
        
[code]
[/code]
       
Unload Me

End Sub
but this still doesnt put the info in the email from the snippet below, but everything else still works in the coding, please can you help
Code: 
        With Sheets("Work Issue")
        Set rngDataToEmail = .Range("A1:I" & .Range("A" & Rows.Count).End(xlUp).Row)
    End With
 
Last edited:
Upvote 0
hi with the new bit of code added i now get a yellow error on line
Code: 
Set rngDataToEmail = .Range("A:I" & .Range("A" & Rows.Count).End(xlUp).Row)
and it says Run Time 1004, Application defined or object defined error, if this helps?
 
Upvote 0
Hi Good morning, just wondering if you are able to help me please? i am really stuck with this at the moment. thank you for your time
 
Upvote 0
Hi, this is the code below that i have used, i have added the extra line as requested in previous comments but its still not getting the data from my 'Work Issue' sheet ranging from A1 - I.

I hope you can have a look and advise/help me please?

HTML: 
Private Sub CommandButton1_Click()

    Const PR_SECURITY_FLAGS = "http://schemas.microsoft.com/mapi/proptag/0x6E010003"
    
    Dim aOutlook As Object
    Dim aEmail As Object
    Dim ulFlags As Integer
    Dim rngeAddresses As Range, rngeCell As Range, strRecipients As String
    Dim rngDataToEmail As Range
    
    Set aOutlook = CreateObject("Outlook.Application")
    Set aEmail = aOutlook.CreateItem(0)
    
        With Sheets("Work Issue")
        Set rngDataToEmail = .Range("A:I" & .Range("A" & Rows.Count).End(xlUp).Row)
    End With
    
    ulFlags = ulFlags Or &H1 ' SECFLAG_ENCRYPTED
    
    aEmail.PropertyAccessor.SetProperty PR_SECURITY_FLAGS, (ulFlags)


          aEmail.HTMLBody = "<html>******>" & _
                            "<p>Hi " & Me.TextBox35.Value & "</p>" & _
                            "<p>" & Me.TextBox33.Value & "</p>" & _
                            "<p>" & Me.TextBox17.Value & "</p>" & _
                            "<table border=""1"", cellpadding=""10"", style=background:""#a6bbde"" >" & _
                "<tr>" & _
                            "<th>Date:</th>" & _
                            "<td>" & Me.TextBox18.Text & "</td><td>" & Me.TextBox19.Text & "</td>" & _
                            "<td>" & Me.TextBox21.Text & "</td><td>" & Me.TextBox23.Text & "</td>" & _
                            "<td>" & Me.TextBox25.Text & "</td><td>" & Me.TextBox26.Text & "</td>" & _
                            "</tr>" & _
                "<tr>" & _
                            "<th>Area:</th>" & _
                            "<td>" & Me.TextBox9.Value & "</td><td>" & Me.TextBox20.Value & "</td>" & _
                            "<td>" & Me.TextBox22.Value & "</td><td>" & Me.TextBox24.Value & "</td>" & _
                            "<td>" & Me.TextBox29.Value & "</td><td>" & Me.TextBox30.Value & "</td>" & _
                            "</tr>" & _
                            "</table>" & _
                "<br><br><br><br><br><br>" & _
                "<p>Many Thanks</p>" & _
                "<p>Complex Team</p>" & _
                "</body></html>"


        aEmail.Recipients.Add (UserForm1.TextBox36.Value)
        aEmail.CC = (UserForm1.TextBox37.Value)
        aEmail.BCC = ""
        aEmail.Subject = "Weekly " & Range("D2").Value & (UserForm1.TextBox39.Value)
        aHTMLBody = rngDataToEmail
        aEmail.Display
        
       
Unload Me

End Sub
 
Upvote 0
Hi, good morning. Just wondering if it is possible to help me regarding this please, what i want to do is copy data from my 'Work Issue' sheet from rows A to I and down to the last entry, i have added the code as above, but this is not working, i really hope you can help me please?
 
Upvote 0
Hi good morning, any ideas at all on this please? i would really apprecaite your help on this one.
 
Upvote 0
You can't copy a range of cells to the email body that way.

You can either concatenate a range of cells into a string and then copy it or use the RangetoHTML function from RonDeBruin:
https://www.rondebruin.nl/win/s1/outlook/bmail2.htm

Try the RangetoHTML version. There are a couple of changes to the code to fit it in. I think they are all in red.
Not sure about your range?

Basically StrBody is now the HTML Code - it's in HTML tags below otherwise it won't render correctly.

You might want to add some VbNewLine spaces after StrBody

Code: 
Private Sub CommandButton1_Click()

    Const PR_SECURITY_FLAGS = "http://schemas.microsoft.com/mapi/proptag/0x6E010003"
    
    Dim aOutlook As Object
    Dim aEmail As Object
    Dim ulFlags As Integer
    Dim rngeAddresses As Range, rngeCell As Range, strRecipients As String
    Dim rngDataToEmail As Range
    [COLOR="#FF0000"]Dim StrBody As String[/COLOR]
    
    Set aOutlook = CreateObject("Outlook.Application")
    Set aEmail = aOutlook.CreateItem(0)      


   With Sheets("Work Issue")
        Set rngDataToEmail = .Range("A:I" & .Range("A" & Rows.Count).End(xlUp).Row)
    End With

    
    ulFlags = ulFlags Or &H1 ' SECFLAG_ENCRYPTED
    
    aEmail.PropertyAccessor.SetProperty PR_SECURITY_FLAGS, (ulFlags)

[HTML]
         StrBody = "<html>******>" & _
                            "<p>Hi " & Me.TextBox35.Value & "</p>" & _
                            "<p>" & Me.TextBox33.Value & "</p>" & _
                            "<p>" & Me.TextBox17.Value & "</p>" & _
                            "<table border=""1"", cellpadding=""10"", style=background:""#a6bbde"" >" & _
                "<tr>" & _
                            "<th>Date:</th>" & _
                            "<td>" & Me.TextBox18.Text & "</td><td>" & Me.TextBox19.Text & "</td>" & _
                            "<td>" & Me.TextBox21.Text & "</td><td>" & Me.TextBox23.Text & "</td>" & _
                            "<td>" & Me.TextBox25.Text & "</td><td>" & Me.TextBox26.Text & "</td>" & _
                            "</tr>" & _
                "<tr>" & _
                            "<th>Area:</th>" & _
                            "<td>" & Me.TextBox9.Value & "</td><td>" & Me.TextBox20.Value & "</td>" & _
                            "<td>" & Me.TextBox22.Value & "</td><td>" & Me.TextBox24.Value & "</td>" & _
                            "<td>" & Me.TextBox29.Value & "</td><td>" & Me.TextBox30.Value & "</td>" & _
                            "</tr>" & _
                            "</table>" & _
                "" & _
                "<p>Many Thanks</p>" & _
                "<p>Complex Team</p>" & _
                "</body></html>"
[/HTML]

        aEmail.Recipients.Add (UserForm1.TextBox36.Value)
        aEmail.CC = (UserForm1.TextBox37.Value)
        aEmail.BCC = ""
        aEmail.Subject = "Weekly " & Range("D2").Value & (UserForm1.TextBox39.Value)
        [COLOR="#FF0000"]aEmail.HTMLBody = StrBody & RangetoHTML(rngDataToEmail)[/COLOR]
        aEmail.Display


Unload Me

End Sub


Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
    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
    rng.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
 
Last edited:
Upvote 0
Hi thank you for your response my range is below, where would i add this please?
Code: 
        With Sheets("Work Issue")
        Set rngDataToEmail = .Range("A1:I" & .Range("A" & Rows.Count).End(xlUp).Row)
    End With
 
Upvote 0
You must log in or register to reply here.

Similar threads

P
  • Solved
Email error on border code
Replies
5
Views
217
Patriot2879
P
P
  • Solved
Copy and cut from sheet 'Raised'
Replies
7
Views
258
Patriot2879
P
P
  • Solved
Compile error: method or data member not found
Replies
6
Views
297
Patriot2879
P
P
  • Question
Email Me. to label and text on two lines issues
Replies
1
Views
182
Micron
M
P
  • Question
Email Encryption code vba
Replies
4
Views
696
Patriot2879
P

Forum statistics

Threads
1,216,101
Messages
6,128,837
Members
449,471
Latest member
lachbee

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top