底稿小帮手代码

Sub 段落处理(control As IRibbonControl) '段落-段落处理-
    Application.ScreenUpdating = False
    For Each pg In Selection.Paragraphs
        If pg.Range.Information(wdWithInTable) = False Then
            '-------------------------------------------------------------------------
            If pg.OutlineLevel = wdOutlineLevel1 Then '如果是1级标题用此格式
                With pg.Range.ParagraphFormat
                    .LeftIndent = CentimetersToPoints(0)   '左缩进
                    .RightIndent = CentimetersToPoints(0)  '右缩进
                    .SpaceBefore = 2.5        '段前 2.5磅等于0.5行,如果你的单位为行,则这里乘5
                    .SpaceBeforeAuto = False
                    .SpaceAfter = 2.5         '段后
                    .SpaceAfterAuto = False
                    .LineSpacingRule = wdLineSpace1pt5   '行距,单倍 wdLineSpaceSingle   1.5倍 wdLineSpace1pt5     两倍 wdLineSpaceDouble
                    .Alignment = wdAlignParagraphCenter  '对齐方式  左对齐:wdAlignParagraphLeft  右对齐:wdAlignParagraphRight  居中:wdAlignParagraphCenter
                    .FirstLineIndent = CentimetersToPoints(0)  '首行缩进
                    .CharacterUnitLeftIndent = 0
                    .CharacterUnitRightIndent = 0
                    .CharacterUnitFirstLineIndent = 0

                End With
                With pg.Range
                    .Font.NameFarEast = "黑体"   '中文
                    .Font.NameAscii = "Times New Roman"   '西文
                    .Font.NameOther = "Times New Roman"   '西文
                    .Font.Size = 20          '字号三号
                    .Font.Bold = True        '加粗      不加粗填false
                End With
                '-------------------------------------------------------------------------
            ElseIf pg.OutlineLevel = wdOutlineLevel2 Then '如果是2级标题用此格式
                With pg.Range.ParagraphFormat
                    .LeftIndent = CentimetersToPoints(0)
                    .RightIndent = CentimetersToPoints(0)
                    .SpaceBefore = 2.5
                    .SpaceBeforeAuto = False
                    .SpaceAfter = 2.5
                    .SpaceAfterAuto = False
                    .LineSpacingRule = wdLineSpace1pt5
                    .Alignment = wdAlignParagraphJustify '两端对齐
                    .FirstLineIndent = CentimetersToPoints(0)
                    .CharacterUnitLeftIndent = 0
                    .CharacterUnitRightIndent = 0
                    .CharacterUnitFirstLineIndent = 0

                End With
                With pg.Range
                    .Font.NameFarEast = "黑体"
                    .Font.NameAscii = "Times New Roman"
                    .Font.NameOther = "Times New Roman"
                    .Font.Size = 18          '字号四号
                    .Font.Bold = True

                End With
                '-------------------------------------------------------------------------
            ElseIf pg.OutlineLevel = wdOutlineLevel3 Then  '如果是3级标题用此格式
                With pg.Range.ParagraphFormat
                    .LeftIndent = CentimetersToPoints(0)
                    .RightIndent = CentimetersToPoints(0)
                    .SpaceBefore = 2.5
                    .SpaceBeforeAuto = False
                    .SpaceAfter = 2.5
                    .SpaceAfterAuto = False
                    .LineSpacingRule = wdLineSpace1pt5
                    .Alignment = wdAlignParagraphLeft
                    .FirstLineIndent = CentimetersToPoints(0)
                    .CharacterUnitLeftIndent = 0
                    .CharacterUnitRightIndent = 0
                    .CharacterUnitFirstLineIndent = 0

                End With
                With pg.Range
                    .Font.NameFarEast = "黑体"
                    .Font.NameAscii = "Times New Roman"
                    .Font.NameOther = "Times New Roman"
                    .Font.Size = 16          '字号小四
                    .Font.Bold = True

                End With
                '-------------------------------------------------------------------------
            ElseIf pg.OutlineLevel = wdOutlineLevel4 Then  '如果是4级标题用此格式
                With pg.Range.ParagraphFormat
                    .LeftIndent = CentimetersToPoints(0)
                    .RightIndent = CentimetersToPoints(0)
                    .SpaceBefore = 2.5
                    .SpaceBeforeAuto = False
                    .SpaceAfter = 2.5
                    .SpaceAfterAuto = False
                    .LineSpacingRule = wdLineSpace1pt5
                    .Alignment = wdAlignParagraphJustify
                    .FirstLineIndent = CentimetersToPoints(0)
                    .CharacterUnitLeftIndent = 0
                    .CharacterUnitRightIndent = 0
                    .CharacterUnitFirstLineIndent = 0

                End With
                With pg.Range
                    .Font.NameFarEast = "仿宋"
                    .Font.NameAscii = "Times New Roman"
                    .Font.NameOther = "Times New Roman"
                    .Font.Size = 16          '字号小四
                    .Font.Bold = True
                End With
                '------------------------------------------------------------------------- 下面是5级以及正文的样式设置
            Else
                With pg.Range.ParagraphFormat
                    .LeftIndent = CentimetersToPoints(0)
                    .RightIndent = CentimetersToPoints(0)
                    .SpaceBefore = 2.5
                    .SpaceBeforeAuto = False
                    .SpaceAfter = 2.5
                    .SpaceAfterAuto = False
                    .LineSpacingRule = wdLineSpace1pt5
                    .Alignment = wdAlignParagraphJustify
                    .FirstLineIndent = CentimetersToPoints(0.35)  '首行缩进2
                    .CharacterUnitLeftIndent = 0
                    .CharacterUnitRightIndent = 0
                    .CharacterUnitFirstLineIndent = 2  '首行缩进2

                End With
                With pg.Range
                    .Font.NameFarEast = "仿宋"
                    .Font.NameAscii = "Times New Roman"
                    .Font.NameOther = "Times New Roman"
                    .Font.Size = 14          '字号四号
                    .Font.Bold = False
                End With
            End If
        End If
    Next
    Application.ScreenUpdating = True
End Sub
Sub 表前单位格式(control As IRibbonControl) '
    For Each pg In Selection.Paragraphs
        pg.IndentFirstLineCharWidth -10000
        pg.IndentFirstLineCharWidth 2
        pg.Range.Font.Bold = False
        With pg.Range.ParagraphFormat
            .LeftIndent = CentimetersToPoints(0)
            .RightIndent = CentimetersToPoints(0)
            .SpaceBefore = 0
            .SpaceBeforeAuto = False
            .SpaceAfter = 0
            .SpaceAfterAuto = False
            .LineSpacingRule = wdLineSpaceSingle
            .Alignment = wdAlignParagraphJustify
            .FirstLineIndent = CentimetersToPoints(0)
            .CharacterUnitLeftIndent = 0
            .CharacterUnitRightIndent = 0
            .CharacterUnitFirstLineIndent = 0
            .LineUnitBefore = 0
            .LineUnitAfter = 0
        End With
        With pg.Range
            .Font.NameFarEast = "宋体"
            .Font.NameAscii = "Times New Roman"
            .Font.NameOther = "Times New Roman"
            .Font.Size = 10.5         '字号五号
            .Font.Bold = False
            .ParagraphFormat.Alignment = wdAlignParagraphRight
        End With
        With pg.Range.ParagraphFormat
            .SpaceBefore = 0
            .SpaceBeforeAuto = False
            .SpaceAfter = 0
            .SpaceAfterAuto = False
        End With
    Next
    Application.ScreenUpdating = True
End Sub
Sub 表后注释格式(control As IRibbonControl) '
    For Each pg In Selection.Paragraphs
        pg.IndentFirstLineCharWidth -10000
        pg.IndentFirstLineCharWidth 2
        pg.Range.Font.Bold = False
        With pg.Range.ParagraphFormat
            .LeftIndent = CentimetersToPoints(0)
            .RightIndent = CentimetersToPoints(0)
            .SpaceBefore = 0
            .SpaceBeforeAuto = False
            .SpaceAfter = 0
            .SpaceAfterAuto = False
            .LineSpacingRule = wdLineSpaceSingle
            .Alignment = wdAlignParagraphJustify
            .FirstLineIndent = CentimetersToPoints(0)
            .CharacterUnitLeftIndent = 0
            .CharacterUnitRightIndent = 0
            .CharacterUnitFirstLineIndent = 0
            .LineUnitBefore = 0
            .LineUnitAfter = 0
        End With
        With pg.Range
            .Font.NameFarEast = "宋体"
            .Font.NameAscii = "Times New Roman"
            .Font.NameOther = "Times New Roman"
            .Font.Size = 10        '字号10
            .Font.Bold = False
            .ParagraphFormat.Alignment = wdAlignParagraphJustify
        End With
        With pg.Range.ParagraphFormat
            .SpaceBefore = 0
            .SpaceBeforeAuto = False
            .SpaceAfter = 0
            .SpaceAfterAuto = False
        End With
    Next
    Application.ScreenUpdating = True
End Sub
Sub 自动编号(control As IRibbonControl)  '针对样式（一）
    '先选择一片范围再运行代码,会将例如"(一)"此样式的编号换为自动编号,"()"为中文全角符号
    '注意只有段落开头为"(一)"样式的编号会替换,段中的编号则不会
    Dim r As Range, P As Range, tpf, NF, NS, LI, FI
    '================================================== 配置区
    tpf = "（[一二三四五六七八九十]@）"  '通配符
    NF = "（%1）"   '编号格式,%1为编号本身,不能动,只需要编辑%1旁边的格式,比如'(一)'为'（%1）' 或者 '1、'为 '%1、' 或者 '第一章'为'第%1章'
    NS = wdListNumberStyleSimpChinNum3  '编号的样式:wdListNumberStyleArabic阿拉伯数字    wdListNumberStyleSimpChinNum3中文数字
    LI = CentimetersToPoints(0)    '左缩进
    FI = CentimetersToPoints(0.74)   '首行缩进
    '================================================== 配置区
    Application.ScreenUpdating = False
    If Selection.Type = wdSelectionIP Then
        MsgBox "请选择范围！"
        Exit Sub
    Else
        Set r = Selection.Range
        Set P = Selection.Range
    End If
    With ListGalleries(wdNumberGallery).ListTemplates(1).ListLevels(1)  '设置编号格式
        .NumberFormat = NF
        .TrailingCharacter = wdTrailingNone
        .NumberStyle = NS
        .NumberPosition = 0
        .Alignment = wdListLevelAlignLeft
        .TextPosition = 0
        .TabPosition = wdUndefined
        .ResetOnHigher = 0
        .StartAt = 1
        .LinkedStyle = ""
    End With
    ListGalleries(wdNumberGallery).ListTemplates(1).Name = ""
    With r.Find
        .ClearFormatting
        .Text = tpf
        .Forward = True
        .MatchWildcards = True
        Do While .Execute
            With .Parent
                pat = .Text
                If .End > P.End Then Exit Do
                ast = Asc(ActiveDocument.Range(Start:=.Start - 1, End:=.Start))
                If ast = 13 Or ast = 12 Then
                    .ListFormat.ApplyListTemplateWithLevel ListTemplate:= _
                        ListGalleries(wdNumberGallery).ListTemplates(1), ContinuePreviousList:= _
                        True, ApplyTo:=wdListApplyToWholeList, DefaultListBehavior:= _
                        wdWord10ListBehavior
                    With .ParagraphFormat
                        .SpaceBeforeAuto = False
                        .SpaceAfterAuto = False
                        .LeftIndent = LI
                        .FirstLineIndent = FI
                    End With
                    If .Text = pat Then
                        .Delete
                    End If
                End If
                .Start = .End
            End With
        Loop
    End With
    Application.ScreenUpdating = True
    MsgBox "完成"
