word_vba.bas

自己编写的WORD文档处理VBA程序

       Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend '选中一个字符
       Selection.Delete Unit:=wdCharacter, Count:=1
       FristS = True
       GoTo strat
    Else
      '-----判断是否到达文件尾，如是结束---------
      If ls = Chr(13) Then
         k = k + 1
         If k > ExitN Then Exit Sub   '当到达文件尾，结束
      Else
          k = 0
      End If
    End If
    Selection.HomeKey
    Selection.TypeText Text:="    "
    
    Selection.MoveDown Unit:=wdLine
    Selection.HomeKey
GoTo strat
    
End Sub

Sub 只去行首空格()

Dim k As Long
Dim n As Long
Dim FristS As Boolean

n = 1: k = 0: FristS = False

Selection.HomeKey Unit:=wdStory '将光标移到第一行

strat:
    Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend '选中一个字符
    ls = Selection.Text
    If ls = " " Or ls = "　" Then
       Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend '选中一个字符
       Selection.Delete Unit:=wdCharacter, Count:=1
       FristS = True
       GoTo strat
    Else
      '-----判断是否到达文件尾，如是结束---------
      If ls = Chr(13) Then
         k = k + 1
         If k > ExitN Then Exit Sub   '当到达文件尾，结束
      Else
          k = 0
      End If
    End If
    
    Selection.MoveDown Unit:=wdLine
    Selection.HomeKey
GoTo strat
    
End Sub
Sub 每段前加4个空格()

Dim k As Long
Dim n As Long
Dim FristS As Boolean

n = 1
k = 0
strat:
    Selection.EndKey: FristS = True
    Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend '选中一个字符
    ls = Selection.Text
    If ls = Chr(13) Then
       Selection.MoveDown Unit:=wdLine
       Selection.HomeKey: FristS = True
       Selection.TypeText Text:="    "
       k = k + 1
       If k > ExitN Then Exit Sub  '当到达文件尾，结束
    Else
       k = 0
    End If

GoTo strat
    
End Sub

Sub 替换回车符()
Dim n As Long
n = 1


Selection.HomeKey Unit:=wdStory '将光标移到第一行

strat:
    Selection.MoveDown Unit:=wdLine
    Selection.EndKey
    Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend '选中一个字符
    ls = Selection.Text
    If Asc(ls) = 11 Then
       Selection.Text = Chr(13)
    End If
       If n > 1150 Then Exit Sub
       n = n + 1
           
GoTo strat
    
End Sub

Sub 去掉一行中只有回车符的空行()
Dim n As Long
n = 1
i = 0

Selection.HomeKey Unit:=wdStory '将光标移到第一行

strat:
    Selection.MoveDown Unit:=wdLine   '向下移动1行
strat1:
    Selection.HomeKey                 '将光标移到行首
    Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend '选中一个字符
    ls = Selection.Text
    
    If Len(Trim(ls)) = 0 Then       '当行首前面为空格时
       Do While True
          Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend '选中一个字符
          ls = Selection.Text
          If Len(Trim(ls)) <> 0 Then
             If Right(ls, 1) = Chr(13) Then
                Selection.TypeBackspace          '删除前面空格及回车符
                GoTo strat1
             End If
             GoTo strat
          End If
       Loop
    End If
    '-----------------------------------------
    
    If ls = Chr(13) Then         '当行首第1字符为回车符时，删除它
       Selection.Delete Unit:=wdCharacter, Count:=1
       GoTo strat1
    'Else
    '   Selection.HomeKey                 '将光标移到行首
      'Selection.EndKey
    '  Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend '选中一个字符
    '  ls = Selection.Text
    '  If Asc(ls) = 11 Then
    '     Selection.Text = Chr(13)
    '  End If
    End If
    
    If n > 8150 Then Exit Sub
    n = n + 1
           
GoTo strat
    
End Sub

Sub 替换()
'
' 替换 Macro
' 宏在 2001-09-19 由 邱万成 录制
'
n = 1

Selection.HomeKey Unit:=wdStory '将光标移到第一行

Do While True
    n = n + 1
    With Selection.Find
        .Text = "来源"  '+ Chr(13) + "网页设计制作：倚天"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindAsk
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute
    'Selection.Delete Unit:=wdCharacter, Count:=1
    'Selection.MoveDown Unit:=wdLine, Count:=1
    Selection.MoveLeft Unit:=wdCharacter, Count:=1
    Selection.Style = ActiveDocument.Styles("标题 1")
    Selection.MoveDown Unit:=wdLine, Count:=1
   If n = 150 Then Exit Sub
Loop
End Sub

Sub 设置格式()
n = 1

Selection.HomeKey Unit:=wdStory '将光标移到第一行
Do While True
    n = n + 1
    Selection.MoveDown Unit:=wdLine, Count:=1
    If Selection.Style = "正文" Then Selection.Style = ActiveDocument.Styles("正文（首行缩进两字）")
   If n = 332150 Then Exit Sub
Loop
End Sub

Sub 段落合并()
'
' 段落合并 Macro
' 宏在 2001-10-01 由 邱万成 录制
'
Dim ls As String
Dim n As Long
n = 1

Selection.HomeKey Unit:=wdStory '将光标移到第一行
    
'Selection.MoveDown Unit:=wdLine, Count:=1
Selection.EndKey Unit:=wdLine

Do While True
    n = n + 1
    Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend  '向左边选中一个
    ls = Selection.Text
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    
    If ls = "？" Or ls = "。" Or ls = "：" Or _
       ((Asc(ls) >= 65 And Asc(ls) <= 90) Or _
       (Asc(ls) >= 97 And Asc(ls) <= 122)) Then
       Selection.MoveDown Unit:=wdLine, Count:=1
       Selection.EndKey Unit:=wdLine
    Else
       Selection.Delete Unit:=wdCharacter, Count:=1
       Selection.EndKey Unit:=wdLine
    End If
    If n = 30000 Then Exit Do
Loop
End Sub
Sub Macro1()
'
' Macro1 Macro
' 宏在 2001-10-01 由 邱万成 录制
'
    Selection.MoveLeft Unit:=wdCharacter, Count:=1
    Selection.Style = ActiveDocument.Styles("标题 1")
End Sub


Sub Macro2()
Attribute Macro2.VB_Description = "宏在 2006-2-13 由 qwcheng 录制"
Attribute Macro2.VB_ProcData.VB_Invoke_Func = "Normal.NewMacros.Macro2"
'
' Macro2 Macro
' 宏在 2006-2-13 由 qwcheng 录制
'
    Selection.MoveDown Unit:=wdLine, Count:=7
End Sub