1 宏共享

任意打开或新建一Word文档，怎样才能看到需要共享的宏？将代码保存到Normal.docm即可！该文档是word的模板文档，会在新建或打开任一word文档时伴随打开，相应的，其中包含的VBA代码也就可以访问了。

操作步骤：

“开发工具”选项卡→宏→Visaul Basic→左侧单击Normal工程→插入→模块→将上述的代码复制到右边的代码窗口。

Normal.docm的具体路径如下：

C:\\Users\username\\AppData\Roaming\\Microsoft\\Templates

2 宏自动运行

2.1 宏名为AutoOpen的宏会自动随文档启动而启动：

sub AutoOpen()

msgbox "auto open!"

end sub

2.2 利用Document对象的Open事件：

在你的VBA项目的ThisDocument对象程序窗口中插入：

Private Sub Document_Open()

msgboxc "document open！"

End Sub

3 自定义工具栏

'添加自定义菜单

'定义一些全局变量

Dim Obj_Toolbar As CommandBar '代表工具栏的变量

Sub AutoOpen()

'Sub Document_Open()

On Error Resume Next

Application.CommandBars("Bars1").Delete

With Application.CommandBars.Add("Bars1", msoBarTop, , True)

.Visible = True

With .Controls.Add

.FaceId = 263

.TooltipText = "替换页眉页脚"

.OnAction = "替换页眉页脚.替换页眉页脚"

.Caption = "替换页眉页脚(&Q)"

.Style = msoButtonIconAndCaption

End With

With .Controls.Add

.FaceId = 264

.TooltipText = "网上复制文本格式"

.OnAction = "网上复制文本格式.网上复制文本格式1"

.Caption = "网上复制文本格式1(&Q)"

.Style = msoButtonIconAndCaption

End With

With .Controls.Add

.FaceId = 264

.TooltipText = "网上复制文本格式2不操作空白段落"

.OnAction = "网上复制文本格式.网上复制文本格式2不操作空白段落"

.Caption = "网上复制文本格式2不操作空白段落(&Q)"

.Style = msoButtonIconAndCaption

End With

With .Controls.Add

.FaceId = 264

.TooltipText = "网上复制文本格式3没有段落"

.OnAction = "网上复制文本格式.网上复制文本格式3没有段落"

.Caption = "网上复制文本格式3没有段落(&Q)"

.Style = msoButtonIconAndCaption

End With

End With

Set Obj_Toolbar = Application.CommandBars.Add("My_Custom_Bar") '新建工具栏，“My_Custom_Bar”代表工具栏的名称

Set Obj_Toolbar_button = Obj_Toolbar.Controls.Add(Type:=msoControlButton, ID:=1) '新建工具栏按钮

With Obj_Toolbar_button '设置按钮的属性

.Caption = "汉字中间的空格替换掉"

.Style = msoButtonIconAndCaption

.FaceId = 684

.OnAction = "网上复制文本格式.汉字中间的空格替换掉"

End With

Set Obj_Toolbar_button = Obj_Toolbar.Controls.Add(Type:=msoControlButton, ID:=1) '新建工具栏按钮

With Obj_Toolbar_button '设置按钮的属性

.Caption = "删除空白段落"

.Style = msoButtonIconAndCaption

.FaceId = 384

.OnAction = "网上复制文本格式.删除空白段落"

End With

With Obj_Toolbar '设置工具栏的属性

.Visible = True '工具栏可视

.Enabled = True '工具栏可用

.Position = msoBarTop '工具栏置顶

End With

End Sub

效果如下：

word如何编辑vba窗体（WordVBA宏共享）(1)

附相关宏：

Sub 替换页眉页脚()

If ActiveWindow.View.SplitSpecial <> wdPaneNone Then ActiveWindow.Panes(2).Close

With ActiveWindow.ActivePane.View

.Type = wdPrintView

.SeekView = wdSeekCurrentPageHeader

Selection.WholeStory

Selection.Delete Unit:=wdCharacter, Count:=1

'Selection.TypeText Text:="这是替换后的页眉"

With ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary)

Set rng = .Range

rng.Text = "第 "

rng.Collapse wdCollapseEnd

'wdCollapseEnd 折叠一个代表完整段落的区域，则该区域将定位于段落结束标记之后（即下段开头）。

