セルの内容をJSONファイル化するアドイン

JSON記法がどうも頭に入らなかった(ホント、どんどんあほになってってるなぁ…orz)ので、
憶えるためってのと、業務で使う予定なので作ってみた。

ソース

以下はThisWorkbookモジュールに記述

Option Explicit
Private Const cnsMenuName As String = "Cell To JSON"             'Cellバーに追加する際のメニュー名

Private Sub Workbook_BeforeClose(Cancel As Boolean)

    On Error Resume Next
    Application.CommandBars("Cell").Controls(cnsMenuName).Delete
    On Error GoTo 0
    
End Sub

Private Sub Workbook_Open()

    Const cnsFaceID   As Long = 89                               'アイコンのFaceID
    Const cnsTipText  As String = "CellをJSONデータに変換します" 'ツールチップテキスト
    Const cnsProcName As String = "CellToJSON"                   'プロシージャー名
    
    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

Sub CellToJSON()

    Dim objStrm     As Object  'ADODB.Stream ※UTF-8で保存する為
    Dim objDIC      As Object  '結合セル時の重複チェック用辞書
    Dim lngRowKey   As Long    '現在行
    Dim lngRowCnt   As Long    'セルの行数
    Dim lngColCnt   As Long    'セルの列数
    Dim rngMerge    As Range   '結合セル範囲格納用
    Dim str1stAddr  As String  '結合セル範囲の最初のセルのアドレス
    Dim strCellVal  As String  'セルの内容
    Dim lngMgRow    As Long    '結合行数
    Dim lngMgCol    As Long    '結合列数
    Dim strStyle    As String  'スタイル属性文字列
    Dim buf         As String  '出力文字
    Dim blnWrite    As Boolean '出力フラグ
    Dim strFileName As String  'テキストファイル名
    Dim i           As Long    'ループカウンター
    Dim j           As Long    'ループカウンター
    
    On Error GoTo ErrHandler
        
    Set objStrm = CreateObject("ADODB.Stream")
    Set objDIC = CreateObject("Scripting.Dictionary")
    
    lngRowCnt = Selection.Rows.Count
    lngColCnt = Selection.Columns.Count
    lngRowKey = 1
    
    With objStrm
        .Charset = "UTF-8"
        .Open
        .WriteText "{" & vbCrLf
        For i = 1 To lngRowCnt
            .WriteText vbTab & """row" & lngRowKey & """ : [" & vbCrLf
            For j = 1 To lngColCnt
                'ストリームへの出力フラグ初期化
                blnWrite = True
                'セルが結合されてる時
                If Selection.Cells(i, j).MergeCells Then
                    '結合セルを格納
                    Set rngMerge = Selection.Cells(i, j).MergeArea
                    '結合セルの一番目のセルのアドレスを取得
                    str1stAddr = rngMerge.Cells(1).Address(0, 0)
                    '結合セル中の一番目のセルのアドレスを辞書に問合せて
                    '辞書に登録されてなかった時はセルの情報を取得
                    If Not objDIC.Exists(str1stAddr) Then
                        objDIC(str1stAddr) = Empty
                        With rngMerge
                            strCellVal = PetitEntities(.Cells(1).Value)
                            lngMgRow = .Rows.Count
                            lngMgCol = .Columns.Count
                            strStyle = GetStyle(.Cells(1))
                        End With
                    Else
                        blnWrite = False
                    End If
                Else
                    '結合されてない時は単純に処理
                    strCellVal = PetitEntities(Selection.Cells(i, j).Value)
                    lngMgRow = 1: lngMgCol = 1
                    strStyle = GetStyle(Selection.Cells(i, j))
                End If
                If blnWrite Then
                    'jsonフォーマットの文字列生成
                    buf = vbTab & vbTab & _
                          "{ ""text"" : """ & strCellVal & """, " & _
                          """rowspan"" : " & lngMgRow & ", " & _
                          """colspan"" : " & lngMgCol & ", " & _
                          """style"" : """ & strStyle & """ }"
    
                    '最終列でない時はカンマを付与
                    If Not (j = lngColCnt Or (j + lngMgCol - 1) = lngColCnt) Then
                        buf = buf & ","
                    End If
                    .WriteText buf & vbCrLf
                End If
            Next j
            .WriteText vbTab & "]"
            '最終行でない時はカンマを付与
            If Not (i = lngRowCnt Or (i + lngMgRow - 1) = lngRowCnt) Then
                .WriteText ","
            End If
            .WriteText vbCrLf
            lngRowKey = lngRowKey + 1
        Next i
        .WriteText "}"
        strFileName = CreateObject("WScript.Shell").SpecialFolders("Desktop") & _
                      "\" & Format$(Now, "yyyymmddhhmmss") & ".txt"
        .SaveToFile strFileName, 2
        .Close
    End With

    MsgBox "JSONデータ化完了", vbInformation
    
'--- 後始末処理
Finally:

    On Error Resume Next
    Set rngMerge = Nothing
    Set objDIC = Nothing
    Set objStrm = Nothing
    Exit Sub

'--- エラー通知
ErrHandler:

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

End Sub

'とりあえず< > & " 半角スペース セル内改行
'だけエンティティする関数
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

'引数で受け取ったセルの書式をhmtlのスタイル属性文字列を返す
'参照する書式は以下の6つ
'セルの幅(ピクセル)、font色、fontウェイト、
'背景色、垂直方向文字位置、水平方向文字位置
Function GetStyle(Target As Range) As String

    Dim buf       As String
    Dim lngPx     As Long
    Dim vntColors As Variant
    
    buf = ""
    lngPx = ActiveWindow.PointsToScreenPixelsX(Target.Width)
    buf = buf & "width: " & lngPx & "px; "
    buf = buf & "color: " & ConvertHTMLColor(Target.Font.Color) & "; "
    buf = buf & "background-color: " & ConvertHTMLColor(Target.Interior.Color) & "; "
    If Target.Font.Bold Then
        buf = buf & "font-weight: bold; "
    End If
    buf = buf & "vertical-align: " & GetVAlign(Target) & "; "
    buf = buf & "text-align: " & GetHAlign(Target) & ";"

    GetStyle = buf

End Function

'Font色・背景色をhtmlのカラーコードに変換する
Function ConvertHTMLColor(ColorValue As Variant) As String

    Dim strColor As String
    
    strColor = Right("000000" & Hex(ColorValue), 6)
    strColor = "#" & Mid(strColor, 5, 2) & Mid(strColor, 3, 2) & Mid(strColor, 1, 2)
    
    ConvertHTMLColor = strColor
    
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