一些WORD VBA代码（替换页眉页脚、批量设置格式、图片插入等）

hdzgx

2017-12-01

关注

转自：http://www.cnblogs.com/Ellen/archive/2011/6/6.html

替换页眉页脚[word]

Sub 替换页眉页脚()
If ActiveWindow.View.SplitSpecial <>wdPaneNone Then ActiveWindow.Panes(2).Close
With ActiveWindow.ActivePane.View
  .Type = wdPrintView
  .SeekView = wdSeekCurrentPageHeader
  Selection.WholeStory
  Selection.Delete Unit:=wdCharacter,Count:=1
  Selection.TypeText Text:="这是替换后的页眉"
  .SeekView = wdSeekMainDocument
End With

WordBasic.ViewFooterOnly
Selection.WholeStory
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.TypeText Text:="这是替换后的页脚"
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
End Sub

posted @ 2011-06-06 21:23 半点忧伤阅读(95) 评论(1)编辑

批量格式设置word

请参考:(请确保所需的文档在同一文件夹下）
Sub批量格式设置()  '此代码为指定文件夹中所有选取的WORD文件的进行格式设置
Dim MyDialog As FileDialog, vrtSelectedItem As Variant, Doc AsDocument
' On Error Resume Next '忽略错误
'定义一个文件夹选取对话框
Set MyDialog =Application.FileDialog(msoFileDialogFilePicker)
With MyDialog
.Filters.Clear '清除所有文件筛选器中的项目
.Filters.Add "所有 WORD 文件", "*.doc", 1 '增加筛选器的项目为所有WORD文件
.AllowMultiSelect = True '允许多项选择
If .Show = -1 Then '确定
Application.ScreenUpdating = False
For Each vrtSelectedItem In .SelectedItems '在所有选取项目中循环
Set Doc = Documents.Open(FileName:=vrtSelectedItem,Visible:=False)
With Doc
With .PageSetup '进行页面设置
.Orientation = wdOrientPortrait '页面方向为纵向
.TopMargin = CentimetersToPoints(4.1) '上边距为4.1cm
.BottomMargin = CentimetersToPoints(4.1) '下边距为4.1cm
.LeftMargin = CentimetersToPoints(3.05) '左边距为3.05cm
.RightMargin = CentimetersToPoints(3.05) '右边距为3.05com
.Gutter = CentimetersToPoints(0) '装订线0cm
.HeaderDistance =CentimetersToPoints(1.5)  '页眉1.5cm
.FooterDistance = CentimetersToPoints(1.75) '页脚1.75cm
.PageWidth = CentimetersToPoints(21) '纸张宽21cm
.PageHeight = CentimetersToPoints(29.7) '纸张高29.7cm
.SectionStart = wdSectionNewPage '节的起始位置：新建页
.OddAndEvenPagesHeaderFooter = False '不勾选“奇偶页不同”
.DifferentFirstPageHeaderFooter = False '不勾选“首页不同”
.VerticalAlignment = wdAlignVerticalTop '页面垂直对齐方式为“顶端对齐”
.SuppressEndnotes = False '不隐藏尾注
.MirrorMargins = False '不设置首页的内外边距
.BookFoldRevPrinting = False '不设置手动双面打印
.BookFoldPrintingSheets = 1 '默认打印份数为1
.GutterPos = wdGutterPosLeft '装订线位于左侧
.LayoutMode = wdLayoutModeLineGrid '版式模式为“只指定行网格”
End With
.Close True
End With
          Next
         Application.ScreenUpdating = True
       End If
    End With
    MsgBox "格式化文档操作设置完毕!",vbInformation
End Sub

posted @ 2011-06-06 21:20 半点忧伤阅读(89) 评论(0)编辑

VBA实现批量修改Word文档的页脚内容

功能示例：

有很多个doc文档，页脚的电话变了，如原电话是4007339339，现在变成4007168339了，要实现批量替换，可使用此程序。

使用说明：

1、复制下面程序代码到VBA里后，点“工具”－“宏”－“宏”－“change”－“运行”

2、输入目录(不要输入根目录，要不速度会很慢)

3、输入要查找的内容

4、输入的替换成你要的内容

－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

'下面是程序代码，复制到Word的VBA里

'此子程序放在Word对象里
Option Explicit
Sub change()

Dim s As String
Dim wb As Object
Dim i As Long
Dim load As String
Dim find As String
Dim change As String

load =InputBox("输入要修改页脚的文件夹路径，自动扫描子文件夹－－－－－－－－－－－－－垃圾桶丁2009-3-8") '要变更的目录
find = InputBox("输入要查找的页脚内容") '查找的内容
change = InputBox("请问要替换成什么内容？") '替换的内容

Set wb = Application.FileSearch
    Withwb
       .NewSearch
       .LookIn = load
       .SearchSubFolders = True
       .FileName = "*.doc"
       .FileType = msoFileTypeExcelWorkbooks
       If .Execute() > 0 Then
           For i = 1 To .FoundFiles.Count
               On Error Resume Next
           s = .FoundFiles(i)

Call Macro1(s, find, change)
            Next i
       End If
    End With
End Sub

'此子程序放在模块里

Option Explicit
Sub Macro1(s As String, find As String, change As String)

Documents.Open FileName:=s, ConfirmConversions:=False, _
       ReadOnly:=False, AddToRecentFiles:=False, PasswordDocument:="",_
       PasswordTemplate:="", Revert:=False, WritePasswordDocument:="",_
       WritePasswordTemplate:="", Format:=wdOpenFormatAuto,XMLTransform:=""
    IfActiveWindow.View.SplitSpecial <>wdPaneNone Then
       ActiveWindow.Panes(2).Close
    End If
    IfActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow._
       ActivePane.View.Type = wdOutlineView Then
       ActiveWindow.ActivePane.View.Type = wdPrintView
    End If
   ActiveWindow.ActivePane.View.SeekView =wdSeekCurrentPageHeader
    IfSelection.HeaderFooter.IsHeader = True Then
       ActiveWindow.ActivePane.View.SeekView =wdSeekCurrentPageFooter
    Else
       ActiveWindow.ActivePane.View.SeekView =wdSeekCurrentPageHeader
    End If
   Selection.find.ClearFormatting
   Selection.find.Replacement.ClearFormatting
    WithSelection.find
       .Text = find '查找的内容
       .Replacement.Text = change '替换的内容
       .Forward = True
       .Wrap = wdFindContinue
       .Format = False
       .MatchCase = False
       .MatchWholeWord = False
       .MatchByte = True
       .MatchWildcards = False
       .MatchSoundsLike = False
       .MatchAllWordForms = False
    EndWith
   Selection.find.Execute Replace:=wdReplaceAll
   ActiveWindow.Close (wdSaveChanges)

End Sub

posted @ 2011-06-06 21:18 半点忧伤阅读(98) 评论(2)编辑

插入图片，制成图册

为了赶编一个图册,我们定了一个图片格式,图片全部存在硬盘上,每个图片均有一定的编号,如果手工实现,至少要24小时以上,中间还会出现DOC文件澎湃死机,想起来头就大.根据工作的流程,定了个索引文件格式,写了个VBA脚本,实现了(1)在WORD中插入表格(关键是单元格合并);(2)在WORD中插入文本框(浮于表格与图片上);(3)定义索引文件的格式(编号\图片\说明);(4)在WORD中读取索引文件格式.

结果,完成一个图册文件的制作,只用了不到20分钟,真是轻松.在工作有好的帮手真的非常重要,thankQCJ.下面是它的VBA代码,等到有时间时,用VC把它实现打包,让更多的人更简单地用吧.

==================================

Subtest()
'
' test Macro
' 宏在 2007-7-16 由 FtpDown 录制

'插入表格
   Dim filename As String, str1() As String, tmp As String, i AsInteger
   Dim photoimg As String, gisimg As String

   filename = "c:\set.txt" '这里是文本文件所在路径位置
   Open filename For Input As 1
   Do Until EOF(1)
   Line Input #1, tmp
   str1 = Split(tmp, ",")
   photoimg = str1(2) & "\1.jpg"
   gisimg = str1(2) & "\2.jpg"

   Selection.Collapse Direction:=wdCollapseStart
   Set myTable = ActiveDocument.Tables.Add(Range:=Selection.Range,_
   NumRows:=2, NumColumns:=3,DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:=_
   wdAutoFitFixed)

   '修改表格的高宽
   myTable.Rows(1).HeightRule = wdRowHeightAtLeast
   myTable.Rows(1).Height = CentimetersToPoints(8.62)

   myTable.Columns(1).PreferredWidthType =wdPreferredWidthPoints
   myTable.Columns(1).PreferredWidth = CentimetersToPoints(12)
   myTable.Columns(2).PreferredWidthType =wdPreferredWidthPoints
   myTable.Columns(2).PreferredWidth = CentimetersToPoints(0.42)
   myTable.Columns(3).PreferredWidthType =wdPreferredWidthPoints
   myTable.Columns(3).PreferredWidth =CentimetersToPoints(12.32)

   myTable.Rows(2).HeightRule = wdRowHeightAtLeast
   myTable.Rows(2).Height = CentimetersToPoints(8.62)

   '合并表格
   myTable.Cell(Row:=1, Column:=2).Merge _
           MergeTo:=myTable.Cell(Row:=2, Column:=2)

myTable.Cell(Row:=1, Column:=3).Merge _
MergeTo:=myTable.Cell(Row:=2, Column:=3)

'插入图片
   myTable.Cell(Row:=1, Column:=1).Range.InlineShapes.AddPicturefilename:= _
       photoimg, LinkToFile:=False, _
        SaveWithDocument:=True

   myTable.Cell(Row:=1, Column:=1).Range.InlineShapes(1).Height =244.35
   myTable.Cell(Row:=1, Column:=1).Range.InlineShapes(1).Width =344.25


   myTable.Cell(Row:=2, Column:=1).Range.InlineShapes.AddPicturefilename:= _
       photoimg, LinkToFile:=False, _
        SaveWithDocument:=True

   myTable.Cell(Row:=2, Column:=1).Range.InlineShapes(1).Height =244.35
   myTable.Cell(Row:=2, Column:=1).Range.InlineShapes(1).Width =344.25

   myTable.Cell(Row:=1, Column:=3).Range.InlineShapes.AddPicturefilename:= _
       gisimg, LinkToFile:=False, _
        SaveWithDocument:=True

   myTable.Cell(Row:=1, Column:=3).Range.InlineShapes(1).Height =498.7
   myTable.Cell(Row:=1, Column:=3).Range.InlineShapes(1).Width =344.25


   '插入文本框
   Set myTB1 =ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal,71, 35, 172, 36)
   myTB1.TextFrame.TextRange = str1(1) & Chr(13)& "部件编码:" & str1(0)

   Set myTB2 =ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal,609, 509, 165, 22)
   myTB2.TextFrame.TextRange ="XXXXXXXXX  2007年7月"

   'Set arrPic = ActiveDocument.Shapes.AddPicture("D:\我的文档\MyPictures\88888\arrow.gif", False, True, 50, 300)

   Selection.MoveDown Unit:=wdLine, Count:=2
   Selection.TypeParagraph
