【VB脚本备忘】【for PPT】规范表格格式（含OFFICE内置编辑器BUG描述）

功能：设置初始变量，统一PPT内的表格风格样式。包括：设置段落、字体、颜色、边距、对齐、描边 ect。

感受：VBA在PPT内的应用，逻辑上没什么难度，但是各种“对象”、“属性”、“方法”太多，语法又长又乱，感觉不规范。

小知识：RGB(0,0,0)是一个LONG型数据，即设置颜色时不应将变量 as RGBColor。

不足：
原计划给表格里的文字“描边”，但是好像VBA存在BUG，<表格内的文字的属性>无法赋值，如：
ActivePresentation.Slides(1).Shapes(2).Table.Cell(1, 1).Shape.TextFrame2.TextRange.Font.Line.Weight = 6
这句不生效，MsgBox .Weight，提示值仍为赋值前的值。
直接通过PPT界面却可以操作，但录出的宏（通过WORD）是空的，很奇怪。经外网搜索，15年已存在类似问题，至今未解决。
因此，即定计划未实现，美中不足，仍需手工操作。
（探讨贴：http://bbs.csdn.net/topics/392305719 http://club.excelhome.net/thread-1389921-1-1.html）

程序：

Sub Set_Table()

    '---------------------------------------------------------------------------------------------------------------
    '单元格边框
    Dim rbwi As Double: rbwi = 0.25                 '单元格-边框-宽度-内 table-border-weight-inside
    Dim rbci As Long: rbci = RGB(180, 180, 180)     '单元格-边框-颜色-内 table-border-color-inside
    Dim rbwo As Double: rbwo = 1                    '单元格-边框-宽度-外 table-border-weight-outside
    Dim rbco As Long: rbco = RGB(20, 20, 20)        '单元格-边框-宽度-外 table-border-weight-outside
    '---------------------------------------------------------------------------------------------------------------
    '单元格底色
    Dim rfcf As Long: rfcf = RGB(0, 60, 120)        '单元格-填充-颜色-首行      range-fill-color-firstline
    Dim rfco As Long: rfco = RGB(255, 255, 255)     '单元格-填充-颜色-非首行    range-fill-color-otherline
    '---------------------------------------------------------------------------------------------------------------
    '单元格边距
    Dim rmlrfc As Double: rmlrfc = 0.1              '单元格-边距-左右-首列      range-margin-left/right-firstcolumn
    Dim rmtbfr As Double: rmtbfr = 0.2              '单元格-边距-上下-首行      range-margin-top/bottom-firstrow
    Dim rmlroc As Double: rmlroc = 0.5              '单元格-边距-左右-非首列    range-margin-left/right-othercolumn
    Dim rmtor As Double: rmtor = 0.3                '单元格-边距-上-非首行      range-margin-top-otherrow
    Dim rmbor As Double: rmbor = 0.53               '单元格-边距-下-非首行      range-margin-bottom-otherrow
    '---------------------------------------------------------------------------------------------------------------
    '文字段落
    Dim swbf As Boolean: swbf = True                '字-行间距-首行-行倍数
    Dim swf As Single: swf = 1                      '字-行间距-首行             word-paragraph-firstrow
    Dim swbo As Boolean: swbo = False               '字-行间距-首行-磅数
    Dim swo As Single: swo = 28                     '字-行间距-其他行           word-paragraph-otherrow
    '---------------------------------------------------------------------------------------------------------------
    '文字字体
    Dim wnf As String: wnf = "微软雅黑"             '字-字体名-中文             word-name-FarEast
    Dim wna As String: wna = "Arial"                '字-字体名-英文             word-name-Ascii
    Dim wno As String: wno = "Arial"                '字-字体名-其他             word-name-other
    Dim ws As Integer: ws = 16                      '字-字号                    word-size
    Dim wcf As Long: wcf = RGB(255, 255, 255)       '字-颜色-首行               word-color-firstrow
    Dim wco As Long: wco = RGB(0, 0, 0)             '字-颜色-其他行             word-color-otherrow
    '---------------------------------------------------------------------------------------------------------------
    '表格位置
    Dim tt As Integer: tt = 150                     '表格-顶                    table-top
    '---------------------------------------------------------------------------------------------------------------
    '列宽
    Dim cw(1 To 9)
    cw(1) = 5
    cw(2) = 5
    cw(3) = 10.5
    cw(4) = 5
    cw(5) = 5
    cw(6) = 5
    cw(7) = 5
    cw(8) = 5
    cw(9) = 5
    '---------------------------------------------------------------------------------------------------------------
    '变量
    Dim sld As Slide
    Dim sh As Shape
    Dim r%, c%
    Dim i%, j%
    Dim b%
    '---------------------------------------------------------------------------------------------------------------
    '换算：1厘米等于28.35磅
    Dim change As Double: change = 28.35
    '边距
    rmtbfr = rmtbfr * change
    rmlrfc = rmlrfc * change
    rmtor = rmtor * change
    rmbor = rmbor * change
    rmlroc = rmlroc * change
    '列宽
    For i = 1 To UBound(cw)
        cw(i) = cw(i) * change
    Next
    '---------------------------------------------------------------------------------------------------------------
    '程序
    For Each sld In ActivePresentation.Slides
        For Each sh In sld.Shapes
            If sh.Type <> 19 Then GoTo 100
            r = sh.Table.Rows.Count
            c = sh.Table.Columns.Count
            '-------------------------------------------------------------------------------------------------------
            '画内框（实际是画全框）
            For i = 1 To r
                For j = 1 To c
                    For b = 1 To 4
                        Call Set_Range_Line(sh, i, j, b, rbwi, rbci)
                    Next
                Next
            Next
            '-------------------------------------------------------------------------------------------------------
            '画外框
            For i = 1 To r
                For j = 1 To c
                    If i = 1 Then Call Set_Range_Line(sh, i, j, 1, rbwo, rbco)
                    If i = r Then Call Set_Range_Line(sh, i, j, 3, rbwo, rbco)
                    If j = 1 Then Call Set_Range_Line(sh, i, j, 2, rbwo, rbco)
                    If j = c Then Call Set_Range_Line(sh, i, j, 4, rbwo, rbco)
                Next
            Next
            '-------------------------------------------------------------------------------------------------------
            '单元格边距
            For i = 1 To r
                For j = 1 To c
                    Select Case i
                        Case 1
                            If j = 1 Then
                                Call Set_Range_Margin(sh, i, j, rmtbfr, rmtbfr, rmlrfc, rmlrfc)
                            Else
                                Call Set_Range_Margin(sh, i, j, rmtbfr, rmtbfr, rmlroc, rmlroc)
                            End If
                        Case Else
                            If j = 1 Then
                                Call Set_Range_Margin(sh, i, j, rmtor, rmbor, rmlrfc, rmlrfc)
                            Else
                                Call Set_Range_Margin(sh, i, j, rmtor, rmbor, rmlroc, rmlroc)
                            End If
                    End Select
                Next
            Next
            '-------------------------------------------------------------------------------------------------------
            '单元格上色 & 段落 & 字体
            For i = 1 To r
                For j = 1 To c
                    If i = 1 Then
                        Call Set_Range_Background(sh, i, j, rfcf)
                        Call Set_Word_Font(sh, i, j, wnf, wna, wno, ws, wcf)
                        Call Set_Word_Para(sh, i, j, swbf, swf)
                    Else
                        Call Set_Range_Background(sh, i, j, rfco)
                        Call Set_Word_Font(sh, i, j, wnf, wna, wno, ws, wco)
                        Call Set_Word_Para(sh, i, j, swbo, swo)
                    End If
                Next
            Next
            '-------------------------------------------------------------------------------------------------------
            '列宽设置
            For j = 1 To c
                Call Set_Column_Width(sh, j%, cw(j))
            Next
            '-------------------------------------------------------------------------------------------------------
            '居中
            For i = 1 To r
                For j = 1 To c
                    If i = 1 Or j = 1 Then
                        Call Set_LMR(sh, i, j, 2)       '2：居中
                    Else
                        Call Set_LMR(sh, i, j, 4)       '4：两端对齐
                    End If
                Next
            Next
            '-------------------------------------------------------------------------------------------------------
            '表格位置定位
            Call Set_Table_Location(sh, tt)
            '-------------------------------------------------------------------------------------------------------
