Word-VBA【干货案例】

【1】

Sub 批量图片1增对比度和降亮度()
   Dim myShape As Shape, myIns As InlineShape
   For Each myIns In ActiveDocument.InlineShapes
       myIns.PictureFormat.IncrementBrightness -0.15  '降亮度
       myIns.PictureFormat.IncrementContrast 0.3      '增对比度
   Next
End Sub

【2】
Sub 批量图片2降对比度和增亮度()
   Dim myShape As Shape, myIns As InlineShape
   For Each myIns In ActiveDocument.InlineShapes
       myIns.PictureFormat.IncrementBrightness 0.15   '增亮度
       myIns.PictureFormat.IncrementContrast -0.3     '降对比度
   Next
End Sub

【3】

Sub 批量调整多个文档图片大小()

Dim fd As FileDialog, vrtSelectedItem As Variant, wd As Document, p As InlineShape, w, h

Application.ScreenUpdating = False

Set fd = Application.FileDialog(msoFileDialogFilePicker)

With fd

.AllowMultiSelect = True

.InitialFileName = ActiveDocument.Path

If .Show <> -1 Then

Application.ScreenUpdating = True

MsgBox '您没有选择任何文档！', vbOK, '退出'

Exit Sub

Else

w = InputBox('输入要设置的图片宽度（cm）', '输入宽度', 8)

h = InputBox('输入要设置的图片高度（cm）', '输入宽度', 8)

For Each vrtSelectedItem In .SelectedItems

Set wd = Documents.Open(vrtSelectedItem)

For Each p In wd.InlineShapes

p.LockAspectRatio = msoFalse '取消锁定纵橫比

p.Width = Round(w / 2.54 * 72 * 4, 0) / 4 '将磅单位转化成厘米

p.Height = Round(h / 2.54 * 72 * 4, 0) / 4

Next

wd.Close savechanges:=True

Set wd = Nothing

Next

End If

End With

Application.ScreenUpdating = True

MsgBox '图片设置完成！', , '运行完成   @萧260961242'

End Sub

【4】处理word内嵌Excel

说明：1、原始的Word文档放在名为“word”的子目录里
           2、包含本代码的宏文档放在“word”的上一层
           3、提取出来的Excel文档存到名为“excel”的子目录，和“word”并列
           4、因为内嵌的Excel文档比较多，加了一个条件判断，只把label包含有“问题”的Excel存下来，不需要的话可以去掉
           5、运行代码时Excel处于关闭状态，所有word文档（除了本宏文档）处于关闭状态

Sub Export_Embedded_Excel()
Dim wdDoc As Document   '用于打开子目录里word文档
Dim iCtr As Integer     '用于遍历word文档里Inlineshapes
Dim i As Long           '用于遍历文件夹里的word文档
Dim xlApp As Object     '用于打开内嵌object
Dim objName As String   '用于获得内嵌object的label
Dim city As String      '用于获得word文档的文件名并作为Excel文档命名的一部分
path = ThisDocument.path
On Error Resume Next
' 逐个打开word文件夹里的文档
With Application.FileSearch
    .NewSearch
    .LookIn = path & '\word'
    .SearchSubFolders = False
    .FileName = '*.doc'
    .FileType = msoFileTypeWordDocuments
    If .Execute() > 0 Then
        For i = 1 To .FoundFiles.Count
            Set wdDoc = Documents.Open(FileName:=.FoundFiles(i))
            city = Left(ActiveDocument.Name, Len(ActiveDocument.Name) - 4)
            Set xlApp = CreateObject('Excel.Application')        '这行代码很关键
' 把文档里内嵌的、名字里包含“问题”的excel文件保存下来
            For iCtr = 1 To wdDoc.InlineShapes.Count
                If wdDoc.InlineShapes(iCtr).Type = wdInlineShapeEmbeddedOLEObject Then
                    If wdDoc.InlineShapes(iCtr).OLEFormat.ProgID = 'Excel.Sheet.8' Then
                        If wdDoc.InlineShapes(iCtr).OLEFormat.IconLabel Like '*问题*' Then
                        objName = wdDoc.InlineShapes(iCtr).OLEFormat.IconLabel
                        wdDoc.InlineShapes(iCtr).OLEFormat.Open
                        Set xlApp = GetObject(, 'Excel.Application')
                        xlApp.Workbooks(1).SaveAs FileName:=path & '\excel\' & city & objName & iCtr & '.xls'
                        xlApp.Workbooks(1).Close
                        End If
                    End If
                End If
            Next iCtr
            xlApp.Quit
            Set xlApp = Nothing
            wdDoc.Close False
