Oscar Sun

                    Sub 內碼_檢字()
Dim d As Document, a, d1 As Document, x As String
Set d = ActiveDocument
Set d1 = Documents(1)
x = Replace(d1.Range.Text, Chr(13), "")
For Each a In d.Characters
    If Asc(a) <> 13 Then
        If InStr(x, a) > 0 Then
        'If Hex(AscW(a)) > "6938" And Hex(AscW(a)) < "2387F" Then
    '    If AscW(a) > -10162 And AscW(a) < 26409 Then
    '        Select Case Hex(AscW(a))
    '        Select Case AscW(a)
    '            Case 1
    '            Case Else
                If a.HighlightColorIndex <> 5 Then '紫紅色
                    a.Select
                    Stop
                    x = Replace(x, a, "")
                End If
    '        End Select
        End If
    End If
Next a
MsgBox "ok!", vbInformation
End Sub


                  

                    Sub 色塊_把色塊所在段落複製到新文件()
Dim d As Document, p As Paragraph, a, dnew As Document
Set d = ActiveDocument
Set dnew = Documents.Add
For Each p In d.Paragraphs
    If p.Range.HighlightColorIndex <> 0 Then
        p.Range.Copy
        dnew.Paragraphs.Add
        dnew.Paragraphs(dnew.Paragraphs.Count).Range.Paste
    End If
Next
End Sub


                  

                    
Public Enum TranType'http://club.excelhome.net/thread-1164625-1-1.html
    Traditional
    Simplified
End Enum
Sub test()
    Translate [a1], [a2], Simplified
End Sub
Public Sub Translate(InputRg As Range, OutputRg As Range, ToType As TranType)
    Dim Wordapp As New Word.Application
    Dim Wd As Document
    Set Wd = Wordapp.Documents.Add()
    Wd.Range.Text = InputRg
    If ToType = Traditional Then
        Wordapp.WordBasic.ToolsSCTCTranslate Direction:=0, Varients:=0, TranslateCommon:=0
    ElseIf ToType = Simplified Then
        Wordapp.WordBasic.ToolsTCSCTranslate Direction:=0, Varients:=0, TranslateCommon:=0
    Else
    
    End If
    OutputRg = Wd.Range.Text
    Wd.Close False
    Set Wordapp = Nothing
    Set Wd = Nothing
End Sub

                  

                    Sub pic透明(r As Range)
Dim inlshape As InlineShape
For Each inlshape In r.InlineShapes
    With inlshape.PictureFormat 'https://msdn.microsoft.com/zh-tw/VBA/Word-VBA/articles/pictureformat-transparentbackground-property-word
                                'https://msdn.microsoft.com/zh-tw/VBA/Word-VBA/articles/inlineshape-pictureformat-property-word
        .TransparentBackground = msoTrue '背景透明
        .TransparencyColor = RGB(255, 255, 255) '字黑色
    End With
Next inlshape
End Sub

'https://stackoverflow.com/questions/38305617/apply-a-picture-style-to-all-pictures-in-a-word-document#_=_
'https://msdn.microsoft.com/zh-tw/VBA/Word-VBA/articles/shadowformat-transparency-property-word
'https://msdn.microsoft.com/zh-tw/VBA/Word-VBA/articles/pictureformat-transparentbackground-property-word?f=255&MSPPError=-2147217396
                  

                    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