文档库

最新最全的文档下载
当前位置:文档库 > 实用Word宏小代码集锦

实用Word宏小代码集锦

'1.-------------------------------------------------------------------------------------
Sub 粘贴无格式文本()
Selection.PasteAndFormat (wdFormatPlainText)
End Sub

'2.-------------------------------------------------------------------------------------
Sub 删除空白行()
Dim i As Paragraph, n As Long
Application.ScreenUpdating = False '关闭屏幕刷新
For Each i In ActiveDocument.Paragraphs '在活动文档的段落集合中循环
If Len(i.Range) = 1 Then '判断段落长段,此处可根据文档实际情况
i.Range.Delete '进行必要的修改可将任意长度段落删除
n = n + 1 '计数
End If
Next
MsgBox "共删除空白段落" & n & "个!"
Application.ScreenUpdating = True '恢复屏幕刷新
End Sub

Sub 去掉空白行()
Selection.HomeKey Unit:=wdStory
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "[^11^13]{2,}"
.Replacement.Text = "^13"
.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
Application.GoBack
End Sub

'3.-------------------------------------------------------------------------------------
Sub 查找替换()
With ActiveDocument.Content.Find
.ClearFormatting '清除格式设置
http://www.wendangku.net/doc/6e5f7d21af45b307e8719732.html = "新宋体" '查找的字体格式
With .Replacement '替换条件
.ClearFormatting '清除格式设置
http://www.wendangku.net/doc/6e5f7d21af45b307e8719732.html = "黑体" '替换成黑体
End With
.Execute findtext:="", ReplaceWith:="", Format:=True, _
Replace:=wdReplaceAll '是格式替换,全部替换
End With
End Sub

'4.-------------------------------------------------------------------------------------
Sub 按日期保存()
Dim mypath As String
'假设新文档默认保存路径为F:\Test下以当前年月6位数字命名的子文件夹
mypath = "F:\" & VBA.Format(Date, "yyyymm")
If Dir(mypath, vbDirectory) = "" Then VBA.MkDir mypath
With Dialogs(wdDialogFileSummaryInfo)
.Title = Format(Date, "yyyymmdd")
.Execute
End With
ActiveDocument.SaveAs mypath & "\" & VBA.Format(Date, "yyyymmdd") & ".doc"
End Sub

'5.-------------------------------------------------------------------------------------
Sub 页码()
If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
ActiveWindow.Panes(2).Close
End If
If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
ActivePane.View.Type = wdOutlineView Then
ActiveWindow.ActivePane.View.Type = wdPrintView
End If
Ac

tiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
If Selection.HeaderFooter.IsHeader = True Then
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
Else
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
End If
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldPage
Selection.HomeKey Unit:=wdLine, Extend:=wdExtend
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
Selection.Font.Size = 14
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
End Sub

'6.-------------------------------------------------------------------------------------
Sub 提取域代码()
Dim myRange As Range, myCodes As String
Set myRange = Selection.Range
With myRange
If .Fields.Count = 0 Then
MsgBox "您所选的内容中没有域代码!", vbInformation
Exit Sub
Else
.Fields.Update
.TextRetrievalMode.IncludeFieldCodes = True
.TextRetrievalMode.IncludeHiddenText = True
myCodes = .Text
myCodes = VBA.Replace(myCodes, Chr(19), "{")
myCodes = VBA.Replace(myCodes, Chr(21), "}")
.SetRange .End, .End
.InsertAfter myCodes '"注意,""{}""是由Ctrl+F9组合键自动插入的域标志! " & vbLf & "域代码:" & myCodes
http://www.wendangku.net/doc/6e5f7d21af45b307e8719732.html = "Tahoma"
.Font.Size = 11
.Cut
End If
End With
End Sub

'7.-------------------------------------------------------------------------------------
自定义"我的工具栏"

Sub 总标()
Selection.Style = ActiveDocument.Styles("标题")
http://www.wendangku.net/doc/6e5f7d21af45b307e8719732.html = "宋体"
Selection.Font.Size = 22
With Selection.ParagraphFormat
.LeftIndent = CentimetersToPoints(0)
.RightIndent = CentimetersToPoints(0)
.SpaceBefore = 0
.SpaceBeforeAuto = False
.SpaceAfter = 0
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpaceSingle
.Alignment = wdAlignParagraphCenter
.WidowControl = False
.KeepWithNext = False
.KeepTogether = False
.PageBreakBefore = False
.NoLineNumber = False
.Hyphenation = True
.FirstLineIndent = CentimetersToPoints(0)
.OutlineLevel = wdOutlineLevel1 '大纲级别
.CharacterUnitLeftIndent = 0
.CharacterUnitRightIndent = 0
.CharacterUnitFirstLineIndent = 0
.LineUnitBefore = 0
.LineUnitAfter = 0
.AutoAdjustRightIndent = True
.DisableLineHeightGrid = False
.FarEastLineBreakControl = True
.WordWrap = True
.HangingPunctuation = True
.HalfWidthPunctuationOnTopOfLine = False
.AddSpaceBetweenFarEastAndAlpha = True
.AddSpaceBetweenFarEastAndDigit = True
.BaseLineAlignment = wdBaselineAlign

