Have macro select range but exclude empty columns

Hello,

I have a worksheet in which a range gets copied and pasted into an email
using a RangeToHTML function from Ron de Bruin's website:
https://www.rondebruin.nl/win/s1/outlook/mail.htm

There's just one little thing I would like to add to the functionality.
I would like the macro that makes the selection, to exclude those columns that have no data. So if a user fills out the sheet with records and for some reason leaves one of the columns in the sheet empty for every record, that column should not be copied to the email.
If there are more than 1 records and in at least one of them a column has a value <> "" the column should be considered for copy.

Does anyone have any idea how I should put that together?

Here is my code that makes the selection and the email (I left out the RangetoHTML function):

Sub Mail_Selection_Outlook_Body()
    ActiveSheet.Unprotect ""
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object

    Set rng = Nothing
    On Error Resume Next
    'Make the selection
    LastRow = Range("A65536").End(xlUp).Row
    
    'Set borders on selection
    Range("A2:J" & LastRow).Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
 
        With Selection.Borders
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
    
    'Create email and copy selection to RangetoHTML
    Range("A2:J" & LastRow + 1).Select
    Set rng = Selection
    On Error GoTo 0

    If rng Is Nothing Then
        MsgBox "Deze selectie  bestaat niet of je sheet is beschermd met een wachtwoord" & _
               vbNewLine & "Corrigeer eerst en probeer het dan opnieuw.", 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
        .To = "emailadress"
        .CC = ""
        .BCC = ""
        .Subject = "Nieuwe artikelen toevoegen en listen"
        .HTMLBody = RangetoHTML(rng)
        .Display
    End With
    On Error GoTo 0

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
    
    'Clear borders, clear contents and save
    ActiveSheet.Activate
    If MsgBox("Wil je deze artikelen nu uit de spreadsheet verwijderen?" & vbNewLine & "Na verwijdering wordt de spreadsheet opgeslagen en gesloten", vbOKCancel) = vbCancel Then
       ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
       Exit Sub
    End If
    ActiveSheet.Range("A2:J" & LastRow + 1).Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
 
        With Selection.Borders
            .LineStyle = xlNone
        End With
        ActiveSheet.Range("A3:J" & LastRow).Select
        Selection.ClearContents
        Range("A3").Select
        ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
        ActiveWorkbook.Close savechanges:=True
End Sub

Thanks in advance for your answer!