word_vba.bas

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

Attribute VB_Name = "NewMacros"
'此模块更新时间：2003.08.04
Dim ls As String
Const ExitN = 100
Sub all()

去空格
去行首空格
每段前加4个空格

End Sub

Sub 只去汉字中的空格_不能去掉英文中的空格()
' 将空行的回车符去掉
' 如行首为英文字母：行首的空格和中间的空格不去掉
' 如行首不是英文  ：将行首和中间的空格去掉

Dim chr13 As Long
Dim n As Long
Dim i As Long  '此值控制在空格中防止进入死循环
Dim FristS As Boolean
Dim k As Long  '从行首开始选中的字符个数
Dim EndN As Long

n = 1: chr13 = 0: i = 1
EndN = 0

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

strat:
    Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend '选中一个字符
    ls = Selection.Text
    '===当选取中的字为回车符时==========================================
    If ls = Chr(13) Or Asc(ls) = 11 Then
       chr13 = chr13 + 1
       If ls = Chr(13) Then EndN = EndN + 1
       If EndN > ExitN Then Exit Sub  '结束

       If chr13 > 1 Then
          '当删除一行后,自动下移一行,所以此处不必用Selection.MoveDown Unit:=wdLine
          Selection.Delete Unit:=wdCharacter, Count:=1
          Selection.HomeKey: FristS = True: k = 1
          GoTo strat
       End If
       Selection.MoveDown Unit:=wdLine
       Selection.HomeKey: FristS = True: k = 1
       GoTo strat
    End If
    
    
    EndN = 0
    '==================================================================
    '    当行首前面为空格，但后面到少有一个字符时，如:"   l"
    '如后面的字符是字母，则保留空格，并移向下一行；
    '如不是字母，将前面的空格删除，只留后面的字符!
    'MsgBox Len(Mid(ls, 1, 1))
    If Len(Trim(ls)) = 0 And FristS Then      '当行首前面为空格时
       i = i + 1
       If i < 50 Then GoTo strat   '当假空格循环50次时
    End If
    '-----------------------------------------
    If Len(Trim(Mid(ls, 1, 1))) = 0 And Len(Trim(ls)) <> 0 And Len(ls) > 2 Then '后面到少有一个字符时，如:"   l"
       ls1 = Right(ls, 1)
       If ((Asc(ls1) >= 65 And Asc(ls1) <= 90) Or _
          (Asc(ls1) >= 97 And Asc(ls1) <= 122)) Then   '当为英文字母时，不删除空格
          'GoTo strat
          Selection.MoveDown Unit:=wdLine '下移一行
          Selection.HomeKey: FristS = True: k = 0
          chr13 = 1
       Else       '当不为英文字母时，删除前面空格
          Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend  '向回移一字符
          Selection.TypeBackspace: FristS = True: k = 0                                           '删除前面空格
       End If
       GoTo strat
    End If
    

    '======================================================================
    '==选中的是英文或中文空格字符时========================================
    If Len(Trim(ls)) = 0 Then
    'If ls = " " Or Asc(ls) = 32 Or ls = "　" Then '当为空格时删除
       Selection.Delete Unit:=wdCharacter, Count:=1
       '当在行首删除的为空格,仍将其设置为行首,只有中文中间删除空格,才将将FristS = False
       If FristS Then k = 1
       i = i + 1
       If i < 50 Then GoTo strat   '当假空格循环50次时
    End If   '----------------------------------------------------------
           
    '==选中的是A-Z 或 a-z字符时,不去空格,直接移到下一行=================
    If ((Asc(ls) >= 65 And Asc(ls) <= 90) Or _
       (Asc(ls) >= 97 And Asc(ls) <= 122)) And FristS And k = 1 Then
       Selection.MoveDown Unit:=wdLine '下移一行
       chr13 = 1
       Selection.HomeKey: FristS = True: k = 1
       GoTo strat
    End If
    '======================================================================
    chr13 = 0: i = 1
    
    Selection.MoveRight Unit:=wdCharacter, Count:=1 '当不为空格时向右移动一个字符
    k = k + 1  '行首向右移动字符个数
    If k >= 1 Then FristS = False

GoTo strat
    
End Sub


Sub 去汉字中和英文中的空格()
' 将空行的回车符去掉
' 如行首为英文字母：行首的空格和中间的空格不去掉
' 如行首不是英文  ：将行首和中间的空格去掉

