VWord中VBA编程学习总结

jacksonrhb2019

Word中VBA编程学习总结：

Word编辑过程，存在大量重复操作，借助VBA程序，简化操作，实现一键word文档格式化。但Word VBA中，Word对象、方法、属性过多，给编程带来不小的难题。另外word本身格式术语极其之多，很多文档格式非常混乱，相对excel VBA来说难度比较大。

为此，在word编辑过程中，总结出哪些重复操作，针对性的编辑一些通用程序，例如：全选表格，全选图片，文件夹内所有文件内容替换，不同节中设置页眉页脚，为所有图表添加题注等；但还有一部分操作，因需求不确定，程序化难度较大，例如：如何一键设置列表级别，非内嵌图片的处理等。

第一部分文件夹中文件处理

1.      当前word文件位置，所有word文件转化为pdf

1.1   关键的一些语句

DIR 指令，遍历文件夹内所有word文档，配合Do while…Loop，即可操作所有文件。

         ExportAsFixedFormat指令，转化为某一格式，设置exportformat:=wdExportFormatPDF即为pdf格式。

1.2   程序举例：

Sub DocToPdf()

'

   Dim myPath, myName, myName1 As String

   Dim SaveAsPDF As String

   Dim arr() As String

   Dim wdDoc As Document

   Application.ScreenUpdating = False

   myPath = ActiveDocument.Path & "\"

   myName = Dir(myPath & "*.doc*") '遍历文件夹内所有word文档

   myName1 = ActiveDocument.Name

   Do While myName <> ""

       Set wdDoc = Application.Documents.Open(myPath & myName, ReadOnly =True)

        '取得每个word文档对象，以下命令可根据实际情况调整，此处为另存pdf

       arr = Split(myName, ".")

       SaveAsPDF = myPath & arr(0) & ".pdf"

       wdDoc.ExportAsFixedFormat outputfilename:=SaveAsPDF,exportformat:=wdExportFormatPDF

       If myName <> myName1 Then wdDoc.Close

       myName = Dir

       Set wdDoc = Nothing

   Loop

   Application.ScreenUpdating = True

End Sub

jacksonrhb2019

第二部分 图表处理

1．        选中所有表格
1.1        关键的一些语句
For each t In Activedocument.Tables … Next  该语句可以遍历当前文档内所有表格，tables代表文档中的表格集合。
        DeleteAllEditableRanges和SelectAllEditableRanges 指令可以删除、选中待编辑区，加入待编辑区使用range.editors.add

1.2        全选表格程序

Sub 表格全选()
    Dim t As Table
    With ActiveDocument
        .DeleteAllEditableRanges wdEditorEveryone
        For Each t In .Tables
            t.Range.Editors.Add wdEditorEveryone
        Next
        .SelectAllEditableRanges wdEditorEveryone
        .DeleteAllEditableRanges wdEditorEveryone
    End With
End Sub

1.3        遍历所有表格，并使表格适应窗口

Sub 所有表格适应窗口()
    Dim t As Table
    For Each t In ActiveDocument.Tables
        t.AutoFitBehavior (wdAutoFitWindow)
    Next
End Sub
2．        如何选择表外文字（除表格外所有内容，包含内嵌图片、题注等）
2.1        关键一些语句：
        编程思路：选择表外文字方法有几个：
a.        遍历所有段落集合（word中为paragraphs），判断paragraph中是否含有表格
if Not t.Range.Information(12)   Then t.range.editors.add  -1
但该方法需要遍历所有段落，对于段落较多的文档不合适。
b.        读取文中所有表格的开始和结束位置，例如本程序中，将表格开始位置赋值给数组sArr（），将结束位置赋值给eArr（），
假设：sArr= s1, s2,s3…         eArr=e1,e2,e3…
                那么 set  rng =  Range(Start:=s1, End:=e1)
                Rng即为表格1的范围
                0至s1即为表格1前面的范围
                e1至s2即为表格1和2之间的范围
                        将rng.Editors.add wdEditorEveryone 即可选中表外文本内容

2.2        代码如下