End Sub
Sub 编号转文本(control As IRibbonControl)
    Dim kgslist As List
    i = MsgBox("点击确定则将该文档下所有编号转为文本", 1)
    If i = 1 Then
        For Each kgslist In ActiveDocument.Lists
            kgslist.ConvertNumbersToText
        Next
    End If
End Sub

Dim aarr(1 To 20), bbrr(1 To 30, 1 To 30) '多列调整
Sub 单表_一键调整(control As IRibbonControl) '单表-格式
    '功能：光标在表格中处理当前表格；否则处理所有表格！
    Application.ScreenUpdating = False  '关闭屏幕刷新
    Application.DisplayAlerts = False  '关闭提示
    On Error Resume Next  '忽略错误
    '-------------------------------------------------------------------------
    Dim mytable As Table, i As Long
    For Each mytable In Selection.Tables
        With mytable
            .Shading.ForegroundPatternColor = wdColorAutomatic
            .Shading.BackgroundPatternColor = wdColorAutomatic
            Options.DefaultHighlightColorIndex = wdNoHighlight
            .Range.HighlightColorIndex = wdNoHighlight
            .Style = "表格主题"
            With .Borders(wdBorderLeft)    '左框线
                .LineStyle = wdLineStyleSingle   '设置线条样式    不需要线条则填wdLineStyleNone
                .LineWidth = wdLineWidth150pt    '宽度为1.5
            End With
            With .Borders(wdBorderRight)   '右框线
                .LineStyle = wdLineStyleSingle
                .LineWidth = wdLineWidth150pt
            End With
            With .Borders(wdBorderTop)     '上框线
                .LineStyle = wdLineStyleSingle
                .LineWidth = wdLineWidth150pt
            End With
            With .Borders(wdBorderBottom)  '下框线
                .LineStyle = wdLineStyleSingle
                .LineWidth = wdLineWidth150pt
            End With
            With .Borders(wdBorderVertical)   '内部纵向框线
                .LineStyle = wdLineStyleSingle
                .LineWidth = wdLineWidth050pt
            End With
            With .Borders(wdBorderHorizontal)   '内部横向框线
                .LineStyle = wdLineStyleSingle
                .LineWidth = wdLineWidth050pt
            End With
            .Borders(wdBorderDiagonalDown).LineStyle = wdLineStyleNone  '左上的斜线
            .Borders(wdBorderDiagonalUp).LineStyle = wdLineStyleNone    '右上的斜线
            '单元格边距
            .TopPadding = CentimetersToPoints(0) '设置上边距为0
            .BottomPadding = CentimetersToPoints(0) '设置下边距为0
            .LeftPadding = PixelsToPoints(0, True)  '设置左边距为0
            .RightPadding = PixelsToPoints(0, True) '设置右边距为0
            .Spacing = PixelsToPoints(0, True) '允许单元格间距为0
            .AllowPageBreaks = True '允许断页
            '.AllowAutoFit = True '允许自动重调尺寸
            With .Rows
                .WrapAroundText = False '取消文字环绕
                '.Alignment = wdAlignRowCenter '表水平居中  wdAlignRowLeft '左对齐
                .AllowBreakAcrossPages = False '不允许行断页
                .Height = CentimetersToPoints(0.8) '行高0.8
                .HeightRule = wdRowHeightAtLeast '行高设为最小值
                .LeftIndent = CentimetersToPoints(0) '左面缩进量为0
            End With
            With .Range
                With .Font '字体格式
                    .NameFarEast = "宋体"
                    .NameAscii = "Times New Roman"
                    .NameOther = "Times New Roman"
                    .Color = wdColorAutomatic '自动字体颜色
                    .Size = 10.5   '字号
                    .Kerning = 0
                    .DisableCharacterSpaceGrid = True  '选定段落中的字符与行网格对齐
                End With
                With .ParagraphFormat '段落格式
                    .LineUnitBefore = 0
                    .LineUnitAfter = 0
                    .SpaceBefore = 0
                    .SpaceAfter = 0
                    .CharacterUnitFirstLineIndent = 0 '取消首行缩进
                    .FirstLineIndent = CentimetersToPoints(0) '取消首行缩进
                    .LineSpacingRule = wdLineSpaceSingle 'wdLineSpaceSingle '单倍行距  wdLineSpaceExactly '行距固定值
                    ''.LineSpacing = 18 '设置行间距为18磅，配合行距固定值
                    '.Alignment = wdAlignParagraphCenter '单元格水平居中
                    .AutoAdjustRightIndent = False  '自动调整所选段落的右缩进
                    .DisableLineHeightGrid = True   '选定段落中的字符与行网格对齐
                End With
                .Cells.VerticalAlignment = wdCellAlignVerticalCenter  '单元格垂直居中
            End With
            For Each cl In .Range.Cells    '文字靠左，数字靠右,合计居中,序号居中
                Acell = ActiveDocument.Range(cl.Range.Start, cl.Range.End - 1).Text '提取文本
                If IsNumeric(Acell) Then
                    cl.Range.ParagraphFormat.Alignment = wdAlignParagraphRight    '右对齐
                Else
                    cl.Range.ParagraphFormat.Alignment = wdAlignParagraphJustify   '左对齐
                    If Acell = "合计" Or Acell = "总计" Or Acell = "总 计" Or Acell = "合 计" Then
                        cl.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter    '水平居中
                        If cl.ColumnIndex = .Columns.Count Then
                            .Columns(cl.ColumnIndex).Select
                            Selection.Font.Bold = True
                        Else
                            cl.Row.Range.Font.Bold = True
                        End If
                    ElseIf Acell = "序号" Or Acell = "序 号" Then
                        .Columns(cl.ColumnIndex).Select
                        Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter    '水平居中
                    End If
                End If
            Next
            '设置首行格式
            .Rows(1).Select ' 选中第一个单元格
            With Selection
                .Rows.HeadingFormat = wdToggle '自动标题行重复
                .ParagraphFormat.Alignment = wdAlignParagraphCenter   '水平居中
                .Range.Font.Bold = True '表头加粗黑体
                .Shading.ForegroundPatternColor = wdColorAutomatic '首行自动颜色
                .Shading.BackgroundPatternColor = -603923969 '首行底纹填充,不要底色则删了这行
                '.Borders(wdBorderBottom).LineStyle = xlContinuous
                '.Borders(wdBorderBottom).LineWidth = wdLineWidth50pt
            End With
            '自动调整表格
            .Columns.PreferredWidthType = wdPreferredWidthAuto
            .AutoFitBehavior (wdAutoFitContent) '根据内容调整表格
            .AutoFitBehavior (wdAutoFitWindow) '根据窗口调整表格
        End With
    Next
    '---------------------------------------------------------------------------------------
    ERR.Clear: On Error GoTo 0 '恢复错误捕捉
    Application.DisplayAlerts = True  '开启提示
    Application.ScreenUpdating = True   '开启屏幕刷新
End Sub
Sub 格宽调整_释放(control As IRibbonControl) '列宽调整-多列加载
    Set mytable = Selection.Tables(1)
    For i = 1 To mytable.Rows.Count
        For j = 1 To mytable.Rows(i).Cells.Count
            mytable.Rows(i).Cells(j).Width = bbrr(i, j)
        Next j
    Next i
End Sub
Sub 格宽调整_读取(control As IRibbonControl)  '列宽调整-多列读取
    Set mytable = Selection.Tables(1)
    mytable.AutoFitBehavior (wdAutoFitFixed)
    For i = 1 To mytable.Rows.Count
        For j = 1 To mytable.Rows(i).Cells.Count
            bbrr(i, j) = mytable.Rows(i).Cells(j).Width
        Next j
    Next i
End Sub
Sub 列宽调整_读取(control As IRibbonControl)   '列宽调整-单列读取
    With Selection.Tables(1)
        ColumnsCounts = .Columns.Count
        For i = 1 To ColumnsCounts
            aarr(i) = .Columns(i).Width
        Next
    End With
End Sub
Sub 列宽调整_释放(control As IRibbonControl) '列宽调整-单列加载
    With Selection.Tables(1)
        .AutoFitBehavior (wdAutoFitFixed)
        ColumnsCounts = .Columns.Count
        For i = 1 To ColumnsCounts
            .Columns(i).Width = aarr(i)
        Next
    End With
End Sub

Sub 千分位符(control As IRibbonControl) '数字-千分位符
    On Error Resume Next
    Dim i As Range, Acell As Cell, CR As Range
    On Error Resume Next
    Application.ScreenUpdating = False
    If Selection.Type = 2 Then '文档选定
        For Each i In Selection.Words
            If IsNumeric(i) Then
                If i Like "####*" = True Then
                    If i.Next Like "." = True And i.Next(wdWord, 2) Like "#*" = True Then
                        i.SetRange Start:=i.Start, End:=i.Next(wdWord, 2).End
                        NC = Format(i, "#,##0.00;-#,##0.00; ")
                        i.Text = NC
                    Else
                        NC = Format(i, "#,##0.00;-#,##0.00; ")
                        i.Text = NC
                    End If
                End If
            End If
        Next i
    ElseIf Selection.Type = 4 Or Selection.Type = 5 Then '竖形表格（5为横形表格）
        For Each Acell In Selection.Cells
            Set CR = ActiveDocument.Range(Acell.Range.Start, Acell.Range.End - 1)
            '            MsgBox CR
            If CR Like "-####*" Or "-####.#*" = True Then
                Yn = Format(CR, "#,##0.00;-#,##0.00; ")
                CR.Text = Yn
            Else
                If CR Like "####*" Or "####.#*" = True Then
                    Yn = Format(CR, "#,##0.00;-#,##0.00; ")
                    CR.Text = Yn
                End If
            End If
        Next Acell
    Else
        MsgBox "您只能选定文本或者表格之一!", vbOK + vbInformation
    End If
    Application.ScreenUpdating = True
    Application.Activate
