Oscar Sun

                  Sub 插入諧聲字檢索系統資料()
Dim cnt As New ADODB.Connection, rst As New ADODB.Recordset
Dim p As String, w, Access As Object
Const fPath As String = "S:\黃老師工作_守真\!!!!!字源\@2018字源@\原來檔240外待補字\漢字3000有而小學及240皆無之1580字"
Dim fs As Object, fd, fc, fl
Dim d As Document, pph As Paragraph, pRng As Range
p = "Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=" & database.dbFile("@@諧聲字檢索系統（唯一）20170518", "")
cnt.Open p
Set Access = CreateObject("Access.application")
Set fs = CreateObject("Scripting.FileSystemObject")
Set fd = fs.GetFolder(fPath)
Set fc = fd.Files
For Each fl In fc
    Set d = Documents.Open(fl.path, , , False)
    'Set d = GetObject(fl)
    d.ActiveWindow.Visible = False
    Set pph = d.Paragraphs(2): Set w = d.Paragraphs(1).Range.Characters(1)
    With pph
        If InStr(.Range.Text, "《說文‧气部》：「气，雲气也。象形") > 0 Then
            Set pRng = pph.Range
            pRng.SetRange .Range.Characters(3).Start, .Range.Characters(.Range.Characters.Count - 1).End
            With rst
1
                .Open "select 出處,形聲字解釋,說明,查核 from 形聲字 where strcomp(形聲字,""" & w.Text & """)=0 order by 形聲字解釋 desc,說明 desc,查核 desc", cnt, adOpenKeyset, adLockReadOnly
                If .RecordCount = 0 Or VBA.IsNull(.Fields(1).Value) Then
'                    GoTo 2
                    Beep
                    Shell "explorer D:\千慮一得齋\書信\圖書管理\i-Part愛情公寓\同修\念佛佛號佛樂\02-南無阿彌陀佛六字佛號(淨空法師念誦).mp3"
                    d.ActiveWindow.Visible = True
                    w.Copy
                    Stop
                    rst.Close: GoTo 1
                End If
                If VBA.IsNull(.Fields(2).Value) Or .Fields(2).Value = "" Then
                    pRng.Text = .Fields(0).Value & "：「" & Replace(Replace(.Fields(1).Value, "「", "『"), "」", "』") & "」"
                Else
                    pRng.Text = .Fields(0).Value & "：「" & Replace(Replace(.Fields(1).Value, "「", "『"), "」", "』") & "」" & Chr(11) & Replace(Access.PlainText(.Fields(2).Value), Chr(13) & Chr(10), Chr(11))  'Chr(11)手動分行符號
                End If
                If Not (VBA.IsNull(.Fields(3).Value) Or .Fields(3).Value = "") Then
                    pRng.Text = pRng.Text & Chr(11) & VBA.Trim(.Fields(3).Value)
                End If
                
                段落及文字.取代造字 pph
2              .Close
            End With
            d.Save
        Else '處理過的移動
            d.Close '移動檔案
            fl.Move "s:\黃老師工作_守真\!!!!!字源\@2018字源@\test\"
            GoTo 3
        End If
    End With
    d.Close
3
Next fl
MsgBox "done", vbInformation

End Sub