Word下的几个VBA代码-CFANZ编程社区

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

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 = True
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 设置段落格式()
  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