End Sub
Sub 除以一万(control As IRibbonControl)
    Application.ScreenUpdating = False
    If Selection.Type = 2 Then
        If IsNumeric(Selection.Text) Then
            i = Selection.Text
            P = i / 10000
            q = Format(Round(P, 2), "#,##0.00;-#,##0.00; ")
            Selection.Text = q & "万"
        End If
    ElseIf Selection.Type = 5 Or Selection.Type = 4 Then
        For Each Acell In Selection.Cells
            Set CR = ActiveDocument.Range(Acell.Range.Start, Acell.Range.End - 1)
            'MsgBox CR
            If IsNumeric(CR.Text) Then
                i = CR.Text
                P = i / 10000
                q = Format(Round(P, 2), "#,##0.00;-#,##0.00; ")
                CR.Text = q & "万"
            End If
        Next
    End If
    Application.ScreenUpdating = True
End Sub
Sub 乘百(control As IRibbonControl)
    Application.ScreenUpdating = False
    If Selection.Type = 2 Then
        If IsNumeric(Selection.Text) Then
            i = Selection.Text
            P = i * 100
            q = Format(Round(P, 2), "#,##0.00;-#,##0.00; ")
            Selection.Text = q & "%"
        End If
    ElseIf Selection.Type = 5 Or Selection.Type = 4 Then
        For Each Acell In Selection.Cells
            Set CR = ActiveDocument.Range(Acell.Range.Start, Acell.Range.End - 1)
            'MsgBox CR
            If IsNumeric(CR.Text) Then
                i = CR.Text
                P = i * 100
                q = Format(Round(P, 2), "#,##0.00;-#,##0.00; ")
                CR.Text = q & "%"
            End If
        Next
    End If
        Application.ScreenUpdating = True
End Sub

Sub 宋体宋体(control As IRibbonControl)
    '选中范围字体为宋体+宋体
    With Selection.Font
        .NameFarEast = "宋体"
        .NameAscii = "宋体"
        .NameOther = "宋体"
    End With
End Sub
Sub 宋体罗马(control As IRibbonControl) '文字-宋体罗马
    '选中范围字体为宋体+Times
    With Selection.Font
        .NameFarEast = "仿宋"
        .NameAscii = "Times New Roman"
        .NameOther = "Times New Roman"
    End With
End Sub
Sub 楷体加粗(control As IRibbonControl) '文字-楷体加粗
    '选中范围字体为楷体加粗
    With Selection.Font
        .NameFarEast = "楷体"
        .NameAscii = "楷体"
        .NameOther = "楷体"
        .Name = "楷体"
        .Bold = True
    End With
End Sub
Sub 去除空白(control As IRibbonControl) '文字-去除空白
    '删除换行及空格
    
    Selection.Find.ClearFormatting   '删除空格
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = " "
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
    Selection.Find.ClearFormatting   '删除大空格
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "　"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
    Selection.Find.Replacement.ClearFormatting    '删除连续两个回车
    With Selection.Find
        .Text = "^p^p"
        .Replacement.Text = "^p"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub
Sub 中英文标点互换(control As IRibbonControl) ' 文字-中英文标点互换
    Dim ChineseInterpunction() As Variant, EnglishInterpunction() As Variant
    Dim myArray1() As Variant, myArray2() As Variant, strFind As String, strRep As String
    Dim msgResult As VbMsgBoxResult, n As Byte
    ' 定义一个中文标点的数组对象
    ChineseInterpunction = Array("，", "。", "；", "：", "？", "！", "……", "—", "～", "（", "）", "《", "》")
    ' 定义一个英文标点的数组对象
    EnglishInterpunction = Array(",", ".", ";", ":", "?", "!", "…", "-", "~", "(", ")", "<", ">")
    ' 提示用户交互的 MSGBOX 对话框
    msgResult = MsgBox("您想中英标点互换吗？按 Y 将中文标点转为英文标点，按 N 将英文标点转为中文标点！", vbYesNoCancel)
    Select Case msgResult
        Case vbCancel
            Exit Sub ' 如果用户选择了取消按钮，则退出程序运行
        Case vbYes ' 如果用户选择了 YES, 则将中文标点转换为英文标点
            myArray1 = ChineseInterpunction
            myArray2 = EnglishInterpunction
            strFind = "“(*)”"
            strRep = """\1"""
        Case vbNo ' 如果用户选择了 NO, 则将英文标点转换为中文标点
            myArray1 = EnglishInterpunction
            myArray2 = ChineseInterpunction
            strFind = """(*)"""
            strRep = "“\1”"
    End Select
    Application.ScreenUpdating = False ' 关闭屏幕更新
    For n = 0 To UBound(ChineseInterpunction)  ' 从数组的下标到上标间作一个循环
        With Selection.Find
            .ClearFormatting ' 不限定查找格式
            .MatchWildcards = False ' 不使用通配符
            ' 查找相应的英文标点，替换为对应的中文标点
            .Execute findtext:=myArray1(n), replacewith:=myArray2(n), Replace:=wdReplaceAll
        End With
    Next
    With Selection.Find
        .ClearFormatting ' 不限定查找格式
        .MatchWildcards = True ' 使用通配符
        .Execute findtext:=strFind, replacewith:=strRep, Replace:=wdReplaceAll
    End With
    Application.ScreenUpdating = True ' 恢复屏幕更新
End Sub
Sub 高亮(control As IRibbonControl) '文字-HighLight
    If Selection.Range.HighlightColorIndex = 0 Then
        Selection.Range.HighlightColorIndex = wdYellow
    Else
        Selection.Range.HighlightColorIndex = wdNoHighlight
    End If
End Sub

Sub 大纲一级(control As IRibbonControl) '大纲调整-一级
    With Selection
        .Paragraphs.OutlineLevel = wdOutlineLevel1
    End With
End Sub
Sub 大纲二级(control As IRibbonControl) '大纲调整-二级
    With Selection
        .Paragraphs.OutlineLevel = wdOutlineLevel2
    End With
End Sub
Sub 大纲三级(control As IRibbonControl) '大纲调整-三级
    With Selection
        .Paragraphs.OutlineLevel = wdOutlineLevel3
    End With
End Sub
Sub 大纲四级(control As IRibbonControl) '大纲调整-四级
    With Selection
        .Paragraphs.OutlineLevel = wdOutlineLevel4
    End With
End Sub
Sub 大纲五级(control As IRibbonControl) '大纲调整-五级
    With Selection
        .Paragraphs.OutlineLevel = wdOutlineLevel5
    End With
End Sub
Sub 大纲正文(control As IRibbonControl) '大纲调整-正文
    With Selection
        .Paragraphs.OutlineLevel = wdOutlineLevelBodyText
    End With
End Sub

Sub 粘贴格式文本(control As IRibbonControl)
    Set xl = GetObject(, "excel.application")
    xlr = xl.Selection.Rows.Count
    xlc = xl.Selection.Columns.Count
    With Selection
        wdc = .Information(16)
        wdr = .Information(13)
        rangeselect wdr, wdc, xlr, xlc
        ReDim arr(1 To 1)
        For Each sht In .Cells
            i = i + 1
            ReDim Preserve arr(1 To i)
            arr(i) = sht.Range.Font.Underline
        Next
        .CopyFormat
        .PasteAndFormat (wdFormatSurroundingFormattingWithEmphasis)
        .PasteFormat
        With .Find
            .Text = " "
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindStop
            .Execute Replace:=wdReplaceAll
        End With
        rangeselect wdr, wdc, xlr, xlc
        For Each sht In .Cells
            j = j + 1
            sht.Range.Font.Underline = arr(j)
        Next
    End With

End Sub
Sub 双下划线(control As IRibbonControl)
    If Selection.Font.Underline = wdUnderlineDouble Then
        Selection.Font.Underline = wdUnderlineNone
    ElseIf Selection.Font.Underline = wdUnderlineNone Then
        Selection.Font.Underline = wdUnderlineDouble
    End If
End Sub
Sub 单下划线(control As IRibbonControl)
    If Selection.Font.Underline = wdUnderlineSingle Then
        Selection.Font.Underline = wdUnderlineNone
    ElseIf Selection.Font.Underline = wdUnderlineNone Then
        Selection.Font.Underline = wdUnderlineSingle
    End If
End Sub
Function rangeselect(wdr, wdc, xlr, xlc)
    With Selection
        .Tables(1).Cell(wdr, wdc).Select
        .Collapse wdCollapseStart
        st = .Start
        .Tables(1).Cell(wdr + xlr - 1, wdc + xlc - 1).Select
        .Collapse wdCollapseEnd
        ed = .End
        ActiveDocument.Range(st, ed).Select
    End With
End Function

Sub 添加批注(control As IRibbonControl) '批注-添加批注
    '添加批注
    Application.ScreenUpdating = False '关闭屏幕更新
    Selection.Collapse Direction:=wdCollapseEnd
    ActiveDocument.Comments.Add _
        Range:=Selection.Range, Text:=""
    Application.ScreenUpdating = True '恢复屏幕更新
End Sub
Sub 删除批注(control As IRibbonControl) '批注-删除批注
    '删除批注
    On Error GoTo err_msgbox
    Selection.Comments(1).Delete
    Exit Sub
err_msgbox:
    MsgBox ("你需要先选中一个批注")
End Sub
Sub 修订上色(control As IRibbonControl)
    Dim oDoc As Document
    Set oDoc = Word.ActiveDocument
    Dim oRevision As Revision
    For Each oRevision In oDoc.Revisions
        With oRevision
            t = .Range.Text
            .Range.HighlightColorIndex = wdYellow
        End With
    Next
End Sub

Sub 选行校验(control As IRibbonControl) '行列校验-选行校验
    i = 0
    x = 0
    n = 0
    If Selection.Type = wdSelectionColumn Then
        For Each Acell In Selection.Cells '求所选列合计数
            If Acell.ColumnIndex > n Then
                n = Acell.ColumnIndex
            End If
            Set CR1 = ActiveDocument.Range(Acell.Range.Start, Acell.Range.End - 1)
            If IsNumeric(CR1.Text) Then
                i = CR1.Text + i
            End If
        Next
        For Each Acell In Selection.Cells '求所选列最后一行合计数
            Set CR2 = ActiveDocument.Range(Acell.Range.Start, Acell.Range.End - 1)
            If Acell.ColumnIndex = n Then
                If IsNumeric(CR2.Text) Then
                    x = CR2.Text + x
                End If
            End If
        Next
        P = i - x
        q = P - x
        y = "列校验:" & Format(P, "Standard") & "-" & Format(x, "Standard") & "=" & Format(q, "Standard")
    Else
        y = "只支持选中表格范围!"
    End If
    Application.StatusBar = y
