VBA to HTML Border Issues

[Hanyo]

Hello all,

Hopefully I don't tick anyone off with verbage/noob issues. . I've done various pieces of VBA coding on/off over the years and I'm now having a pretty stupid issue. I found a bunch of code over the net and created some via macros and my little frankencode works well. Except the borders for my tables never stay consistent when transferred to HTML and don't seem to have any reasons why (that I can see). What I'm doing is taking a .csv file from a 3rd party vendor, rearranging it, reformatting it, importing into a permanent excel file that will house the code, then adding a little user form so that a worker can click some buttons and send multiple emails containing only the row pertaining to that customer. But it appears my coding is adding the borders on the original sheet (I would prefer it do this on the temp workbook and then delete it after the email is generated). Any help would be greatly appreciated. It seems to be first time it's run it shows my temp worksheet, 2nd time it runs it will create email with data and the 3rd time it will put in all borders except the bloody bottom one. And it repeats the 3rd results from that point forward..Here's what I'm using for generating the email/HTML

Sub Send_Row()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    Dim rng As Range
    Dim Ash As Worksheet

    Set Ash = ActiveSheet
    On Error GoTo cleanup
    Set OutApp = CreateObject("Outlook.Application")

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

    For Each cell In Ash.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" _
           And LCase(cell.Offset(0, 1).Value) = "yes" Then

            Ash.Range("A1:X100").AutoFilter Field:=2, Criteria1:=cell.Value

            With Ash.AutoFilter.Range
                On Error Resume Next
                Set rng = Union(Range("d1:d100"), Range("f1:f100"), Range("j1:j100"), Range("n1:n100"))
                On Error GoTo 0
            End With

            Set OutMail = OutApp.CreateItem(0)

            On Error Resume Next
            With OutMail
                .To = cell.Value
                .Subject = "Your RoofConnect Completed Workorder"
                .HTMLBody = RangetoHTML(rng)
                .Display  'Or use .Send
            End With
            On Error GoTo 0

            Set OutMail = Nothing
            Ash.AutoFilterMode = False
        End If
    Next cell

cleanup:
    Set OutApp = Nothing
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    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
    Dim Rng2 As Range
 
    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
 
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
    ActiveSheet.Paste
    Columns("a:a").EntireColumn.AutoFit
    Columns("b:b").EntireColumn.AutoFit
    Columns("c:c").EntireColumn.AutoFit
    Columns("d:d").EntireColumn.AutoFit
    Columns("e:e").EntireColumn.AutoFit
    Columns("f:f").EntireColumn.AutoFit
    Columns("g:g").EntireColumn.AutoFit
    Columns("h:H").EntireColumn.AutoFit
    Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
  
    With rng.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With rng.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With rng.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With rng.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With rng.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThick
    End With
    With rng.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlMedium
    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

Any ideas/better functionality would be greatly appreciated!!

 

[Vinnyjuice]

I don't mean to hijack the thread, but I am having the same issues and I thought it would be better to post here rather than make my own thread.

When using the RangeToHTML function with an autofiltered range, the bottom border is always missing.

I have included a sample of my code here (data is just a simple table I made up with Yes/No values that are filtered on).

Has anyone come across this and been able to solve it?

Thanks!

Sub Test()
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object

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

    Sheets("Sheet1").Activate
   ActiveSheet.Range("$A$1:$B$3004").AutoFilter Field:=2, Criteria1:="No"

    FinalRow = Cells(Rows.Count, 1).End(xlUp).Row

    Set rng = Nothing
    On Error Resume Next
    Set rng = Sheets("Sheet1").Range("A1" & ":B" & FinalRow).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

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

    On Error Resume Next
    With OutMail
        .To = "[EMAIL="test@test.com"]test@test.com[/EMAIL]    "
        .CC = ""
        .BCC = ""
        .Subject = "Test"
        .HTMLBody = RangetoHTML(rng)
        .Display
    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing

    ActiveSheet.ShowAllData

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    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
    Dim i As Integer

    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    Application.ScreenUpdating = False

    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
        .UsedRange.EntireColumn.AutoFit
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0

        For i = 7 To 12
            With .UsedRange.Borders(i)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
                .TintAndShade = 0
                .Weight = xlMedium
            End With
        Next i

    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
    Application.ScreenUpdating = True
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing

End Function

Thank you fullysic. This helped. I need wondering in internet for a while now for the solution. Thank you for fixing it ????????????

 

[Vinnyjuice]

I don't mean to hijack the thread, but I am having the same issues and I thought it would be better to post here rather than make my own thread.

When using the RangeToHTML function with an autofiltered range, the bottom border is always missing.

I have included a sample of my code here (data is just a simple table I made up with Yes/No values that are filtered on).

Has anyone come across this and been able to solve it?

Thanks!

Sub Test()
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object

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

    Sheets("Sheet1").Activate
   ActiveSheet.Range("$A$1:$B$3004").AutoFilter Field:=2, Criteria1:="No"

    FinalRow = Cells(Rows.Count, 1).End(xlUp).Row

    Set rng = Nothing
    On Error Resume Next
    Set rng = Sheets("Sheet1").Range("A1" & ":B" & FinalRow).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

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

    On Error Resume Next
    With OutMail
        .To = "[EMAIL="test@test.com"]test@test.com[/EMAIL]    "
        .CC = ""
        .BCC = ""
        .Subject = "Test"
        .HTMLBody = RangetoHTML(rng)
        .Display
    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing

    ActiveSheet.ShowAllData

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    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
    Dim i As Integer

    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    Application.ScreenUpdating = False

    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
        .UsedRange.EntireColumn.AutoFit
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0

        For i = 7 To 12
            With .UsedRange.Borders(i)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
                .TintAndShade = 0
                .Weight = xlMedium
            End With
        Next i

    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
    Application.ScreenUpdating = True
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing

End Function

Noob here. May I know what is the "i" for. Without the "i" I am getting the border issue. However I don't understand what "i" stands for and why is it 7 to 12.

 

[dumitrudan608]

I fixed the issue with a workaround by resizing the range to include 1 cell outside the table, to an unformatted zone:

        With Log_03.Range("VBA_rng_email")
            Set RNG = Union(.Resize(iRow), .Offset(.Rows.Count).Resize(1))
        End With
        strbody = strbody & RangetoHTML(RNG) & "<br>"

- Where iRow is the number if rows from the table i want to grab

 

[loftyowl]

Howdy all, not sure if this will ever get to anyone who finds it useful but this "missing bottom border" quirk has plagued me off and on for a few years now. Anyway, I finally decided to try and fix it today and came up with a solution that (at least in my case) works very well. You may have to tweak it if your range is non-contiguous or otherwise odd but I find that if I offset from my table 1 row and apply a top edge border it fixes for me!

This bit should go in your RangetoHTML function after it has pasted the "rng" into the TempWB.

With Range("A1").CurrentRegion.Offset(1, 0).Borders(xlEdgeTop)
    .LineStyle = xlContinuous
    .Weight = xlThin
    .ColorIndex = xlAutomatic
End With