'但是，在该区域折叠后，可以用 MoveEnd 方法将区域回移一个字符。

ActiveDocument.Fields.Add rng, wdFieldPage, "Page"

Set rng = .Range

rng.Collapse wdCollapseEnd

rng.Text = " 页 / 共 "

rng.Collapse wdCollapseEnd

ActiveDocument.Fields.Add rng, wdFieldNumPages, "Pages"

Set rng = .Range

rng.Collapse wdCollapseEnd

rng.Text = " 页 "

.Range.Fields.Update

.Range.ParagraphFormat.Alignment = wdAlignParagraphRight

'隐藏页眉的横线；

.Range.Borders(wdBorderBottom).Visible = False

End With

'加载一图片文件作为页眉

'Selection.InlineShapes.AddPicture FileName:="F:\Website\witiso\33VBA\实例\word\top.jpg", LinkToFile:=False, SaveWithDocument:=True

.SeekView = wdSeekMainDocument

End With

WordBasic.ViewFooterOnly

Selection.WholeStory

Selection.Delete Unit:=wdCharacter, Count:=1

'Selection.TypeText Text:="这是替换后的页脚"

Dim GetDocName

GetDocName = Left$(ActiveDocument.Name, Len(ActiveDocument.Name) - 4)

With ActiveDocument.Sections(1).Footers(wdHeaderFooterPrimary)

Set rng = .Range

rng.Text = GetDocName

rng.Collapse wdCollapseEnd

Set rng = .Range

rng.Collapse wdCollapseEnd

rng.Text = " 第 "

rng.Collapse wdCollapseEnd

ActiveDocument.Fields.Add rng, wdFieldPage, "Pages"

Set rng = .Range

rng.Collapse wdCollapseEnd

rng.Text = " 页 / 共 "

rng.Collapse wdCollapseEnd

ActiveDocument.Fields.Add rng, wdFieldNumPages, "Pages"

Set rng = .Range

rng.Collapse wdCollapseEnd

rng.Text = " 页 "

.Range.Fields.Update

.Range.ParagraphFormat.Alignment = wdAlignParagraphRight

End With

ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument

' 设置页面边距和页眉页脚边距

With ActiveDocument.PageSetup

.TopMargin = CentimetersToPoints(1.5)

.BottomMargin = CentimetersToPoints(1.7)

.LeftMargin = CentimetersToPoints(1.7)

.RightMargin = CentimetersToPoints(1.5)

.HeaderDistance = CentimetersToPoints(1)

.FooterDistance = CentimetersToPoints(1.2)

End With

ActiveWindow.ActivePane.VerticalPercentScrolled = 0

End Sub

Sub 网上复制文本格式1()

Selection.WholeStory

Selection.Cut

Selection.PasteAndFormat (wdFormatPlainText)

Application.Run MacroName:="替换页眉页脚.替换页眉页脚"

Application.Run MacroName:="删除空白段落"

Application.Run MacroName:="汉字中间的空格替换掉"

Application.Run MacroName:="段落设置"

End Sub

Sub 网上复制文本格式2不操作空白段落()

Selection.WholeStory

Selection.Cut

Selection.PasteAndFormat (wdFormatPlainText)

Application.Run MacroName:="替换页眉页脚.替换页眉页脚"

Application.Run MacroName:="汉字中间的空格替换掉"

Application.Run MacroName:="段落设置"

End Sub

Sub 网上复制文本格式3没有段落()

Application.Run MacroName:="替换页眉页脚.替换页眉页脚"

Application.Run MacroName:="去掉全部段落"

Application.Run MacroName:="汉字中间的空格替换掉"

Application.Run MacroName:="段落设置"

End Sub

Sub 删除空白段落()

Selection.WholeStory

Dim para As Paragraph

For Each para In ActiveDocument.Paragraphs

If VBA.Len(para.Range) = 1 Then

para.Range.Delete

End If

Next

Dim i As Integer

For i = 1 To 2

Selection.WholeStory

Selection.Find.ClearFormatting

Selection.Find.Replacement.ClearFormatting

'On Error Resume Next

With Selection.Find

.Text = "^p^p"

.Replacement.Text = "^p"

.Forward = True '向后搜索

.Wrap = wdFindContinue

