Oscar Sun

                  Sub 字集筆畫排序(ByRef Ctrl As Boolean)
Application.ScreenUpdating = False
字集筆畫排序_sub Ctrl
MsgBox "完成！", vbInformation
Application.ScreenUpdating = True
Ctrl = False
End Sub
Sub 字集筆畫排序_sub(Ctrl As Boolean)
Dim IPflg As Boolean, s As Selection, r As Range, rstart As Long
Dim rChr13InsertCount As Long, rChr13InsertedCount As Long
Set s = d.ActiveWindow.Selection
If s.Type = wdSelectionIP Then IPflg = True
If IPflg Then
    Set r = d.Range
Else
    Set r = s.Range
End If
rstart = r.Start '記下選取區的開始位置
rChr13InsertCount = r.Characters.Count '乃利用Word中「排序」指令，故須先分段
'記下分段數

Dim Char
Dim e As Long
On Error GoTo ErrH
With r
    e = .End '因為插入後文件長度變動,故不能取靜態者!
'    If CLng(i) > e Then Exit Sub
    If VBA.InStr(VBA.Left(.Text, VBA.IIf(r.Characters(r.Characters.Count) = Chr(13), e - 1, e)), VBA.Chr(13)) Then
        GoSub clearP
        rChr13InsertCount = r.Characters.Count '記下有多少字要處理，就是要插入多少段落符號
    End If
    If Not IPflg Then '若有選取區者
        r.InsertParagraphBefore
        rstart = rstart + 1
        r.SetRange rstart, .End
        rChr13InsertCount = r.Characters.Count - 1
        Char = 1 '計數器
    Else
        Char = 1
    End If
    Do Until rChr13InsertedCount = rChr13InsertCount
        r.Characters(Char).InsertAfter Chr(13)
        rChr13InsertedCount = rChr13InsertedCount + 1
        Char = Char + 2
    Loop
    r.InsertAfter Chr(13)
    ' r.Sort ExcludeHeader:=False, FieldNumber:="段落", SortFieldType:= _
        wdSortFieldStroke, SortOrder:=wdSortOrderAscending, FieldNumber2:="", _
        SortFieldType2:=wdSortFieldStroke, SortOrder2:=wdSortOrderAscending, _
        FieldNumber3:="", SortFieldType3:=wdSortFieldStroke, SortOrder3:= _
        wdSortOrderAscending, Separator:=wdSortSeparateByTabs, SortColumn:=False, _
         CaseSensitive:=False, LanguageID:=wdTraditionalChinese
    If Ctrl Then
         r.Sort ExcludeHeader:=False, FieldNumber:="段落", SortFieldType:= _
        wdSortFieldStroke, SortOrder:=wdSortOrderAscending, _
         CaseSensitive:=False, LanguageID:=wdSimplifiedChinese
    Else
        r.Sort ExcludeHeader:=False, FieldNumber:="段落", SortFieldType:= _
            wdSortFieldStroke, SortOrder:=wdSortOrderAscending, _
             CaseSensitive:=False, LanguageID:=wdTraditionalChinese
    End If

    GoSub clearP
    r.InsertAfter Chr(13) '若後面尚有文本可作區隔
    If Not IPflg Then r.SetRange rstart, e
    r.Select '選取已排序的範圍以醒目
End With
Exit Sub
ErrH:
Select Case Err.Number
    Case Else
        MsgBox Err.Number & Err.Description, vbCritical: Resume Next
End Select
Exit Sub

clearP:
    With r
'               較全部取代快了快三倍!!
'            StatusBar = "清除段落中..."
            For Each Char In .Characters
                If Char = VBA.Chr(13) Then Char.Delete
            Next
            e = .End '再取一次現在文件之長度
'            StatusBar = "清除段落完畢!!"
    End With
Return
End Sub