End Sub
Sub 选列校验(control As IRibbonControl) '行列校验-选列校验
    i = 0
    x = 0
    n = 0
    If Selection.Type = wdSelectionColumn Then
        For Each Acell In Selection.Cells '求所选列合计数
            If Acell.RowIndex > n Then
                n = Acell.RowIndex
            End If
            Set CR1 = ActiveDocument.Range(Acell.Range.Start, Acell.Range.End - 1)
            If IsNumeric(CR1.Text) Then
                i = CR1.Text + i
            End If
        Next
        For Each Acell In Selection.Cells '求所选列最后一行合计数
            Set CR2 = ActiveDocument.Range(Acell.Range.Start, Acell.Range.End - 1)
            If Acell.RowIndex = n Then
                If IsNumeric(CR2.Text) Then
                    x = CR2.Text + x
                End If
            End If
        Next
        P = i - x
        q = P - x
        y = "列校验:" & Format(P, "Standard") & "-" & Format(x, "Standard") & "=" & Format(q, "Standard")
    Else
        y = "只支持选中表格范围!"
    End If
    Application.StatusBar = y
End Sub
Sub 区域求和(control As IRibbonControl) '行列校验-区域求和
    i = 0
    If Selection.Type = 5 Then
        For Each Acell In Selection.Cells
            Set CR = ActiveDocument.Range(Acell.Range.Start, Acell.Range.End - 1)
            If IsNumeric(CR.Text) Then
                i = CR.Text + i
            End If
        Next
        i = "合计:" & Format(i, "#,##0.00;-#,##0.00; ")
    ElseIf Selection.Type = 4 Then
        For Each Acell In Selection.Cells
            Set CR = ActiveDocument.Range(Acell.Range.Start, Acell.Range.End - 1)
            If IsNumeric(CR.Text) Then
                i = CR.Text + i
            End If
        Next
        i = "合计:" & Format(i, "#,##0.00;-#,##0.00; ")
    Else
        i = "只支持表格内行或列求和!"
    End If
    Application.StatusBar = i
End Sub

Sub 多表_一键调整(control As IRibbonControl) '批量调整表格格式
    Application.ScreenUpdating = False  '关闭屏幕刷新
    Application.DisplayAlerts = False  '关闭提示
    On Error Resume Next  '忽略错误
    '-------------------------------------------------------------------------
    Dim mytable As Table, i As Long
    For Each mytable In ActiveDocument.Tables
        With mytable
            .Shading.ForegroundPatternColor = wdColorAutomatic
            .Shading.BackgroundPatternColor = wdColorAutomatic
            Options.DefaultHighlightColorIndex = wdNoHighlight
            .Range.HighlightColorIndex = wdNoHighlight
            .Style = "表格主题"
            With .Borders(wdBorderLeft)
                .LineStyle = wdLineStyleSingle: .LineWidth = wdLineWidth150pt
            End With
            With .Borders(wdBorderRight)
                .LineStyle = wdLineStyleSingle: .LineWidth = wdLineWidth150pt
            End With
            With .Borders(wdBorderTop)
                .LineStyle = wdLineStyleSingle: .LineWidth = wdLineWidth150pt
            End With
            With .Borders(wdBorderBottom)
                .LineStyle = wdLineStyleSingle: .LineWidth = wdLineWidth150pt
            End With
            With .Borders(wdBorderVertical)
                .LineStyle = wdLineStyleSingle: .LineWidth = wdLineWidth050pt
            End With
            .Borders(wdBorderDiagonalDown).LineStyle = wdLineStyleNone
            .Borders(wdBorderDiagonalUp).LineStyle = wdLineStyleNone
            '单元格边距
            .TopPadding = CentimetersToPoints(0) '设置上边距为0
            .BottomPadding = CentimetersToPoints(0) '设置下边距为0
            .LeftPadding = PixelsToPoints(0, True)  '设置左边距为0
            .RightPadding = PixelsToPoints(0, True) '设置右边距为0
            .Spacing = PixelsToPoints(0, True) '允许单元格间距为0
            .AllowPageBreaks = True '允许断页
            '.AllowAutoFit = True '允许自动重调尺寸
            With .Rows
                .WrapAroundText = False '取消文字环绕
                '.Alignment = wdAlignRowCenter '表水平居中  wdAlignRowLeft '左对齐
                .AllowBreakAcrossPages = False '不允许行断页
                .Height = CentimetersToPoints(0.8) '行高0.8
                .HeightRule = wdRowHeightAtLeast '行高设为最小值
                .LeftIndent = CentimetersToPoints(0) '左面缩进量为0
            End With
            With .Range
                With .Font '字体格式
                    .NameFarEast = "宋体"
                    .NameAscii = "Times New Roman"
                    .NameOther = "Times New Roman"
                    .Color = wdColorAutomatic '自动字体颜色
                    .Size = 10.5   '字号
                    .Kerning = 0
                    .DisableCharacterSpaceGrid = True  '选定段落中的字符与行网格对齐
                End With
                With .ParagraphFormat '段落格式
                    .LineUnitBefore = 0
                    .LineUnitAfter = 0
                    .SpaceBefore = 0
                    .SpaceAfter = 0
                    .CharacterUnitFirstLineIndent = 0 '取消首行缩进
                    .FirstLineIndent = CentimetersToPoints(0) '取消首行缩进
                    .LineSpacingRule = wdLineSpaceSingle 'wdLineSpaceSingle '单倍行距  wdLineSpaceExactly '行距固定值
                    ''.LineSpacing = 18 '设置行间距为18磅，配合行距固定值
                    '.Alignment = wdAlignParagraphCenter '单元格水平居中
                    .AutoAdjustRightIndent = False  '自动调整所选段落的右缩进
                    .DisableLineHeightGrid = True   '选定段落中的字符与行网格对齐
                End With
                .Cells.VerticalAlignment = wdCellAlignVerticalCenter  '单元格垂直居中
            End With
            For Each cl In .Range.Cells    '文字靠左，数字靠右
                Acell = ActiveDocument.Range(cl.Range.Start, cl.Range.End - 1).Text '提取文本
                If IsNumeric(Acell) Then
                    cl.Range.ParagraphFormat.Alignment = wdAlignParagraphRight    '右对齐
                Else
                    cl.Range.ParagraphFormat.Alignment = wdAlignParagraphJustify   '左对齐
                    If Acell = "合计" Or Acell = "总计" Or Acell = "总 计" Or Acell = "合 计" Then
                        cl.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter    '水平居中
                        If cl.ColumnIndex = .Columns.Count Then
                            .Columns(cl.ColumnIndex).Select
                            Selection.Font.Bold = True
                        Else
                            cl.Row.Range.Font.Bold = True
                        End If
                    ElseIf Acell = "序号" Or Acell = "序 号" Then
                        .Columns(cl.ColumnIndex).Select
                        Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter    '水平居中
                    End If
                End If
            Next
            '设置首行格式
            .Rows(1).Select ' 选中第一个单元格
            With Selection
                .Rows.HeadingFormat = wdToggle '自动标题行重复
                .ParagraphFormat.Alignment = wdAlignParagraphCenter   '水平居中
                .Range.Font.Bold = True '表头加粗黑体
                .Shading.ForegroundPatternColor = wdColorAutomatic '首行自动颜色
                .Shading.BackgroundPatternColor = -603923969 '首行底纹填充
                '.Borders(wdBorderBottom).LineStyle = xlContinuous
                '.Borders(wdBorderBottom).LineWidth = wdLineWidth50pt
            End With
            '自动调整表格
            .Columns.PreferredWidthType = wdPreferredWidthAuto
            .AutoFitBehavior (wdAutoFitContent) '根据内容调整表格
            .AutoFitBehavior (wdAutoFitWindow) '根据窗口调整表格
        End With
    Next
    '---------------------------------------------------------------------------------------
    ERR.Clear: On Error GoTo 0 '恢复错误捕捉
    Application.DisplayAlerts = True  '开启提示
    Application.ScreenUpdating = True   '开启屏幕刷新
End Sub
Sub 多表处理_表格选中(control As IRibbonControl) '
    Dim tempTable As Table
    'Application.ScreenUpdating = False
    '判断文档是否被保护
    If ActiveDocument.ProtectionType = wdAllowOnlyFormFields Then
        MsgBox "文档已保护，此时不能选中多个表格！"
        Exit Sub
    End If
    '删除所有可编辑的区域
    ActiveDocument.DeleteAllEditableRanges wdEditorEveryone
    '添加可编辑区域
    For Each tempTable In ActiveDocument.Tables
        tempTable.Range.Editors.Add wdEditorEveryone
    Next
    '选中所有可编辑区域
    ActiveDocument.SelectAllEditableRanges wdEditorEveryone
    '删除所有可编辑的区域
    ActiveDocument.DeleteAllEditableRanges wdEditorEveryone
    'Application.ScreenUpdating = True
    MsgBox "完成"
End Sub

''
' VBA-JSON v2.3.1
' (c) Tim Hall - https://github.com/VBA-tools/VBA-JSON
'
' JSON Converter for VBA
'
' Errors:
' 10001 - JSON parse error
'
' @class JsonConverter
' @author tim.hall.engr@gmail.com
' @license MIT (http://www.opensource.org/licenses/mit-license.php)
'' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ '
'
' Based originally on vba-json (with extensive changes)
' BSD license included below
'
' JSONLib, http://code.google.com/p/vba-json/
'
' Copyright (c) 2013, Ryo Yokoyama
' All rights reserved.
'
' Redistribution and use in source and binary forms, with or without
' modification, are permitted provided that the following conditions are met:
'     * Redistributions of source code must retain the above copyright
'       notice, this list of conditions and the following disclaimer.
'     * Redistributions in binary form must reproduce the above copyright
'       notice, this list of conditions and the following disclaimer in the
'       documentation and/or other materials provided with the distribution.
'     * Neither the name of the <organization> nor the
'       names of its contributors may be used to endorse or promote products
'       derived from this software without specific prior written permission.
'
' THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
' ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
' WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
' DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT HOLDER> BE LIABLE FOR ANY
' DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
' (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
' LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
' ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
' (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
' SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ '
Option Explicit