Loop
Close
End Sub
Sub sx()
'
' sx Macro
' 宏在 2007-7-18 由 zwx 创建
'
Dim tmp As String, FileNumber As Integer

Set fs =CreateObject("Scripting.FileSystemObject")
Set a = fs.CreateTextFile("c:\Errmeilan.txt", True)
Set b = fs.CreateTextFile("c:\OKmeilan.txt", True)
filename = "c:\meilan.txt" '这里是文本文件所在路径位置
FileNumber = FreeFile
Open filename For Input As FileNumber
Do Until EOF(FileNumber)
   Line Input #FileNumber, tmp
   str1 = Split(tmp, ",")
   photoimg = str1(2) & "\001.jpg"
   gisimg = str1(2) & "\002.jpg"

   If fs.FileExists(photoimg) = True And fs.FileExists(gisimg) = TrueThen
      b.writeLine (tmp)
   Else
      a.writeLine (tmp)
   End If
Loop
a.Close
b.Close
Set fs = Nothing
Set a = Nothing
Set b = Nothing
End Sub

posted @ 2011-06-06 21:16 半点忧伤阅读(27) 评论(0)编辑

word插入图片222

我写论文时经常要把所有的图调整成一样大小，使用的都是以下的代码，供参考。至于批量插入图片等功能，因为写论文时从来用不上，也不知道应该弄成什么样子，所以无法回答你。

