Word2003 VBA 小代码集粹

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发表的帖子，
'链接为/viewthread.php?tid=112178；
'②守柔版主于2005-7-27年发表于站内的文章《Word中鲜为人知的三招》，
'链接为/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 = "header.htm" Then
w.Text = ""
ActiveDocument.HTMLProject.RefreshProject
ActiveDocument.HTMLProject.RefreshD
ocument
If 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发表的帖子，
'链接为/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:0
6:29 发表的帖子，
'链接为/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，
'链接为/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
mandBars("Edit").Controls("查找(&F)...").Execute
End With
End Sub


'12．-------------------------------------------------------------------------------------
Sub 以选定文本从选区后发生一次查找__不出现查找对话框()
'此宏本自sylun于2008.04.03 10:52:13发表的帖子，
'链接为/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发表的帖子，
'链接为/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 &quo
t;N" + Trim(Str(j)) + "■"
End If
End If
End If
End If
j = j + 1
Next
End Sub


'14．------------------------------------

-----------


Dim CurrentPageStart As Long, CurrentPageEnd As Long, myRange As Range
Dim Currentpage As Integer, Pages As Integer
On Error Resume Next
Currentpage = rmation(wdActiveEndPageNumber)
Pages = rmation(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，
'链接为/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，
'链接为/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
Sele
ction.Paste
MyDoc.Close False
Next
End If
meDoc.SaveAs FileName:=myPath & "\合并文档.doc"
meDoc.Close True
End With
Application

.ScreenUpdating = True

本文来源：https://www.bwwdw.com/article/6r0e.html