Sub 表外文字()
    Dim rng As Range
    Dim sArr(), eArr()
    Dim Cnt As Integer
   
    With ActiveDocument
        .DeleteAllEditableRanges wdEditorEveryone
        Cnt = .Tables.Count
        ReDim sArr(Cnt - 1)
        ReDim eArr(Cnt - 1)
        
        For i = 0 To Cnt - 1
            sArr(i) = .Tables.Item(i + 1).Range.Start
            eArr(i) = .Tables.Item(i + 1).Range.End
        Next
        
        If sArr(0) <> 0 Then  '表前文字
            Set rng = .Range(Start:=0, End:=sArr(0))
            rng.Editors.Add wdEditorEveryone
        End If
        
        For i = 0 To Cnt - 2 '表间文字
            Set rng = .Range(Start:=eArr(i), End:=sArr(i + 1))
            rng.Editors.Add wdEditorEveryone
        Next
        
        If eArr(Cnt - 1) <> .Range.End Then '表后文字
            Set rng = .Range(Start:=eArr(Cnt - 1), End:=.Range.End)
            rng.Editors.Add wdEditorEveryone
        End If
        
        .SelectAllEditableRanges wdEditorEveryone
        .DeleteAllEditableRanges wdEditorEveryone
    End With
   
End Sub

3．        选中所有图片
3.1 word知识补充
        Word中图片格式主要有两类：
1）内嵌式至行中，在word中对象为inlineshape；该类型图片在段后打换行符（enter），该图片占用一个段落（paragraph）。在有些时候，我们设置段落行距为固定磅数时，该类型图片仅显示一部分（这个问题曾困扰我好久，之前我都是设置为上下型来解决，没想到是行距造成的，，，，，）。

设置为单倍行距时：


设置为固定磅数，比如20磅时


        2）第二个类型为，非内嵌式。这种格式又分为环绕、四周、上下等等。在word中对象为shape。因为这种类型缺少段落的属性，不好用代码编辑，操作，所以我通常使用非内嵌的格式。内嵌的图片占用一个段落的范围，可以准确的知道图片范围的位置。
如：pic.Range.Paragraphs(1).Range.Editors.Add wdEditorEveryone

3.2 选中所有内嵌图片

Sub SelectAllPic()
    Dim pic As InlineShape
    With ActiveDocument
        .DeleteAllEditableRanges wdEditorEveryone
        For Each pic In .InlineShapes
            pic.Range.Paragraphs(1).Range.Editors.Add wdEditorEveryone
        Next
        .SelectAllEditableRanges wdEditorEveryone
        .DeleteAllEditableRanges wdEditorEveryone
    End With
End Sub


3.3 将shape类图片转换为inlineshape
Sub 图片格式化()
    Dim sh As Shape
    Dim sha As InlineShape
   
    For Each sh In ActiveDocument.Shapes
        sh.ConvertToInlineShape
    Next
   
    For Each sha In ActiveDocument.InlineShapes
        sha.LockAspectRatio = msoTrue ‘锁定横竖比，设定高度为5cm，28.34是单位转换至磅（也可以使用CentimetersToPoints，将厘米转换为磅）
        sha.Height = 28.34 * 5
    Next
End Sub

jacksonrhb2019

第三部分 各种类型正文的选择
1.        Word知识补充
1.1        Lists 列表对象集合和 ListParagraphs集合
在我做投标文件时，经常需要选中纯文本（不含图片、表格、题注、带列表文本），或单独选中所有题注、所有图片、所有表格，仅选中某级标题等等。所以对这些问题我琢磨了很久，终于对word复杂的格式系统有了一点了解。
对图片、表格前文已有介绍。
题注：一般包含图片题注、表格题注，在word中该对象为field，后面专门介绍。

带列表的文本：这个真是非常复杂，word中常用分为三种：
就是这三兄弟，分别为项目符号列表、简单编号列表、多级列表
Word中有两个与列表相关的对象：Lists 列表对象集合和 ListParagraphs集合
Lists 在官网office VBA参考中解释为：list对象的集合，这些对象代表指定文档中的所有列表。讲真还是不知道他在说啥。

于是我在在空白文档中增加这三种列表，监控下lists到底是什么：