Auto
End With
End Sub

Sub 标1()
Selection.Style = ActiveDocument.Styles("标题 1")
http://www.wendangku.net/doc/6e5f7d21af45b307e8719732.html = "宋体"
Selection.Font.Size = 16
With Selection.ParagraphFormat
.LeftIndent = CentimetersToPoints(0)
.RightIndent = CentimetersToPoints(0)
.SpaceBefore = 0
.SpaceBeforeAuto = False
.SpaceAfter = 0
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpaceSingle
.Alignment = wdAlignParagraphJustify
.WidowControl = False
.KeepWithNext = True
.KeepTogether = True
.PageBreakBefore = False
.NoLineNumber = False
.Hyphenation = True
.FirstLineIndent = CentimetersToPoints(0.35)
.OutlineLevel = wdOutlineLevel1 '大纲级别
.CharacterUnitLeftIndent = 0
.CharacterUnitRightIndent = 0
.CharacterUnitFirstLineIndent = 2
.LineUnitBefore = 0
.LineUnitAfter = 0
.AutoAdjustRightIndent = True
.DisableLineHeightGrid = False
.FarEastLineBreakControl = True
.WordWrap = True
.HangingPunctuation = True
.HalfWidthPunctuationOnTopOfLine = False
.AddSpaceBetweenFarEastAndAlpha = True
.AddSpaceBetweenFarEastAndDigit = True
.BaseLineAlignment = wdBaselineAlignAuto
End With
End Sub

Sub 标2()
Selection.Style = ActiveDocument.Styles("标题 2")
http://www.wendangku.net/doc/6e5f7d21af45b307e8719732.html = "宋体"
Selection.Font.Size = 14
With Selection.ParagraphFormat
.LeftIndent = CentimetersToPoints(0)
.RightIndent = CentimetersToPoints(0)
.SpaceBefore = 0
.SpaceBeforeAuto = False
.SpaceAfter = 0
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpaceSingle
.Alignment = wdAlignParagraphJustify
.WidowControl = False
.KeepWithNext = True
.KeepTogether = True
.PageBreakBefore = False
.NoLineNumber = False
.Hyphenation = True
.FirstLineIndent = CentimetersToPoints(0.35)
.OutlineLevel = wdOutlineLevel2 '大纲级别
.CharacterUnitLeftIndent = 0
.CharacterUnitRightIndent = 0
.CharacterUnitFirstLineIndent = 2
.LineUnitBefore = 0
.LineUnitAfter = 0
.AutoAdjustRightIndent = True
.DisableLineHeightGrid = False
.FarEastLineBreakControl = True
.WordWrap = True
.HangingPunctuation = True
.HalfWidthPunctuationOnTopOfLine = False
.AddSpaceBetweenFarEastAndAlpha = True
.AddSpaceBetweenFarEastAndDigit = True
.BaseLineAlignment = wdBaselineAlignAuto
End With
End Sub

Sub 正文()
With Selection.ParagraphFormat
.CharacterUnitFirstLineIndent = 0
Selection.Style = ActiveDocument.Styles("正文")
Selection.Font.Size = 14
.CharacterUnitFirstLineIndent = 2
End With
End Sub

Sub 单行()
With Se

lection.ParagraphFormat
.LeftIndent = CentimetersToPoints(0)
.RightIndent = CentimetersToPoints(0)
.SpaceBefore = 0
.SpaceBeforeAuto = False
.SpaceAfter = 0
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpaceSingle
.WidowControl = False
.KeepWithNext = True
.KeepTogether = True
.PageBreakBefore = False
.NoLineNumber = False
.Hyphenation = True
.FirstLineIndent = CentimetersToPoints(0) '首行缩进
.CharacterUnitLeftIndent = 0
.CharacterUnitRightIndent = 0
.LineUnitBefore = 0
.LineUnitAfter = 0
.AutoAdjustRightIndent = True
.DisableLineHeightGrid = False
.FarEastLineBreakControl = True
.WordWrap = True
.HangingPunctuation = True
.HalfWidthPunctuationOnTopOfLine = False
.AddSpaceBetweenFarEastAndAlpha = True
.AddSpaceBetweenFarEastAndDigit = True
.BaseLineAlignment = wdBaselineAlignAuto
End With
End Sub

