转自：http://www.cnblogs.com/Ellen/archive/2011/6/6.html
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)编辑 请参考:(请确保所需的文档在同一文件夹下）
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文档的页脚内容 功能示例： 有很多个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 posted @ 2011-06-06 21:18 半点忧伤 阅读(98) 评论(2)编辑 为了赶编一个图册,我们定了一个图片格式,图片全部存在硬盘上,每个图片均有一定的编号,如果手工实现, 至少要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
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)编辑 我写论文时经常要把所有的图调整成一样大小，使用的都是以下的代码，供参考。至于批量插入图片等功能，因为写论文时从来用不上，也不知道应该弄成什么样子，所以无法回答你。
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)编辑 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
End
Sub
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)编辑 过程名：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 |