Dim chr13 As Long
Dim n As Long
Dim i As Long  '此值控制在空格中防止进入死循环
Dim FristS As Boolean
Dim k As Long  '从行首开始选中的字符个数
Dim EndN As Long

n = 1: chr13 = 0: i = 1
EndN = 0

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

strat:
    Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend '选中一个字符
    ls = Selection.Text
    '===当选取中的字为回车符时==========================================
    If ls = Chr(13) Or Asc(ls) = 11 Then
       chr13 = chr13 + 1
       If ls = Chr(13) Then EndN = EndN + 1
       If EndN > ExitN Then Exit Sub  '结束

       If chr13 > 1 Then
          '当删除一行后,自动下移一行,所以此处不必用Selection.MoveDown Unit:=wdLine
          Selection.Delete Unit:=wdCharacter, Count:=1
          Selection.HomeKey: FristS = True: k = 1
          GoTo strat
       End If
       Selection.MoveDown Unit:=wdLine
       Selection.HomeKey: FristS = True: k = 1
       GoTo strat
    End If
    
    
    EndN = 0
    '==================================================================
    '    当行首前面为空格，但后面到少有一个字符时，如:"   l"
    '如后面的字符是字母，则保留空格，并移向下一行；
    '如不是字母，将前面的空格删除，只留后面的字符!
    'MsgBox Len(Mid(ls, 1, 1))
    If Len(Trim(ls)) = 0 And FristS Then      '当行首前面为空格时
       i = i + 1
       If i < 50 Then GoTo strat   '当假空格循环50次时
    End If
    '-----------------------------------------
    If Len(Trim(Mid(ls, 1, 1))) = 0 And Len(Trim(ls)) <> 0 And Len(ls) > 2 Then '后面到少有一个字符时，如:"   l"
       ls1 = Right(ls, 1)
       If ((Asc(ls1) >= 65 And Asc(ls1) <= 90) Or _
          (Asc(ls1) >= 97 And Asc(ls1) <= 122)) Then   '当为英文字母时，不删除空格
          'GoTo strat
          Selection.MoveDown Unit:=wdLine '下移一行
          Selection.HomeKey: FristS = True: k = 0
          chr13 = 1
       Else       '当不为英文字母时，删除前面空格
          Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend  '向回移一字符
          Selection.TypeBackspace: FristS = True: k = 0                                           '删除前面空格
       End If
       GoTo strat
    End If
    

    '======================================================================
    '==选中的是英文或中文空格字符时========================================
    If Len(Trim(ls)) = 0 Then
    'If ls = " " Or Asc(ls) = 32 Or ls = "　" Then '当为空格时删除
       Selection.Delete Unit:=wdCharacter, Count:=1
       '当在行首删除的为空格,仍将其设置为行首,只有中文中间删除空格,才将将FristS = False
       If FristS Then k = 1
       i = i + 1
       If i < 50 Then GoTo strat   '当假空格循环50次时
    End If   '----------------------------------------------------------
           
    '==选中的是A-Z 或 a-z字符时,不去空格,直接移到下一行=================
    'If ((Asc(ls) >= 65 And Asc(ls) <= 90) Or _
    '   (Asc(ls) >= 97 And Asc(ls) <= 122)) And FristS And k = 1 Then
    '   Selection.MoveDown Unit:=wdLine '下移一行
    '   chr13 = 1
    '   Selection.HomeKey: FristS = True: k = 1
    '   GoTo strat
    'End If
    '======================================================================
    chr13 = 0: i = 1
    
    Selection.MoveRight Unit:=wdCharacter, Count:=1 '当不为空格时向右移动一个字符
    k = k + 1  '行首向右移动字符个数
    If k >= 1 Then FristS = False

GoTo strat
    
End Sub

Sub 去掉负号()
'去掉行首的---符号
Dim k As Long
Dim n As Long
Dim FristS As Boolean

n = 1: k = 1: FristS = False

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

strat:
    Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend '选中一个字符
    ls = Selection.Text
    If ls = "-" And k = 1 Then
       Selection.Delete Unit:=wdCharacter, Count:=1
       FristS = True
       GoTo strat
    End If
    Selection.MoveDown Unit:=wdLine
    Selection.HomeKey: FristS = True
    GoTo strat
    '-----------------------------------------------------------
    k = k + 1: If k > 1 Then FristS = False
    Selection.MoveRight Unit:=wdCharacter, Count:=1 '当不为空格时移动
    
    n = n + 1
    If n > 33350 Then Exit Sub
GoTo strat
    
End Sub

Sub 去行首空格后加4个空格()

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