Word下的几个VBA代码

 

•  删除文档中所有内容为空的行

Sub DelBlank()    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 = TrueEnd Sub

• 删除文档中的隐藏文字

Sub test() n = 0 ActiveDocument.ActiveWindow.View.ShowHiddenText = True For Each i In ActiveDocument.Characters  If i.Font.Hidden = True Then   n = n + 1   i.Delete  End If Next MsgBox "共删除隐藏字符" & n & "个"End Sub

• 删除空格

Sub  删除空格()  Dim FindChar As String, Fcount As Integer, RepChar As String  On Error Resume Next  Application.ScreenUpdating = False '关闭屏幕更新  FindChar = " "  RepChar = ""  With ActiveDocument.Content.Find  '此处针对全文档    Do While .Execute(findtext:=FindChar) = True '如果发现    Fcount = Fcount + 1 '计数器    Loop        If MsgBox("文档中共发现了" & Fcount & "个" & FindChar & vbCrLf _& ",按Yes键将进行下一步的替换工作,按No取消", vbYesNo + vbInformation) = vbYes Then     .Execute findtext:=FindChar, Wrap:=wdFindContinue, replacewith:=RepChar, Replace:=wdReplaceAll     End If  End With  Application.ScreenUpdating = True '恢复屏幕更新 End Sub

• 段首空格删除

Sub  删除段首空格1() Selection.WholeStory 'CTR+A Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter 'CTR+E Selection.ParagraphFormat.Reset 'CTR+QEnd Sub

Sub 删除段首空格2()     Dim i As Paragraph, n As Long     Application.ScreenUpdating = False '关闭屏幕刷新     For Each i In ActiveDocument.Paragraphs '在活动文档的段落集合中循环           For n = 1 To i.Range.Characters.Count               If i.Range Like " *" _               Or i.Range Like "　*" Then                  i.Range.Characters(1).Delete                Else: Exit For                End If             Next n        Next       Application.ScreenUpdating = True '恢复屏幕刷新    End Sub

Sub 删除段首空格3()      Dim i As Paragraph, n As Long      Application.ScreenUpdating = False '关闭屏幕刷新      For Each i In ActiveDocument.Paragraphs '在活动文档的段落集合中循环           For n = 1 To i.Range.Characters.Count               If i.Range.Characters(1).Text = " " _               Or i.Range.Characters(1).Text = "　" Then                  i.Range.Characters(1).Delete               Else: Exit For               End If            Next n       Next      Application.ScreenUpdating = True '恢复屏幕刷新     End Sub

• 删除空白段落

'功能简介:可以对指定长度的段落进行删除，当LEN=1时'可对空白段落进行删除。''* ---------------------------------------Sub 删除空段()  Dim i As Paragraph, n As Long  Call 删除段首空格2 '调用工程  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 设置段落格式()  Dim pa As Paragraph  On Error Resume Next  Application.ScreenUpdating = False  '关闭屏幕更新  For Each pa In ActiveDocument.Paragraphs  pa.Format.CharacterUnitFirstLineIndent = 2  Next  With ActiveDocument.Content.Font    .Name = "楷体_GB2312"    .Size = 14  End With Application.ScreenUpdating = True  '恢复屏幕更新 End Sub

