用excelVBA代码调整word

dongfgdwdjg

        习惯于用excel的代码，再用wordVBA代码，总觉得别扭，自己还是水平太低，不知道在word里怎么象在excel里一样设置一个按钮模块，一点击就可以运行代码，也觉得录制宏也不顺手。所以要批量操作word时，我喜欢在excel里代码操作，而在word通过录制宏获得的许多代码，在excel里运行时报错，这很让我苦恼，也总想办法解决。

        创建这个帖子，我想把自己用excelVBA代码调整word的一些实例汇总起来，公开代码，给一些象我一样菜的人提供点儿借鉴和帮助，也做为自己的一个笔记用，以后要是还做了相关实例，也陆续上贴过来。

        就应用excelVBA代码来说我都很菜，用excelVBA代码调整word水平就更低了，许多代码都是抄录前辈大师们的，我就是一个不太合格的搬运工；只是希望能给一些象我这样的人提供点什么。

        开贴了，欢迎大家来拍砖、吐槽、批评、修改、优化、建议、交流、讨论，更欢迎有人鼓励、赞赏、献花；不主张在这儿求助，求助单独开贴效果更好，也不希望出现谩骂，我本好意，如有得罪纯属无心；如果代码侵犯了哪位的智力成果，请包涵一些。

        附件是我用excelVBA代码调整word文件格式的一个实例。

        先附上我所用的 遍历文件夹打开word文件的主代码