&#61548;        项目编号列表
i.        简单符号列表
A.        简单符号列表
1.        多级列表1级
1.1.        多级列表2级
2.        多级列表1级，与1相关联，没有重新编号
2.1.        多级列表2级。

然后写入如下代码     k = ActiveDocument.Lists.Count
   监控得知k = 4

当你点选一个项目符号时，同属一个list的段落全部会变灰，那么这个项目编号就是1个list对象。所以示例代码中有4个list对象

同理看下什么是listparagraphs
代码：l = ActiveDocument.ListParagraphs.Count
监控得知l=7 ，每个带编号的段落都是一个ListParagraphs里的item

理解lists和listparagraphs 就可以准确编辑各种列表段落。

1.2 对象ListFormat 列表格式属性
列表格式属性通过调用该对象的属性可获取
比如：ListType ，列表到底是什么类型，是项目编号，是简单编号，还是多级编号呢？
        ListType属性可以得到其类型：
        项目编号为：wdListBullet 或 2
        简单编号列表：wdlistSimpleNumbering 或 3
        多级列表：wdListOutlineNumbering 或 4
        用这个小代码可以监控到ListType
Sub test()
    For i = 1 To ActiveDocument.ListParagraphs.Count
        j = ActiveDocument.ListParagraphs.Item(i).Range.ListFormat.ListType
    Next
End Sub
        还有就是ListLevelNumber，可以获取级别，word中规定了最多9个级别。

1.3 列表前面的那个符号或数字怎么选中
        那个编号的格式有时要设置为中文格式，有时是西文格式，点选甚是麻烦，找了好久才发现，代码ListParagraphs.Item(i).SelectNumber 可以选中数字。

       
2.        选中纯文本内容
如何选中纯文本内容，不包含表格、图片、题注、带列表的正文？
        在选择表外内容时，思路已经介绍过，这里再简述下：
        找到tables、inlineshape、fields、listparagraphs各自段落的start和end值，添加e1和s2、e2和s3范围至editors即可。
此处有个问题就是得到的两个数组sArr和eArr，各自需要从小到大排序，排序算法很多，可以从网上找到，此处我使用冒泡算法如下：
Function BubbleSort(ByRef byArr() As Variant, bySize As Integer)
    Dim TEMP As Variant
    For i = 0 To bySize - 2
        For j = i + 1 To bySize - 1
            If byArr(i) > byArr(j) Then
                TEMP = byArr(j)
                byArr(j) = byArr(i)
                byArr(i) = TEMP
            End If
        Next j
    Next i
End Function

2.1 选择纯文本代码

Sub ChooseContent()
    Dim rng As Range
    Dim sArr() As Variant
    Dim eArr() As Variant
    Dim ListC, TableC, FieldC, InshapeC, Cnt As Integer
   
    With ActiveDocument
        ListC = .ListParagraphs.Count
        TableC = .Tables.Count
        FieldC = .Fields.Count
        InshapeC = .InlineShapes.Count
        Cnt = ListC + TableC + FieldC + InshapeC
        ReDim sArr(Cnt - 1)
        ReDim eArr(Cnt - 1)
        
        If ListC <> 0 Then ‘获取带列表的段落位置
            For i = 0 To ListC - 1
                sArr(i) = .ListParagraphs.Item(i + 1).Range.Start
                eArr(i) = .ListParagraphs.Item(i + 1).Range.End
            Next
        End If
        
        If TableC <> 0 Then ‘获取表格的位置
            For i = ListC To ListC + TableC - 1
                sArr(i) = .Tables.Item(i + 1 - ListC).Range.Start - 1
                eArr(i) = .Tables.Item(i + 1 - ListC).Range.End
            Next
        End If
        
        If FieldC <> 0 Then ‘获取题注的位置
            For i = ListC + TableC To ListC + TableC + FieldC - 1
                sArr(i) = .Fields.Item(i + 1 - ListC - TableC).Result.Paragraphs(1).Range.Start
                eArr(i) = .Fields.Item(i + 1 - ListC - TableC).Result.Paragraphs(1).Range.End
            Next
        End If
         
        If InshapeC Then ‘获取内嵌图片位置
            For i = ListC + TableC + FieldC To ListC + TableC + FieldC + InshapeC - 1
                sArr(i) = .InlineShapes.Item(i + 1 - ListC - TableC - FieldC).Range.Start
                eArr(i) = .InlineShapes.Item(i + 1 - ListC - TableC - FieldC).Range.End + 1
            Next
        End If
        
        Call BubbleSort(sArr, Cnt - 1) ‘排序
        Call BubbleSort(eArr, Cnt - 1)
        
        If sArr(0) <> 0 Then  '前文字
            Set rng = .Range(Start:=0, End:=sArr(0))
            rng.Editors.Add wdEditorEveryone
        End If
        
        For i = 0 To Cnt - 2 '间文字
             If eArr(i) < sArr(i + 1) Then
                Set rng = .Range(Start:=eArr(i), End:=sArr(i + 1))
            End If
            rng.Editors.Add wdEditorEveryone
        Next
        
        If eArr(Cnt - 1) <> .Range.End Then '后文字
            Set rng = .Range(Start:=eArr(Cnt - 1), End:=.Range.End)
            rng.Editors.Add wdEditorEveryone
        End If
        
    End With
