Word2003 VBA 小代码集粹

雨雪霏霏 · 发表于 2010-1-11 11:49

　　好久没有在家园里露面了。呵呵。
　　使用Word也有些年头了，以下贴出一些我经常使用的VBA代码，希望能给兄弟姐妹带来一些方便。
　　其中有一些是照搬网友的成果，有一些我进行了一些小改动，还有一些是自己的小制作。
　　为了交流使用的方便，代码中的宏名全部使用中文。
　　恳请兄弟姐妹测试改进！

　　抛砖旨在引玉，欢迎兄弟姐妹贡献出“箱藏宝贝”！
　　众人拾柴火焰高，共同努力提升Word操作效率！

　　1．完美显示图片表格的普通视图
　　2．完美显示图片表格的页面视图
　　3．彻底删除页眉页脚
　　4．切换纵横向页面
　　5．禁用“改写”模式
　　6．无格式粘贴
　　7．与设备无关的位图
　　8．全文编号转文本
　　9．将包含指定字符的段落设为标题1样式
　　10．全文全角字母和数字转为半角
　　11．以选定文本从文档首查找__弹出查找对话框
　　12．以选定文本从选区后发生一次查找__不出现查找对话框
　　13．全文段首加段号
　　14．全选当前页
　　15．删除指定文件夹下所有Word文档的前三段
　　16．复制指定文件夹下所有文档至同目录新文档

'1．-------------------------------------------------------------------------------------
Sub 完美显示图片表格的普通视图()
'此宏为雨雪霏霏特别奉献的小偏方，欢迎各位朋友测试。
'如果文档中的嵌入式图片、表格显示迟滞、错位，运行此宏，将在普通视图下完美显示它们。

ActiveDocument.PrintPreview
ActiveDocument.ClosePrintPreview
ActiveWindow.View.Type = wdNormalView
End Sub

'2．-------------------------------------------------------------------------------------
Sub 完美显示图片表格的页面视图()
'此宏为雨雪霏霏特别奉献的小偏方，欢迎各位朋友测试。
'如果文档中的各种图片、表格显示迟滞、错位，运行此宏，将在页面视图下完美显示它们。

ActiveDocument.PrintPreview
ActiveDocument.ClosePrintPreview
ActiveWindow.View.Type = wdNormalView
ActiveWindow.View.Type = wdPrintView
End Sub

'3．-------------------------------------------------------------------------------------
Sub 彻底删除页眉页脚()
'此宏为雨雪霏霏试写。思路来自：
'①konggs版主于2005-7-26 20:38、2005-7-27 08:51发表的帖子，
'链接为http://club.excelhome.net/viewthread.php?tid=112178；
'②守柔版主于2005-7-27年发表于站内的文章《Word中鲜为人知的三招》，
'链接为http://www.excelhome.cn/Article/ShowArticle.asp?ArticleID=439。

'此宏不足处在于：
'①刪除页眉页脚后不能再恢复；
'②本地文档进行删除操作后不保存退出的话，会在下次启动Word时出现文档恢复窗格。

Dim w, y As String
Application.ScreenUpdating = False
Set w = ActiveDocument.HTMLProject.HTMLProjectItems(2)
If ActiveDocument.HTMLProject.HTMLProjectItems.Count = 2 Then
      If w.Name = "header.htm" Then
         w.Text = ""
         ActiveDocument.HTMLProject.RefreshProject
         ActiveDocument.HTMLProject.RefreshDocument
         If ActiveDocument.Name Like "*.doc" Then
            MsgBox "本文档页眉页脚已彻底清除，请及时保存。" & Chr(13) & _
                     "若退出本地文档时未保存，重新启动Word时将出现恢复窗格。", vbExclamation, "ExcelHome"
         Else
            Exit Sub
         End If
      End If
Else
      MsgBox "本文档当前未设置页眉页脚，不需要进行删除操作。", vbOKOnly, "ExcelHome"
End If
Application.ScreenUpdating = True
End Sub

'4．-------------------------------------------------------------------------------------
Sub 切换纵横向页面()
'在"纵向页面"与"横向页面"间切换。

If ActiveDocument.PageSetup.Orientation = wdOrientLandscape Then
      ActiveDocument.PageSetup.Orientation = wdOrientPortrait
Else
      ActiveDocument.PageSetup.Orientation = wdOrientLandscape
End If
End Sub

'5．-------------------------------------------------------------------------------------
Sub OverType()
'想永久不进入Word的"改写"模式，将此代码贴入VBE即可。
Options.OverType = False
End Sub

'6．-------------------------------------------------------------------------------------
Sub 无格式粘贴()
'将剪贴板上的内容以"无格式文本"方式粘贴到当前位置。
Selection.PasteAndFormat (wdFormatPlainText)
End Sub

