Oscar Sun

                  Sub 只留下5031常用字_未選取則以paragraph為單位()
'Selection.Style = "標題 1"
'If Selection.Type <> wdSelectionIP Then Selection.Collapse wdCollapseEnd
'Selection.Move wdStory
'Selection.InsertParagraphAfter
'Selection.Move wdStory
'Selection.PasteSpecial DataType:=wdPasteText

Dim rng As Range, cnt As New ADODB.Connection, rst As New ADODB.Recordset, a
Static dbf As String
If Selection.Type = wdSelectionIP Then
    Set rng = Selection.Paragraphs(1).Range
Else
    Set rng = Selection.Range
End If
If dbf = "" Then dbf = system.dbFile("@@諧聲字檢索系統（唯一）20170518.mdb", "") ' "E:\@@@華語文工具及資料@@@\@@諧聲字檢索系統（唯一）20170518.mdb
cnt.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbf
If rng.Characters.Count > 1 Then
    Application.ScreenUpdating = False
    For Each a In rng.Characters
        If Not a Like "[" & Chr(13) & Chr(10) & Chr(8) & Chr(7) & Chr(9) & "]" Then
            rst.Open "select 漢字 from 5031常用字 where strcomp(漢字,""" & a & """)=0", cnt, adOpenKeyset
            If rst.RecordCount = 0 Then
                a.Delete
            End If
            rst.Close
        End If
    Next a
    Application.ScreenUpdating = True
    
'    If rng.Characters.Count > 1 Then
'        rng.Select
'        If d Is Nothing Then Set d = rng.Document
'        Str.字集筆畫排序
'        Selection.Collapse wdCollapseStart
'        Selection.MoveUp
'        Selection.Delete
'        If rng.Document.path <> "" Then rng.Document.Save
'    End If
End If
End Sub