|
|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
好久没有在家园里露面了。呵呵。
使用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, 下载次数: 632)
[ 本帖最后由 雨雪霏霏 于 2010-1-13 07:51 编辑 ] |
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2010-1-11 11:49
楼主
发表于 2010-1-11 17:24