' === VBA-UTC Headers
#If Mac Then
    
    #If VBA7 Then
        
        ' 64-bit Mac (2016)
        Private Declare PtrSafe Function utc_popen Lib "/usr/lib/libc.dylib" Alias "popen" _
            (ByVal utc_Command As String, ByVal utc_Mode As String) As LongPtr
        Private Declare PtrSafe Function utc_pclose Lib "/usr/lib/libc.dylib" Alias "pclose" _
            (ByVal utc_File As LongPtr) As LongPtr
        Private Declare PtrSafe Function utc_fread Lib "/usr/lib/libc.dylib" Alias "fread" _
            (ByVal utc_Buffer As String, ByVal utc_Size As LongPtr, ByVal utc_Number As LongPtr, ByVal utc_File As LongPtr) As LongPtr
        Private Declare PtrSafe Function utc_feof Lib "/usr/lib/libc.dylib" Alias "feof" _
            (ByVal utc_File As LongPtr) As LongPtr
        
    #Else
        
        ' 32-bit Mac
        Private Declare Function utc_popen Lib "libc.dylib" Alias "popen" _
            (ByVal utc_Command As String, ByVal utc_Mode As String) As Long
        Private Declare Function utc_pclose Lib "libc.dylib" Alias "pclose" _
            (ByVal utc_File As Long) As Long
        Private Declare Function utc_fread Lib "libc.dylib" Alias "fread" _
            (ByVal utc_Buffer As String, ByVal utc_Size As Long, ByVal utc_Number As Long, ByVal utc_File As Long) As Long
        Private Declare Function utc_feof Lib "libc.dylib" Alias "feof" _
            (ByVal utc_File As Long) As Long
        
    #End If
    
    #ElseIf VBA7 Then
        
        ' http://msdn.microsoft.com/en-us/library/windows/desktop/ms724421.aspx
        ' http://msdn.microsoft.com/en-us/library/windows/desktop/ms724949.aspx
        ' http://msdn.microsoft.com/en-us/library/windows/desktop/ms725485.aspx
        Private Declare PtrSafe Function utc_GetTimeZoneInformation Lib "kernel32" Alias "GetTimeZoneInformation" _
            (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION) As Long
        Private Declare PtrSafe Function utc_SystemTimeToTzSpecificLocalTime Lib "kernel32" Alias "SystemTimeToTzSpecificLocalTime" _
            (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpUniversalTime As utc_SYSTEMTIME, utc_lpLocalTime As utc_SYSTEMTIME) As Long
        Private Declare PtrSafe Function utc_TzSpecificLocalTimeToSystemTime Lib "kernel32" Alias "TzSpecificLocalTimeToSystemTime" _
            (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpLocalTime As utc_SYSTEMTIME, utc_lpUniversalTime As utc_SYSTEMTIME) As Long
        
    #Else
        
        Private Declare Function utc_GetTimeZoneInformation Lib "kernel32" Alias "GetTimeZoneInformation" _
            (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION) As Long
        Private Declare Function utc_SystemTimeToTzSpecificLocalTime Lib "kernel32" Alias "SystemTimeToTzSpecificLocalTime" _
            (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpUniversalTime As utc_SYSTEMTIME, utc_lpLocalTime As utc_SYSTEMTIME) As Long
        Private Declare Function utc_TzSpecificLocalTimeToSystemTime Lib "kernel32" Alias "TzSpecificLocalTimeToSystemTime" _
            (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpLocalTime As utc_SYSTEMTIME, utc_lpUniversalTime As utc_SYSTEMTIME) As Long
        
    #End If
    
    #If Mac Then
        
        #If VBA7 Then
            Private Type utc_ShellResult
                utc_Output As String
                utc_ExitCode As LongPtr
            End Type
            
        #Else
            
            Private Type utc_ShellResult
                utc_Output As String
                utc_ExitCode As Long
            End Type
            
        #End If
        
    #Else
        
        Private Type utc_SYSTEMTIME
            utc_wYear As Integer
            utc_wMonth As Integer
            utc_wDayOfWeek As Integer
            utc_wDay As Integer
            utc_wHour As Integer
            utc_wMinute As Integer
            utc_wSecond As Integer
            utc_wMilliseconds As Integer
        End Type
        
        Private Type utc_TIME_ZONE_INFORMATION
            utc_Bias As Long
            utc_StandardName(0 To 31) As Integer
            utc_StandardDate As utc_SYSTEMTIME
            utc_StandardBias As Long
            utc_DaylightName(0 To 31) As Integer
            utc_DaylightDate As utc_SYSTEMTIME
            utc_DaylightBias As Long
        End Type
        
    #End If
    ' === End VBA-UTC
    
    Private Type json_Options
        ' VBA only stores 15 significant digits, so any numbers larger than that are truncated
        ' This can lead to issues when BIGINT's are used (e.g. for Ids or Credit Cards), as they will be invalid above 15 digits
        ' See: http://support.microsoft.com/kb/269370
        '
        ' By default, VBA-JSON will use String for numbers longer than 15 characters that contain only digits
        ' to override set `JsonConverter.JsonOptions.UseDoubleForLargeNumbers = True`
        UseDoubleForLargeNumbers As Boolean
        
        ' The JSON standard requires object keys to be quoted (" or '), use this option to allow unquoted keys
        AllowUnquotedKeys As Boolean
        
        ' The solidus (/) is not required to be escaped, use this option to escape them as \/ in ConvertToJson
        EscapeSolidus As Boolean
    End Type
    Public JsonOptions As json_Options
    
    ' ============================================= '
    ' Public Methods
    ' ============================================= '
    
    ''
    ' Convert JSON string to object (Dictionary/Collection)
    '
    ' @method ParseJson
    ' @param {String} json_String
    ' @return {Object} (Dictionary or Collection)
    ' @throws 10001 - JSON parse error
    ''
    Public Function ParseJson(ByVal JsonString As String) As Object
        Dim json_Index As Long
        json_Index = 1
        
        ' Remove vbCr, vbLf, and vbTab from json_String
        JsonString = VBA.Replace(VBA.Replace(VBA.Replace(JsonString, VBA.vbCr, ""), VBA.vbLf, ""), VBA.vbTab, "")
        
        json_SkipSpaces JsonString, json_Index
        Select Case VBA.Mid$(JsonString, json_Index, 1)
            Case "{"
                Set ParseJson = json_ParseObject(JsonString, json_Index)
            Case "["
                Set ParseJson = json_ParseArray(JsonString, json_Index)
            Case Else
                ' Error: Invalid JSON string
                ERR.Raise 10001, "JSONConverter", json_ParseErrorMessage(JsonString, json_Index, "Expecting '{' or '['")
        End Select
    End Function
    
    ''
    ' Convert object (Dictionary/Collection/Array) to JSON
    '
    ' @method ConvertToJson
    ' @param {Variant} JsonValue (Dictionary, Collection, or Array)
    ' @param {Integer|String} Whitespace "Pretty" print json with given number of spaces per indentation (Integer) or given string
    ' @return {String}
    ''
    Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitespace As Variant, Optional ByVal json_CurrentIndentation As Long = 0) As String
        Dim json_Buffer As String
        Dim json_BufferPosition As Long
        Dim json_BufferLength As Long
        Dim json_Index As Long
        Dim json_LBound As Long
        Dim json_UBound As Long
        Dim json_IsFirstItem As Boolean
        Dim json_Index2D As Long
        Dim json_LBound2D As Long
        Dim json_UBound2D As Long
        Dim json_IsFirstItem2D As Boolean
        Dim json_Key As Variant
        Dim json_Value As Variant
        Dim json_DateStr As String
        Dim json_Converted As String
        Dim json_SkipItem As Boolean
        Dim json_PrettyPrint As Boolean
        Dim json_Indentation As String
        Dim json_InnerIndentation As String
        
        json_LBound = -1
        json_UBound = -1
        json_IsFirstItem = True
        json_LBound2D = -1
        json_UBound2D = -1
        json_IsFirstItem2D = True
        json_PrettyPrint = Not IsMissing(Whitespace)
        
        Select Case VBA.VarType(JsonValue)
            Case VBA.vbNull
                ConvertToJson = "null"
            Case VBA.vbDate
                ' Date
                json_DateStr = ConvertToIso(VBA.CDate(JsonValue))
                
                ConvertToJson = """" & json_DateStr & """"
            Case VBA.vbString
                ' String (or large number encoded as string)
                If Not JsonOptions.UseDoubleForLargeNumbers And json_StringIsLargeNumber(JsonValue) Then
                    ConvertToJson = JsonValue
                Else
                    ConvertToJson = """" & json_Encode(JsonValue) & """"
                End If
            Case VBA.vbBoolean
                If JsonValue Then
                    ConvertToJson = "true"
                Else
                    ConvertToJson = "false"
                End If
            Case VBA.vbArray To VBA.vbArray + VBA.vbByte
                If json_PrettyPrint Then
                    If VBA.VarType(Whitespace) = VBA.vbString Then
                        json_Indentation = VBA.String$(json_CurrentIndentation + 1, Whitespace)
                        json_InnerIndentation = VBA.String$(json_CurrentIndentation + 2, Whitespace)
                    Else
                        json_Indentation = VBA.Space$((json_CurrentIndentation + 1) * Whitespace)
                        json_InnerIndentation = VBA.Space$((json_CurrentIndentation + 2) * Whitespace)
                    End If
                End If
                
                ' Array
                json_BufferAppend json_Buffer, "[", json_BufferPosition, json_BufferLength
                
                On Error Resume Next
                
                json_LBound = LBound(JsonValue, 1)
                json_UBound = UBound(JsonValue, 1)
                json_LBound2D = LBound(JsonValue, 2)
                json_UBound2D = UBound(JsonValue, 2)
                
                If json_LBound >= 0 And json_UBound >= 0 Then
                    For json_Index = json_LBound To json_UBound
                        If json_IsFirstItem Then
                            json_IsFirstItem = False
                        Else
                            ' Append comma to previous line
                            json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength
                        End If
                        
                        If json_LBound2D >= 0 And json_UBound2D >= 0 Then
                            ' 2D Array
                            If json_PrettyPrint Then
                                json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength
                            End If
                            json_BufferAppend json_Buffer, json_Indentation & "[", json_BufferPosition, json_BufferLength
                            
                            For json_Index2D = json_LBound2D To json_UBound2D
                                If json_IsFirstItem2D Then
                                    json_IsFirstItem2D = False
                                Else
                                    json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength
                                End If
                                
                                json_Converted = ConvertToJson(JsonValue(json_Index, json_Index2D), Whitespace, json_CurrentIndentation + 2)
                                
                                ' For Arrays/Collections, undefined (Empty/Nothing) is treated as null
                                If json_Converted = "" Then
                                    ' (nest to only check if converted = "")
                                    If json_IsUndefined(JsonValue(json_Index, json_Index2D)) Then
                                        json_Converted = "null"
                                    End If
                                End If
                                
                                If json_PrettyPrint Then
                                    json_Converted = vbNewLine & json_InnerIndentation & json_Converted
                                End If
                                
                                json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength
                            Next json_Index2D
                            
                            If json_PrettyPrint Then
                                json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength
                            End If
                            
                            json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength
                            json_IsFirstItem2D = True
                        Else
                            ' 1D Array
                            json_Converted = ConvertToJson(JsonValue(json_Index), Whitespace, json_CurrentIndentation + 1)
                            
                            ' For Arrays/Collections, undefined (Empty/Nothing) is treated as null
                            If json_Converted = "" Then
                                ' (nest to only check if converted = "")
                                If json_IsUndefined(JsonValue(json_Index)) Then
                                    json_Converted = "null"
                                End If
                            End If
                            
                            If json_PrettyPrint Then
                                json_Converted = vbNewLine & json_Indentation & json_Converted
                            End If
                            
                            json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength
                        End If
                    Next json_Index
                End If
                
                On Error GoTo 0
                
                If json_PrettyPrint Then
                    json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength
                    
                    If VBA.VarType(Whitespace) = VBA.vbString Then
                        json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace)
                    Else
                        json_Indentation = VBA.Space$(json_CurrentIndentation * Whitespace)
                    End If
                End If
                
                json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength
                
                ConvertToJson = json_BufferToString(json_Buffer, json_BufferPosition)
                
                ' Dictionary or Collection
            Case VBA.vbObject
                If json_PrettyPrint Then
                    If VBA.VarType(Whitespace) = VBA.vbString Then
                        json_Indentation = VBA.String$(json_CurrentIndentation + 1, Whitespace)
                    Else
                        json_Indentation = VBA.Space$((json_CurrentIndentation + 1) * Whitespace)
                    End If
                End If
                
                ' Dictionary
                If VBA.TypeName(JsonValue) = "Dictionary" Then
                    json_BufferAppend json_Buffer, "{", json_BufferPosition, json_BufferLength
                    For Each json_Key In JsonValue.Keys
                        ' For Objects, undefined (Empty/Nothing) is not added to object
                        json_Converted = ConvertToJson(JsonValue(json_Key), Whitespace, json_CurrentIndentation + 1)
                        If json_Converted = "" Then
                            json_SkipItem = json_IsUndefined(JsonValue(json_Key))
                        Else
                            json_SkipItem = False
                        End If
                        
                        If Not json_SkipItem Then
                            If json_IsFirstItem Then
                                json_IsFirstItem = False
                            Else
                                json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength
                            End If
                            
                            If json_PrettyPrint Then
                                json_Converted = vbNewLine & json_Indentation & """" & json_Key & """: " & json_Converted
                            Else
                                json_Converted = """" & json_Key & """:" & json_Converted
                            End If
                            
                            json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength
                        End If
                    Next json_Key
                    
                    If json_PrettyPrint Then
                        json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength
                        
                        If VBA.VarType(Whitespace) = VBA.vbString Then
                            json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace)
                        Else
                            json_Indentation = VBA.Space$(json_CurrentIndentation * Whitespace)
                        End If
                    End If
                    
                    json_BufferAppend json_Buffer, json_Indentation & "}", json_BufferPosition, json_BufferLength
                    
                    ' Collection
                ElseIf VBA.TypeName(JsonValue) = "Collection" Then
                    json_BufferAppend json_Buffer, "[", json_BufferPosition, json_BufferLength
                    For Each json_Value In JsonValue
                        If json_IsFirstItem Then
                            json_IsFirstItem = False
                        Else
                            json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength
                        End If
                        
                        json_Converted = ConvertToJson(json_Value, Whitespace, json_CurrentIndentation + 1)
                        
                        ' For Arrays/Collections, undefined (Empty/Nothing) is treated as null
                        If json_Converted = "" Then
                            ' (nest to only check if converted = "")
                            If json_IsUndefined(json_Value) Then
                                json_Converted = "null"
                            End If
                        End If
                        
                        If json_PrettyPrint Then
                            json_Converted = vbNewLine & json_Indentation & json_Converted
                        End If
                        
                        json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength
                    Next json_Value
                    
                    If json_PrettyPrint Then
                        json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength
                        
                        If VBA.VarType(Whitespace) = VBA.vbString Then
                            json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace)
                        Else
                            json_Indentation = VBA.Space$(json_CurrentIndentation * Whitespace)
                        End If
                    End If
                    
                    json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength
                End If
                
                ConvertToJson = json_BufferToString(json_Buffer, json_BufferPosition)
            Case VBA.vbInteger, VBA.vbLong, VBA.vbSingle, VBA.vbDouble, VBA.vbCurrency, VBA.vbDecimal
                ' Number (use decimals for numbers)
                ConvertToJson = VBA.Replace(JsonValue, ",", ".")
            Case Else
                ' vbEmpty, vbError, vbDataObject, vbByte, vbUserDefinedType
                ' Use VBA's built-in to-string
                On Error Resume Next
                ConvertToJson = JsonValue
                On Error GoTo 0
        End Select
    End Function
    
    ' ============================================= '
    ' Private Functions
    ' ============================================= '
    
    Private Function json_ParseObject(json_String As String, ByRef json_Index As Long) As Dictionary
        Dim json_Key As String
        Dim json_NextChar As String
        
        Set json_ParseObject = New Dictionary
        json_SkipSpaces json_String, json_Index
        If VBA.Mid$(json_String, json_Index, 1) <> "{" Then
            ERR.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting '{'")
        Else
            json_Index = json_Index + 1
            
            Do
                json_SkipSpaces json_String, json_Index
                If VBA.Mid$(json_String, json_Index, 1) = "}" Then
                    json_Index = json_Index + 1
                    Exit Function
                ElseIf VBA.Mid$(json_String, json_Index, 1) = "," Then
                    json_Index = json_Index + 1
                    json_SkipSpaces json_String, json_Index
                End If
                
                json_Key = json_ParseKey(json_String, json_Index)
                json_NextChar = json_Peek(json_String, json_Index)
                If json_NextChar = "[" Or json_NextChar = "{" Then
                    Set json_ParseObject.Item(json_Key) = json_ParseValue(json_String, json_Index)
                Else
                    json_ParseObject.Item(json_Key) = json_ParseValue(json_String, json_Index)
                End If
            Loop
        End If
    End Function
    
    Private Function json_ParseArray(json_String As String, ByRef json_Index As Long) As Collection
        Set json_ParseArray = New Collection
        
        json_SkipSpaces json_String, json_Index
        If VBA.Mid$(json_String, json_Index, 1) <> "[" Then
            ERR.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting '['")
        Else
            json_Index = json_Index + 1
            
            Do
                json_SkipSpaces json_String, json_Index
                If VBA.Mid$(json_String, json_Index, 1) = "]" Then
                    json_Index = json_Index + 1
                    Exit Function
                ElseIf VBA.Mid$(json_String, json_Index, 1) = "," Then
                    json_Index = json_Index + 1
                    json_SkipSpaces json_String, json_Index
                End If
                
                json_ParseArray.Add json_ParseValue(json_String, json_Index)
            Loop
        End If
    End Function
    
    Private Function json_ParseValue(json_String As String, ByRef json_Index As Long) As Variant
        json_SkipSpaces json_String, json_Index
        Select Case VBA.Mid$(json_String, json_Index, 1)
            Case "{"
                Set json_ParseValue = json_ParseObject(json_String, json_Index)
            Case "["
                Set json_ParseValue = json_ParseArray(json_String, json_Index)
            Case """", "'"
                json_ParseValue = json_ParseString(json_String, json_Index)
            Case Else
                If VBA.Mid$(json_String, json_Index, 4) = "true" Then
                    json_ParseValue = True
                    json_Index = json_Index + 4
                ElseIf VBA.Mid$(json_String, json_Index, 5) = "false" Then
                    json_ParseValue = False
                    json_Index = json_Index + 5
                ElseIf VBA.Mid$(json_String, json_Index, 4) = "null" Then
                    json_ParseValue = Null
                    json_Index = json_Index + 4
                ElseIf VBA.InStr("+-0123456789", VBA.Mid$(json_String, json_Index, 1)) Then
                    json_ParseValue = json_ParseNumber(json_String, json_Index)
                Else
                    ERR.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting 'STRING', 'NUMBER', null, true, false, '{', or '['")
                End If
        End Select
    End Function
    
    Private Function json_ParseString(json_String As String, ByRef json_Index As Long) As String
        Dim json_Quote As String
        Dim json_Char As String
        Dim json_Code As String
        Dim json_Buffer As String
        Dim json_BufferPosition As Long
        Dim json_BufferLength As Long
        
        json_SkipSpaces json_String, json_Index
        
        ' Store opening quote to look for matching closing quote
        json_Quote = VBA.Mid$(json_String, json_Index, 1)
        json_Index = json_Index + 1
        
        Do While json_Index > 0 And json_Index <= Len(json_String)
            json_Char = VBA.Mid$(json_String, json_Index, 1)
            
            Select Case json_Char
                Case "\"
                    ' Escaped string, \\, or \/
                    json_Index = json_Index + 1
                    json_Char = VBA.Mid$(json_String, json_Index, 1)
                    
                    Select Case json_Char
                        Case """", "\", "/", "'"
                            json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength
                            json_Index = json_Index + 1
                        Case "b"
                            json_BufferAppend json_Buffer, vbBack, json_BufferPosition, json_BufferLength
                            json_Index = json_Index + 1
                        Case "f"
                            json_BufferAppend json_Buffer, vbFormFeed, json_BufferPosition, json_BufferLength
                            json_Index = json_Index + 1
                        Case "n"
                            json_BufferAppend json_Buffer, vbCrLf, json_BufferPosition, json_BufferLength
                            json_Index = json_Index + 1
                        Case "r"
                            json_BufferAppend json_Buffer, vbCr, json_BufferPosition, json_BufferLength
                            json_Index = json_Index + 1
                        Case "t"
                            json_BufferAppend json_Buffer, vbTab, json_BufferPosition, json_BufferLength
                            json_Index = json_Index + 1
                        Case "u"
                            ' Unicode character escape (e.g. \u00a9 = Copyright)
                            json_Index = json_Index + 1
                            json_Code = VBA.Mid$(json_String, json_Index, 4)
                            json_BufferAppend json_Buffer, VBA.ChrW(VBA.Val("&h" + json_Code)), json_BufferPosition, json_BufferLength
                            json_Index = json_Index + 4
                    End Select
                Case json_Quote
                    json_ParseString = json_BufferToString(json_Buffer, json_BufferPosition)
                    json_Index = json_Index + 1
                    Exit Function
                Case Else
                    json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength
                    json_Index = json_Index + 1
            End Select
        Loop
    End Function
    
    Private Function json_ParseNumber(json_String As String, ByRef json_Index As Long) As Variant
        Dim json_Char As String
        Dim json_Value As String
        Dim json_IsLargeNumber As Boolean
        
        json_SkipSpaces json_String, json_Index
        
        Do While json_Index > 0 And json_Index <= Len(json_String)
            json_Char = VBA.Mid$(json_String, json_Index, 1)
            
            If VBA.InStr("+-0123456789.eE", json_Char) Then
                ' Unlikely to have massive number, so use simple append rather than buffer here
                json_Value = json_Value & json_Char
                json_Index = json_Index + 1
            Else
                ' Excel only stores 15 significant digits, so any numbers larger than that are truncated
                ' This can lead to issues when BIGINT's are used (e.g. for Ids or Credit Cards), as they will be invalid above 15 digits
                ' See: http://support.microsoft.com/kb/269370
                '
                ' Fix: Parse -> String, Convert -> String longer than 15/16 characters containing only numbers and decimal points -> Number
                ' (decimal doesn't factor into significant digit count, so if present check for 15 digits + decimal = 16)
                json_IsLargeNumber = IIf(InStr(json_Value, "."), Len(json_Value) >= 17, Len(json_Value) >= 16)
                If Not JsonOptions.UseDoubleForLargeNumbers And json_IsLargeNumber Then
                    json_ParseNumber = json_Value
                Else
                    ' VBA.Val does not use regional settings, so guard for comma is not needed
                    json_ParseNumber = VBA.Val(json_Value)
                End If
                Exit Function
            End If
        Loop
    End Function
    
    Private Function json_ParseKey(json_String As String, ByRef json_Index As Long) As String
        ' Parse key with single or double quotes
        If VBA.Mid$(json_String, json_Index, 1) = """" Or VBA.Mid$(json_String, json_Index, 1) = "'" Then
            json_ParseKey = json_ParseString(json_String, json_Index)
        ElseIf JsonOptions.AllowUnquotedKeys Then
            Dim json_Char As String
            Do While json_Index > 0 And json_Index <= Len(json_String)
                json_Char = VBA.Mid$(json_String, json_Index, 1)
                If (json_Char <> " ") And (json_Char <> ":") Then
                    json_ParseKey = json_ParseKey & json_Char
                    json_Index = json_Index + 1
                Else
                    Exit Do
                End If
            Loop
        Else
            ERR.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting '""' or '''")
        End If
        
        ' Check for colon and skip if present or throw if not present
        json_SkipSpaces json_String, json_Index
        If VBA.Mid$(json_String, json_Index, 1) <> ":" Then
            ERR.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting ':'")
        Else
            json_Index = json_Index + 1
        End If
    End Function
    
    Private Function json_IsUndefined(ByVal json_Value As Variant) As Boolean
        ' Empty / Nothing -> undefined
        Select Case VBA.VarType(json_Value)
            Case VBA.vbEmpty
                json_IsUndefined = True
            Case VBA.vbObject
                Select Case VBA.TypeName(json_Value)
                    Case "Empty", "Nothing"
                        json_IsUndefined = True
                End Select
        End Select
    End Function
    
    Private Function json_Encode(ByVal json_Text As Variant) As String
        ' Reference: http://www.ietf.org/rfc/rfc4627.txt
        ' Escape: ", \, /, backspace, form feed, line feed, carriage return, tab
        Dim json_Index As Long
        Dim json_Char As String
        Dim json_AscCode As Long
        Dim json_Buffer As String
        Dim json_BufferPosition As Long
        Dim json_BufferLength As Long
        
        For json_Index = 1 To VBA.Len(json_Text)
            json_Char = VBA.Mid$(json_Text, json_Index, 1)
            json_AscCode = VBA.AscW(json_Char)
            
            ' When AscW returns a negative number, it returns the twos complement form of that number.
            ' To convert the twos complement notation into normal binary notation, add 0xFFF to the return result.
            ' https://support.microsoft.com/en-us/kb/272138
            If json_AscCode < 0 Then
                json_AscCode = json_AscCode + 65536
            End If
            
            ' From spec, ", \, and control characters must be escaped (solidus is optional)
            
            Select Case json_AscCode
                Case 34
                    ' " -> 34 -> \"
                    json_Char = "\"""
                Case 92
                    ' \ -> 92 -> \\
                    json_Char = "\\"
                Case 47
                    ' / -> 47 -> \/ (optional)
                    If JsonOptions.EscapeSolidus Then
                        json_Char = "\/"
                    End If
                Case 8
                    ' backspace -> 8 -> \b
                    json_Char = "\b"
                Case 12
                    ' form feed -> 12 -> \f
                    json_Char = "\f"
                Case 10
                    ' line feed -> 10 -> \n
                    json_Char = "\n"
                Case 13
                    ' carriage return -> 13 -> \r
                    json_Char = "\r"
                Case 9
                    ' tab -> 9 -> \t
                    json_Char = "\t"
                Case 0 To 31, 127 To 65535
                    ' Non-ascii characters -> convert to 4-digit hex
                    json_Char = "\u" & VBA.Right$("0000" & VBA.Hex$(json_AscCode), 4)
            End Select
            
            json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength
        Next json_Index
        
        json_Encode = json_BufferToString(json_Buffer, json_BufferPosition)
    End Function
    
    Private Function json_Peek(json_String As String, ByVal json_Index As Long, Optional json_NumberOfCharacters As Long = 1) As String
        ' "Peek" at the next number of characters without incrementing json_Index (ByVal instead of ByRef)
        json_SkipSpaces json_String, json_Index
        json_Peek = VBA.Mid$(json_String, json_Index, json_NumberOfCharacters)
    End Function
    
    Private Sub json_SkipSpaces(json_String As String, ByRef json_Index As Long)
        ' Increment index to skip over spaces
        Do While json_Index > 0 And json_Index <= VBA.Len(json_String) And VBA.Mid$(json_String, json_Index, 1) = " "
            json_Index = json_Index + 1
        Loop
    End Sub
    
    Private Function json_StringIsLargeNumber(json_String As Variant) As Boolean
        ' Check if the given string is considered a "large number"
        ' (See json_ParseNumber)
        
        Dim json_Length As Long
        Dim json_CharIndex As Long
        json_Length = VBA.Len(json_String)
        
        ' Length with be at least 16 characters and assume will be less than 100 characters
        If json_Length >= 16 And json_Length <= 100 Then
            Dim json_CharCode As String
            
            json_StringIsLargeNumber = True
            
            For json_CharIndex = 1 To json_Length
                json_CharCode = VBA.Asc(VBA.Mid$(json_String, json_CharIndex, 1))
                Select Case json_CharCode
                    ' Look for .|0-9|E|e
                    Case 46, 48 To 57, 69, 101
                        ' Continue through characters
                    Case Else
                        json_StringIsLargeNumber = False
                        Exit Function
                End Select
            Next json_CharIndex
        End If
    End Function
    
    Private Function json_ParseErrorMessage(json_String As String, ByRef json_Index As Long, ErrorMessage As String)
        ' Provide detailed parse error message, including details of where and what occurred
        '
        ' Example:
        ' Error parsing JSON:
        ' {"abcde":True}
        '          ^
        ' Expecting 'STRING', 'NUMBER', null, true, false, '{', or '['
        
        Dim json_StartIndex As Long
        Dim json_StopIndex As Long
        
        ' Include 10 characters before and after error (if possible)
        json_StartIndex = json_Index - 10
        json_StopIndex = json_Index + 10
        If json_StartIndex <= 0 Then
            json_StartIndex = 1
        End If
        If json_StopIndex > VBA.Len(json_String) Then
            json_StopIndex = VBA.Len(json_String)
        End If
        
        json_ParseErrorMessage = "Error parsing JSON:" & VBA.vbNewLine & _
            VBA.Mid$(json_String, json_StartIndex, json_StopIndex - json_StartIndex + 1) & VBA.vbNewLine & _
            VBA.Space$(json_Index - json_StartIndex) & "^" & VBA.vbNewLine & _
            ErrorMessage
    End Function
    
    Private Sub json_BufferAppend(ByRef json_Buffer As String, _
            ByRef json_Append As Variant, _
            ByRef json_BufferPosition As Long, _
            ByRef json_BufferLength As Long)
        ' VBA can be slow to append strings due to allocating a new string for each append
        ' Instead of using the traditional append, allocate a large empty string and then copy string at append position
        '
        ' Example:
        ' Buffer: "abc  "
        ' Append: "def"
        ' Buffer Position: 3
        ' Buffer Length: 5
        '
        ' Buffer position + Append length > Buffer length -> Append chunk of blank space to buffer
        ' Buffer: "abc       "
        ' Buffer Length: 10
        '
        ' Put "def" into buffer at position 3 (0-based)
        ' Buffer: "abcdef    "
        '
        ' Approach based on cStringBuilder from vbAccelerator
        ' http://www.vbaccelerator.com/home/VB/Code/Techniques/RunTime_Debug_Tracing/VB6_Tracer_Utility_zip_cStringBuilder_cls.asp
        '
        ' and clsStringAppend from Philip Swannell
        ' https://github.com/VBA-tools/VBA-JSON/pull/82
        
        Dim json_AppendLength As Long
        Dim json_LengthPlusPosition As Long
        
        json_AppendLength = VBA.Len(json_Append)
        json_LengthPlusPosition = json_AppendLength + json_BufferPosition
        
        If json_LengthPlusPosition > json_BufferLength Then
            ' Appending would overflow buffer, add chunk
            ' (double buffer length or append length, whichever is bigger)
            Dim json_AddedLength As Long
            json_AddedLength = IIf(json_AppendLength > json_BufferLength, json_AppendLength, json_BufferLength)
            
            json_Buffer = json_Buffer & VBA.Space$(json_AddedLength)
            json_BufferLength = json_BufferLength + json_AddedLength
        End If
        
        ' Note: Namespacing with VBA.Mid$ doesn't work properly here, throwing compile error:
        ' Function call on left-hand side of assignment must return Variant or Object
        Mid$(json_Buffer, json_BufferPosition + 1, json_AppendLength) = CStr(json_Append)
        json_BufferPosition = json_BufferPosition + json_AppendLength
    End Sub
    
    Private Function json_BufferToString(ByRef json_Buffer As String, ByVal json_BufferPosition As Long) As String
        If json_BufferPosition > 0 Then
            json_BufferToString = VBA.Left$(json_Buffer, json_BufferPosition)
        End If
    End Function
    
    ''
    ' VBA-UTC v1.0.6
    ' (c) Tim Hall - https://github.com/VBA-tools/VBA-UtcConverter
    '
    ' UTC/ISO 8601 Converter for VBA
    '
    ' Errors:
    ' 10011 - UTC parsing error
    ' 10012 - UTC conversion error
    ' 10013 - ISO 8601 parsing error
    ' 10014 - ISO 8601 conversion error
    '
    ' @module UtcConverter
    ' @author tim.hall.engr@gmail.com
    ' @license MIT (http://www.opensource.org/licenses/mit-license.php)
    '' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ '
    
    ' (Declarations moved to top)
    
    ' ============================================= '
    ' Public Methods
    ' ============================================= '
    
    ''
    ' Parse UTC date to local date
    '
    ' @method ParseUtc
    ' @param {Date} UtcDate
    ' @return {Date} Local date
    ' @throws 10011 - UTC parsing error
    ''
    Public Function ParseUtc(utc_UtcDate As Date) As Date
        On Error GoTo utc_ErrorHandling
        
        #If Mac Then
            ParseUtc = utc_ConvertDate(utc_UtcDate)
        #Else
            Dim utc_TimeZoneInfo As utc_TIME_ZONE_INFORMATION
            Dim utc_LocalDate As utc_SYSTEMTIME
            
            utc_GetTimeZoneInformation utc_TimeZoneInfo
            utc_SystemTimeToTzSpecificLocalTime utc_TimeZoneInfo, utc_DateToSystemTime(utc_UtcDate), utc_LocalDate
            
            ParseUtc = utc_SystemTimeToDate(utc_LocalDate)
        #End If
        
        Exit Function
        
utc_ErrorHandling:
        ERR.Raise 10011, "UtcConverter.ParseUtc", "UTC parsing error: " & ERR.Number & " - " & ERR.Description
    End Function
    
    ''
    ' Convert local date to UTC date
    '
    ' @method ConvertToUrc
    ' @param {Date} utc_LocalDate
    ' @return {Date} UTC date
    ' @throws 10012 - UTC conversion error
    ''
    Public Function ConvertToUtc(utc_LocalDate As Date) As Date
        On Error GoTo utc_ErrorHandling
        
        #If Mac Then
            ConvertToUtc = utc_ConvertDate(utc_LocalDate, utc_ConvertToUtc:=True)
        #Else
            Dim utc_TimeZoneInfo As utc_TIME_ZONE_INFORMATION
            Dim utc_UtcDate As utc_SYSTEMTIME
            
            utc_GetTimeZoneInformation utc_TimeZoneInfo
            utc_TzSpecificLocalTimeToSystemTime utc_TimeZoneInfo, utc_DateToSystemTime(utc_LocalDate), utc_UtcDate
            
            ConvertToUtc = utc_SystemTimeToDate(utc_UtcDate)
        #End If
        
        Exit Function
        
utc_ErrorHandling:
        ERR.Raise 10012, "UtcConverter.ConvertToUtc", "UTC conversion error: " & ERR.Number & " - " & ERR.Description
    End Function
    
    ''
    ' Parse ISO 8601 date string to local date
    '
    ' @method ParseIso
    ' @param {Date} utc_IsoString
    ' @return {Date} Local date
    ' @throws 10013 - ISO 8601 parsing error
    ''
    Public Function ParseIso(utc_IsoString As String) As Date
        On Error GoTo utc_ErrorHandling
        
        Dim utc_Parts() As String
        Dim utc_DateParts() As String
        Dim utc_TimeParts() As String
        Dim utc_OffsetIndex As Long
        Dim utc_HasOffset As Boolean
        Dim utc_NegativeOffset As Boolean
        Dim utc_OffsetParts() As String
        Dim utc_Offset As Date
        
        utc_Parts = VBA.Split(utc_IsoString, "T")
        utc_DateParts = VBA.Split(utc_Parts(0), "-")
        ParseIso = VBA.DateSerial(VBA.CInt(utc_DateParts(0)), VBA.CInt(utc_DateParts(1)), VBA.CInt(utc_DateParts(2)))
        
        If UBound(utc_Parts) > 0 Then
            If VBA.InStr(utc_Parts(1), "Z") Then
                utc_TimeParts = VBA.Split(VBA.Replace(utc_Parts(1), "Z", ""), ":")
            Else
                utc_OffsetIndex = VBA.InStr(1, utc_Parts(1), "+")
                If utc_OffsetIndex = 0 Then
                    utc_NegativeOffset = True
                    utc_OffsetIndex = VBA.InStr(1, utc_Parts(1), "-")
                End If
                
                If utc_OffsetIndex > 0 Then
                    utc_HasOffset = True
                    utc_TimeParts = VBA.Split(VBA.Left$(utc_Parts(1), utc_OffsetIndex - 1), ":")
                    utc_OffsetParts = VBA.Split(VBA.Right$(utc_Parts(1), Len(utc_Parts(1)) - utc_OffsetIndex), ":")
                    
                    Select Case UBound(utc_OffsetParts)
                        Case 0
                            utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), 0, 0)
                        Case 1
                            utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), VBA.CInt(utc_OffsetParts(1)), 0)
                        Case 2
                            ' VBA.Val does not use regional settings, use for seconds to avoid decimal/comma issues
                            utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), VBA.CInt(utc_OffsetParts(1)), Int(VBA.Val(utc_OffsetParts(2))))
                    End Select
                    
                    If utc_NegativeOffset Then: utc_Offset = -utc_Offset
                Else
                    utc_TimeParts = VBA.Split(utc_Parts(1), ":")
                End If
            End If
            
            Select Case UBound(utc_TimeParts)
                Case 0
                    ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), 0, 0)
                Case 1
                    ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), VBA.CInt(utc_TimeParts(1)), 0)
                Case 2
                    ' VBA.Val does not use regional settings, use for seconds to avoid decimal/comma issues
                    ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), VBA.CInt(utc_TimeParts(1)), Int(VBA.Val(utc_TimeParts(2))))
            End Select
            
            ParseIso = ParseUtc(ParseIso)
            
            If utc_HasOffset Then
                ParseIso = ParseIso - utc_Offset
            End If
        End If
        
        Exit Function
        
utc_ErrorHandling:
        ERR.Raise 10013, "UtcConverter.ParseIso", "ISO 8601 parsing error for " & utc_IsoString & ": " & ERR.Number & " - " & ERR.Description
    End Function
    
    ''
    ' Convert local date to ISO 8601 string
    '
    ' @method ConvertToIso
    ' @param {Date} utc_LocalDate
    ' @return {Date} ISO 8601 string
    ' @throws 10014 - ISO 8601 conversion error
    ''
    Public Function ConvertToIso(utc_LocalDate As Date) As String
        On Error GoTo utc_ErrorHandling
        
        ConvertToIso = VBA.Format$(ConvertToUtc(utc_LocalDate), "yyyy-mm-ddTHH:mm:ss.000Z")
        
        Exit Function
        
utc_ErrorHandling:
        ERR.Raise 10014, "UtcConverter.ConvertToIso", "ISO 8601 conversion error: " & ERR.Number & " - " & ERR.Description
    End Function
    
    ' ============================================= '
    ' Private Functions
    ' ============================================= '
    
    #If Mac Then
        
        Private Function utc_ConvertDate(utc_Value As Date, Optional utc_ConvertToUtc As Boolean = False) As Date
            Dim utc_ShellCommand As String
            Dim utc_Result As utc_ShellResult
            Dim utc_Parts() As String
            Dim utc_DateParts() As String
            Dim utc_TimeParts() As String
            
            If utc_ConvertToUtc Then
                utc_ShellCommand = "date -ur `date -jf '%Y-%m-%d %H:%M:%S' " & _
                    "'" & VBA.Format$(utc_Value, "yyyy-mm-dd HH:mm:ss") & "' " & _
                    " +'%s'` +'%Y-%m-%d %H:%M:%S'"
            Else
                utc_ShellCommand = "date -jf '%Y-%m-%d %H:%M:%S %z' " & _
                    "'" & VBA.Format$(utc_Value, "yyyy-mm-dd HH:mm:ss") & " +0000' " & _
                    "+'%Y-%m-%d %H:%M:%S'"
            End If
            
            utc_Result = utc_ExecuteInShell(utc_ShellCommand)
            
            If utc_Result.utc_Output = "" Then
                ERR.Raise 10015, "UtcConverter.utc_ConvertDate", "'date' command failed"
            Else
                utc_Parts = Split(utc_Result.utc_Output, " ")
                utc_DateParts = Split(utc_Parts(0), "-")
                utc_TimeParts = Split(utc_Parts(1), ":")
                
                utc_ConvertDate = DateSerial(utc_DateParts(0), utc_DateParts(1), utc_DateParts(2)) + _
                    TimeSerial(utc_TimeParts(0), utc_TimeParts(1), utc_TimeParts(2))
            End If
        End Function
        
        Private Function utc_ExecuteInShell(utc_ShellCommand As String) As utc_ShellResult
            #If VBA7 Then
                Dim utc_File As LongPtr
                Dim utc_Read As LongPtr
            #Else
                Dim utc_File As Long
                Dim utc_Read As Long
            #End If
            
            Dim utc_Chunk As String
            
            On Error GoTo utc_ErrorHandling
            utc_File = utc_popen(utc_ShellCommand, "r")
            
            If utc_File = 0 Then: Exit Function
            
            Do While utc_feof(utc_File) = 0
                utc_Chunk = VBA.Space$(50)
                utc_Read = CLng(utc_fread(utc_Chunk, 1, Len(utc_Chunk) - 1, utc_File))
                If utc_Read > 0 Then
                    utc_Chunk = VBA.Left$(utc_Chunk, CLng(utc_Read))
                    utc_ExecuteInShell.utc_Output = utc_ExecuteInShell.utc_Output & utc_Chunk
                End If
            Loop
            
utc_ErrorHandling:
            utc_ExecuteInShell.utc_ExitCode = CLng(utc_pclose(utc_File))
        End Function
        
    #Else
        
        Private Function utc_DateToSystemTime(utc_Value As Date) As utc_SYSTEMTIME
            utc_DateToSystemTime.utc_wYear = VBA.year(utc_Value)
            utc_DateToSystemTime.utc_wMonth = VBA.month(utc_Value)
            utc_DateToSystemTime.utc_wDay = VBA.Day(utc_Value)
            utc_DateToSystemTime.utc_wHour = VBA.Hour(utc_Value)
            utc_DateToSystemTime.utc_wMinute = VBA.Minute(utc_Value)
            utc_DateToSystemTime.utc_wSecond = VBA.Second(utc_Value)
            utc_DateToSystemTime.utc_wMilliseconds = 0
        End Function
        
        Private Function utc_SystemTimeToDate(utc_Value As utc_SYSTEMTIME) As Date
            utc_SystemTimeToDate = DateSerial(utc_Value.utc_wYear, utc_Value.utc_wMonth, utc_Value.utc_wDay) + _
                TimeSerial(utc_Value.utc_wHour, utc_Value.utc_wMinute, utc_Value.utc_wSecond)
        End Function
        
    #End If