Sub 打开关闭word文件的主代码()

    t= Timer    '把初始系统时间赋值给变量

   Dim kg%, m%, i%, kongge%, konghang%, hanghao%, s%, arr, PathSht AsString, sh As Worksheet '声明变量

   On Error Resume Next '容错语句，遇错继续

   PathSht = ThisWorkbook.Path & IIf(Right(ThisWorkbook.Path, 1) ="\", "", "\") '取本文件所在文件夹（本文件的父文件夹？）为变量路径，如果路径最右边一个字符不是"\"则追加一个"\"

    s= 1

   Dim FolderObj ' As Object '声明一个Object型的变量

   Set wd = CreateObject("word.application")

   Set fso = CreateObject("scripting.filesystemobject")    '创建文件系统对象(File SystemObject)，可以是文件夹，磁盘，子文件夹

   For Each FolderObj In fso.getfolder(PathSht).Files    'sf '在文件集合中的每个文件中循环

   arr = Range("A5:CS5").Value '把第5 行要求格式数据赋值到数组arr

       If FolderObj.Name Like "*.doc*" And Not FolderObj.Name Like"*$*.doc*" Then    '如果文件名称中包含指定内容，则

           With wd.Documents.Open(mypath & FolderObj)    '打开word文档

                Application.StatusBar = "正在处理 "& "第" & s & "个文件：    " & FolderObj.Name

                .Close True

           End With

       End If

       s = s + 1

   Next FolderObj

   Application.StatusBar = ""

   MsgBox "运行" & Format((Timer - t), "0.00000") & "秒"    '以秒为单位，得到运行时间，对话框显示

End Sub

dongfgdwdjg

进行页面设置部分的代码：
通过页面宽度和高度尺寸设置，一方面可以设置页面大小，另一方面也同时设置了页面方向，把这两个尺寸数据换一下位置，页面方向随即改变；
代码是在word里录制宏获得的，在excel里用的时候总报错，我试了很多次，最后在前边加一个wd.（就是新创建的word应用程序），居然解决了。这个真不是搬运来的。

1.                  With .PageSetup '页面设置
   
2.                     .PageWidth = wd.CentimetersToPoints(arr(1, 4)) '纸张宽度
   
3.                     .PageHeight = wd.CentimetersToPoints(arr(1, 5)) '纸张长度
   
4.                     .TopMargin = wd.CentimetersToPoints(arr(1, 6)) '页面上边距
   
5.                     .BottomMargin = wd.CentimetersToPoints(arr(1, 7)) '页面下边距
   
6.                     .LeftMargin = wd.CentimetersToPoints(arr(1, 8)) '页面左边距
   
7.                     .RightMargin = wd.CentimetersToPoints(arr(1, 9)) '页面右边距
   
8.                     .HeaderDistance = wd.CentimetersToPoints(arr(1, 10)) '页眉距边界
   
9.                     .FooterDistance = wd.CentimetersToPoints(arr(1, 11)) '页脚距边界
   
10.                 End With
    

复制代码

dongfgdwdjg

删除页眉页脚部分代码：
这个主要是搬运的，没什么可说的，但取消页眉下划线那句，我费了很多次验证，也试验过在word里录制宏，等于0的时候没有下划线，其他数字则是相应的下划线形式，如等于1是实线，等于2则是点划线。

                For Each mysec In .Sections '循环文件每一部分
                        For Each myhd In mysec.Headers '循环页眉每一部分；如果是页脚，把mysec.Headers改为mysec.Footers
                            myhd.Range.Delete '删除页眉
                            myhd.Range.ParagraphFormat.Borders(wdBorderBottom).LineStyle = 0 ' wdLineStyleNone,取消页眉下划线
                        Next
                    For Each myhd1 In mysec.Footers '循环页脚每一部分
                        myhd1.Range.Delete '删除页脚
                    Next
                 Next

dongfgdwdjg

插入页眉图片并设置大小的代码：
也是我搬运的，只是指定图片路径方面还是可以提供点儿借鉴
对齐方式经过验证，可以认为：0为左对齐，1为居中对齐，2为右对齐，3为两端对齐，4为分散对齐
                            myhd.Range.InlineShapes.AddPicture Filename:=ThisWorkbook.Path & "\公司标识.jpg", LinkToFile:=False, SaveWithDocument:=True '插入本文件所在文件中名为“公司标识”的图片到页眉
                            myhd.Range.InlineShapes(1).Height = VBA.Round(arr(1, 14) * 28.3527, 2) '页眉图片高度设置
                            myhd.Range.InlineShapes(1).Width = VBA.Round(arr(1, 15) * 28.3527, 2) '页眉图片宽度设置
                            myhd.Range.ParagraphFormat.Alignment = arr(1, 16) 'wdAlignParagraphLeft'图片位置设置，实际上是整个页眉位置（对齐方式）设置

dongfgdwdjg

插入页眉图片并设置大小的代码：
也是我搬运的，只是指定图片路径方面还是可以提供点儿借鉴
对齐方式经过验证，可以认为：0为左对齐，1为居中对齐，2为右对齐，3为两端对齐，4为分散对齐
                            myhd.Range.InlineShapes.AddPicture Filename:=ThisWorkbook.Path & "\公司标识.jpg", LinkToFile:=False, SaveWithDocument:=True '插入本文件所在文件中名为“公司标识”的图片到页眉
                            myhd.Range.InlineShapes(1).Height = VBA.Round(arr(1, 14) * 28.3527, 2) '页眉图片高度设置
                            myhd.Range.InlineShapes(1).Width = VBA.Round(arr(1, 15) * 28.3527, 2) '页眉图片宽度设置
                            myhd.Range.ParagraphFormat.Alignment = arr(1, 16) 'wdAlignParagraphLeft'图片位置设置，实际上是整个页眉位置（对齐方式）设置

dongfgdwdjg

设置页脚页码的代码：
有搬运的也有通过录宏得到的，各种不同来源的放到一起，就是给学习多个选择。
我在调试的时候，本来想设置阿拉伯数字页码，但每次都有前后两个短线，有点抓狂，我甚至都删除、卸载了软件重新安装，也不解决问题，说来都是泪啊。后来才发现是那句.NumberStyle = wdPageNumberStyleNumberInDash捣的鬼，咱不懂英语又不熟练VBA，多走很多弯路啊。
字体加粗方面，加粗，Font.Bold = True，值为-1；不加粗，Font.Bold = flase，值为0；这个，只要不比我水平低，都知道吧？我却是刚知道的。
                    If arr(1, 17) = "第*页，共*页" Then '如果页码形式要求为“第*页，共*页”
                              Set Rng = .Sections(1).Footers(wdHeaderFooterPrimary).Range
                              Rng.Text = "第 "
                              Rng.Collapse wdCollapseEnd '将光标定位于找到内容的末尾
                              .Fields.Add Rng, wdFieldPage, "Page" 'ActiveDocument.Fields.Add Rng, wdFieldPage, "Page"
                              Set Rng = .Sections(1).Footers(wdHeaderFooterPrimary).Range
                              Rng.Collapse wdCollapseEnd
                              Rng.Text = " 页 , 共 "
                              Rng.Collapse wdCollapseEnd
                              .Fields.Add Rng, wdFieldNumPages, "Pages"
                              Set Rng = .Sections(1).Footers(wdHeaderFooterPrimary).Range
                              Rng.Collapse wdCollapseEnd
                              Rng.Text = " 页 "
                          With .Sections(1).Footers(wdHeaderFooterPrimary)
                              .Range.Fields.Update
                              .Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
                          End With
                    End If
                    If arr(1, 17) = "第*页" Then '如果页码形式要求为“第*页”
                        With .Sections(1)
                            .Footers(wdHeaderFooterPrimary).PageNumbers.Add PageNumberAlignment:=wdAlignPageNumberOutside, FirstPage:=True
                            With .Footers(wdHeaderFooterPrimary).Range.Frames(1).Range
                                .InsertAfter "页"
                                .InsertBefore "第"
                            End With
                        End With
                    End If
                    If arr(1, 17) = "─1─" Then '如果页码形式要求为“─1─”
                        With .Sections(1)
                            .Footers(wdHeaderFooterPrimary).PageNumbers.Add PageNumberAlignment:=wdAlignPageNumberOutside, FirstPage:=True
                            With .Footers(wdHeaderFooterPrimary).Range.Frames(1).Range
                                .InsertAfter "─"
                                .InsertBefore "─"
                            End With
                        End With
                    End If
                    If arr(1, 17) = "1" Then '如果页码形式要求为纯阿拉伯数字形式
                        With mysec.Footers(1).PageNumbers
                            .Add wdAlignPageNumberOutside, True 'wdAlignPageNumberOutside页码位置为外侧, FirstPage:=True首页编码（起始页码）
                            .NumberStyle = wdPageNumberStyleArabic '页码格式为纯阿拉伯数字
'                            .NumberStyle = wdPageNumberStyleNumberInDash '页码格式为带短划线阿拉伯数字格式（字面意思就是页码在破折号内）
'                            .NumberStyle = wdPageNumberStyleArabicFullWidth '页码格式为全角格式
'                            .NumberStyle = wdPageNumberStyleUppercaseLetter '页码格式为大写字母ABC格式
                            .RestartNumberingAtSection = False
                        End With
                    End If
               If .Sections(1).Footers.Count > 0 Then
               With .Sections(1).Footers(1).Range '设置字体格式
                     .Font.NameFarEast = arr(1, 18)
                     .Font.Size = arr(1, 19)   '小五号字体Font.Size = 9
'                     .Font.ColorIndex = WorkFontColor
'                        arr(19, s) = GetWorkFontColor
                        If arr(1, 21) = "加粗" Then .Font.Bold = -1 Else .Font.Bold = 0
               End With
                With .Sections(1).Footers(1).Range.ParagraphFormat '页脚第1段 段落缩进和间距
                    If arr(1, 22) = "左对齐" Then .Alignment = 0
                    If arr(1, 22) = "居中对齐" Then .Alignment = 1
                    If arr(1, 22) = "右对齐" Then .Alignment = 2
                    If arr(1, 22) = "两端对齐" Then .Alignment = 3
                    If arr(1, 22) = "分散对齐" Then .Alignment = 4
                End With
          End If

dongfgdwdjg

整个文档段落格式设置部分代码：
主要是用excelVBA代码选择整篇word文档代码怎么弄，这个很重要的知识点，也没找到大神们的论述，我在word里录制宏得Selection.WholeStory，在excel里运行报错，困扰了我好长时间，最后也在前边加一个wd.（就是新创建的word应用程序）解决的。这好象值得举一反三。
另外就是对行距的设置，输入整数位行距，设置没有问题，而小数倍行距，则给设置成了整数倍，没办法，加个判断语句用.LineSpacingRule = wdLineSpace pt重新设置一下。

1.                 wd.Selection.WholeStory
   
2.                 With wd.Selection.ParagraphFormat '先全文设置段落缩进和间距，再后续调整
   
3.                     .LineSpacingRule = arr(1, 34)     '.LineSpacing  '  标准行距  1行=12磅
   
4.                     If arr(1, 34) = 1.5 Then .LineSpacingRule = wdLineSpace1pt5
   
5.                     If arr(1, 34) = 2.5 Then .LineSpacingRule = wdLineSpace2pt5
   
6.                     If arr(1, 34) = 3.5 Then .LineSpacingRule = wdLineSpace3pt5
   
7.                     If arr(1, 34) = 4.5 Then .LineSpacingRule = wdLineSpace4pt5
   
8.                     .LineUnitAfter = arr(1, 35) '.SpaceAfter
   
9.                     .LineUnitBefore = arr(1, 36)    '.SpaceBefore
   
10.                     If arr(1, 37) = "左对齐" Then .Alignment = 0
    
11.                     If arr(1, 37) = "居中对齐" Then .Alignment = 1
    
12.                     If arr(1, 37) = "右对齐" Then .Alignment = 2
    
13.                     If arr(1, 37) = "两端对齐" Then .Alignment = 3
    
14.                     If arr(1, 37) = "分散对齐" Then .Alignment = 4
    
15.                 End With
    
16.                 With wd.Selection '''取得字体格式
    
17.                         .Font.Name = arr(1, 38) '设置字体，If Cells(5, 27) = .Font.NameFarEast Then arr(27, s) = "" Else arr(27, s) = .Font.NameFarEast
    
18.                         .Font.Size = arr(1, 39) '设置字号
    
19.                         .Font.Bold = arr(1, 41) '设置是否加粗
    
20.                 End With
    

复制代码

kkkrin

看看看看看看看看看看看看看看看

ljjldd

哈哈，赞一个

blackttea1

学习啦，谢谢