VBA to HTML Border Issues

Hanyo · Oct 28, 2011

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

Code:

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!!

AlphaFrog · Oct 28, 2011

Code:

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

Hanyo · Oct 28, 2011

Thanks Frog...but that's the issue I ran into in the beginning is that code returns all 100 lines from the original sheet, the two lines that are pulled from the original and put into the TempWB sheet. And it still drops the bottom border from the last row.

....starting to erk me. LMAO

Hanyo · Oct 28, 2011

Could I possibly just assign a new range value/name to the information that's put into the TempWB sheet? and the just reference that range after it pastes and add the border, then copy to HTML and then close the TempWB?

AlphaFrog · Oct 28, 2011

It works for me.

How are you defining the range to copy before you call the RangetoHTML function?

I don't understand this...
"...that code returns all 100 lines from the original sheet, the two lines that are pulled from the original and put into the TempWB sheet."

Hanyo · Oct 28, 2011

I have the "rng" defined in the first portion of the send row code as

Code:

Set rng = Union(Range("d1:d100"), Range("f1:f100"), Range("j1:j100"), Range("n1:n100"))[CODE]

[/CODE]

Then the results I get always look like

 <table class="MsoNormalTable" style="width:331.0pt;border-collapse:collapse;mso-yfti-tbllook:1184; mso-padding-alt:0in 0in 0in 0in" border="0" cellpadding="0" cellspacing="0" width="441"> <tbody><tr style="mso-yfti-irow:0;mso-yfti-firstrow:yes;height:15.75pt"> <td style="width:82.0pt;border:solid windowtext 1.0pt; padding:.75pt .75pt 0in .75pt;height:15.75pt" nowrap="nowrap" valign="bottom" width="109"> [FONT=&quot]WORKORDER_ID[/FONT]
</td> <td style="width:78.0pt;border:solid windowtext 1.0pt; border-left:none;mso-border-left-alt:solid windowtext 1.0pt;padding:.75pt .75pt 0in .75pt; height:15.75pt" nowrap="nowrap" valign="bottom" width="104"> [FONT=&quot]CLIENTNUMBER[/FONT]
</td> <td style="width:106.0pt;border:solid windowtext 1.0pt; border-left:none;mso-border-left-alt:solid windowtext 1.0pt;padding:.75pt .75pt 0in .75pt; height:15.75pt" nowrap="nowrap" valign="bottom" width="141"> [FONT=&quot]SUBTYPE[/FONT]
</td> <td style="width:65.0pt;border:solid windowtext 1.0pt; border-left:none;mso-border-left-alt:solid windowtext 1.0pt;padding:.75pt .75pt 0in .75pt; height:15.75pt" nowrap="nowrap" valign="bottom" width="87"> [FONT=&quot]BUILDING_ID[/FONT]
</td> </tr> <tr style="mso-yfti-irow:1;height:15.75pt"> <td style="border:solid windowtext 1.0pt;border-top: none;mso-border-top-alt:solid windowtext 1.0pt;padding:.75pt .75pt 0in .75pt; height:15.75pt" nowrap="nowrap" valign="bottom"> [FONT=&quot]81053[/FONT]
</td> <td style="border-top:none;border-left:none;border-bottom: solid windowtext 1.0pt;border-right:solid windowtext 1.0pt;mso-border-top-alt: solid windowtext 1.0pt;mso-border-left-alt:solid windowtext 1.0pt;padding: .75pt .75pt 0in .75pt;height:15.75pt" nowrap="nowrap" valign="bottom"> [FONT=&quot]WEB-194335[/FONT]
</td> <td style="border-top:none;border-left:none;border-bottom: solid windowtext 1.0pt;border-right:solid windowtext 1.0pt;mso-border-top-alt: solid windowtext 1.0pt;mso-border-left-alt:solid windowtext 1.0pt;padding: .75pt .75pt 0in .75pt;height:15.75pt" nowrap="nowrap" valign="bottom"> [FONT=&quot]RA - Approved Repair[/FONT]
</td> <td style="border-top:none;border-left:none;border-bottom: solid windowtext 1.0pt;border-right:solid windowtext 1.0pt;mso-border-top-alt: solid windowtext 1.0pt;mso-border-left-alt:solid windowtext 1.0pt;padding: .75pt .75pt 0in .75pt;height:15.75pt" nowrap="nowrap" valign="bottom"> [FONT=&quot]15030[/FONT]
</td> </tr> <tr style="mso-yfti-irow:2;mso-yfti-lastrow:yes;display:none"> <td style="width:82.0pt;padding:0in 0in 0in 0in" width="109"></td> <td style="width:78.0pt;padding:0in 0in 0in 0in" width="104"></td> <td style="width:106.0pt;padding:0in 0in 0in 0in" width="141"></td> <td style="width:65.0pt;padding:0in 0in 0in 0in" width="87"></td> </tr> </tbody></table>
....ok, why does it show up here and in my email it always drops the bottom line?

Hanyo · Oct 28, 2011

here's the whole code with your snippet....

Code:

Sub Send_Row()
' Don't forget to copy the function RangetoHTML in the module.
' Working in Office 2000-2010
    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

            'Change the filter range and filter Field if needed
            'It will filter on Column B now (mail addresses)
            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 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

Hanyo · Oct 29, 2011

Sorry Frog...didn't see your question about the 100 lines. In the beginning of the code, there's

Code:

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

And in it's infancy, my script was returning a table with the retrieved two rows of information and then creating a table with borders that dropped 100 lines down. Just acting real screwy and wondering if I should just start a brand new file or something. Using Office 2007, don't want to switch to 2010..too many bugs for me. But when I cut and past the table it shows up correctly (as you could see). but my email drops the bottom border line and doesn't show up once email is sent either......::scratching head::

AlphaFrog · Oct 29, 2011

I couldn't replicate the problem, but I think it has something to do with how you define the copy range on AutoFiltered data. As a test, give this a try...

Code:

Set rng = Union(Range("d1:d100"), Range("f1:f100"), Range("j1:j100"), Range("n1:n100"))[COLOR="Red"].SpecialCells(xlCellTypeVisible)[/COLOR]

fullysic · Oct 30, 2011

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!

Code:

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

VBA to HTML Border Issues

Hanyo

New Member

Excel Facts

AlphaFrog

MrExcel MVP

Hanyo

New Member

Hanyo

New Member

AlphaFrog

MrExcel MVP

Hanyo

New Member

Hanyo

New Member

Hanyo

New Member

AlphaFrog

MrExcel MVP

fullysic

New Member

Similar threads

Forum statistics

Share this page

VBA to HTML Border Issues

New Member

Excel Facts

MrExcel MVP

New Member

New Member

MrExcel MVP

New Member

New Member

New Member

MrExcel MVP

New Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock