原创并分享：我的得意代码

zhanglei1371

自来到EH坛学习了不少东西，尤其是守柔、sylun的代码让我受益匪浅。当然也根据自己的心得写出了些代码，为感谢论坛和坛友给我的帮助，特将自认为还不错的代码拿出来与大家分享，希望对VBA新手有所帮助。
由于本人水平有限，代码未免会有不少瑕疵，希望大家能予以批评指定。
需要指出的是：所有的代码全部是用于word的，因为本人日常工作基本用不着Excel，故对Excel VBA基本不懂。代码在Word2003下测试通过。
现将模板也上传：使用方法如下：
使用时只需工具-模板和加载项-添加本文件。
或者直接放在C:\Documents and Settings\Administrator\Application Data\Microsoft\Word\STARTUP文件夹下也可。
My VBA Code.rar (92.49 KB, 下载次数: 1796)

2013-8-22 08:29 上传

点击文件名下载附件

代码见楼下......

（请事先勾选相应引用）

zhanglei1371

1.删除全文空白行
由于空行的前面可能会有一些空白符号，经我观察，空白字符有6种：全角空格、半角空格、不间断空格、制表符、换行符、回车符，所以如果空白行中有这些东西的话，常规方法难以一下除去，故本过程将这些全部考虑在内。为了提高速度，只用一次替换完成。
Sub 删除全文空白行()
    Application.ScreenUpdating = False
    t = Timer
    Dim S As Range
    Set S = ActiveDocument.Content   '
    S.Find.Execute "^13[ 　^t" & ChrW(160) & "^11^13]{1,}", , , 2, , , , , , "^p", 2
    Set S = Nothing
    Application.ScreenUpdating = True
           MsgBox Timer - t  ‘消耗时间
End Sub
2.删除段落首位空白
有时我们从网上下载网文，很多时候段落前后会有空白，其实最快的方法就是按Ctrl+E和Ctrl+J完成即可。
用代码表示的话可以用Sendkeys来模拟按键，版块内有这样的帖子，然而个人感觉sendkeys方法不太可靠，因为我遇到过用了后有时会出现内容消失的情况。
故想到直接去执行工具栏图标的方式完成：
Sub 去除段落首尾空格()
    CommandBars.FindControl(ID:=122).Execute
    CommandBars.FindControl(ID:=123).Execute
End Sub
这样便相当于按了一次居中和两端对齐的按钮。

zhanglei1371

3.我的段落缩进
这应该是我非常满意的作品了。花了我不少时间去反复改进，也是我目前应用最频繁的代码了。作用就是将选定范围的段落首位空格去掉，同时将选定范围的空行去除，若有标题则调整居中，正文格式则首行缩进2.
Sub 我的缩进()
    On Error Resume Next
    Dim t As Single, pa As Paragraph, sp As Integer
    Application.ScreenUpdating = False
    t = Timer
    Dim S As Range
    sp = Selection.End
    Set S = IIf(Selection.Type = wdSelectionIP, ActiveDocument.Content, Selection.Range)  '经典选择语句！！！
    If S = ActiveDocument.Content Then
        AB = MsgBox("要进行全文缩进处理吗？", vbYesNoCancel + vbQuestion, "全文处理判断")
        If AB <> vbYes Then Exit Sub
    End If
    S.Select
    For Each pa In Selection.Paragraphs
        With pa ’从此处向下为对三级标题的设置，大家使用时可按自己喜好DIY。
            If .Style = ("标题 1") Then
                .Range.Font.Size = 30
                .Range.Font.Bold = True
                .Range.Font.Name = "华文行楷"
                .Range.Font.Color = wdColorRed
                .Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
            ElseIf .Style = ("标题 2") Then
                .Range.Font.NameFarEast = "华文隶书"
                .Range.Font.NameAscii = "Arial"
                .Range.Font.Size = 21
                .Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
                .Range.Font.Color = wdColorRed
            ElseIf .Style = ("标题 3") Then
                .Range.Font.Size = 16
                .Range.Font.Bold = True
                .Range.Font.Color = wdColorBlue
                '                    .Range.Font.Name = "华文新魏"
                .Range.Font.Name = "楷体_GB2312"
                .Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
            ElseIf .Style = "正文" Then
                .Range.ParagraphFormat.CharacterUnitFirstLineIndent = 2
            Else
                .Range.ParagraphFormat.CharacterUnitFirstLineIndent = 2
            End If
        End With
        sp = 0
        Do While pa.Range.Characters(1) Like "[" & Chr$(9) & ChrW(160) & ChrW("&H" & "0020") & ChrW("&H" & "E5E5") & Chr$(32) & "　""]"
             pa.Range.Characters(1) = ""
            sp = sp + 1
            If sp > 100 Then Exit Do       '因为有的空格删之不去，加上这两句以防死循环！
        Loop
        pa.Range.Select
        If Len(pa.Range) = 1 Then GoTo aaa:
        sp = 0
        Do While pa.Range.Characters(pa.Range.Characters.Count - 1) Like "[" & Chr$(9) & ChrW(160) & t16 & ChrW("&H" & "0020") & ChrW("&H" & "E5E5") & Chr$(32) & "　""]"
            pa.Range.Characters(pa.Range.Characters.Count - 1) = ""
            sp = sp + 1
            If sp > 100 Then Exit Do
        Loop
