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

 

[fullysic]

*bump*

 

[Hanyo]

Thanks Frog....still no bottom border. I'm seriously starting to wonder if it simply a matter of my Outlook not responding correctly. Cause if I do a copy&paste of the table into anything :oof:: there's the bottom border.....unless anyone else has any other ideas?

 

[Norie]

Have you tried copying the data to send a blank worksheet and using that with RangeToHTML?

Copying it should keep the formatting, but if it doesn't you can easily add it.

Or you could write your own code to convert the data into an HTML table, which isn't as hard as it might sound.

 

[Hanyo]

Norie, thanks for the thought. Here's the complete code I currently have, decided to add some lines at the beginning of the email...just not sure what we want to say yet. And I'd be all about simply taking the data from excel and putting it into an HTML table, be fine to me....just never worked with HTML before and not sure how that would work.....

Sub Send_Row()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    Dim rng As Range
    Dim Ash As Worksheet
    Dim StrBody As String
    
    Set Ash = ActiveSheet
    On Error GoTo cleanup
    Set OutApp = CreateObject("Outlook.Application")
    StrBody = "This is line 1" & "<br>" & _
              "This is line 2" & "<br>" & _
              "This is line 3" & "<br><br><br>"

    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")).SpecialCells(xlCellTypeVisible)
                On Error GoTo 0
            End With

            Set OutMail = OutApp.CreateItem(0)

            On Error Resume Next
            With OutMail
                .To = cell.Value
                .Subject = "Your Completed Workorder"
                .HTMLBody = StrBody & 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]

And I hate that it seems to build the border on the original data, not in the TempWB....

 

[Norie]

Actually it looks like that code is doing what I suggested, so forget what I said.

 

[fullysic]

You gave me an idea Hanyo, and I have found a solution... sort of. I unfortunately don't think it will work for you though, as you dont want to modify your original data at all.

In my original data table that is autofiltered, I added a line of text at the bottom below the final border of the whole table and changed the text colour to white and ensured it had a value that the autofilter filters on (eg in my case autofilter filters for "Yes").

After doing so the table is being copied over with the bottom border, and of course the invisible text. It's not a perfect solution, but should work for me in the mean time until we find a better way to solve the problem.

 

[fullysic]

Ok I think I've found a different solution which is working for me... If I set the end row of my range to 1 row below where the data actually ends the borders seem to display in the email (and there is a blank row at the bottom).

So for example if my data table range is A1:B10 i use the following code:

Set rng = Sheets("Sheet1").Range("A1:B11").SpecialCells(xlCellTypeVisible)

By doing this the bottom borders will appear in the email. I don't know if this will work for you Hanyo, but hopefully it may point you in the right direction.

 

[Hanyo]

First, thanks to all whom have attempted to help my amateur self....Arigato. I think I found the problem.....my code appears to keep it's data capture open-ended. (Bear with me, and remember Robin Williams) e.g-If I have smith@smith.com for an email and they have a total of three rows of information that matches their email address with a building # (after an index lookup function), the code will return an HTML table with those three rows of information and create an email....only problem is it will create three emails to the same person with a table of all three rows. .....which is fine, sort of. I would prefer it to either create one email with one row of data (which would be my best option I think and I'm pretty sure would solve my border issue), or one email with all rows of data (which I'd rather not due, because I'm pretty sure it would keep that open-ended border crud around). Can any guru look at my code and see what needs to be altered to achieve either of these? (outing:: I just wanted a frigging bottom line to my table))

Sub Send_Row()     Dim OutApp As Object     Dim OutMail As Object     Dim cell As Range     Dim rng As Range     Dim Ash As Worksheet     Dim StrBody As String          Set Ash = ActiveSheet     On Error GoTo cleanup     Set OutApp = CreateObject("Outlook.Application")     StrBody = "This is line 1" & "" & _               "This is line 2" & "" & _               "This is line 3" & ""      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")).SpecialCells(xlCellTypeVisible)                 On Error GoTo 0             End With              Set OutMail = OutApp.CreateItem(0)              On Error Resume Next             With OutMail                 .To = cell.Value                 .Subject = "Your Completed Workorder"                 .HTMLBody = StrBody & 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</pre>

 

[Hanyo]

sorry...code messed up in pasting....this is a frigging nightmare...."and I shall name thus code Sybil!!"

 Sub Send_Row()
      Dim OutApp As Object
      Dim OutMail As Object
      Dim cell As Range
      Dim rng As Range
      Dim Ash As Worksheet
      Dim StrBody As String 
   
      Set Ash = ActiveSheet
      On Error GoTo cleanup
      Set OutApp = CreateObject("Outlook.Application")
      StrBody = "This is line 1" & "" & _
                "This is line 2" & "" & _
                "This is line 3" & ""
   
      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")).SpecialCells(xlCellTypeVisible)
                  On Error GoTo 0
              End With
   
              Set OutMail = OutApp.CreateItem(0)
   
              On Error Resume Next
              With OutMail
                  .To = cell.Value
                  .Subject = "Your Completed Workorder"
                  .HTMLBody = StrBody & 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