Copy Pasting certain cells of excel in automated Outlook Mail

[sd266]

Hi Team,

I am using the below code for VBA to pick the respective range of an excel and publish it to an automated email after a static line of body which is coded already in the VBA. Also I am looking for the mail to be in HTML format. The code is working fine but not copying the excel range nor it is taking the mail body sentence which is coded into VBA.

Sub MarginCap_Mailing()
'Macro Purpose: To send an email through outlook
Dim Oapp As Object
Dim Omail As Object
Dim signature As String
Dim sEmail As String
Dim sEmailcc As String
Dim sEmailcolumn As String
Dim sEmailcccolumn As String
Dim sSubject As String
Dim sBody As String
Dim lDataColumn As Long
Dim rng As Range
a1 = Range("C3").Value
GoTo nocc
a1 = Range("C3").Value
nocc:
b1 = Range("C2").Value
b2 = Range("C2").Value
sEmailcolumn = b1
sEmailcccolumn = a1
sSubject = Range("C4").Value
sBody = "******>" & Range("C5").Value & "
" & "
" & "Below deals were highlighted for margin breach, please advise if these are a real breaches." & RangetoHTML(rng) & ""
'Bind to Outlook
Set Oapp = CreateObject("Outlook.Application")
'Create an new email and save in draft
Set Omail = Oapp.CreateItem(0) 'O=olmailitem
'With Omail
'.Display
    'End With
        'Signature=Omail.HTMLbody
        
        Omail.BodyFormat = 3
        Omail.Display
        Omail.To = sEmailcolumn
        Omail.CC = sEmailcccolumn
        Omail.Subject = sSubject
        signature = Omail.HTMLBody
        Omail.HTMLBody = sBody & "
" & signature
        Omail.Display
        Omail.Save
        Omail.Close olPromtForSave
        Sheets("Email").Select
            Range("B7").Select
            ActiveCell.CurrentRegion.Select
            Selection.Copy
'        End With
End Sub
Function RangetoHTML(rng As Range)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    
    TempFile = Environ$("temp") & "\" & Format(Date, "DD-MM-YYYY") & ".htm"
    
    'Copy the Range and create and new workibook to paste the data in
    Application.ScreenUpdating = False
    Sheets("Email").Select
    Range("B7").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .WrapText = False
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = False
    .Copy
End With
    Range("B7").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.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 date from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FilesystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", "align=left x:publishsource=")
    'Close TempWB
    Application.DisplayAlerts = False
        TempWB.Close False
    Application.DisplayAlerts = True
    'Delete the htm file we used in this function
    'Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
    
End Function

 

[sd266]

Hi Moderators, Could someone please help me with this.