aaa:
        If Len(pa.Range) = 1 Then pa.Range.Delete
        S.Select
    Next
    Application.ScreenUpdating = True
    If Timer - t > 5 Then MsgBox "已完成！共消耗时间为：" & Timer - t
End Sub

zhanglei1371

4.自动编号替换为手动编号，word自动编号可以为熟练掌握者在排版时提供很大的便利，而这种自作聪明的自动生成也会让不熟练者非常抓狂。因为自动的变化不容易控制。那么下面这段代码就将其自动转为手动编号，其实核心代码就是第四句。为了令其更规范，将其编号格式进一步替换成为半角点+空格的形式。
Sub 自动编号替换为手动编号()
Dim S As Range
If Selection.Type = wdSelectionIP Then Selection.Expand wdParagraph
Set S = Selection.Range
Selection.Range.ListFormat.ConvertNumbersToText
    With Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "([0-9]{1,})([.．、^9^32" & ChrW(160) & ChrW(12288) & "]{1,})"
        .Wrap = 0
        .Replacement.Text = "\1. "    ‘此处可改为顿号或其他
        .MatchWildcards = 1
        .Execute Replace:=wdReplaceAll
    End With
End Sub

zhanglei1371

5. 批量设定选定区域图片宽度，虽然网上也有类似的代码，但多是对全文进行的操作，而且只对一种有效。本方法适用于嵌入式和浮动式图片，而且仅对选定区域的有效不影响全文其他部分。
Sub 批量设定选定区域图片宽度()
    On Error Resume Next
    M = InputBox("请输入要调整图片的宽度：", "厘米单位", 14) * 28.35
    If Selection.Type = wdSelectionInlineShape Then
        For n = 1 To Selection.InlineShapes.Count
            pw = Selection.InlineShapes(n).Width
            ph = Selection.InlineShapes(n).Height
            Selection.InlineShapes(n).Width = M
            Selection.InlineShapes(n).Height = ph * M / pw
        Next
    ElseIf Selection.Type = wdSelectionShape Then
        Selection.ShapeRange.Width = M
    ElseIf Selection.Type = wdSelectionNormal Then
        Selection.Range.ShapeRange.Width = M
        For n = 1 To Selection.Range.InlineShapes.Count
            pw = Selection.Range.InlineShapes(n).Width
            ph = Selection.Range.InlineShapes(n).Height
            Selection.Range.InlineShapes(n).Width = M
            Selection.Range.InlineShapes(n).Height = ph * M / pw '11111
        Next
    End If
End Sub

zhanglei1371

6. 每行插入表格n个图：这段代码也是我非常满意的代码之一。作用就是将选中的多个图像以表格+文件名的形式插入到文档中，而且自动根据每行插入的图像的个数来调整图像的比例大小。n为每行你要显示的图像数量。
Sub 每行插入表格n个图()
    On Error Resume Next
    Application.ScreenUpdating = False
Dim D As FileDialog, a, P As InlineShape, t As Table
If Selection.Information(wdWithInTable) = True Then MsgBox "请将光标置于表格之外！": Exit Sub
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "请选择..."
        If .Show = -1 Then
        n = InputBox("请输入表格的列数：", "列数", 3)
        M = .SelectedItems.Count
        Debug.Print "共有" & M & "个图片"; M
   h = IIf(M / n = Int(M / n), 2 * M / n, 2 * (Int(M / n) + 1))
   Set t = ActiveDocument.Tables.Add(Selection.Range, h, n)
        t.Borders.Enable = True