Sub 一次性调整公式以外的图片大小及格式()
      '功能 1 ：把全文的图片调整成同样大小，公式除外
      '功能 2 ：如果图片不是 jpg 格式的，统一调整成 jpg格式并居中，以减小文档体积
      '========================
      Mywidth = 7 '需要的图片宽度（厘米）
      Myheigth = 5 '需要的图片高度（厘米）
      '========================
      Dim myPic As InlineShape
   For Each myPic InActiveDocument.InlineShapes
      With myPic
           .Select
            Select Case.Type
            CasewdInlineShapePicture
                 .Height =28.345 * Myheigth
                 .Width =28.345 * Mywidth
                 Selection.ParagraphFormat.Alignment=
wdAlignParagraphCenter
                             Selection.Cut
                 Selection.PasteSpecialLink:=False,
DataType:=15, Placement:=wdInLine, DisplayAsIcon:=False
            EndSelect
      End With
   Next
End Sub

posted @ 2011-06-06 21:15 半点忧伤阅读(49) 评论(1)编辑

word插入图片，调整大小

Sub Macro1()
ActiveDocument.Tables(1).Cell(3, 1).Select
Selection.InlineShapes.AddPicture FileName:="C:\a.jpg",LinkToFile:=True, SaveWithDocument:=True
End Sub
HF