• 设置大纲级别
  

   '* +++++++++++++++++++++++++++++++++++++++'实现以日期2010开头的段落，第一句加粗的代码，'并将该段落升为一级大纲。''* ----------------------------------------Sub 设置大纲1()  On Error Resume Next  Application.ScreenUpdating = False  '关闭屏幕更新  For RQJC = 1 To ActiveDocument.Range(0, ActiveDocument.Range.End).Paragraphs.Count '对正文全文段落进行循环    With ActiveDocument.Paragraphs(RQJC).Range    If ActiveDocument.Range(.Start, .Start + 4).Text = "2010" Then '当每一段落前四个字符以“2010”开头    .Sentences(1).Font.Bold = True '每一段第一句字体加粗    ActiveDocument.Paragraphs(RQJC).OutlineLevel = wdOutlineLevel1 '该段落的大纲级别变为一级大纲    End If    End With   Next RQJC   Application.ScreenUpdating = True  '恢复屏幕更新 End Sub

  
  

  '* +++++++++++++++++++++++++++++++++++++++    '字符数小于41的段落，第一句加粗，    '并将该段落升为二级大纲。'    '* -------------------------------------------    Sub 设置大纲2()      Dim n As Long, i As Paragraph      On Error Resume Next      Application.ScreenUpdating = False  '关闭屏幕更新      For n = 1 To ActiveDocument.Paragraphs.Count        If ActiveDocument.Paragraphs(n).Range.Characters.Count < 41 _        And ActiveDocument.Paragraphs(n).Range.Characters.Count > 0 Then '段落字符数小于41,约为一两行        ActiveDocument.Paragraphs(n).Range.Sentences.First.Font.Bold = True '每一段第一句字体加粗        ActiveDocument.Paragraphs(n).OutlineLevel = wdOutlineLevel2 '该段落的大纲级别变为二级大纲        End If      Next n      Application.ScreenUpdating = True  '恢复屏幕更新     End Sub

  
  

  '* +++++++++++++++++++++++++++++++++++++++'以数字开头的段落，第一句加粗，'并将该段落升为二、三级大纲。''* ------------------------------------------Sub 设置大纲3()  Dim pa As Paragraph, MyStr1 As String, MyStr2 As String, MyStr3 As String  On Error Resume Next  Application.ScreenUpdating = False  '关闭屏幕更新  Call 删除段首空格3  '调用工程  MyStr1 = "第一二三四五六七八九十" '假定为手动加注每个段落开头为中文大写数字  MyStr2 = "123456789" '假定为手动加注每个段落开头为数字，半角  MyStr3 = "１２３４５６７８９" '假定为手动加注每个段落开头为数字，全角  For Each pa In ActiveDocument.Paragraphs    If InStr(MyStr1, ActiveDocument.Range(pa.Range.Start, pa.Range.Start + 1).Text) > 0 Then    pa.Range.Sentences.First.Font.Bold = True '每一段第一句字体加粗    pa.OutlineLevel = wdOutlineLevel2 '该段落的大纲级别变为二级大纲    End If    If InStr(MyStr2, ActiveDocument.Range(pa.Range.Start, pa.Range.Start + 1).Text) > 0 Then    pa.Range.Sentences.First.Font.Bold = True '每一段第一句字体加粗    pa.OutlineLevel = wdOutlineLevel3 '该段落的大纲级别变为三级大纲    End If    If InStr(MyStr3, ActiveDocument.Range(pa.Range.Start, pa.Range.Start + 1).Text) > 0 Then    pa.Range.Sentences.First.Font.Bold = True '每一段第一句字体加粗    pa.OutlineLevel = wdOutlineLevel3 '该段落的大纲级别变为三级大纲    End If  Next  Application.ScreenUpdating = True  '恢复屏幕更新 End Sub 

  
  

  '* +++++++++++++++++++++++++++++++++++++++'以"第#"开头的段落，第一句加粗，'并将该段落升为二级大纲。''* ------------------------------------------Sub 设置大纲4()  Dim pa As Paragraph, MyStr1 As String  On Error Resume Next  Application.ScreenUpdating = False  '关闭屏幕更新  Call 删除段首空格3  '调用工程  MyStr1 = "一二三四五六七八九十" '假定为手动加注每个段落开头为中文大写数字  For Each pa In ActiveDocument.Paragraphs      If pa.Range.Characters.First.Text = "第" Then        If InStr(MyStr1, ActiveDocument.Range(pa.Range.Start + 1, pa.Range.Start + 2).Text) > 0 Then        pa.Range.Sentences.First.Font.Bold = True '每一段第一句字体加粗        pa.OutlineLevel = wdOutlineLevel2 '该段落的大纲级别变为二级大纲        End If      End If  Next  Application.ScreenUpdating = True  '恢复屏幕更新 End Sub