Launch Outlook and Copy only Columns and Rows with Data

[Vincent.Eymard]

Hi,
I have been strugling with this one, I learned of some scripts here at this forums on how to launch outlook and copy columns and rows to it.
However, is it possible for the Macro to only copy the rows only to the extent where there is data?
Below is an example, it copies from B6 till V500. At times I only have data until V200 or maybe less. Is there a workaround for this? I mean copy only to outlook those columns and rows with populated data.
Please advise?

Thank you.

Sub Email_Create()

    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    
     
    Set rng = Nothing
    On Error Resume Next
    
    Set rng = Nothing
    On Error Resume Next
    Set rng = Selection.SpecialCells(xlCellTypeVisible)
    Set rng = Sheets("Sheet1").Range("B6:V500").SpecialCells(xlCellTypeVisible)


    On Error GoTo 0

    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.createitem(0)

    On Error Resume Next
    With OutMail
        .SentOnBehalfOfName = " "
        .To = ""
        .CC = ""
        .BCC = ""
        .Subject = "Test Email"
        .HTMLBody = RangetoHTML(rng)
        .Display
            End With
    On Error GoTo 0

    With Application
        .EnableEvents = True
        .ScreenUpdating = True

    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
 
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(Now, "dd-mm-yy h-mm-ss") & ".htm"
 
    
    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
 
    
    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
 
    
    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=")
 
    
    TempWB.Close savechanges:=False
 
    
    Kill TempFile
 
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
    


End Function