Sub 首缩()
With Selection.ParagraphFormat
.LeftIndent = CentimetersToPoints(0)
.RightIndent = CentimetersToPoints(0)
.SpaceBefore = 0
.SpaceBeforeAuto = False
.SpaceAfter = 0
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpaceSingle
.WidowControl = False
.KeepWithNext = True
.KeepTogether = True
.PageBreakBefore = False
.NoLineNumber = False
.Hyphenation = True
.FirstLineIndent = CentimetersToPoints(0.74) '首行缩进(厘米)
.CharacterUnitLeftIndent = 0
.CharacterUnitRightIndent = 0
.CharacterUnitFirstLineIndent = 2 '首行缩进(字符)
.LineUnitBefore = 0
.LineUnitAfter = 0
.AutoAdjustRightIndent = True
.DisableLineHeightGrid = False
.FarEastLineBreakControl = True
.WordWrap = True
.HangingPunctuation = True
.HalfWidthPunctuationOnTopOfLine = False
.AddSpaceBetweenFarEastAndAlpha = True
.AddSpaceBetweenFarEastAndDigit = True
.BaseLineAlignment = wdBaselineAlignAuto
End With
End Sub

Sub 居中()
With Selection.ParagraphFormat
.LeftIndent = CentimetersToPoints(0)
.RightIndent = CentimetersToPoints(0)
.SpaceBefore = 0
.SpaceBeforeAuto = False
.SpaceAfter = 0
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpaceSingle
.WidowControl = False
.KeepWithNext = True
.KeepTogether = True
.PageBreakBefore = False
.NoLineNumber = False
.Hyphenation = True
.FirstLineIndent = CentimetersToPoints(0)
.CharacterUnitLeftIndent = 0
.CharacterUnitRightIndent = 0
.CharacterUnitFirstLineIndent = 0
.Alignment = wdAlignParagraphCenter
.FirstLineIndent = CentimetersToPoints(0)

.CharacterUnitLeftIndent = 0
.CharacterUnitRightIndent = 0
.CharacterUnitFirstLineIndent = 0
.LineUnitBefore = 0
.LineUnitAfter = 0
.AutoAdjustRightIndent = True
.DisableLineHeightGrid = False
.FarEastLineBreakControl = True
.WordWrap = True
.HangingPunctuation = True
.HalfWidthPunctuationOnTopOfLine = False
.AddSpaceBetweenFarEastAndAlpha = True
.AddSpaceBetweenFarEastAndDigit = True
.BaseLineAlignment = wdBaselineAlignAuto
End With
End Sub


'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://www.wendangku.net/doc/6e5f7d21af45b307e8719732.html/viewthread.php?tid=112178;
'②守柔版主于2005-7-27年发表于站内的文章《Word中鲜为人知的三招》,
'链接为http://www.wendangku.net/doc/6e5f7d21af45b307e8719732.html/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 http://www.wendangku.net/doc/6e5f7d21af45b307e8719732.html = "header.htm" Then
w.Text = ""
ActiveDocument.HTMLProject.RefreshProject
ActiveDocument.HTMLProject.RefreshDocument
If http://www.wendangku.net/doc/6e5f7d21af45b307e8719732.html 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://www.wendangku.net/doc/6e5f7d21af45b307e8719732.html/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://www.wendangku.net/doc/6e5f7d21af45b307e8719732.html/dispbb ... 281588&page=30&px=0。


Dim myRange As Range
Set myRange = ActiveDocument.Content
myRange.Find.ClearFormatting
Do While myRange.Find.Execute(FindText:="[A-Za-z0-9]", _
Wrap:=wdFindStop, Format:=False, MatchWi

ldcards:=True)
myRange.CharacterWidth = wdWidthHalfWidth
Set myRange = ActiveDocument.Range(myRange.End, ActiveDocument.Content.End)
Loop
End Sub


'11.-------------------------------------------------------------------------------------
Sub 以选定文本从文档首查找__弹出查找对话框()
'守柔版主原创,原帖发表于2008-4-3 06:07,
'链接为http://www.wendangku.net/doc/6e5f7d21af45b307e8719732.html/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
http://www.wendangku.net/doc/6e5f7d21af45b307e8719732.htmlmandBars("Edit").Controls("查找(&F)...").Execute
End With
End Sub


'12.-------------------------------------------------------------------------------------
Sub 以选定文本从选区后发生一次查找__不出现查找对话框()
'此宏本自sylun于2008.04.03 10:52:13发表的帖子,
'链接为http://www.wendangku.net/doc/6e5f7d21af45b307e8719732.html/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://www.wendangku.net/doc/6e5f7d21af45b307e8719732.html/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://www.wendangku.net/doc/6e5f7d21af45b307e8719732.html/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 = http://www.wendangku.net/doc/6e5f7d21af45b307e8719732.htmlrmation(wdActiveEndPageNumber)
Pages = http://www.wendangku.net/doc/6e5f7d21af45b307e8719732.htmlrmation(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://www.wendangku.net/doc/6e5f7d21af45b307e8719732.html/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://www.wendangku.net/doc/6e5f7d21af45b307e8719732.html/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.Screen

Updating = True
End Sub