Sunday 15 April 2012

Copy a Range as HTML

A while back (actually, quite a while back), I promised to write about creating HTML tables in SharePoint using Excel. Sorry to take so long, I've had a few issues since then but hopefully I can blog a bit more now.

As I did not have SharePoint in front of me when I wrote this, please forgive me if I have misnamed some parts of the UI in a Content Editor Web Part, I'm just going from memory.

First, you can create a very simple table in a Content Editor Web Part, just by copying a range and pasting it into the Rich Text Editor. (When I say, "basic", I mean "basic")

Or you can use some VBA code to transform the range into HTML. Here's something I wrote. It will copy basic formatting which you can paste into a HTML editor. The result is spat out into the Immediate Window. If not visible in the Visual Basic Editor (below the Code Window), click the Ctrl + G on your keyboard to bring it up.

Private Sub CopyRangeAsHTML()

    On Error Resume Next

    Dim c As Range
    Dim rw As Long, col As Long
    Dim lCol As Long, lRow As Long
    Dim rwString As String, tblString As String
    Dim aTag As String, bTag As String
    Dim rSpan As Long, cSpan As Long
    Dim cHeight As Double, cWidth As Double
    Dim cAlign As String, cVAlign As String
    Dim bColor As String, fColor As String

    For Each c In Selection

        Exit For

    Next c

    rw = c.Row
    col = c.Column

    For lRow = 1 To Selection.Rows.Count

        rwString = ""

        For lCol = 1 To Selection.Columns.Count

            rSpan = Cells(rw + lRow - 1, col + lCol - 1).MergeArea.Rows.Count

            cSpan = Cells(rw + lRow - 1, col + lCol - 1).MergeArea.Columns.Count

            cWidth = Cells(rw + lRow - 1, col + lCol - 1).MergeArea.Width * 2

            cHeight = Cells(rw + lRow - 1, col + lCol - 1).Height * 2

            Select Case Cells(rw + lRow - 1, col + lCol - 1).HorizontalAlignment

                Case xlLeft: cAlign = "left"

                Case xlCenter: cAlign = "center"

                Case xlRight: cAlign = "right"

                Case xlGeneral

                If IsNumeric(Cells(rw + lRow - 1, col + lCol - 1)) Then cAlign = "right" Else cAlign = "left"

            End Select

            Select Case Cells(rw + lRow - 1, col + lCol - 1).VerticalAlignment

                Case xlTop: cVAlign = "top"

                Case xlCenter: cVAlign = "center"

                Case xlBottom: cVAlign = "bottom"

            End Select

            bColor = Right("000000" & Hex(Cells(rw + lRow - 1, col + lCol - 1).Interior.Color), 6)

            bColor = "#" & Right(bColor, 2) & Mid(bColor, 3, 2) & Left(bColor, 2)

            fColor = Right("000000" & Hex(Cells(rw + lRow - 1, col + lCol - 1).Font.Color), 6)

            fColor = "#" & Right(fColor, 2) & Mid(fColor, 3, 2) & Left(fColor, 2)

            aTag = "<td rowspan=""" & rSpan & """" & " colspan=""" & cSpan & """" & " width=""" & cWidth & """" & " height=""" & cHeight & """" & " align = """ & cAlign & """" & " valign = """ & cVAlign & """" & " bgcolor =""" & bColor & """><font color=""" & fColor & """>"

            bTag = "</font></td>"

            If Cells(rw + lRow - 1, col + lCol - 1).Font.Bold = True Then

                aTag = aTag & "<b>"

                bTag = "</b>" & bTag

            End If

            If Cells(rw + lRow - 1, col + lCol - 1).Font.Italic = True Then

                aTag = aTag & "<i>"

                bTag = "</i>" & bTag

            End If

            If Cells(rw + lRow - 1, col + lCol - 1).Font.Underline <> -4142 Then

                aTag = aTag & "<u>"

                bTag = "</u>" & bTag

            End If

            If Cells(rw + lRow - 1, col + lCol - 1).Font.Strikethrough = True Then

                aTag = aTag & "<strike>"

                bTag = "</strike>" & bTag

            End If

            If Cells(rw + lRow - 1, col + lCol - 1).Address = Cells(rw + lRow - 1, col + lCol - 1).MergeArea.Item(1).Address Then

                rwString = rwString & aTag & Cells(rw + lRow - 1, col + lCol - 1).Text & " " & bTag

            Else

                rwString = rwString

            End If

        Next lCol

        tblString = tblString & "<tr>" & rwString & "</tr>" & Chr(10)

    Next lRow

    tblString = "<table border = ""1"" cellspacing = ""0"" bordercolor=""Black"" style=""border-collapse: collapse"">" & Chr(10) & tblString & "</table>"

    Debug.Print tblString

    On Error GoTo 0

End Sub


This is what the result might look like.