Private   Sub Command1_Click()
       Dim   xApp As   New   Word.Application
       Dim   xDoc As   Document
       Dim   xShape As   InlineShape

       Set   xApp   =  New   Word.Application

       '添加文档并返回文档对象
       Set   xDoc   =  xApp.Documents.Add

       '插入一个图形Shape并返回其对象引用
       Set   xShape =   xDoc.InlineShapes.AddPicture( "D:\2003  document\My Pictures\1_151_115.jpg ")

       '设置Shape的大小
       xShape.Width   =  200
       xShape.Height   =  200

       Set   xShape =   Nothing

       '保存
       xDoc.SaveAs   "c:\dfgh.doc"

       xDoc.Close
       xApp.Quit

       Set   xDoc   =  Nothing
       Set   xApp   =  Nothing
End   Sub

这是上面代码的注释，可能对你的理解有一些帮助。如果需要多次插入图片，重复调用
       '插入一个图形Shape并返回其对象引用
       Set   xShape =   xDoc.InlineShapes.AddPicture( "D:\2003  document\My Pictures\1_151_115.jpg ")

       '设置Shape的大小
       xShape.Width   =  200
       xShape.Height   =  200

       Set   xShape =   Nothing
就可以了。

'*****************************

哈哈~终于可以了 O YEAH~ 感谢wangz的耐心介绍！另外我找到了另外一种方式，互联网的资源~分享如下：

word批量修改图片大小——固定长宽篇
这部分要说的是把word中的所有图片修改成固定的并且相同的长和宽！
1、打开word，工具－宏－宏（或者直接按Alt+F8）进入宏的界面，如下面所示，输入一个宏名，宏名自己起，能记住就行！
2、宏名起好了，单击“创建”进入Visual Basic 编辑器，输入如下代码并保存
Sub setpicsize() '设置图片大小
Dim n'图片个数
On Error Resume Next'忽略错误
For n = 1ToActiveDocument.InlineShapes.Count 'InlineShapes类型图片
ActiveDocument.InlineShapes(n).Height= 400 '设置图片高度为400px
ActiveDocument.InlineShapes(n).Width = 300 '设置图片宽度 300px
Nextn
For n = 1 To ActiveDocument.Shapes.Count'Shapes类型图片
ActiveDocument.Shapes(n).Height = 400 '设置图片高度为 400px
ActiveDocument.Shapes(n).Width = 300 '设置图片宽度 300px
Next n
EndSub
3、返回word，工具－宏－宏（或者直接按Alt+F8），再次进入宏的界面，选择刚才编辑好的宏，并单击“运行”按钮，就可以了！（图片多时，可能会花一些时间）word批量修改图片大小——按比例缩放篇
这部分要说的是把word中的所有图片按比例缩放！
具体操作同上，只是代码部分稍做修改，代码如下：
Sub setpicsize() '设置图片大小
Dim n'图片个数
Dim picwidth
Dimpicheight
On Error Resume Next'忽略错误
For n = 1 To ActiveDocument.InlineShapes.Count'InlineShapes类型图片
picheight = ActiveDocument.InlineShapes(n).Height
picwidth = ActiveDocument.InlineShapes(n).Width
ActiveDocument.InlineShapes(n).Height = picheight * 1.1'设置高度为1.1倍
ActiveDocument.InlineShapes(n).Width= picwidth * 1.1 '设置宽度为1.1倍
Next n
For n = 1 To
ActiveDocument.Shapes.Count 'Shapes类型图片
picheight = ActiveDocument.Shapes(n).Height
picwidth = ActiveDocument.Shapes(n).Width
ActiveDocument.Shapes(n).Height = picheight * 1.1 '设置高度为1.1倍
ActiveDocument.Shapes(n).Width = picwidth * 1.1 '设置宽度为1.1倍
Next n
End Sub
'********************************

今天收获很大，又找到了批量给图片加边框的方法，分享一下：

Dim i As Integer

For i = 1 To ActiveDocument.InlineShapes.Count

With ActiveDocument.InlineShapes(i)
With .Borders(wdBorderLeft)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth100pt
.Color = wdColorAutomatic
End With
With .Borders(wdBorderRight)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth100pt
.Color = wdColorAutomatic
End With
With .Borders(wdBorderTop)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth100pt
.Color = wdColorAutomatic
End With
With .Borders(wdBorderBottom)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth100pt
.Color = wdColorAutomatic
End With
.Borders.Shadow = False
End With
With Options
.DefaultBorderLineStyle = wdLineStyleSingle
.DefaultBorderLineWidth = wdLineWidth100pt
.DefaultBorderColor = wdColorAutomatic
End With
Next i

