Attribute VB_Name = "NewMacros"
Sub pastespecial()
Attribute pastespecial.VB_ProcData.VB_Invoke_Func = "Normal.NewMacros.pastespecial"
'
' pastespecial 宏
'快捷键：alt－s,快速粘贴无格式文本
'
Selection.Collapse Direction:=wdCollapseStart
Selection.pastespecial DataType:=wdPasteText
End Sub
Sub indent()
Attribute indent.VB_ProcData.VB_Invoke_Func = "Normal.NewMacros.indent"
'
' indent 宏
'快捷键：alt－z，段落缩进2字符
'
With Selection.ParagraphFormat
.CharacterUnitFirstLineIndent = 2
End With
End Sub
Sub charspace()
Attribute charspace.VB_ProcData.VB_Invoke_Func = "Normal.NewMacros.charspace"
'
' charspace 宏
'快捷键：alt－i，快速增加字符间距，每次增加0.1
'
Dim myspace As Single
myspace = Selection.Font.Spacing
myspace = myspace + 0.1
If Abs(myspace) < 0.1 Then myspace = 0
With Selection.Font
.Spacing = myspace
End With
StatusBar = "fontspacing=" + CStr(myspace)
End Sub
Sub charspaced()
'
' charspaced 宏
'快捷键：alt－u,快速减少字符间距，每次减少0.1
'
Dim myspace As Single
myspace = Selection.Font.Spacing
myspace = myspace - 0.1
If Abs(myspace) < 0.1 Then myspace = 0
With Selection.Font
.Spacing = myspace
End With
StatusBar = "fontspacing=" + CStr(myspace)
End Sub

Sub linespace()
Attribute linespace.VB_ProcData.VB_Invoke_Func = "Normal.NewMacros.宏1"
'
' linespace 宏
'快捷键：alt－A,快速增加行距
'
Dim myspace As Single
myspace = Selection.ParagraphFormat.linespacing
myspace = myspace + 1
With Selection.ParagraphFormat
.LineSpacingRule = wdLineSpaceExactly
.linespacing = myspace
End With
StatusBar = "linespacing=" + CStr(myspace)
End Sub
Sub linespaced()
Attribute linespaced.VB_ProcData.VB_Invoke_Func = "Normal.NewMacros.linespaced"
'
' linespaced 宏
'快捷键：alt－D，快速减少行距
'
Dim myspace As Single
myspace = Selection.ParagraphFormat.linespacing
myspace = myspace - 1
With Selection.ParagraphFormat
.LineSpacingRule = wdLineSpaceExactly
.linespacing = myspace
End With
StatusBar = "linespacing=" + CStr(myspace)
End Sub
Sub macrosubstitute()
Attribute macrosubstitute.VB_ProcData.VB_Invoke_Func = "Normal.NewMacros.macrosubstitute"
'
' macrosubstitute 宏
'快捷键：alt－R，多次替换
'
Dim replnu, i As Integer
Dim findT(), replT() As String
Dim Message, Title, Default, MyValue
Message = "替换数量"    ' 设置提示信息。
Title = "替换数量"    ' 设置标题。
Default = "1"    ' 设置缺省值。
replnu = InputBox(Message, Title, Default)
ReDim findT(CInt(replnu)), replT(CInt(replnu)) As String
For i = 1 To CInt(replnu)
Message = "查找文本" & Str(i)  ' 设置提示信息。
Title = "查找文本"    ' 设置标题。
Default = ""    ' 设置缺省值。
findT(i) = InputBox(Message, Title, Default)
Message = "替换文本" & Str(i)  ' 设置提示信息。
Title = "替换文本"    ' 设置标题。
Default = ""    ' 设置缺省值。
replT(i) = InputBox(Message, Title, Default)
Next i
For i = 1 To CInt(replnu)

Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = findT(i)
.Replacement.Text = replT(i)
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Next i

End Sub
Sub sustitutemacro()
Attribute sustitutemacro.VB_ProcData.VB_Invoke_Func = "Normal.NewMacros.sustitutemacro"
'
' sustitutemacro 宏
' 快捷键：alt－T，快速整理文本（删除空行，多余回车，段前空格等），
'
Dim tim, i, j, k As Integer
tim = 0
i = 0
j = 0
k = 0
With ActiveDocument.Content.Find
Do While .Execute(FindText:="　") = True
tim = tim + 1
Loop
j = tim
tim = 0
End With
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "　"
.Replacement.Text = " "
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = True
.MatchWholeWord = False
.MatchByte = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
With ActiveDocument.Content.Find
Do While .Execute(FindText:="　") = True
tim = tim + 1
Loop
MsgBox ("当前文档替换 " + CStr(tim) + " 个全角空格 "), 48, "完成"
j = j - tim
End With
StatusBar = "替换：" + CStr(j) + "个全角空格"
MsgBox ("当前文档替换 " + CStr(j) + " 个全角空格 "), 48, "完成"
'全角空格替换完成！

tim = 0
i = 0
j = 0
k = 0
Do While j = 0
With ActiveDocument.Content.Find
Do While .Execute(FindText:="^l") = True
tim = tim + 1
Loop
End With
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^l"
.Replacement.Text = "^p"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
If tim = 0 Then
j = 1
Else
i = i + tim
StatusBar = "替换：" + CStr(i) + "个软回车"
End If
tim = 0
Loop
MsgBox ("当前文档查找到 " + Str(i) + " 个软回车 "), 48, "完成"
'软回车替换完成！

tim = 0
i = 0
j = 0
k = 10
Do While j = 0
With ActiveDocument.Content.Find
Do While .Execute(FindText:="^p" + space(k)) = True
tim = tim + 1
tim = tim * k
Loop
End With
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^p" + space(k)
.Replacement.Text = "^p"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
If tim = 0 And k = 1 Then
j = 1
Else
i = i + tim
StatusBar = "替换：" + CStr(i) + "个段落前空格 " + " k=" + CStr(k)
End If
tim = 0
k = k - 1
If k < 1 Then
k = 1
End If
Loop
MsgBox ("当前文档查找到 " + Str(i) + " 个段落前空格"), 48, "完成"
'段落前空格替换完成！

tim = 0
i = 0
j = 0
k = 10
Do While j = 0
With ActiveDocument.Content.Find
Do While .Execute(FindText:=space(k) + "^p") = True
tim = tim + 1
tim = tim * k
Loop
End With
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = space(k) + "^p"
.Replacement.Text = "^p"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
If (tim = 0 Or tim = 1) And k = 1 Then
j = 1
Else
i = i + tim
StatusBar = "替换：" + CStr(i) + "个回车前空格 " + " k=" + CStr(k)
End If
tim = 0
k = k - 1
If k < 1 Then
k = 1
End If
Loop
MsgBox ("当前文档查找到 " + Str(i) + " 个回车前空格"), 48, "完成"
'回车前空格替换完成！

tim = 0
i = 0
j = 0
k = 0
Do While j = 0
With ActiveDocument.Content.Find
Do While .Execute(FindText:="^p^p") = True
tim = tim + 1
Loop
End With
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^p^p"
.Replacement.Text = "^p"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
If tim = 0 Or tim = 1 Then
j = 1
Else
i = i + tim
k = k + 1
StatusBar = "替换：" + CStr(i - k) + "个空行"
End If
tim = 0
Loop
MsgBox ("当前文档查找到 " + Str(i - k + 1) + " 个空行 "), 48, "完成"
End Sub