End Sub

该代码仍需完善的地方：1）表格内不能含图片或带列表正文，以后有时间再更新此问题；2）与图表相连的地方，有时会出现问题。


2.2 选择带列表正文
没什么新的内容，直接上代码
Function ChooseListContent(byListType As Integer, byListLevel As Integer)  ‘ byListtype代表编号的类型，可取2,3，或4，byListLevel 代表级别，取值为1至9 ，遍历所有ListParagraphs判断类型和级别即可添加选择

    Dim para As ListParagraphs
    Dim iListType, iListLevel As Integer
   
    With ActiveDocument
        .DeleteAllEditableRanges wdEditorEveryone
        
        Set para = .ListParagraphs
        
        For i = 1 To para.Count
            With para.Item(i).Range
               
                iListType = .ListFormat.ListType
                iListLevel = .ListFormat.ListLevelNumber
               
                If iListType = byListType And iListLevel = byListLevel Then
                    .Editors.Add wdEditorEveryone
                End If
               
            End With
        Next
        
        .SelectAllEditableRanges wdEditorEveryone
        .DeleteAllEditableRanges wdEditorEveryone
    End With

End Function

2.3 批量增加表格和图片题注

录制宏，更改为遍历所有内嵌图片：

Private Sub CommandButton4_Click()
'所有图片后面加题注
    Dim pic As InlineShape
    For Each pic In ActiveDocument.InlineShapes
        pic.Select
        Selection.InsertCaption Label:="图", TitleAutoText:="InsertCaption1", Title _
        :="", Position:=wdCaptionPositionBelow, ExcludeLabel:=0
    Next
End Sub
同理遍历所有表格：
Private Sub CommandButton7_Click()
' 所有表前加题注
    Dim ta As Table
    For Each ta In ActiveDocument.Tables
        ta.Select
        Selection.InsertCaption Label:="表", TitleAutoText:="InsertCaption1", Title _
        :="", Position:=wdCaptionPositionAbove, ExcludeLabel:=0
    Next
   
End Sub


3.        同一文件夹所有文档，相同内容的替换

做了一个用户窗体，可批量替换多个内容


主要代码可通过录入宏获取，再更改下遍历文件夹即可

Private Sub CommandButton1_Click()
   
    Dim myPath, myName, myName1 As String
    Dim wdDoc As Document
   
    Application.ScreenUpdating = False
   
    If opt = 0 Then  ‘当前文件
        Set wdDoc = ActiveDocument
        For i = 0 To --TextBox3.Value - 1
        
            With doc.Content.Find
                .Text = oTextbox1(i)
                .Replacement.Text = oTextbox2(i)
                .Execute Replace:=wdReplaceAll
            End With
        Next
    End If
        
    If opt = 1 Then  ‘所有文件
        myPath = ActiveDocument.Path & "\"
        myName = Dir(myPath & "*.doc*") '遍历文件夹内所有word文档
        myName1 = ActiveDocument.Name
        
        Do While myName <> ""
            Set wdDoc = Application.Documents.Open(myPath & myName, ReadOnly = False)
            
            For i = 0 To --TextBox3.Value - 1
                With wdDoc.Content.Find
                    .Text = oTextbox1(i)
                    .Replacement.Text = oTextbox2(i)
                    .Execute Replace:=wdReplaceAll
                End With
            Next
            
            If myName <> myName1 Then
                wdDoc.Save
                wdDoc.Close
            End If
            
            myName = Dir
            Set wdDoc = Nothing
        Loop
   End If
   
    Application.ScreenUpdating = True
   
