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

weiyingde

转自：http://blog.sina.com.cn/s/blog_4636489701014qyv.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 As Document
' 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文档的页脚内容
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
    With wb
        .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:=""
    If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
        ActiveWindow.Panes(2).Close
    End If
    If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
        ActivePane.View.Type = wdOutlineView Then
        ActiveWindow.ActivePane.View.Type = wdPrintView
    End If
    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
    If Selection.HeaderFooter.IsHeader = True Then
        ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
    Else
        ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
    End If
    Selection.find.ClearFormatting
    Selection.find.Replacement.ClearFormatting
    With Selection.find
        .Text = find '查找的内容
        .Replacement.Text = change '替换的内容
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.find.Execute Replace:=wdReplaceAll
    ActiveWindow.Close (wdSaveChanges)
End Sub

weiyingde

插入图片，制成图册
为了赶编一个图册,我们定了一个图片格式,图片全部存在硬盘上,每个图片均有一定的编号,如果手工实现,至少要24小时以上, 中间还会出现DOC文件澎湃死机,想起来头就大.根据工作的流程,定了个索引文件格式,写了个VBA脚本,实现了(1)在WORD中插入表格(关键是单元 格合并);(2)在WORD中插入文本框(浮于表格与图片上);(3)定义索引文件的格式(编号\图片\说明);(4)在WORD中读取索引文件格式.
   结果,完成一个图册文件的制作,只用了不到20分钟,真是轻松.在工作有好的帮手真的非常重要,thank QCJ.下面是它的VBA代码,等到有时间时,用VC把它实现打包,让更多的人更简单地用吧.
==================================
Sub test()
'
' test Macro
' 宏在 2007-7-16 由 FtpDown 录制
'插入表格
    Dim filename As String, str1() As String, tmp As String, i As Integer
    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.AddPicture filename:= _
        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.AddPicture filename:= _
        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.AddPicture filename:= _
        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:\我的文档\My Pictures\88888\arrow.gif", False, True, 50, 300)
   
    Selection.MoveDown Unit:=wdLine, Count:=2
    Selection.TypeParagraph
Loop
Close
End Sub

weiyingde

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) = True Then
       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 In ActiveDocument.InlineShapes
       With myPic
               .Select
               Select Case .Type
               Case wdInlineShapePicture
                       .Height = 28.345 * Myheigth
                       .Width = 28.345 * Mywidth
                       Selection.ParagraphFormat.Alignment =
wdAlignParagraphCenter
                                         Selection.Cut
                       Selection.PasteSpecial Link:=False,
DataType:=15, Placement:=wdInLine, DisplayAsIcon:=False
               End Select
       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 = 1 To ActiveDocument.InlineShapes.Count 'InlineShapes类型图片
ActiveDocument.InlineShapes(n).Height = 400 '设置图片高度为 400px
ActiveDocument.InlineShapes(n).Width = 300 '设置图片宽度 300px
Next n
For n = 1 To ActiveDocument.Shapes.Count 'Shapes类型图片
ActiveDocument.Shapes(n).Height = 400 '设置图片高度为 400px
ActiveDocument.Shapes(n).Width = 300 '设置图片宽度 300px
Next n
End Sub
3、返回word，工具－宏－宏（或者直接按Alt+F8），再次进入宏的界面，选择刚才编辑好的宏，并单击“运行”按钮，就可以了！（图片多时，可能会花一些时间）word批量修改图片大小——按比例缩放篇
这部分要说的是把word中的所有图片按比例缩放！
具体操作同上，只是代码部分稍做修改，代码如下：
Sub setpicsize() '设置图片大小
Dim n'图片个数
Dim picwidth
Dim picheight
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

weiyingde

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

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
    Exit Function
End If
If DotName = "" Or Not FileExist(DotName) Then
        MsgBox "没有找到打印模板，无法打印！！", vbExclamation
        Exit Function
End If
MsgWinShow "正在从模板生成文档..."

''If Not wdDoc Is Nothing Then
''    On Error Resume Next
''    wdDoc.Close wdDoNotSaveChanges
''    Set wdDoc = Nothing
''    wdApp.Quit
''    Set wdApp = Nothing
''    On Error GoTo 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 Case adoRS.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
    Case Else
   
    With wdApp.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
        .Execute Replace:=2     ''2=wdReplaceAll
    End With
   
    End Select
Next
    wdApp.Visible = True
   
Set wdDoc = Nothing
Set wdApp = Nothing

MsgWinHide
End Function

闻启学

mark 一下  ！！！！

zhoujieses

很实用，谢谢分享

cndwb

非常值得收藏，谢谢分享

xj123321

谢谢分享