Excel VBA ワークシートをHTMLテーブル

Excel VBA

Excel VBA ワークシートをHTMLテーブル

Option Explicit
 
 
Public Function MakeHtmlTable(table As Range, headerType As String, headerSize As Integer, cls As String) As String
    Dim buf As String
    Dim cl As Range
    Dim rowPos As Integer
    Dim isFirstRow As Boolean
    Dim celVal As String
    Dim colPos As Integer
    Dim isColHeader As Boolean
    Dim isRowHeader As Boolean
    Dim celTag As String
    
    If Trim(cls) <> "" Then
        cls = " class=""" & cls & """ "
    Else
        cls = " border=""1"" "
    End If
    
    isColHeader = InStr(headerType, "c") > 0
    isRowHeader = InStr(headerType, "r") > 0
    
    isFirstRow = True
    rowPos = -1
    buf = "<table " & cls & ">"
    For Each cl In table
    
        If rowPos <> cl.Row Then
            If Not isFirstRow Then
                buf = buf & "</tr>"
            End If
            buf = buf & "<tr>"
            isFirstRow = False
            colPos = 0
        End If
        
        celVal = EscapeHtmlSpecial(cl.text)
        If Trim(celVal) = "" Then
            celVal = " "
        End If
        
        rowPos = cl.Row
        
        If (isColHeader And headerSize > colPos) Or _
           (isRowHeader And headerSize > rowPos) Then
            celTag = "th"
        Else
            celTag = "td"
            
        End If
        buf = buf & EncloseTag(celVal, celTag)
        colPos = colPos + 1
    Next
    buf = buf & "</table>"
 
    MakeHtmlTable = buf
 
End Function
Public Function EncloseTag(value As String, tag As String)
    EncloseTag = "<" & tag & ">" & value & "</" & tag & ">"
End Function
 
Public Function EscapeHtmlSpecial(text As String) As String
    Dim buf As String
    Dim c As String
    Dim i As Integer
    
    For i = 1 To Len(text)
        c = Mid(text, i, 1)
    
        Select Case c
        Case "&"
            c = "&"
        Case "<"
            c = "<"
        Case ">"
            c = ">"
        Case """"
            c = "'"""
        End Select
    
        buf = buf & c
    Next
        
    EscapeHtmlSpecial = buf
End Function