利用宏批量调整word中图和表格格式
批量调整图片
设置固定大小n厘米：
Sub resetImgSize()
Dim iShape As InlineShape
For Each iShape In ActiveDocument.InlineShapes
iShape.LockAspectRatio = msoTrue
iShape.Height = CentimetersToPoints(n)
iShape.Width = CentimetersToPoints(n)
Next
End Sub
等比例缩放n倍：
Sub resetImgSize()
Dim imgHeight
Dim imgWidth
Dim iShape As InlineShape
For Each iShape In ActiveDocument.InlineShapes
iShape.LockAspectRatio = msoTrue
imgHeight = iShape.Height
imgWidth = iShape.Width
iShape.Height = CentimetersToPoints(n * imgHeight )
iShape.Width = CentimetersToPoints(n * imgWidth)
Next
End Sub
最大宽度n厘米等比例缩放：
Sub resetImgSize()
Dim imgHeight
Dim imgWidth
Dim iShape As InlineShape
For Each iShape In ActiveDocument.InlineShapes
iShape.LockAspectRatio = msoTrue
imgHeight = iShape.Height
imgWidth = iShape.Width
iShape.Height = CentimetersToPoints(n * imgHeight / imgWidth)
iShape.Width = CentimetersToPoints(n)
Next
End Sub
图题注设置
Sub adjustImage()
On Error Resume Next
'该代码可以批量调整技术报告的表格格式，每行有注释，可以情况进行自定义调整
For i = 1 To ActiveDocument.InlineShapes.Count
If ActiveDocument.InlineShapes(i).Type = 3 Then
ActiveDocument.InlineShapes(i).Range.Style = "图表居中"
ActiveDocument.InlineShapes(i).Range.Next(wdParagraph, 1).Select
Selection.Style = ActiveDocument.Styles("图")
End If
Next i
End Sub
Sub InsertCaption() '修改系统插入“题注”命令
'功能：自动删除标签与编号间的空格（英文除外），并在题注数字后添加一个空格；适用于：Word 2003 - 2013，不兼容WPS文字！
'真正从原理上协同系统插入题注，无任何前提条件；用户照常插入题注即可，甚至感觉不到程序的存在！
'Endlesswx于2015年8月4日
'另,如果插入的始终未域代码而不是数字，非程序问题，Alt+F9一次即可
Dim Lab As String, startPt As Long, endPt As Long, myrang As Range
'On Error Resume Next '发生错误时让程序继续执行下一句代码
' Application.ScreenUpdating = False '关闭屏幕更新，2013在此处关闭更新会导致输入框灰色不可选，故修正在调出对话框之后
startPt = Selection.Start 'startPt标注起始点
'***将if条件隐藏隐藏即可实现----手动替换题注空格***
If Application.Dialogs(357).Show = -1 Then '插入“题注”对话框秀出来,如果按确定结束时执行以下程序，避免按取消后的空格,357也可换成wdDialogInsertCaption
Application.ScreenUpdating = False '关闭屏幕更新
Lab = Dialogs(357).label
endPt = Selection.Start 'endPt标记插入的题注部分终点
Selection.Start = startPt '选定插入的整个题注
'删除标签与编号间的空格（英文后的保留）
With Selection.Find
.Text = Lab & " "
.Forward = True 'False=向上查找,(True=向下查找)
.MatchWildcards = False '不使用通配符
If Lab Like "*[0-9a-zA-Z.]" Then '此处判断标签的最后一个字符是否为英文或数字，是则不删除空格
Else
.Replacement.Text = Lab
.Execute Replace:=wdReplaceOne '替换找到的第一个，此处用作删除空格
endPt = endPt - 1 '删除空格后，末位减1
Selection.End = endPt
End If
End With
'在题注数字后添加一个空格
Selection.Fields.ToggleShowCodes '切换域代码，这样才能用^d查找域
With Selection.Find
.Text = "^d"
.Replacement.Text = "^& "
.Forward = False 'False=向上查找,(True=向下查找)
.MatchWildcards = False '不使用通配符
.Execute Replace:=wdReplaceOne '替换找到的第一个，此处用作添加空格
End With
'选定整个插入的题注内容，将域代码切换回来
endPt = endPt + 1 '增加空格后，末位加1
With Selection
.Start = startPt
.End = endPt
.Fields.ToggleShowCodes '切换域代码（切换回来）
End With
'将光标定位至题注所在段尾处
' Selection.MoveRight Unit:=wdCharacter, Count:=1 '此句光标返回插入题注前的原始位置，对于已经输好标题的情况并不合适
'选择段尾回车符
With Selection.Find
.Text = "^13"
.Forward = True 'False=向上查找,(True=向下查找)
.MatchWildcards = False '不使用通配符
.Wrap = wdFindContinue '继续查找
.Execute
End With
Selection.MoveLeft Unit:=wdCharacter, Count:=1 '定位到段尾回车前
End If
Application.ScreenUpdating = True '恢复屏幕更新
End Sub
Function GetListString()
Dim lngNumOfParagraphs As Long
Dim strListValue As String
On Error Resume Next
Do
If Err.Number Then Exit Do
lngNumOfParagraphs = lngNumOfParagraphs + 1
If (Selection.Previous(wdParagraph, lngNumOfParagraphs).Paragraphs.OutlineLevel <> wdOutlineLevelBodyText) Then
strListValue = Selection.Previous(wdParagraph, lngNumOfParagraphs).Paragraphs(1).Range.Text
GoTo Report_ListValue
End If
Loop
Exit Function
Report_ListValue:
' MsgBox "The selected table is in chapter: " & strListValue
strListValue = Left(strListValue, Len(strListValue) - 1)
GetListString = strListValue
End Function
Sub 图片插入题注()
Dim titleA As String '初始章节标题
Dim titleB As String '当前图片所在章节标题
Dim s
Dim t
t = 0
titleA = GetListString()
For s = 1 To 10
'查找下一个图片
With Selection.Find
.ClearFormatting
.Text = "^g"
.Execute Forward:=True
End With
titleB = GetListString()
'如果图片已切换章节，则退出
If (titleB <> titleA) Then
Exit For
' t = 0
' titleA = titleB
End If
'判断是否为图片
If Selection.Type = 7 Then
'在图片下方换行
Selection.MoveRight
Selection.TypeParagraph
'输入题注标题
t = t + 1
Selection.TypeText titleA & t
'插入题注
Selection.HomeKey Unit:=wdLine
Selection.InsertCaption Label:="图", TitleAutoText:="InsertCaption3", _
Title:="", Position:=wdCaptionPositionBelow, ExcludeLabel:=0
'题注居中
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
End If
Next s
End Sub
批量调整表格
表题注设置
Sub adjustTable()
'该代码可以批量调整技术报告的表格格式，每行有注释，可以情况进行自定义调整
Dim i, j, k As Integer
On Error Resume Next
T = Timer
Application.Browser.Target = wdBrowseTable
Application.ScreenUpdating = False
k = ActiveDocument.Tables.Count
For i = 1 To k
ActiveDocument.Tables(i).Style = "网格型 5" '设置表格样式为网格型 5
For m = 1 To ActiveDocument.Tables(i).Rows.Count
ActiveDocument.Tables(i).Rows(m).Range.Style = "表中文字"
If m = 1 Then ActiveDocument.Tables(i).Rows(m).Range.Style = "表头"
Next m
'设置每个表格前一段落为图表头格式
ActiveDocument.Tables(i).Range.Previous(wdParagraph, 1).Select
Selection.Style = ActiveDocument.Styles("表") '设置表头的样式为样式名为“图表头”的样式，可更改成存在的样式
j = j + 1
'StatusBar = "正在调整第" & i & "个表格,共" & k & "个表格，请稍候..."
Next i
Application.ScreenUpdating = True
'MsgBox "恭喜您!" & Chr(13) & Chr(10) & "已处理完" & j & "个表格,耗时" & Format(Timer - T, "0.00" & "秒。"), , "by sysware "
End Sub
*批量调整表格并添加表头标题
Sub 批量修改表格()
Dim tempTable As Table
Application.ScreenUpdating = False
If ActiveDocument.ProtectionType = wdAllowOnlyFormFields Then
MsgBox "文档已保护，此时不能选中多个表格！"
Exit Sub
End If
ActiveDocument.DeleteAllEditableRanges wdEditorEveryone
For Each tempTable In ActiveDocument.Tables
tempTable.Range.Editors.Add wdEditorEveryone
Next
ActiveDocument.SelectAllEditableRanges wdEditorEveryone
ActiveDocument.DeleteAllEditableRanges wdEditorEveryone
Application.ScreenUpdating = True
End Sub
Sub FormatAllTables()
For i = 1 To ActiveDocument.Tables.Count
' ActiveDocument.Tables(i).Style = "my"
With ActiveDocument.Tables(i).Range.ParagraphFormat
.LeftIndent = CentimetersToPoints(0)
.RightIndent = CentimetersToPoints(0)
.SpaceBefore = 0
.SpaceBeforeAuto = False
.SpaceAfter = 0
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpace1pt5
.Alignment = wdAlignParagraphJustify
.WidowControl = False
.KeepWithNext = False
.KeepTogether = False
.PageBreakBefore = False
.NoLineNumber = False
.Hyphenation = True
.FirstLineIndent = CentimetersToPoints(0)
.OutlineLevel = wdOutlineLevelBodyText
.CharacterUnitLeftIndent = 0
.CharacterUnitRightIndent = 0
.CharacterUnitFirstLineIndent = 0
.LineUnitBefore = 0
.LineUnitAfter = 0
.MirrorIndents = False
.TextboxTightWrap = wdTightNone
.AutoAdjustRightIndent = True
.DisableLineHeightGrid = False
.FarEastLineBreakControl = True
.WordWrap = True
.HangingPunctuation = True
.HalfWidthPunctuationOnTopOfLine = False
.AddSpaceBetweenFarEastAndAlpha = True
.AddSpaceBetweenFarEastAndDigit = True
.BaseLineAlignment = wdBaselineAlignAuto
End With
' 设置表中的字体及大小
ActiveDocument.Tables(i).Select
With Selection
.Font.Size = 10
.Font.Name = "宋体"
.InsertCaption Label:="表", TitleAutoText:="InsertCaption1", Title:="", Position:=wdCaptionPositionAbove, ExcludeLabel:=0
End With
ActiveDocument.Tables(i).Cell(1, 1).Select
With Selection
.SelectRow
.Font.Bold = True
.Shading.BackgroundPatternColor = -603923969
.ParagraphFormat.Alignment = wdAlignParagraphCenter
End With
Next
End Sub