End sub

'****************************

posted @ 2011-06-06 21:07 半点忧伤阅读(1669) 评论(1)编辑

使用vb调用vba在word中插入图片的代码

过程名：wdout

作用：使用定义好的模板，自动将其中的形如｛????｝的字符以字段中的内容替换，并将｛照片｝替换成照片。如果没有照片，则删除相应的替换字符。

参数：photofile——照片文件的路径字符串，为完整绝对路径。不判断文件是否存在，如果不存在将出错。

插入图片其实只有一句
wdApp.Selection.InlineShapes.AddPicture FileName:= _
PhotoFile, LinkToFile:=False, SaveWithDocument:= _
True
可以用word的宏记录取得相应的代码。

Private Function WdOut(ByVal PhotoFile As String)
''{单位}{费用名称}{费用名细}{大写金额}{金额}{鉴定单位}{经办人}{日期}

Dim wdApp As Object, wdDoc As Object
Dim i As Integer

If CheckWord = False Then
MsgBox"没有安装Word软件或软件安装错误！", vbExclamation
ExitFunction
End If

If DotName = "" Or Not FileExist(DotName) Then
MsgBox "没有找到打印模板，无法打印！！", vbExclamation
Exit Function
End If

MsgWinShow "正在从模板生成文档..."

''If Not wdDoc Is Nothing Then
''    On ErrorResume Next
''   wdDoc.Close wdDoNotSaveChanges
''    Set wdDoc= Nothing
''   wdApp.Quit
''    Set wdApp= Nothing
''    On ErrorGoTo 0
''End If
''

Set wdApp = CreateObject("Word.Application")
With wdApp
' .Visible =True
Set wdDoc =.Documents.Add(DotName, False, 0,True) ''wdNewBlankDocument=0
End With

For i = 0 To adoRS.Fields.Count - 1
    'With.Content.Find

    Select CaseadoRS.Fields(i).Name
    Case"照片"
       wdApp.Selection.Find.ClearFormatting
       With wdApp.Selection.Find
           .Text = "{照片}"
           .Replacement.Text = "A"
           .Forward = True
           .Wrap = wdFindContinue
           .Format = False
           .MatchCase = False
           .MatchWholeWord = False
           .MatchByte = True
           .MatchWildcards = False
           .MatchSoundsLike = False
           .MatchAllWordForms = False
       End With

       wdApp.Selection.Find.Execute
       wdApp.Selection.Delete Unit:=1,Count:=1           ''删除       1=wdCharacter

    If PhotoFile> "" Then
       wdApp.Selection.InlineShapes.AddPicture FileName:= _
           PhotoFile, LinkToFile:=False, SaveWithDocument:= _
           True
       wdApp.Selection.MoveLeft Unit:=wdCharacter, Count:=1
       wdApp.Selection.MoveRight Unit:=wdCharacter, Count:=1,Extend:=wdExtend
       wdApp.Selection.InlineShapes(1).Fill.Visible =0       ''0= msoFalse
       wdApp.Selection.InlineShapes(1).LockAspectRatio =-1    ''-1=msoTrue
       wdApp.Selection.InlineShapes(1).Height = 28 * 4.1
       wdApp.Selection.InlineShapes(1).Width = 28 * 2.8
    End If
    CaseElse

    WithwdApp.Selection.Find
       .ClearFormatting
       .Replacement.ClearFormatting

       .Text = "{" & adoRS.Fields(i).Name& "}"
       .Replacement.Text = adoRS.Fields(i).Value &""
       .Forward = True
       .Wrap =1      ''1=wdFindContinue
       .Format = False
       .MatchCase = False
       .MatchWholeWord = False
       .MatchByte = True
       .MatchWildcards = False
       .MatchSoundsLike = False
       .MatchAllWordForms = False
       .ExecuteReplace:=2    ''2=wdReplaceAll
    EndWith

    EndSelect
Next
   wdApp.Visible = True

Set wdDoc = Nothing
Set wdApp = Nothing

MsgWinHide

End Function

本文来自CSDN博客，转载请标明出处：http://blog.csdn.net/lanman/archive/2008/04/09/2265650.aspx

一些WORD VBA代码（替换页眉页脚、批量设置格式、图片插入等）

转自：http://www.cnblogs.com/Ellen/archive/2011/6/6.html

相关推荐