End Sub

jacksonrhb2019

第四部分 页眉页脚处理

1.        横向纵向混用文档设置页边距
1.1 关键一些语句
        遍历所有节：For Each sec In ActiveDocument.Sections…Next
       

1.2        示例代码
设置页边距（此处增加用户窗体frmPageSetup，通过窗体获取要设置的页边距）



Sub 页面设置()
    Dim sec As Section
    For Each sec In ActiveDocument.Sections
        If sec.PageSetup.Orientation = wdOrientPortrait Then '竖向页面
            With sec.PageSetup
                .TopMargin = CentimetersToPoints(frmPageSetup.VTop.Value)
                .BottomMargin = CentimetersToPoints(frmPageSetup.VBelow.Value)
                .LeftMargin = CentimetersToPoints(frmPageSetup.VLeft.Value)
                .RightMargin = CentimetersToPoints(frmPageSetup.VRight.Value)
                .HeaderDistance = CentimetersToPoints(frmPageSetup.VHeader.Value)
                .FooterDistance = CentimetersToPoints(frmPageSetup.VFooter.Value)
            End With
        
        Else '横向页面
            With sec.PageSetup
                .TopMargin = CentimetersToPoints(frmPageSetup.HTop.Value)
                .BottomMargin = CentimetersToPoints(frmPageSetup.HBelow.Value)
                .LeftMargin = CentimetersToPoints(frmPageSetup.HLeft.Value)
                .RightMargin = CentimetersToPoints(frmPageSetup.HRight.Value)
                .HeaderDistance = CentimetersToPoints(frmPageSetup.HHeader.Value)
                .FooterDistance = CentimetersToPoints(frmPageSetup.HFooter.Value)
            End With
        End If
    Next
   
End Sub


2.        页眉编辑
该段代码不能通用，是我按公司模版页眉页脚编辑的，不过通过代码学会了如何通过程序录入内容的操作。

最终页眉如下图：


代码示例及各条语句讲解

Sub 当前页眉编辑()
   
    Dim picPath As String
    Dim rng As Range
    Dim sec As Section
   
    picPath = "C:\Users\010200004520\Pictures\CRRC.jpg"   ‘ logo位置
   
    Application.ScreenUpdating = False
   
    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader   ‘ 打开页眉编辑视图
   
With Selection  ‘打开视图后，可以看到光标已定位到页眉
        .WholeStory  ‘全选页眉区域 ，并删除所有内容
        .Delete
        .ParagraphFormat.Borders(wdBorderBottom).LineStyle = wdLineStyleNone  ‘删除所有内容后，页眉下面总有一条线，该句设置无此条线
        .ParagraphFormat.Alignment = wdAlignParagraphJustify   ' 页眉区域段落格式两端对齐
        
        .ParagraphFormat.WordWrap = False  ‘ 设置 允许西文在单词中间换行 为false，因为需要输入带下划线的空格，若为True，在输入空格时，不会换行，一直会延伸至页面外。（可以在工具栏中：段落-> 中文版式 中找到）
        Do  ‘该段循环，可以一直输入一行空格，一直到换行为止
            .TypeText Text:=" "   ‘输入一个空格符
            .WholeStory
            n = Selection.Range.ComputeStatistics(wdStatisticLines)
            .EndKey wdStory  ‘光标定位到整个区域最后一个字符
        Loop Until n <> 1
        
        .WholeStory   ‘全选
        .Font.Underline = wdUnderlineDash  ‘ 设置下划线
        .HomeKey unit:=wdLine        ‘光标定位到行首
        .InlineShapes.AddPicture FileName:=picPath, LinkToFile:=False, SaveWithDocument:=True   ‘ 插入logo ，并设置logo的大小
        .WholeStory
        .InlineShapes(1).Height = 28.345 * 0.8
        .InlineShapes(1).Width = 28.345 * 2.45
        .EndKey unit:=wdLine    ‘插入logo后，定位光标到段尾，选择第二行，并删除
        .Expand unit:=wdLine
        .Delete