' 下一个文档
        Next i
    End If
End With
End Sub

【5】删除图片文字-AlternativeText

Sub 删除可选文字()

Dim oShape As Shape

Dim oInlineShape As InlineShape

For Each oShape In ActiveDocument.Shapes

oShape.AlternativeText = '要删除“可选文字”则此处留空，也可以替换成自己需要的文字'

Next

For Each oInlineShape In ActiveDocument.InlineShapes

oInlineShape.AlternativeText = '要删除“可选文字”则此处留空，也可以替换成自己需要的文字'

Next

MsgBox '处理完毕！'

End Sub

【6】排版

Sub 格式设置()

Application.ScreenUpdating = False

'更改所有硬回车为软回车

Selection.Find.ClearFormatting

Selection.Find.Replacement.ClearFormatting

With Selection.Find

.Text = '^l'

.Replacement.Text = '^p'

.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

'去除所有空行

Dim i As Paragraph, n As Integer

Application.ScreenUpdating = False

For Each i In ActiveDocument.Paragraphs

If Len(i.Range) = 1 Then

i.Range.Delete

n = n + 1

End If

Next

Application.ScreenUpdating = True

'去除半角空格

Selection.Find.ClearFormatting

Selection.Find.Replacement.ClearFormatting

With Selection.Find

.Text = ' '

.Replacement.Text = ''

.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

'去除全角空格

Selection.Find.ClearFormatting

Selection.Find.Replacement.ClearFormatting

With Selection.Find

.Text = '　'

.Replacement.Text = ''

.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

'替换非标准引号为标准引号

Selection.Find.ClearFormatting

Selection.Find.Replacement.ClearFormatting

With Selection.Find

.Text = '''(*)'''

.Replacement.Text = ChrW(8220) & '\1' & ChrW(8221)

.Forward = True

.Wrap = wdFindContinue

.Format = False

.MatchCase = False

.MatchWholeWord = False

.MatchByte = False

.MatchAllWordForms = False

.MatchSoundsLike = False

.MatchWildcards = True

End With

Selection.Find.Execute Replace:=wdReplaceAll

'字母数字符号全角转半角 Macro

Dim qjsz, bjsz As String, iii As Integer '定义qjsz(全角数字)、bjsz(半角数字)为字符串型，iii为整数型

qjsz = '０１２３４５６７８９ａｂｃｄｅｆｇｈｉｊｋｌｍｎｏｐｑｒｓｔｕｖｗｘｙｚＡＢＣＤＥＦＧＨＩＪＫＬＭＮＯＰＱＲＳＴＵＶＷＸＹＺ,./<>?;’:[]{}\|=-+_)(*%$#@!`~&'

bjsz = '0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ，。／《》？；'：【】｛｝＼｜＝－＋＿）（×％＄＃＠！'～＆'

Selection.WholeStory

For iii = 1 To 95 '循环10次

With Selection.Find

.Text = Mid(qjsz, iii, 1) 'mid函数：返回文本字符串中从指定位置开始的特定数目的字符，每次取一个数字

.Replacement.Text = Mid(bjsz, iii, 1) '将用于替换的相应位置的半角数字

.Format = False '保留替换前的字符格式

.MatchWildcards = False

.Execute Replace:=wdReplaceAll '用半角符号替换全角符号

End With

Next iii

'修改小数点错误

Selection.Find.ClearFormatting

Selection.Find.Replacement.ClearFormatting

With Selection.Find

.Text = '([0-9])。([0-9])'

.Replacement.Text = '\1.\2'

.Forward = True

.Wrap = wdFindContinue

.Format = False

.MatchCase = False

.MatchWholeWord = False

.MatchByte = False

.MatchAllWordForms = False

.MatchSoundsLike = False

.MatchWildcards = True

End With

Selection.Find.Execute Replace:=wdReplaceAll

'设置字号

Selection.WholeStory  '全选

