セルをHTMLのtableに変換するAddin - SO NOTE そうのて (；^ω^)

かなり既出っぽいけど、以前作ったExcelのAddinを最近リメイクしたんでupしてみる。

SETUP

1.まずはここからAddin本体をDLします。
2.DLした圧縮ファイルを解凍し、Addin本体「Cell2HTMLTable.xla」を適当なディレクトリに置きます。
3.Excelを起動し、メニューバーから「ツール − アドイン」と辿ります。

4.参照ボタンをクリックします。

5.ファイル選択ダイアログが起動するので、2で置いたAddinを選択し、「OK」をクリックします。

6.「OK」をクリックします。

7.適当なセル上で右クリックして下さい。「Cell To <Table>」ってのが一番下に追加されていればSETUP完了です。

使い方

至って簡単。table化したいセルの範囲を選択した状態で右クリックして「Cell To <Table>」を選択するだけ。
「HTML化完了」のメッセージボックスが表示されれば、正常に終了してるので、あとはデスクトップ上に作成されている
ファイル名「yyyymmddhhmmss」形式のhtmlファイルをIEなり、FFなりで開いてみて下さい。

な表が

ってな感じでHTML化されます。

HTMLソース

作成されるソースはこんな感じになります。

styleタグとtableタグのみ作成します。

動作確認

OS:Win2k & WinXP
Office:2k & 2003
にて動作確認してます。VistaやOffice2007は確認してません。(ってか、持ってないしｗ)

Addinのコード

右クリックのコンテキストメニューへ追加

Option Explicit

Private Sub Workbook_Open()

    Const cnsMenuName As String = "Cell To <Table>"               'Cellsバーに追加する際のメニュー名
    Const cnsFaceID   As Long = 1948                              'アイコンのFaceID
    Const cnsTipText  As String = "CellをHTMLのTableに変換します" 'ツールチップテキスト
    Const cnsProcName As String = "CreateHTMLTableSource"         'プロシージャー名
    
    Dim cbCells       As CommandBar
    Dim cbNewMenu     As CommandBarButton
    
    Set cbCells = Application.CommandBars("Cell")

    '新規作成するメニューを予め削除しておく
    On Error Resume Next
    cbCells.Controls(cnsMenuName).Delete
    On Error GoTo 0
    
    Set cbNewMenu = cbCells.Controls.Add(Type:=msoControlButton)
    
    With cbNewMenu
        .TooltipText = cnsTipText
        .FaceId = cnsFaceID
        .Caption = cnsMenuName
        .OnAction = cnsProcName
    End With

End Sub

メイン処理部分

Option Explicit
Const cnsClsName    As String = "hoge"
Public dicStyle     As Object 'style属性格納用辞書
Public lngClsNo     As Long   'class名のインクリメントカウンタ

' 選択されたセルからHTMLのTableソースを生成する
Sub CreateHTMLTableSource()

    Dim lngRow      As Long    '選択範囲の行数
    Dim lngCol      As Long    '選択範囲の列数
    Dim strLTAddr   As String  '結合セル左上セルアドレス
    Dim dicMrgAddr  As Object  '結合セル左上判定用辞書
    Dim strHTMLSrc  As String  'HTMLソース
    Dim strFName    As String  'htmlファイル
    Dim objFSO      As Object  'FileSystemObject
    Dim vv          As Variant 'DictionaryのItem出力用
    
    Dim i As Long, j As Long

    On Error GoTo ErrHandler
    
    lngClsNo = 1
    lngRow = Selection.Rows.Count
    lngCol = Selection.Columns.Count
    
    Set dicMrgAddr = CreateObject("Scripting.Dictionary")
    Set dicStyle = CreateObject("Scripting.Dictionary")

    strHTMLSrc = "<table>" & vbCrLf
    
    With Selection
        For i = 1 To lngRow
            strHTMLSrc = strHTMLSrc & vbTab & "<tr>" & vbCrLf
            For j = 1 To lngCol
                '結合セル判定
                If .Item(i, j).MergeCells Then
                    '結合範囲左上セルのアドレス取得
                    strLTAddr = .Item(i, j).MergeArea.Address(0, 0)
                    '左上セルのアドレスが結合セル判定辞書中に無ければtdタグ生成
                    If Not dicMrgAddr.Exists(strLTAddr) Then
                        dicMrgAddr(strLTAddr) = Empty
                        strHTMLSrc = strHTMLSrc & vbTab & vbTab & CreateTDTag(.Item(i, j)) & vbCrLf
                    End If
                Else
                    strHTMLSrc = strHTMLSrc & vbTab & vbTab & CreateTDTag(.Item(i, j)) & vbCrLf
                End If
            Next j
            strHTMLSrc = strHTMLSrc & vbTab & "</tr>" & vbCrLf
        Next i
        strHTMLSrc = strHTMLSrc & "</table>"
    End With
    
    'htmlファイル名 ※デスクトップのPath + yyyymmddhhmmss + .html
    strFName = CreateObject("WScript.Shell").SpecialFolders("Desktop") & _
                "\" & Format$(Now, "yyyymmddhhmmss") & ".html"
    
    'styleのキーを配列で取得
    vv = dicStyle.Keys
    
    'FSOをCreateObject
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    
    'htmlファイル出力
    With objFSO.CreateTextFile(strFName)
        .WriteLine "<style type=""text/css"">"
        .WriteLine "table { border-collapse: collapse; }"
        .WriteLine "td { border: solid 1px #696969; }"
        For i = LBound(vv) To UBound(vv)
            .WriteLine "." & dicStyle.Item(vv(i)) & " { " & vv(i) & " }"
        Next i
        .WriteLine "</style>"
        .WriteLine strHTMLSrc
        .Close
    End With
    
    MsgBox "HTML化完了", vbInformation