End With
‘ 编辑完成返回主视窗
    ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
        
    Application.ScreenUpdating = True

End Sub



3.        页脚编辑

基本与页眉相似，不同点是插入了表格（表格线已设置为隐藏）：

显示框线：

Sub 当前页脚编辑()
   
   
    Dim picPath As String
    Dim t As Table
    Application.ScreenUpdating = False
    picPath = "C:\Users\010200004520\Pictures\CRRCCN.jpg"
   
    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
   
    With Selection
        .WholeStory
        .Delete
        .ParagraphFormat.Alignment = wdAlignParagraphJustify
        
        .ParagraphFormat.WordWrap = False
        Do
            .TypeText Text:=" "
            .WholeStory
            n = Selection.Range.ComputeStatistics(wdStatisticLines)
            .EndKey wdStory
        Loop Until n <> 1
        .WholeStory
        .Font.Underline = wdUnderlineDash
        
        .EndKey unit:=wdLine
        .Expand unit:=wdLine
        .Delete
        
        .EndKey unit:=wdLine
        .Font.Underline = wdUnderlineNone
        .Tables.Add Range:=.Range, NumRows:=2, NumColumns:=2, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:=wdAutoFitFixed  ‘插入表格，可以使用录入宏获取代码

        .WholeStory
        Set t = Selection.Tables(1)
    End With
        
        t.Select
        With Selection
            .Font.Underline = wdUnderlineNone
            .Borders(wdBorderTop).LineStyle = wdLineStyleNone
            .Borders(wdBorderLeft).LineStyle = wdLineStyleNone
            .Borders(wdBorderBottom).LineStyle = wdLineStyleNone
            .Borders(wdBorderRight).LineStyle = wdLineStyleNone
            .Borders(wdBorderHorizontal).LineStyle = wdLineStyleNone
            .Borders(wdBorderVertical).LineStyle = wdLineStyleNone
            .Borders(wdBorderDiagonalDown).LineStyle = wdLineStyleNone
            .Borders(wdBorderDiagonalUp).LineStyle = wdLineStyleNone
        End With
        
        t.Cell(1, 2).Select
        With Selection
            .ParagraphFormat.Alignment = wdAlignParagraphRight
            .EndKey unit:=wdLine
            .InlineShapes.AddPicture FileName:=picPath, LinkToFile:=False, SaveWithDocument:=True
            .WholeStory
            .InlineShapes(1).Height = 28.345 * 0.4
            .InlineShapes(1).Width = 28.345 * 4.39
        End With
   
    ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
    Application.ScreenUpdating = True
End Sub




第五部分 总结
               
        Word VBA编程因涉及对象、属性、方法太多，入门不易。但是了解一些常用的对象之后，比excel VBA还是容易一些。
        比较重要的几个对象或方法：Range（尤其如何给start和end赋值非常灵活）、Selection、Section、 Paragraph、Table、Field、List、ListParagraph、Inlineshape等
        以上代码知识个起步，大家可以根据自己需要，建立代码库，内嵌至word，以方便工作为目的。
         
这个是我在自定义功能区中新建的选项卡。（我这个比较简单，因为程序都写在模版文件Normal中，启动word就可以加载。有时间的也可以学习下Ribbon或Com加载项等方式进行封装）

jacksonrhb2019

暂时只到这里，后面有时间再更新啦

dnaxys

感谢楼主分享，mark一下

kingtau

感谢分享，非常实用

wks9527

问下楼主哎，我想设置所有表格适应窗口，标题栏跨行重复，表格内文字字体字号，还有表格内文字水平居中和垂直居中，这个该如何写在一个代码里边？

风之惑

感谢楼主分享宝贵学习经验

jyrongyi

感谢分享，非常实用