Oscar Sun

                  Sub 聲符補形聲字插入()
Static objConnection As ADODB.Connection, objRecordset As ADODB.Recordset ' e As Excel.Workbook
Const f = "E:\黃老師工作_守真\聲符\!!!部件聲符最全20110220（黃訂唯一515部件）.xls"
Dim cnt As New ADODB.Connection, rst As New ADODB.Recordset
Dim x As String, i As Long, w As String, st As String

'Const adOpenStatic = 3
'Const adLockOptimistic = 3
'Const adCmdText = &H0001
'https://technet.microsoft.com/zh-tw/library/ee692882.aspx

'If e Is Nothing Then Set e = GetObject(f)
x = Selection.Paragraphs(1).Range.Characters(1)
Selection.MoveUntil Chr(13)
Selection.InsertParagraphAfter
Selection.MoveDown
Selection.TypeText "部件聲符最全"
Selection.Paragraphs(1).Style = "標題 2"
Selection.InsertParagraphAfter
Selection.MoveDown
Selection.Paragraphs(1).Style = "內文"
i = i + 1

If objConnection Is Nothing Then
    Set objConnection = CreateObject("ADODB.Connection")
    Set objRecordset = CreateObject("ADODB.Recordset")
    
    'objConnection.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
        "Data Source=" & f & ";" & _
            "Extended Properties=""Excel 8.0;HDR=Yes;"";"
    objConnection.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
        "Data Source=" & f & ";" & _
            "Extended Properties=""Excel 8.0;HDR=Yes;"";"
    
    objRecordset.Open "Select * FROM [Sheet1$]", _
        objConnection, adOpenStatic, adLockOptimistic, adCmdText
End If
Do Until objRecordset.EOF
'    Wscript.Echo objRecordset.Fields.Item("Name"), _
'        objRecordset.Fields.Item("Number")
    w = objRecordset.Fields.Item(3)
    If StrComp(w, x) = 0 Then
        Selection.TypeText objRecordset.Fields.Item(0)
    End If
    objRecordset.MoveNext
Loop
objRecordset.MoveFirst


'Do Until e.Sheets(1).Cells(i, 1) = ""
'    w = e.Sheets(1).Cells(i, 4)
'    If StrComp(w, x) = 0 Then
'        Selection.TypeText e.Sheets(1).Cells(i, 1)
'    End If
'    i = i + 1
'Loop
Selection.InsertParagraphAfter
Selection.MoveDown
Selection.TypeText "諧聲字檢索系統"
Selection.Paragraphs(1).Style = "標題 2"
Selection.InsertParagraphAfter
Selection.MoveDown
Selection.Paragraphs(1).Style = "內文"

'If cnt Is Nothing Then

    cnt.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=E:\黃老師工作_守真\聲符\@@諧聲字檢索系統（唯一）20160512.mdb" ', , , adAsyncConnect
'End If
st = "SELECT 形聲字.序號, 形聲字.形聲字, 聲符.聲符 FROM 聲符 INNER JOIN 形聲字 ON 聲符.聲符ID = 形聲字.聲符ID WHERE (((StrComp(聲符.聲符,""" & x & """))=0)) ORDER BY 形聲字.序號 ;"
rst.Open st, cnt

If Not rst.EOF Then
    rst.MoveFirst
    rst.Move 1
    Do Until rst.EOF
        Word.ActiveDocument.ActiveWindow.Selection.TypeText rst.Fields("形聲字").Value
    rst.Move 1
    Loop
    Selection.MoveUp wdParagraph, 3, wdExtend
    比較漢文博士和國學大師部件檢字的異同
End If
'MsgBox "done!", vbInformation
End Sub