t.Borders.OutsideLineStyle = wdLineStyleDouble
            For Each a In .SelectedItems
                B = Split(a, "\")(UBound(Split(a, "\")))
                C = Split(B, ".")(0)
                Set P = Selection.InlineShapes.AddPicture(FileName:=a, SaveWithDocument:=True)
                With P
                    w = .Width
                    .Width = Int(410 / n)
                    .Height = .Width * .Height / w
                End With
                i = i + 1
                Selection.MoveLeft wdCharacter, 1
                Selection.MoveDown wdLine, 1
                Selection.TypeText C
Selection.Cells(1).Select
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter '决定了首行居中
Selection.HomeKey
Selection.MoveDown wdLine, -1
                Selection.MoveRight wdCharacter, 2
                Debug.Print i, n
                If i = Val(n) Then
                    Selection.MoveRight wdCharacter, 1
                    Selection.Cells(1).Select
                    Selection.EndKey
                    Selection.MoveDown wdLine, 1
                    i = 0
                End If
            Next
        End If
    End With
    Application.ScreenUpdating = True
End Sub

zhanglei1371

7. 表格行列转置代码，本代码能够实现表格行变成列，列变成行，也就是翻转90度吧，论坛有类似的代码，但本代码的特点在于加入原来表格有格式的话，比如颜色，再转置后能保留格式不丢失。
Sub 表格行列转置()
On Error Resume Next
Dim a As Table, B As Table
Set a = Selection.Tables(1)
Debug.Print a.Cell(1, 2).Range.Text
i = a.Rows.Count
j = a.Columns.Count
Selection.EndKey wdStory
Selection.TypeParagraph
Set B = Selection.Tables.Add(Selection.Range, j, i)
    B.Borders.Enable = 1
    For S = 1 To i
        For P = 1 To j
        Debug.Print S, P
        Debug.Print a.Cell(S, P).Range.Text
        Text = a.Cell(S, P).Range
        B.Cell(P, S).Range = Mid(Text, 1, Len(Text) - 2) '不用mid会自动生成回车
        B.Cell(P, S).Range.Font.Color = a.Cell(S, P).Range.Font.Color
        B.Cell(P, S).Shading.BackgroundPatternColor = a.Cell(S, P).Shading.BackgroundPatternColor
        Next
    Next
a.Delete
End Sub

东亚五金

谢谢楼主分享，这是excel用的还是word用的

zhanglei1371

8. 四重查找替换，本代码主要是让喜欢查找替换的朋友做一个参考，并不是像上面代码一样直接拿来使用，作用就是逐渐缩小范围来查找，直至缩小四次。有兴趣的朋友可在word文档键入=rand(15,3)回车测试下。
Sub 四重查找()
    Selection.HomeKey wdStory
    'With Selection.Find
    With ActiveDocument.Content.Find
        .Text = "那只[!^13]@懒狗[!^13]@^13"
        .MatchWildcards = 1
        Do While .Execute
            .Parent.Select
            .Parent.Font.Color = wdColorBrightGreen
            Dim S As Range, P As Range, R As Range
            Set ss = Selection.Range
            Set S = Selection.Range.Duplicate
            With S.Find
                .Text = "敏捷*那只"
                .MatchWildcards = 1
                Do While .Execute
                    If Not .Parent.InRange(ss) Then
                        Exit Do
                    Else
                        .Parent.Font.Color = wdColorBlue
                    End If
                    Debug.Print .Parent
                    Set P = .Parent.Duplicate
                    With P.Find
                        .Text = "棕毛*跃过"
                        .MatchWildcards = 1
                        Do While .Execute
                            If Not .Parent.InRange(ss) Then
                                Exit Do
                            Else
                                .Parent.Font.Color = wdColorPink
                            End If
                            Debug.Print .Parent
                            Set R = .Parent.Duplicate
                            With R.Find
                                .Text = "狐狸"
                                .MatchWildcards = 1
                                .Replacement.Font.Color = vbRed
                                .Execute , , , , , , , , , , 2
                                .Text = "狐"
                                .Replacement.Font.Size = 24
                                .Replacement.Font.Bold = 1
                                .Replacement.Font.Color = wdColorBlack
                                .Execute , , , , , , , , , , 2
                            End With
                        Loop
                    End With
                Loop
            End With
        Loop
    End With
End Sub

zhanglei1371

9.  干掉不正常的大纲级别：经常排版懂得自动生成目录的朋友可能会遇到这样的情况，就是在自动生成的目录总会有大段大段的文本段落混在当中，而定位到这些段落时又发现和周围的正文没有区别，其实是这些文本的大纲级别为123级造成的，下面的代码用于解决这样的情况。
Sub 干掉不正常的大纲级别()
On Error Resume Next
Application.ScreenUpdating = False
t = Timer
    Dim S As Paragraph
    For Each S In ActiveDocument.Paragraphs
        If S.OutlineLevel = wdOutlineLevel1 And S.Range.ParagraphFormat.Style <> "标题 1" Then
            S.OutlineLevel = wdOutlineLevelBodyText
        ElseIf S.OutlineLevel = wdOutlineLevel2 And S.Range.ParagraphFormat.Style <> "标题 2" Then
            S.OutlineLevel = wdOutlineLevelBodyText
        ElseIf S.OutlineLevel = wdOutlineLevel3 And S.Range.ParagraphFormat.Style <> "标题 3" Then
            S.OutlineLevel = wdOutlineLevelBodyText
        End If
    Next
Application.ScreenUpdating = True
  If ActiveDocument.Path <> "" Then ActiveDocument.Save
  If Timer - t > 5 Then MsgBox "已完成！共消耗时间为：" & Timer - t
End Sub