'7．-------------------------------------------------------------------------------------
Sub 与设备无关的位图()
'将剪贴板上的图片以"与设备无关的位图"方式粘贴到当前位置。
'特别适用于从网上复制了某个图片之后，快速、干净地将之粘贴到Word文档中。
Selection.Range.PasteSpecial DataType:=wdPasteDeviceIndependentBitmap, Placement:=wdInLine
End Sub

'8．-------------------------------------------------------------------------------------
Sub 全文编号转文本()
'将文档中全部自动编号转成正常文本。
ActiveDocument.Range.ListFormat.ConvertNumbersToText
End Sub

'9．-------------------------------------------------------------------------------------
Sub 将包含指定字符的段落设为标题1样式()
'此宏本自sylun于2008-2-24 13:35发表的帖子，
'链接为http://club.excelhome.net/viewthread.php?tid=300641。

Selection.HomeKey wdStory
Dim tdwb As String
tdwb = InputBox("将所有包含指定字符的段落设置为标题1样式。" & _
                  Chr(13) & Chr(13) & Chr(13) & "请输入：", "ExcelHome")
With Selection.Find
      .ClearFormatting
      Do While .Execute(FindText:=tdwb)
         .Parent.Bookmarks("\Para").Range.Style = ActiveDocument.Styles("标题 1")
      Loop
End With
Selection.HomeKey wdStory
End Sub

'10．-------------------------------------------------------------------------------------
Sub 全文全角字母和数字转为半角()
'此宏本自chylhr于2007-11-26 18:06:29 发表的帖子，
'链接为http://club.excelhome.net/dispbb ... 281588&page=30&px=0。

Dim myRange As Range
Set myRange = ActiveDocument.Content
myRange.Find.ClearFormatting
Do While myRange.Find.Execute(FindText:="[Ａ-Ｚａ-ｚ０-９]", _
                              Wrap:=wdFindStop, Format:=False, MatchWildcards:=True)
      myRange.CharacterWidth = wdWidthHalfWidth
      Set myRange = ActiveDocument.Range(myRange.End, ActiveDocument.Content.End)
Loop
End Sub

'11．-------------------------------------------------------------------------------------
Sub 以选定文本从文档首查找__弹出查找对话框()
'守柔版主原创，原帖发表于2008-4-3 06:07，
'链接为http://club.excelhome.net/thread-310233-3-6.html。

'请指定快捷键为CTRL+F
Dim strFind As String
On Error Resume Next
With Selection
      If .Type <> wdSelectionIP Then
         strFind = .Text
         If Len(strFind) > 255 Then Exit Sub
         .Find.Execute FindText:=strFind, Wrap:=wdFindStop
         .HomeKey wdStory
      End If
      Application.CommandBars("Edit").Controls("查找(&F)...").Execute
End With
End Sub

'12．-------------------------------------------------------------------------------------
Sub 以选定文本从选区后发生一次查找__不出现查找对话框()
'此宏本自sylun于2008.04.03 10:52:13发表的帖子，
'链接为http://club.excelhome.net/viewthread.php?tid=310233&extra=&page=3。
'使用此宏前请点VBE"工具→引用→Microsoft Forms 2.0 Object Library (C:\WINNT\system32\FM20.DLL)"。

Dim myData As DataObject
With Selection
      If .Type = wdSelectionNormal And .Characters.Count < 255 Then
         .Copy
      End If
End With
Selection.Collapse wdCollapseEnd
Set myData = New DataObject
myData.GetFromClipboard
With Dialogs(wdDialogEditFind)
      .Find = myData.GetText(1)
      .Execute
End With
End Sub

'13．-------------------------------------------------------------------------------------
Sub 全文段首加段号()
'此宏本自peihuatlb于2009-12-18 17:28发表的帖子，
'链接为http://club.excelhome.net/thread-512830-1-1.html。

Application.ScreenUpdating = False
Dim I As Paragraph
Dim j As Integer
j = 1
For Each I In ActiveDocument.Paragraphs
      If j < 10 Then
         I.Range.Characters(1).InsertBefore "N" + "000" + Trim(Str(j)) + "■"
      Else
         If j >= 10 And j < 100 Then
            I.Range.Characters(1).InsertBefore "N" + "00" + Trim(Str(j)) + "■"
         Else
            If j >= 100 And j < 1000 Then
                  I.Range.Characters(1).InsertBefore "N" + "0" + Trim(Str(j)) + "■"
            Else
                  If j >= 1000 Then
                     I.Range.Characters(1).InsertBefore "N" + Trim(Str(j)) + "■"
                  End If
            End If
         End If
      End If
      j = j + 1
Next
End Sub

'14．-------------------------------------------------------------------------------------
Sub 全选当前页()
'守柔版主原创，原帖发表于2004-11-1 06:03，
'链接为http://club.excelhome.net/thread-67954-1-1.html