.Format = False ' 不清除格式

.MatchCase = False ' 匹配大小写

.MatchWholeWord = False ' 整词匹配

.MatchByte = False ' 全角

.MatchWildcards = False '不勾选"使用通配符"

.MatchSoundsLike = False ' 不匹配 同音词

.MatchAllWordForms = False ' 不查找单词的所有形式

'([!。：……？！）])^13{1,}表示查找所有以

'非句号、冒号、中文省略号、问号、感叹句和右括号为结尾、硬回车符号为标志的段落。用在对话框中

'^13是回车符（段落标记^p），^11是换行符。用中括号括起来表示这两个都可以，{1,}表示1个以上。

End With

Selection.Find.Execute Replace:=wdReplaceAll

Next i

End Sub

Sub 汉字中间的空格替换掉()

Selection.WholeStory

Selection.Find.ClearFormatting

Selection.Find.Replacement.ClearFormatting

With Selection.Find

.Text = "([一-﨩])( {1,})([一-﨩])"

.Replacement.Text = "\1\3"

.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

ActiveWindow.ActivePane.DisplayRulers = Not ActiveWindow.ActivePane. _

DisplayRulers

End Sub

Sub 段落设置()

Selection.WholeStory

With Selection.ParagraphFormat

.SpaceBeforeAuto = False

.SpaceAfterAuto = False

.FirstLineIndent = CentimetersToPoints(0.75)

.LeftIndent = CentimetersToPoints(0) '左缩进

.RightIndent = CentimetersToPoints(0) '右缩进

.SpaceBefore = 0 '段前间距

.SpaceBeforeAuto = False

.SpaceAfter = 2.5 '段后间距

.SpaceAfterAuto = False

.LineSpacingRule = wdLineSpaceExactly '单倍行距

.LineSpacing = 18

.Alignment = wdAlignParagraphJustify '段落2端对齐

.WidowControl = False '孤行控制

.KeepWithNext = False '与下段同页

.KeepTogether = False '段中不分页

.PageBreakBefore = False '段前分页

.NoLineNumber = False '取消行号

.Hyphenation = True '取消段字

.FirstLineIndent = CentimetersToPoints(0.36) '首行缩进

.OutlineLevel = wdOutlineLevelBodyText

.CharacterUnitLeftIndent = 0

.CharacterUnitRightIndent = 0

.CharacterUnitFirstLineIndent = 2.02

.LineUnitBefore = 0

.LineUnitAfter = 0.5

.MirrorIndents = False

.TextboxTightWrap = wdTightNone

.AutoAdjustRightIndent = True

.DisableLineHeightGrid = False

.FarEastLineBreakControl = True

.WordWrap = True

.HangingPunctuation = True

.HalfWidthPunctuationOnTopOfLine = False

.AddSpaceBetweenFarEastAndAlpha = True

.AddSpaceBetweenFarEastAndDigit = True

.BaseLineAlignment = wdBaselineAlignAuto

End With

ActiveWindow.ActivePane.VerticalPercentScrolled = 0

End Sub

Sub 去掉全部段落()

Selection.WholeStory

Selection.Cut

Selection.PasteAndFormat (wdFormatPlainText)

Selection.WholeStory

Dim para As Paragraph

For Each para In ActiveDocument.Paragraphs

If VBA.Len(para.Range) = 1 Then

para.Range.Delete

End If

Next

Selection.WholeStory

Selection.Find.ClearFormatting

Selection.Find.Replacement.ClearFormatting

'On Error Resume Next

With Selection.Find

.Text = "^13"

.Replacement.Text = ""

.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

Dim i As Integer

For i = 1 To 2

Selection.WholeStory

Selection.Find.ClearFormatting

Selection.Find.Replacement.ClearFormatting

'On Error Resume Next

With Selection.Find

.Text = "^p"

.Replacement.Text = ""

.Forward = True

.Wrap = wdFindContinue

.Format = False

.MatchCase = False

.MatchWholeWord = False

.MatchByte = False

.MatchAllWordForms = False

.MatchSoundsLike = False

.MatchWildcards = False

End With

Selection.Find.Execute Replace:=wdReplaceAll

Next i

End Sub

word如何编辑vba窗体（WordVBA宏共享）(2)

－End－

,