Oscar Sun

                  Sub 分析漢字聲符() '漢字聲符列表()20161110'
Dim d As Document, a As Object, x As String, v(3) As String, i As Integer, rng As Range, myrng As Range, a_myrng As Object, c As Cell, rngd As New Document, od As New Document
Dim cnt As New ADODB.Connection, rst As New ADODB.Recordset, objparam As New ADODB.Parameter, cmd As New ADODB.Command
Dim cp As String
Application.ScreenUpdating = False

'cnt.Open "Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=C:\!!!@漢字教學集中@!!!\!!@@數位工具@@!!\9諧聲系統\@@諧聲字檢索系統（唯一）20160512.mdb;Mode=Share Deny None;Extended Properties="";Jet OLEDB:System database=C:\Users\123\AppData\Roaming\Microsoft\Access\System.mdw;Jet OLEDB:Registry Path=Software\Microsoft\Office\14.0\Access\Access Connectivity Engine;Jet OLEDB:Database Password="";Jet OLEDB:Engine Type=5;Jet OLEDB:Database Locking Mode=1;Jet OLEDB:Global Partial Bulk Ops=2;Jet OLEDB:Global Bulk Transactions=1;Jet OLEDB:New Database Password="";Jet OLEDB:Create System Database=False;Jet OLEDB:Encrypt Database=False;Jet OLEDB:Don't Copy Locale on Compact=False;Jet OLEDB:Compact Without Replica Repair=False;Jet OLEDB:SFP=False;Jet OLEDB:Support Complex Data=True;Jet OLEDB:Bypass UserInfo Validation=False"'
cnt.Open "Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=C:\!!!@漢字教學集中@!!!\!!@@數位工具@@!!\9諧聲系統\@@諧聲字檢索系統（唯一）20160512.mdb"
Set cmd.ActiveConnection = cnt
cmd.CommandText = "漢字聲符查詢"
cmd.CommandType = adCmdStoredProc
rst.CursorType = adOpenStatic
rst.LockType = adLockReadOnly
Set d = ActiveDocument
cp = d.ActiveWindow.Caption

rngd.ActiveWindow.Visible = False
od.ActiveWindow.Visible = False
od.Range.Text = d.Range.Text
Set rng = od.Range
For Each a In rng.Characters
    If StrComp(a, Chr(13)) <> 0 Then
        Set objparam = cmd.CreateParameter("q", adBSTR, adParamInput, 2, a)
        cmd.Parameters.Append objparam
        rst.Open cmd
        If rst.RecordCount > 0 Then
            For i = 0 To 3 '取得各屬性值：0.形聲字拼音、1.形聲字形符、2.形聲字聲符、3.形聲字聲符拼音
                x = Nz(rst.Fields(i).Value, "")
                If i = 1 Then '從【形聲字解釋】取形符
                    Set myrng = rngd.Range
                    myrng.Text = x
                    For Each a_myrng In myrng.Characters
                        If StrComp(a_myrng, ChrW(20174)) = 0 Or StrComp(a_myrng, "從") = 0 Then
                            If Not a_myrng.Next.Next.Next.Next Is Nothing Then
                                If StrComp(a_myrng.Next.Next.Next.Next, "聲") = 0 Then '有逗號
                                    v(i) = a_myrng.Next
                                    Exit For
                                ElseIf StrComp(a_myrng.Next.Next.Next, "聲") = 0 Then '沒逗號
                                    v(i) = a_myrng.Next
'                                Else
''                                    MsgBox "check!", vbExclamation
''                                    Stop
'                                    v(i) = ""
                                    Exit For
                                End If
                            Else
                                v(i) = ""
                                Exit For
                            End If
                        End If
                    Next a_myrng
                    If a_myrng Is Nothing Then
                        v(i) = ""
                    End If
                Else
                    v(i) = x
                End If
            Next i
            GoSub tbl
        Else
            x = ""
'            v = Empty
            GoSub tbl
        End If
        cmd.Parameters.Delete (0)
        rst.Close

    End If
    d.ActiveWindow.Caption = a.End & "/" & rng.Characters.Count
Next a
rngd.Close wdDoNotSaveChanges
od.Close wdDoNotSaveChanges
Set rngd = Nothing
Set od = Nothing
Dim clm
clm = Array(29.75, 99.75, 27.85, 29.75, 99.75)
For i = 1 To 5
    d.Tables(1).Columns(i).Width = clm(i - 1)
Next i
d.ActiveWindow.Caption = cp
Application.ScreenUpdating = True
Exit Sub

tbl:
If d.Tables.Count = 0 Then
    'd.Tables.Add d.Paragraphs(1).Range, 1, 5
    d.Tables.Add d.Range, 1, 5
Else
    d.Tables(1).Rows.Add
End If
d.Tables(1).Rows(d.Tables(1).Rows.Count).Cells(1).Range.Text = a
If rst.RecordCount > 0 Then
    i = 0
    For Each c In d.Tables(1).Rows(d.Tables(1).Rows.Count).Cells
        If c.ColumnIndex > 1 Then
            c.Range.Text = v(i)
            i = i + 1
        End If
    Next c
End If

Return
End Sub