Dim CurrentPageStart As Long, CurrentPageEnd As Long, myRange As Range
Dim Currentpage As Integer, Pages As Integer
On Error Resume Next
Currentpage = Selection.Information(wdActiveEndPageNumber)
Pages = Selection.Information(wdNumberOfPagesInDocument)
CurrentPageStart = Selection.GoTo(what:=wdGoToPage, Which:=wdGoToNext, Name:=Currentpage).start
If Currentpage = Pages Then
      CurrentPageEnd = ActiveDocument.Content.End
Else
      CurrentPageEnd = Selection.GoTo(what:=wdGoToPage, Which:=wdGoToNext, Name:=Currentpage + 1).start
End If
Set myRange = ActiveDocument.Range(CurrentPageStart, CurrentPageEnd)
myRange.Select
End Sub

'15．-------------------------------------------------------------------------------------
Sub 删除指定文件夹下所有Word文档的前三段()
'kqbt原创，原帖发表于2009-12-21 23:53，
'链接为http://club.excelhome.net/thread-516002-1-1.html。

Application.ScreenUpdating = False
Dim myPath As String, I As Integer, MyDoc As Document
With Application.FileDialog(msoFileDialogFolderPicker)
      .Title = "选择目标文件夹"
      If .Show = -1 Then
         myPath = .SelectedItems(1)
      Else
         Exit Sub
      End If
End With
With Application.FileSearch
      .LookIn = myPath
      .FileType = msoFileTypeWordDocuments
      If .Execute > 0 Then
         For I = 1 To .FoundFiles.Count
            Set MyDoc = Documents.Open(FileName:=.FoundFiles(I), Visible:=False)
            MyDoc.Range(MyDoc.Paragraphs(1).Range.start, MyDoc.Paragraphs(3).Range.End).Delete
            MyDoc.Close True
         Next
      End If
End With
Application.ScreenUpdating = True
End Sub

'16．-------------------------------------------------------------------------------------
Sub 复制指定文件夹下所有文档至同目录新文档()
'kqbt原创，原帖发表于2009-12-2 16:40，
'链接为http://club.excelhome.net/thread-508243-1-7.html。

Application.ScreenUpdating = False
Dim myPath As String, myName As String, I As Integer, meDoc, MyDoc
With Application.FileDialog(msoFileDialogFolderPicker)
      .Title = "选择目标文件夹"
      If .Show = -1 Then
         myPath = .SelectedItems(1)
      Else
         Exit Sub
      End If
End With
With Application.FileSearch
      .LookIn = myPath
      .FileType = msoFileTypeWordDocuments
      If .Execute > 0 Then
         Set meDoc = Documents.Add
         For I = 1 To .FoundFiles.Count
            Set MyDoc = Documents.Open(FileName:=.FoundFiles(I), Visible:=False)
            MyDoc.Range.Copy
            Selection.Paste
            MyDoc.Close False
         Next
      End If
      meDoc.SaveAs FileName:=myPath & "\合并文档.doc"
      meDoc.Close True
End With
Application.ScreenUpdating = True
End Sub

Word2003 VBA 小代码集粹.rar (4.02 KB, 下载次数: 630)

[ 本帖最后由雨雪霏霏于 2010-1-13 07:51 编辑 ]

雨雪霏霏 · 发表于 2010-1-11 11:57

（二楼作个预留。呵呵。）

wxq12121 · 发表于 2010-1-11 13:53

学习一下，呵呵

hoper023 · 发表于 2010-1-11 17:13

谢谢，等有空我也整理一下！！

kqbt · 发表于 2010-1-11 17:24

登记一下，等着淘宝

守柔 · 发表于 2010-1-12 10:36

雨兄辛苦了，善哉！

雨雪霏霏 · 发表于 2010-1-13 08:14

原帖由守柔于 2010-1-12 10:36 发表
雨兄辛苦了，善哉！

　　呵呵，点滴做起！
　　即使不能仰见已把Word之剑使得出神入化的老大，也还可以像蜗牛一样，一步一步往上爬，到小草尖上荡秋千，与小露珠玩耍。
　　老大、孔兄、sylun兄等等剑侠，已为Word版块创出“风光无限好”的大石林，小弟难追形神，在后头当一个小小资料搜集员，亦乐在其中！
　　老大、孔兄前头已为小弟VBA之路花了许多心血，奈何小弟资质愚钝，又不下功夫学，全无长进，惶哉愧哉！
　　祈望百忙中的老大，还能抽暇加以指点！幸甚！

xxsj · 发表于 2010-1-18 17:45

学习学习！

tangqingfu · 发表于 2010-2-8 12:24

谢谢雨雪霏霏兄的分享，收藏学习！

zx710627 · 发表于 2010-2-8 13:27

真是个学习的好地方。

		自动登录	找回密码
密码			免费注册

[分享] Word2003 VBA 小代码集粹

VBA石林中的蜗牛