100
        Next
    Next
    
End Sub

Sub Set_Range_Line(sh As Shape, i%, j%, b%, rbw As Double, rbc&)
    With sh.Table.Cell(i, j).Borders(b)
        .Weight = rbw
        .ForeColor.RGB = rbc
    End With
End Sub

Sub Set_Range_Background(sh As Shape, i%, j%, rfc&)
    sh.Table.Cell(i, j).Shape.Fill.ForeColor.RGB = rfc
End Sub

Sub Set_Range_Margin(sh As Shape, i%, j%, rmt As Double, rmb As Double, rml As Double, rmr As Double)
    With sh.Table.Cell(i, j).Shape.TextFrame
        .MarginTop = rmt
        .MarginBottom = rmb
        .MarginLeft = rml
        .MarginRight = rmr
    End With
End Sub

Sub Set_LMR(sh As Shape, i%, j%, align%)
    sh.Table.Cell(i, j).Shape.TextFrame.TextRange.ParagraphFormat.Alignment = align
End Sub

Sub Set_Word_Font(sh As Shape, i%, j%, wnf$, wna$, wno$, ws%, wc&)
    With sh.Table.Cell(i, j).Shape.TextFrame2.TextRange.Font
        .NameFarEast = wnf
        .NameAscii = wna
        .NameOther = wna
        .Size = ws
        .Fill.ForeColor.RGB = wc
    End With
End Sub

Sub Set_Word_Para(sh As Shape, i%, j%, swb As Boolean, sw As Single)
    With sh.Table.Cell(i, j).Shape.TextFrame2.TextRange.ParagraphFormat
        .LineRuleWithin = swb
        .SpaceWithin = sw
    End With
End Sub

Sub Set_Table_Location(sh As Shape, tt%)
    pw = ActivePresentation.PageSetup.SlideWidth    'PageWidth
    tw = sh.Width                                   'TableWidth
    sh.Left = (pw - tw) / 2
    sh.Top = tt
End Sub

Sub Set_Column_Width(sh As Shape, j%, cw)
    sh.Table.Columns(j).Width = cw
End Sub