This code is to put a excel range onto a email

[Eric Penfold]

This code just puts

RangetoHTML(Rng1)

instead in the email body?And it seems to not run the function?

Sub Emails()

    Dim wb     As Workbook
    Dim ws     As Worksheet
    Dim wb1    As Workbook
    Dim ws1    As Worksheet
    Dim EmailApp As Object
    Dim EmailItem As Object
    Dim Rng    As Range, Cell As Range, Rng1   As Range
    Dim D      As Integer
    Dim LRow   As Long
    Dim xMailbody As String
    Dim CurrentDate As Date, Tomorrow As Date
    Dim Result As Integer
    Dim SupliersEmails As String
    Dim FormatRuleInput As String

    Set wb = ActiveWorkbook
    Set ws = wb.Worksheets("Sheet")
    Set wb1 = Workbooks("Personal.xlsb")
    Set ws1 = wb1.Worksheets("Emails")
    Set EmailApp = CreateObject("Outlook.Application")
    Set EmailItem = EmailApp.CreateItem(0)
    LRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
    Set Rng = ws.Range("E2:E" & LRow)
    Set Rng1 = Application.InputBox( _
         Title:="Number Format Rule From Cell", _
         Prompt:="Select Range to Email", _
         Type:=8)
    If Rng1 Is Nothing Then Exit Sub
    On Error GoTo 0
   
    On Error Resume Next
   
    SupliersEmails = Application.WorksheetFunction.VLookup(Me.SuppliersName.Value, ws1.Range("A2:B" & LRow), 2, 0)
   
    Select Case Time
        Case Is < TimeValue("12:00:00")
            xMailbody = "Good Morning"
        Case Is < TimeValue("17:00:00")
            xMailbody = "Good Afternoon"
    End Select
   
    With EmailItem
       
        For Each Cell In Rng1
            CurrentDate = Date
            Tomorrow = Date + 1
            .To = SupliersEmails
            .CC = ""
            .BCC = ""
            .Subject = "POs Chase"
            If Cell = CurrentDate Or Cell = Tomorrow Then
                .HTMLBody = xMailbody & "," & _
                            "<p> Please can you confirm the delivery Date?<P>RangetoHTML(Rng1)<P>" & "Kind Regards"
            Else
                .HTMLBody = xMailbody & "," & _
                            "<p> I am just looking to confirm that our purchase order number is still on schedule to be delivered to us on the below date?<P>RangetoHTML(Rng1)<P>" & "Kind Regards"
            End If
        Next Cell
    End With
   
    Result = MsgBox("Do you need to Check Text Yes/No", vbInformation + vbYesNo, "Need to Check Text")
   
    Select Case Result
        Case vbYes
            EmailItem.Display
        Case vbNo
            EmailItem.Send
    End Select
   
End Sub
Function RangetoHTML(Rng1 As Range)

    Dim fso    As Object
    Dim ts     As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    Dim RangeHTML As Range

    TempFile = ("S:\Company\PURCHASING\Stock Control\Reports") & ".htm"
    Rng1.Copy
    With TempWB = Workbooks.Add(1)
        With TempWB.Sheets(1)
            .Cells(1).PasteSpecial Paste:=8
            .Cells(1).PasteSpecial , , False, False
            .Cells(1).PasteFormats , , False, False
            .Cell(1).Select
            Application.CutCopyMode = False
            On Error Resume Next
            .DrawingObjects.Visible = True
            .DrawingObjects.Delete
            On Error GoTo 0
           
            With TempWB.PublishObjects.Add( _
                  SourceType:=xlSourceRange, _
                  Filename:=TempFile, _
                  Sheet:=TempWB.Sheets(1).Name, _
                  Source:=TempWB.Sheets(1).UsedRange.Address, _
                  HtmlType:=xlHtmlStatic)
                .Publish (True)
               
                Set fso = CreateObject("Scripting.FileSystemObject")
                Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
                RangeHTML = ts.ReadAll
                ts.Close
                RangetoHTML = Replace(RangetoHTML, "align=center x:puplishsource=", _
                              "align=left x:puplishsource=")
               
                TempWB.Close Savechanges:=False
               
                Kill TempFile
               
                Set ts = Nothing
                Set fso = Nothing
                Set TempWB = Nothing
               
            End With
        End With
    End With
   
End Function

 

[I_know_nuffin]

try changing

"<p> I am just looking to confirm that our purchase order number is still on schedule to be delivered to us on the below date?<P>RangetoHTML(Rng1)<P>" & "Kind Regards"

to the below

"<p> I am just looking to confirm that our purchase order number is still on schedule to be delivered to us on the below date?<P>" & RangetoHTML(Rng1) & "Kind Regards"

 

[Eric Penfold]

The function now is active but for some reason it won`t fill into the Email Body any detail?

 

[I_know_nuffin]

The function now is active but for some reason it won`t fill into the Email Body any detail?

with the below code I use to create an email , I used variables to hold the data and add those into the htmlbody

e.g. msgBody1, msgBody2 & msgBody3

maybe try assigning your RangetoHTML(Rng1) to a variable and use that

 With olMailItm
       '.Display
       .To = Todest
    'Do additional formatting on the BCC and Subject lines, add the body text from the spreadsheet, and send.
       .CC = SDest
       .BCC = ""
       .Subject = "Subject report"
       .HTMLBody = "<html><body>" & msgBody1 & msgBody2 & msgBody3 & "<a href=""file:///" & strpath & """>" & strpath & "</a>" _
                     & "<br><br><a href=""file:///" & MDTPath & """>" & MDTPath & "</a></body></html>" & "<br>" & "Regards" & "<br>" & Signature
        '& .HTMLBody
       
       
       .Display ' - show message rather than send it
       '.Send
   End With