Selection.ClearFormatting  '清除全文格式

Selection.Font.Size = 14  '设置字号为14号

'设置行距

Selection.ParagraphFormat.LineSpacingRule = wdLineSpaceExactly

Selection.ParagraphFormat.LineSpacing = 25

Selection.ParagraphFormat.Alignment = wdAlignParagraphJustify  '设置文本为两端对齐

Selection.ParagraphFormat.CharacterUnitFirstLineIndent = 2  '设置段首缩进2字符

Selection.HomeKey Unit:=wdStory  '移至文首

Selection.EndKey Unit:=wdLine, Extend:=wdExtend  '选中首行

Selection.ClearFormatting  '清除首行格式

Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter  '设置首行居中对齐

Selection.ParagraphFormat.LineUnitBefore = 1  '设置首行段前间距1行

Selection.ParagraphFormat.LineUnitAfter = 1  '设置首行段后间距1行

Selection.Font.Name = '微软雅黑'  '设置首行字体为“微软雅黑”

Selection.Font.Size = 18  '设置首行字号为18号

Selection.Font.Bold = wdToggle  '设置首行字形为加粗

Application.ScreenUpdating = True

End Sub

【6】文档合并

Sub 批量合并()

On Error Resume Next

Dim fd As FileDialog, i&, doc As Document, p$, t&, j&, s As Section, k&, n&, m&, c&

Set fd = Application.FileDialog(msoFileDialogFolderPicker)

If fd.Show = -1 Then p = fd.SelectedItems(1) Else Exit Sub

Set fd = Nothing

If MsgBox('是否合并文件夹 ' & p & ' ?', 4 + 48) = vbNo Then End

If MsgBox('<是>：Word 文档(*.doc)    <否>：文本文档(*.txt)', 4 + 48) = vbYes Then t = 0 Else t = 1

If MsgBox('请选择分隔符！——<是>：分节符    <否>：分页符', 4 + 48) = vbYes Then j = 1 Else j = 0

If j = 1 Then

If MsgBox('每节页码！——<是>：重排    <否>：顺延', 4 + 48) = vbYes Then k = 1 Else k = 2

Else

k = 2

End If

Documents.Add

With Application.FileSearch

.NewSearch

.LookIn = p

.SearchSubFolders = True

If t = 0 Then .FileName = '*.doc' Else .FileName = '*.txt'

If .Execute > 0 Then

For i = 1 To .FoundFiles.Count

If t = 0 Then

Set doc = Documents.Open(FileName:=.FoundFiles(i), Visible:=False)

Else

Set doc = Documents.Open(FileName:=.FoundFiles(i), Encoding:=936, Visible:=False)

End If

doc.Content.Copy

doc.Close

Selection.EndKey 6

Selection.Paste

ActiveDocument.Characters(1).Copy

If j = 1 Then

Selection.InsertBreak Type:=wdSectionBreakNextPage

Else

Selection.InsertBreak Type:=wdPageBreak

End If

Next i

MsgBox '合并完毕！共合并 ' & .FoundFiles.Count & ' 个文件！', 0 + 64

Else

MsgBox '未发现文件！', 0 + 16

End If

End With

With ActiveDocument

.Characters.Last.Previous.Delete

.Characters.Last.Previous.Delete

'重排页码

For Each s In .Sections

s.Range.Select

With Selection.Sections(1).Headers(1).PageNumbers

.NumberStyle = wdPageNumberStyleNumberInDash

If k = 1 Then .RestartNumberingAtSection = True Else .RestartNumberingAtSection = False

.StartingNumber = 1

End With

Selection.Sections(1).Footers(1).PageNumbers.Add PageNumberAlignment:=wdAlignPageNumberCenter, FirstPage:=True

ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter

Selection.HeaderFooter.LinkToPrevious = Not Selection.HeaderFooter.LinkToPrevious

ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument

Next

Selection.HomeKey 6

'奇数加页

Do

For Each s In .Sections

n = s.Range.Information(3)

n = n - m

m = m + n

If n Mod 2 = 1 Then

s.Range.Characters.Last.InsertBreak Type:=wdPageBreak

n = 0

m = 0

c = 1

Exit For

Else

c = 0

End If

Next

Loop Until c = 0

End With

End Sub