Oscar Sun

                  Sub 字集部首排序()
'先讓圖排在前面
Application.ScreenUpdating = False
Str.字集筆畫排序_sub
'排好後會選取已排序的範圍以醒目
Dim sl As Selection, r As Range, iCount As Long, iParaCount As Long, iChar As Long
Dim cnt As New ADODB.Connection, rst As New ADODB.Recordset, c, w As String
Dim fieldsName As String ' ,rst簡化字小抄  As New ADODB.Recordset
Set sl = d.ActiveWindow.Selection
Set r = sl.Range
iChar = 1
'文字轉表格
iParaCount = r.Characters.Count
For iCount = 1 To iParaCount - 1
    r.Characters(iChar).InsertAfter VBA.Chr(9) & VBA.Chr(13)
    iChar = iChar + 3
Next iCount
r.ConvertToTable Chr(9), iParaCount, 2
'r.Select
cnt.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
        "Data Source=" & system.dbFile("詞典DATA.mdb", "!!@詞典附檔@!\Back-End")
rst.Open "SELECT ID, F1 " & _
        "FROM 簡化字小抄 where ID=8", cnt, adOpenDynamic, adLockReadOnly
Select Case rst.Fields("F1").Value
    Case 3, 2 '大陸版、海外版
        fieldsName = "簡化字形"
    Case 1
        fieldsName = "字"
End Select
rst.Close
rst.Open "SELECT 字." & fieldsName & " as 字, 部首.部首, 部首.部首ID, 字.部首外筆畫, 字.總筆畫 " & _
        "FROM 部首 INNER JOIN 字 ON 部首.部首ID = 字.部首ID" & _
        " ORDER BY 部首.部首ID, 字.部首外筆畫, 字.總筆畫 ", cnt, adUseClient, adOpenDynamic, adLockReadOnly
        'adUseClient，要有此引數，AbsolutePosition屬性才能被調用
For Each c In r.Tables(1).Columns(1).Cells
    rst.MoveFirst
    w = VBA.CStr(c.Range.Characters(1))
'    If VBA.Len(w) > 1 Then
'        rst.Find "VBA.left(字,1)=""" & VBA.Left(w, 1) & """ and " & _
'            "VBA.right(字,1)=""" & VBA.Right(w, 1) & """"
''    rst.Find "strcomp(字,""" & c.Range.Characters(1) & """)=0"
'    Else
        rst.Find "字 = '" & w & "'" 'ADO Find方法可以正確判斷擴充字集長度len()為2的字，就不必再另外比對了
'    End If
    If Not rst.EOF And Not rst.BOF Then
        c.Next.Range.Text = VBA.CStr(rst.AbsolutePosition)  'https://docs.microsoft.com/en-us/sql/ado/reference/ado-api/absoluteposition-and-cursorlocation-properties-example-vb?view=sql-server-ver15
        'https://docs.microsoft.com/en-us/sql/ado/reference/ado-api/absoluteposition-property-ado?view=sql-server-ver15
    End If
Next c
rst.Close
cnt.Close
r.Tables(1).Sort FieldNumber:=2, ExcludeHeader:=False, SortFieldType:= _
        wdSortFieldNumeric, SortOrder:=wdSortOrderAscending, _
         CaseSensitive:=False
r.Tables(1).ConvertToText Chr(9)
For Each c In r.Characters
    If VBA.StrComp(c, Chr(9)) = 0 Or VBA.StrComp(c, Chr(13)) = 0 Or VBA.IsNumeric(c) Then c.Delete
Next c
r.Select
Set cnt = Nothing: Set rst = Nothing
Application.ScreenUpdating = True
MsgBox "完成！", vbInformation
End Sub