Finally:

    Set dicMrgAddr = Nothing
    Set dicStyle = Nothing
    Set objFSO = Nothing

    Exit Sub
    
ErrHandler:

    With Err
        MsgBox .Number & vbCrLf & .Description, vbCritical, "Error Occured..."
    End With
    Resume Finally

End Sub

'tdタグを返す関数
Function CreateTDTag(Target As Range)
    
    Dim strStyle   As String
    Dim strTag     As String
    Dim strVal     As String

    strStyle = ""
    
    'Font色
    strStyle = strStyle & "color: " & getForeColor(Target) & "; "
    
    '背景色
    strStyle = strStyle & "background-color: " & getBackColor(Target) & "; "
    
    'テキスト垂直方向配置
    strStyle = strStyle & "vertical-align: " & getVAlign(Target) & "; "
    
    'テキスト水平方向配置
    strStyle = strStyle & "text-align: " & getHAlign(Target) & "; "
    
    'style属性値がstyle辞書中に存在するかチェック
    If Not dicStyle.Exists(strStyle) Then
        dicStyle(strStyle) = cnsClsName & lngClsNo
        strTag = "<td class=""" & cnsClsName & lngClsNo & """"
        lngClsNo = lngClsNo + 1
    Else
        strTag = "<td class=""" & dicStyle.Item(strStyle) & """"
    End If
    
    '結合セルチェック(rowspan,colspan)
    If Target.MergeCells Then
        With Target.MergeArea
            If .Columns.Count > 1 Then
                strTag = strTag & " colspan=""" & .Columns.Count & """"
            End If
            If .Rows.Count > 1 Then
                strTag = strTag & " rowspan=""" & .Rows.Count & """"
            End If
        End With
    End If
    
    strTag = strTag & ">"
    
    'タグ値をセット
    strTag = strTag & PetitEntities(Target.Text) & "</td>"
    
    CreateTDTag = strTag

End Function

'Font色取得Function
Function getForeColor(rng As Range)

    Dim strFrColor As String
    
    strFrColor = Right("000000" & Hex(rng.Font.Color), 6)
    strFrColor = "#" & Mid(strFrColor, 5, 2) & Mid(strFrColor, 3, 2) & Mid(strFrColor, 1, 2)
    
    getForeColor = strFrColor
    
End Function

'背景色取得Function
Function getBackColor(rng As Range)

    Dim strBgColor As String
    
    strBgColor = Right("000000" & Hex(rng.Interior.Color), 6)
    strBgColor = "#" & Mid(strBgColor, 5, 2) & Mid(strBgColor, 3, 2) & Mid(strBgColor, 1, 2)

    getBackColor = strBgColor
    
End Function

'テキスト垂直方向配置取得Function
Function getVAlign(rng As Range)

    Dim ss As String
    
    Select Case rng.VerticalAlignment
        Case -4107 '下詰め
            ss = "bottom"
        Case -4160 '上詰め
            ss = "top"
        Case Else
            ss = "middle"
    End Select

    getVAlign = ss

End Function

'テキスト水平方向配置取得Function
Function getHAlign(rng As Range)

    Dim ss As String
    
    Select Case rng.HorizontalAlignment
        Case -4108 '中央揃え
            ss = "center"
        Case -4131 '左詰め
            ss = "left"
        Case -4152 '右詰め
            ss = "right"
        Case Else
            '対象セルの値が数値の場合、明示的に配置位置が設定されていなくても右詰めとする
            If IsNumeric(rng.Text) Then
                ss = "right"
            Else
                ss = "left"
            End If
    End Select

    getHAlign = ss

End Function

'< > & " 半角スペース セル内改行 文字だけ一応エンティティしておく
Function PetitEntities(ArgStrings As String)

    '< → &lt;
    ArgStrings = Replace(ArgStrings, "<", "&lt;")
    '> → &gt;
    ArgStrings = Replace(ArgStrings, ">", "&gt;")
    '& → &amp;
    ArgStrings = Replace(ArgStrings, "&", "&amp;")
    '" → &quot;
    ArgStrings = Replace(ArgStrings, """", "&quot;")
    '  → &nbsp;
    ArgStrings = Replace(ArgStrings, " ", "&nbsp;")
    'vbLf → <br>
    ArgStrings = Replace(ArgStrings, vbLf, "<br>")

    PetitEntities = ArgStrings

End Function

パスワード

VBAプロジェクトには、一応ロックをかけてますが、パスワードは「sonote」です。
改変等、自由にしてもらってOKです。