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