Oscar Sun on SnipSave | Web-based code snippet manager for developers

根據上下文脈絡有條件地標識易學關鍵字 vbscript

                    Rem rng 要處理的範圍 ,arr 要處理的關鍵字 （預設為字串陣列）
Sub marking易學關鍵字(rng As Range, arr As Variant, Optional defaultHighlightColorIndex As word.WdColorIndex = word.wdYellow, _
        Optional fontColor As word.WdColorIndex = word.wdRed, Optional allDoc As Boolean = False)
    
    Dim xd As String, e, eArrKey, arrKey, startRng As Long, endRng As Long ', dict As Scripting.Dictionary
    Dim examOK As Boolean, rngExam As Range, processCntr As Long, dictCoordinatesPhrase As New Scripting.Dictionary, key, isInPhrasesAvoid As Boolean, isFollowedAvoid As Boolean, isPrecededAvoid As Boolean

    On Error GoTo eH
    word.Options.defaultHighlightColorIndex = defaultHighlightColorIndex
    examOK = True
    If allDoc Then Set rng = rng.Document.Range
    startRng = rng.start
    endRng = rng.End
    Set rngExam = rng.Document.Range

    xd = rng.text

    With rng.Find
        .ClearFormatting
'        .HitHighlight
        
'        With .Replacement '現在不用 wdReplaceAll 引數的方法了
'            .font.ColorIndex = fontColor 'wdRed
'            .Highlight = True
'        End With
        For Each e In arr '遍歷每個要標識的關鍵字
        
'            If e = "乾知大始" Then Stop 'just for test
            
            If InStr(xd, e) > 0 Then '在有超連結等功能變數、隱藏文字時可能會miss，今測試並不會，待再測試。
            
                rng.SetRange startRng, endRng
                'If e = "豫" Then
                isFollowedAvoid = Keywords.易學KeywordsToMark_ExamFollowedAvoid.Exists(e)
                isPrecededAvoid = Keywords.易學KeywordsToMark_ExamPrecededAvoid.Exists(e)
                isInPhrasesAvoid = Keywords.易學KeywordsToMark_ExamInPhraseAvoid.Exists(e)
                If isFollowedAvoid Or isPrecededAvoid Or isInPhrasesAvoid Then
'                    '若有內嵌於的片語語詞（包含關鍵的片語語句）需查驗的話，就先記下要比對的位置集合
'                    '若後、前檢查都未過就不必了，故今再改移至內嵌之檢查，並以 dictCoordinatesPhrase.Count 來作判斷
'                    If isInPhrasesAvoid Then
'                        arrKey = Keywords.易學KeywordsToMark_ExamInPhraseAvoid(e)
'                        For Each eArrKey In arrKey '遍歷每個該避開的詞語，蒐集其在文件中的所在位置，以供後續比對
'                            'Set rngExam = rngExam.Document.Range '弄錯了，已有allDoc參數控制是否操作整份文件
'                            rngExam.SetRange startRng, endRng '不需處理整份文件，就只就操作範圍內處置就可。感恩感恩　讚歎讚歎　南無阿彌陀佛 20240915
'                            With rngExam.Find
'                                Do While .Execute(eArrKey, , , , , , True, wdFindStop)
'                                    '記下含有目前關鍵字的詞語片語語彙片段在範圍中的位置
'                                    dictCoordinatesPhrase.Add rngExam.start, rngExam.End
'                                Loop
'                            End With
'                        Next eArrKey
'                    End If
                    
                    Do While .Execute(e, , , , , , True, wdFindStop, True) '在範圍中尋遍關鍵字出現的位置
                        examOK = True '歸零
                        
'                        rng.Select '偵錯用
                        
                        If Not rng.Next Is Nothing Then
                            If rng.Next.Characters.Count > 0 Then
                                '後綴檢查
                                'If UBound(VBA.Filter(Keywords.易學KeywordsToMark_ExamFollowedAvoid(e), rng.Next.Characters(1).text)) < 0 Then
                                If isFollowedAvoid Then
                                    arrKey = Keywords.易學KeywordsToMark_ExamFollowedAvoid(e)
                                    For Each eArrKey In arrKey
                                        If rng.End + VBA.Len(eArrKey) <= endRng Then '這樣的寫法，如果內含超連結等功能變數，恐怕就會失誤了！
                                            rngExam.SetRange rng.End, rng.End + VBA.Len(eArrKey)
                                            If VBA.StrComp(rngExam.text, eArrKey) = 0 Then '找到要避開的關鍵字
                                                examOK = False '檢測不通過
                                                Exit For
                                            End If
                                        End If
                                    Next eArrKey
                                End If
                                If examOK Then
checkPrevious:
                                    If Not rng.Previous Is Nothing Then
                                        '前綴檢查
                                        If rng.Previous.Characters.Count > 0 Then
                                            'If UBound(VBA.Filter(Keywords.易學KeywordsToMark_ExamPrecededAvoid(e), rng.Previous.Characters(rng.Previous.Characters.Count).text)) < 0 Then
                                            If isPrecededAvoid Then
                                                arrKey = Keywords.易學KeywordsToMark_ExamPrecededAvoid(e)
                                                For Each eArrKey In arrKey
                                                    If rng.start - VBA.Len(eArrKey) > -1 Then '這樣的寫法，如果內含超連結等功能變數，恐怕就會失誤了！
                                                        rngExam.SetRange rng.start - VBA.Len(eArrKey), rng.start
                                                        If VBA.StrComp(rngExam.text, eArrKey) = 0 Then '找到要避開的關鍵字
                                                            examOK = False '檢測不通過
                                                            Exit For
                                                        End If
                                                    End If
                                                Next eArrKey
                                            End If
                                            If examOK Then
checkPhrases:                                   '內嵌於檢查：關鍵字含在該避免的片語詞句檢查
                                                'If Keywords.易學KeywordsToMark_ExamInPhraseAvoid.Exists(e) Then
                                                If isInPhrasesAvoid Then
                                                    If dictCoordinatesPhrase.Count = 0 Then
                                                        GoSub buildDictCoordinatesPhrase
                                                    End If
                                                
                                                    For Each key In dictCoordinatesPhrase
                                                     '遍歷每個該避開的詞語片語座標
                                                        '若目前關鍵字內含於要避開的詞語片語語彙片段
                                                        If rng.start >= key And rng.End <= dictCoordinatesPhrase(key) Then

'                                                            rng.Select 'just for test

                                                            examOK = False '檢測不通過
                                                            Exit For
                                                        End If
                                                    Next key

'                                                    arrKey = Keywords.易學KeywordsToMark_ExamInPhraseAvoid(e)
'                                                    For Each eArrKey In arrKey '遍歷每個該避開的詞語，當先蒐集其位置在文件中所在位置，以供後續比對
'                                                        Set rngExam = rngExam.Document.Range
'                                                        With rngExam.Find
'                                                            Do While .Execute(eArrKey, , , , , , True, wdFindStop)
'                                                                '目前關鍵字內含於要避開的詞語片語語彙片段
'                                                                If rng.start >= rngExam.start And rng.End <= rngExam.End Then
'
''                                                                    rng.Select 'just for test
'
'                                                                    examOK = False '檢測不通過
'                                                                    Exit For
'                                                                End If
'                                                            Loop
'                                                        End With
'                                                    Next eArrKey
                                                    
                                                End If
                                                '後、前、中三關都檢驗合格了
                                                If examOK Then '合格才標識
                                                    With rng
                                                        processCntr = processCntr + 1
                                                        If processCntr Mod 35 = 0 Then SystemSetup.playSound 1 '播放音效以免誤以為當了
                                                        Rem 此檔可供效能測試，跑起來不知何故特別久！ file:///H:\我的雲端硬碟\黃老師遠端工作\1易學雜著文本\非清人已初步標點\何良俊＠四友齋叢說.docx
                                                        
                                                        .HighlightColorIndex = defaultHighlightColorIndex
                                                        If .font.ColorIndex = wdAuto Then .font.ColorIndex = fontColor
                                                    End With
                                                Else '片語詞句檢查未過
                                                    If rng.HighlightColorIndex = defaultHighlightColorIndex Then
                                                        With rng
'                                                            .Select 'just for test
                                                            
                                                            .HighlightColorIndex = wdNoHighlight
                                                            .font.ColorIndex = wdAuto
                                                        End With
                                                    End If
                                                End If
                                            Else '前綴檢查未過
                                                'If allDoc Then
                                                If rng.HighlightColorIndex = defaultHighlightColorIndex Then
                                                    With rng
                                                        .HighlightColorIndex = wdNoHighlight
                                                        .font.ColorIndex = wdAuto
                                                    End With
                                                End If
                                            End If
                                        End If
                                    Else '如果前也無後也無
                                        GoTo checkPhrases:
                                    End If
                                Else '後綴檢查未過
                                    'If allDoc Then
                                    If rng.HighlightColorIndex = defaultHighlightColorIndex Then
                                        With rng
                                            .HighlightColorIndex = wdNoHighlight
                                            .font.ColorIndex = wdAuto
                                        End With
                                    End If
                                End If
                            End If
                        Else '如果沒有下文
                            GoTo checkPrevious
                        End If
                    Loop 'Do While .Execute(e, , , , , , True, wdFindStop, True) '在範圍中尋遍關鍵字出現的位置

                    If dictCoordinatesPhrase.Count > 0 Then
                        dictCoordinatesPhrase.RemoveAll '歸零供下一個關鍵字使用
                    End If
                        'If Keywords.易學KeywordsToMark_ExamInPhraseAvoid.Exists(e) Then
                         '       ……
                          '          dictCoordinatesPhrase.Add rngExam.start, rngExam.End
                          
                Else '不用檢查直接取代（逕行標識）者
                    Do While .Execute(e, , , , , , True, wdFindStop, True) '此效能也不會比 wdReplaceAll 引數者慢，可見其內當亦係用類似之迴圈實作者也 20240919 感恩感恩　讚歎讚歎　南無阿彌陀佛
'                        .Parent.HighlightColorIndex = defaultHighlightColorIndex
'                        .Parent.Font.ColorIndex = fontColor
                        Rem 若寫成以下會有49DLL呼叫規格錯誤，這次重寫又不會了，可見是 VBE編譯器故障 20240920
                        With rng
                            .HighlightColorIndex = defaultHighlightColorIndex
                            If .font.ColorIndex = wdAuto Then .font.ColorIndex = fontColor
                        End With
                    Loop
'                    .Execute e, , , , , , True, wdFindStop, True, e, Replace:=wdReplaceAll '在含有超連結等格式化文字時會失靈
                    'rng.SetRange startRng, endRng'前已有
                End If
            End If
        Next e '下一個打算要標識的關鍵字
    End With

finish:
    rng.SetRange startRng, endRng '設回原來的樣子才不會改變，於呼叫端才不會出錯
    Set dictCoordinatesPhrase = Nothing
    
    Exit Sub
    
buildDictCoordinatesPhrase:
        '若有內嵌於的片語語詞（包含關鍵的片語語句）需查驗的話，就先記下要比對的位置集合
'        若後、前檢查都未過就不必了，故今再改移至內嵌之檢查，並以 dictCoordinatesPhrase.Count 來作判斷
        If isInPhrasesAvoid Then
            arrKey = Keywords.易學KeywordsToMark_ExamInPhraseAvoid(e)
            For Each eArrKey In arrKey '遍歷每個該避開的詞語，蒐集其在文件中的所在位置，以供後續比對
                    '已有allDoc參數控制是否操作整份文件
                rngExam.SetRange startRng, endRng '故不需處理整份文件，就只就操作範圍內處置就可。感恩感恩　讚歎讚歎　南無阿彌陀佛 20240915
                With rngExam.Find
                    Do While .Execute(eArrKey, , , , , , True, wdFindStop)
'                        記下含有目前關鍵字的詞語片語語彙片段在範圍中的位置
                        dictCoordinatesPhrase.Add rngExam.start, rngExam.End
                    Loop
                End With
            Next eArrKey
        End If
        
        Return

eH:
    Select Case Err.Number
        Case Else
            MsgBox Err.Number & Err.Description
            Debug.Print Err.Number & Err.Description
            Resume
    End Select
End Sub

ArraysOP vbscript

View Snippet

                    Option Explicit

Rem 20230509 YouChat大菩薩
Rem 在 VBA 中，可以使用 IsArray 函數來判斷一個變量是否是一個數組，但無法確定數組是否具有元素。 如果要檢查數組是否已初始化，可以使用 UBound 函數，該函數返回數組中可用的最後一個索引。 如果數組未初始化，則將返回 -1。 以下是使用 IsArray 和 UBound 函數的示例代碼：
Function IsArrayAlready(myArray) As Boolean
'    Dim myArray() As Integer
    ' Check if array is initialized
    If IsArray(myArray) And UBound(myArray) > -1 Then
        ' Array is initialized and has at least one element
        IsArrayAlready = True
    Else
        ' Array is not initialized or has no elements
    End If
    Rem 注意：無法直接檢查數組中是否存在元素，但是可以通過 UBound 函數檢查數組中可用的最後一個索引，以此來確定數組中是否有元素。
End Function

Rem 20230328 Adrenaline ：
Rem 漢字會照部首再筆畫排序
Public Sub SortArray_QuickSort(arrayToSort As Variant) 'VBA引數預設為傳址（pass by reference）
'    Dim arrayToSort As Variant
'    Dim i As Integer
'
'    ' 取得陣列
'    arrayToSort = Application.Transpose(ExistedNumColumnRange.value)
'
    ' 用 QuickSort 排序
    'Call QuickSortArray(arrayToSort, 1, UBound(arrayToSort))
    Call QuickSortArray(arrayToSort, LBound(arrayToSort), UBound(arrayToSort))
    
'    ' 輸出排序後的結果
'    Debug.Print "排序後的結果："
'    For i = 1 To UBound(arrayToSort)
'        Debug.Print arrayToSort(i)
'    Next i
End Sub

Private Sub QuickSortArray(ByRef arr As Variant, ByVal left As Long, ByVal right As Long)
    Dim i As Long
    Dim j As Long
    Dim pivot As Variant
    Dim temp As Variant
    
    i = left
    j = right
    pivot = arr((left + right) \ 2)
    
    While i <= j
        While arr(i) < pivot And i < right
            i = i + 1
        Wend
        
        While pivot < arr(j) And j > left
            j = j - 1
        Wend
        
        If i <= j Then
            temp = arr(i)
            arr(i) = arr(j)
            arr(j) = temp
            i = i + 1
            j = j - 1
        End If
    Wend
    
    If left < j Then
        Call QuickSortArray(arr, left, j)
    End If
    
    If i < right Then
        Call QuickSortArray(arr, i, right)
    End If
End Sub

Rem creedit with chatGPT大菩薩
Rem 漢字會照筆畫再部首排序
Sub SortStringArray(ByRef arr() As String)
'arr = Array("apple", "banana", "cherry")
QuickSort arr, LBound(arr), UBound(arr) 'chatGPT大菩薩：LBound 是一個 VBA 函數，它會回傳陣列的下界（Lower Bound），也就是陣列的第一個元素的索引。在大多數情況下，陣列的下界是 0，但有時也可以定義成其他數字。例如，如果定義了一個索引為 1 到 10 的陣列，那麼 LBound 的值就是 1。
'For Each s In arr
'Debug.Print s
'Next s
End Sub

Private Sub QuickSort(ByRef arr() As String, ByVal l As Long, ByVal r As Long) 'l=left,r=right chatGPT大菩薩：是的，在這個 QuickSort 函數中， l 參數代表左邊的索引位置，而 r 參數代表右邊的索引位置。這些參數是快速排序算法的主要部分，用於指定排序的邊界。在這個函數中， arr 數組是要進行排序的數組， l 和 r 指定了要進行排序的數組的區間。
If l >= r Then Exit Sub
Dim i As Long, j As Long, X As String
i = l: j = r: X = arr((l + r) \ 2)
'Do
'    While arr(i) < x
'        i = i + 1
'    Wend
'    While x < arr(j)
'    j = j - 1
'    Wend
'    If i <= j Then
'    Swap arr(i), arr(j)
'    i = i + 1
'    j = j - 1
'    End If
'Loop Until i > j
Do
    While StrComp(arr(i), X, vbTextCompare) < 0
    i = i + 1
    Wend
    While StrComp(X, arr(j), vbTextCompare) < 0
    j = j - 1
    Wend
    If i <= j Then
        Swap arr(i), arr(j)
        i = i + 1
        j = j - 1
    End If
Loop Until i > j
QuickSort arr, l, j
QuickSort arr, i, r
End Sub


Private Sub Swap(ByRef a As String, ByRef b As String)
Dim temp As String
temp = a
a = b
b = temp
End Sub

Rem Bing大菩薩'https://www.notion.so/Characters-76ccb4ff823e4a82b0d0af042e5a650b?pvs=4#d7f45c8d4863487db4d92e4cb7787525
'如果只保留漢字中文排序，則 hanOnly=true
Function CharactersToArray(myRange As Range, Optional hanOnly As Boolean = False) As String()

    Dim myArray() As String, arr, e, xRng As String
    Dim i As Long

    If hanOnly Then
        arr = Str.Symbol_withoutEnter
        xRng = myRange.Text
        For Each e In arr
            xRng = VBA.Replace(xRng, e, "")
        Next e
        myRange.Text = VBA.Replace(xRng, Chr(13), "")
    End If
        
    ReDim myArray(1 To myRange.Characters.Count)
    
    For i = 1 To myRange.Characters.Count
        myArray(i) = myRange.Characters(i)
    Next i
    
    CharactersToArray = myArray
End Function

據某一部件列出含此部件組成的國教院3100字 WordVBA Sub 部件構字列出() vbscript

View Snippet

                    rem demo : https://www.youtube.com/live/XSTwXYBq7YM?feature=share
Option Explicit
Dim docx As Document
'定義：漢字 wArray、（漢字所構成之）部件 bjArray、（有部件資料的漢字）筆數 arrSize = ubound( wArray) or = ubound(bjArray)
Dim wArray(), bjArray() As String, arrSize As Integer

Private Sub initialize4808_5032Arrs()
    If arrSize > 0 Then Exit Sub
    On Error GoTo eH
    Dim a, c As Cell, cN As Cell, bj As String, sl As Selection, b As String, r As Integer, flg As Boolean, rng As Range
    
    If docx Is Nothing Then
        'set docx=GetObject(system.SearchPath & "\!!!!部件4要檔!!!!\!!!@@@黃沛榮部件表OKOKOK20161021@@@.docm")
opendocx:
        Set docx = GetObject(system.SearchPath & "\!!!!部件4要檔!!!!\4808字之部件new.docm")
'            Dim dd As Document, ddFn As String
'            ddFn = system.SearchPath & "\!!!!部件4要檔!!!!\4808字之部件new.docm"
'            For Each dd In Documents
'                If VBA.StrComp(dd.FullName, ddFn, vbTextCompare) = 0 Then
'                    Set docx = dd
'                    Exit For
'                End If
'            Next dd
'            If docx Is Nothing Then
'                Set docx = Documents.Open(ddFn, , ReadOnly:=True, Visible:=False)
'            End If
arr:
        For Each c In docx.Tables(1).Columns(1).Cells
            r = r + 1
            If r > 1 Then
    '            wd = wd & VBA.Replace(c.Range.Text, Chr(13) & Chr(7), "")
                ReDim Preserve wArray(r - 2), bjArray(r - 2)
                wArray(r - 2) = c.Range.Characters(1)
                Set cN = c.Next
'                If cN.Range.InlineShapes.Count > 0 Then
                    For Each a In cN.Range.Characters 'c.Next.Range.Characters
                        If InStr(Chr(13) & Chr(7) & Chr(10), a.Text) = 0 Then
                            If a.InlineShapes.Count > 0 Then
                                bj = bj & "," + a.InlineShapes(1).alternativeText & ","
                            Else
                                bj = bj & "," + a & ","
                            End If
                        End If
                    Next a
                    bjArray(r - 2) = VBA.Replace(bj, ",,", ","): bj = ""
'                Else
'                    bjArray(r - 2) = VBA.Replace(cN.Range.Text, Chr(13) & Chr(7), "") & ","
'                End If
            End If
        Next c
        arrSize = r - 2
        r = 0
        With docx.ActiveWindow
            .Parent.UserControl = True
            .WindowState = wdWindowStateMinimize
            .Visible = True
        End With
    End If
    
    Exit Sub
    
eH:
    Select Case Err.Number
        Case 5825 '物件已被刪除
            Resume opendocx
        Case 9 '陣列索引超出範圍
            Resume arr
        Case Else
            MsgBox Err.Number & Err.Description
'            Resume
    End Select
End Sub




Sub 部件構字列出()
    'alt+b
    Dim ur As UndoRecord, sl As Selection, a As Range, soundInfo As Boolean, st As Long, ed As Long ', slText As String, dict As New scripting.Dictionary, rng As Range
    Dim slx As String
    On Error GoTo eH
    
    system.stopUndo ur, "部件構字列出"
    
    
    Set sl = Selection
    If sl.Type = wdSelectionIP Then
        st = sl.Start: ed = sl.Characters(1).End
    Else
        If right(sl.Text, 1) = Chr(13) Then sl.SetRange sl.Start, sl.End - 1
        st = sl.Start: ed = sl.End
    End If
    
    initialize4808_5032Arrs
    
    '上一行開啟4808文檔會影響原來的selection,故須重設
    sl.SetRange st, ed
    
    If sl.Characters.Count = 1 And sl.InlineShapes.Count > 0 Then
        slx = sl.InlineShapes(1).alternativeText
    Else
        slx = sl.Text
    End If
    'If UBound(VBA.Filter(bjArray, "," + sl.Text + ",")) > -1 Then
    If ArraysOP.IsArrayAlready(VBA.Filter(bjArray, "," + slx + ",")) Then
        部件構字列出_sub
        Exit Sub
    End If
    If sl.Characters.Count > 10 Then soundInfo = True
    
    Do While st < ed
        Set a = sl.Document.Range(st, st)
        a.Select
        If sl.Text <> Chr(13) Then
            sl.SetRange a.Characters(1).Start, a.Characters(1).Start
            部件構字列出_sub False
            st = sl.Start
            ed = ed + sl.Start - a.Characters(1).End
        Else
            st = st + 1
        End If
        
    Loop
    
    system.contiUndo ur
    
    If soundInfo Then
        system.playSound 12
        MsgBox "done!", vbInformation
    End If
    
    Exit Sub
    
eH:
    Select Case Err.Number
        Case 49 'DLL 呼叫規格錯誤
            Resume Next
        Case Else
            MsgBox Err.Number + Err.Description
            system.contiUndo ur
            'resume
    End Select
'    If right(sl.Text, 1) = Chr(13) Then sl.SetRange sl.Start, sl.End - 1
'    slText = "," 'sl.Text

'
'    '取得要處理的部件集合
'    For Each a In sl.Characters
'        If a.InlineShapes.Count > 0 Then '字圖
'            slText = slText + a.InlineShapes(1).alternativeText + ","
'            dict(a.InlineShapes(1).alternativeText) = a 'a.InlineShapes(1)
'        Else
'            slText = slText + a.Text + ","
'            dict(a.Text) = a
'        End If
'    Next a
'    'slText = left(slText, Len(slText) - 1)
'
'    '逐一部件處理
'    For Each b In bjArray
'        st = InStr(slText, "," + b + ",")
'        If st > 0 Then
'            slText = VBA.Replace(slText, b + ",", "")
'            Set rng = sl.Document.Range(sl.End, sl.End)
'            Select Case VBA.TypeName(dict(b))
'                Case "Range", "String"
'                    rng.Text = dict(b)
'                Case "InlineShape"
'                    rng.InlineShapes.New rng
'                    Set rng.InlineShapes(1) = a.InlineShapes(1)
'            End Select
'            sl.SetRange rng.Start, rng.Start
'            部件構字列出_sub
'        End If
'    Next b
'
    
'    system.contiUndo ur

End Sub

Rem 20230509 demo : https://www.youtube.com/live/XSTwXYBq7YM?feature=share
'只算3100 則 set5032=false ;要5032 則 set5032=true
Sub 部件構字列出_sub(Optional set5032 As Boolean = False)
    On Error GoTo eH
    
    'Static wArray(), bjArray() As String, arrSize As Integer 'static docx as Document
    'Dim a, c As Cell, cN As Cell, bj As String, sl As Selection, b As String, r As Integer, flg As Boolean, rng As Range
    Dim sl As Selection, b As String, r As Integer, flg As Boolean, rng As Range
    Dim rngChar As Range 'Dim st As Long, ed As Long
    'If Selection.Range.Characters.Count > 1 Then Exit Sub
    Set sl = Selection '.Document.ActiveWindow.Selection
    If sl.Type <> wdSelectionIP Then
        If right(sl, 1) = Chr(13) Then sl.SetRange sl.Start, sl.End - 1
    End If
    b = sl.Text
    If sl.Type <> wdSelectionIP Then
        If b = "" And sl.Characters.Count = 1 And sl.InlineShapes.Count > 0 Then
            b = sl.InlineShapes(1).alternativeText
        End If
        Set rngChar = sl.Document.Range(sl.Start, sl.End)
        sl.Collapse wdCollapseEnd
    Else
        If sl.Characters(1).InlineShapes.Count > 0 Then
            b = sl.Characters(1).InlineShapes(1).alternativeText
        'Else
        End If
        Set rngChar = sl.Characters(1)
        sl.MoveRight
    End If
    
    If b = "" Then Exit Sub
    
    initialize4808_5032Arrs
    
    If set5032 = False Then
        
        Dim arr(1, 6) As String, db As New databases, cnt As New ADODB.Connection, rst As New Recordset, i As Byte, wList As String, level As Byte, tb As Table
        '配置arr
        For i = 0 To 6
            arr(0, i) = StrConv(i + 1, vbWide)
        Next i
        For i = 0 To 6
            arr(1, i) = ""
        Next i
        db.字表比較 cnt
        
        Set rng = sl.Range
        For r = 0 To arrSize
            'If VBA.InStr(bjArray(r), b & ",") Then
            '如果找到部件
            If VBA.InStr(bjArray(r), "," + b + ",") Then
                '如果找到的漢字不是部件本身
                If VBA.StrComp(wArray(r), b) <> 0 Then
                    ''將漢字插入到文件
                    'rng.InsertAfter wArray(r)
                    '將漢字加入陣列arr備用
                    rst.Open "select 級 from 國教院3100 where strcomp(國教院字,""" & wArray(r) & """)=0", cnt, adOpenKeyset, adLockReadOnly
                    If rst.recordCount > 0 Then
                        level = CByte(rst.Fields(0).Value)
                        wList = arr(1, level - 1)
                        arr(1, level - 1) = wList + wArray(r)
                        If Not flg Then flg = True
                    End If
                    rst.Close
                End If
            End If
        Next r
        If Not flg Then
            MsgBox "沒有「" + b + "」部件構成的漢字!", vbExclamation
            sl.SetRange rng.End, rng.End
        Else

            'rng.Select
            Set tb = rng.Tables.Add(rng, 2, 7, wdWord9TableBehavior, wdAutoFitContent)
            'rng.Tables(1).AutoFitBehavior wdAutoFitContent
            For i = 0 To 6
                tb.Cell(1, i + 1).Range.Text = arr(0, i)
            Next i
            For i = 0 To 6
                tb.Cell(2, i + 1).Range.Text = arr(1, i)
            Next i
            'For Each c In tb.Rows(1).Cells
            tb.Rows(1).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
            tb.Rows(1).Cells.VerticalAlignment = wdCellAlignVerticalCenter
            tb.Rows(2).Range.Font.NameFarEast = "標楷體"
            tb.Range.Font.ColorIndex = wdAuto
        
    '        character_set.只留下黃選3000常用字_未選取則以paragraph為單位
            With rngChar.Font
                .Size = 14
                If rngChar.InlineShapes.Count > 0 Then
                    Dim sp As Shape, ilnsp As InlineShape
                    rngChar.InlineShapes(1).Delete
                    rngChar.Select
                    Selection.Font.Size = 14
                    Selection.Font.Color = 192
                    UserForm3.insertBujianPic b
                    Set ilnsp = Selection.Characters(1).InlineShapes(1)
                    'Selection.Characters(1).InlineShapes(1).Select
                    'Set sp = ilnsp.ConvertToShape
                    With ilnsp.PictureFormat
'                        .ColorType = msoPictureAutomatic
'                        .TransparentBackground = msoTriStateToggle
                        .TransparencyColor = RGB(0, 0, 0) '黑色可被穿透（即原圖黑色處透明）
                        '.TransparencyColor = RGB(255, 255, 255) '白色可被穿透（即原圖黑色處透明）
                        .Parent.Fill.Transparency = 0
                        .Parent.Fill.Visible = False

'                        .Parent.Fill.Visible = False
'                        .Parent.Fill.BackColor.RGB = RGB(192, 0, 0)
                        '.Parent.Fill.ForeColor.RGB = RGB(255, 255, 255)
'                        '.TransparencyColor = RGB(192, 0, 0) '字深紅色

                        .Parent.Fill.BackColor.RGB = RGB(192, 0, 0)
'                        .TransparencyColor = RGB(255, 255, 255) '白色可被穿透（即原圖黑色處透明）
'                        .Parent.Fill.Transparency = 1
'                        .Parent.Fill.Visible = False
'                        .Parent.Fill.BackColor.RGB = RGB(255, 255, 255)
'                        .Parent.Fill.BackColor.RGB = RGB(170, 170, 170)
                    End With
'                    With ilnsp.PictureFormat
'                        .TransparentBackground = msoTrue '背景透明
'                        .TransparencyColor = RGB(192, 0, 0) '字深紅色
'                    End With
'                    'sp.Fill.ForeColor.RGB = RGB(192, 0, 0)
''                    sp.ConvertToInlineShape
'                    'Selection.Characters(1).InlineShapes(1).Fill.ForeColor.RGB = RGB(255, 0, 0)
'                    'Selection.Collapse
                Else
                    .Color = 192
                End If
            End With
            sl.SetRange tb.Range.End, tb.Range.End
        End If
        cnt.Close
        Set db = Nothing: Set rst = Nothing: Set cnt = Nothing
        
    '要5032
    Else 'set5032 = true
        For r = 0 To arrSize
            '如果找到部件
            If VBA.InStr(bjArray(r), b) Then
                '如果找到的漢字不是部件本身
                If VBA.StrComp(wArray(r), b) <> 0 Then
                    '將漢字插入到文件
                    rng.InsertAfter wArray(r)
                    If Not flg Then flg = True
                End If
            End If
        Next r
        If Not flg Then
            MsgBox "沒有此部件!", vbExclamation
            sl.SetRange rng.End, rng.End
        Else
            rng.Select
            character_set.只留下黃選3000常用字_未選取則以paragraph為單位
            sl.SetRange rng.End, rng.End
        End If
    End If
    
    
    
    Exit Sub
    
    
eH:
    Select Case Err.Number
'        Case 5825 '物件已被刪除
'            Resume opendocx
'        Case 9 '陣列索引超出範圍
'            Resume arr
        Case Else
            MsgBox Err.Number & Err.Description
'            Resume
    End Select
End Sub

Word 指定快速鍵、設定指定鍵、shortcutkeys vbscript

View Snippet

                    Sub shortcutKeys() '指定快速鍵
CustomizationContext = NormalTemplate
'KeyBindings.Add _
    KeyCategory:=wdKeyCategoryCommand, _
    Command:="Docs.在本文件中尋找選取字串", _
    KeyCode:=BuildKeyCode(wdKeyControl, wdKeyShift, wdKeyPageDown)
KeyBindings.Add _
    KeyCategory:=wdKeyCategoryCommand, _
    Command:="Docs.貼上純文字", _
    KeyCode:=BuildKeyCode(wdKeyShift, wdKeyInsert)
End Sub

Sub shortcutKeys1() '指定快速鍵
'https://docs.microsoft.com/zh-tw/office/vba/api/word.keybindings.add?f1url=%3FappId%3DDev11IDEF1%26l%3Dzh-TW%26k%3Dk(vbawd10.chm160825445);k(TargetFrameworkMoniker-Office.Version%3Dv15)%26rd%3Dtrue
CustomizationContext = ActiveDocument
'KeyBindings.Add _
    KeyCategory:=wdKeyCategoryCommand, _
    Command:="Docs.在本文件中尋找選取字串", _
    KeyCode:=BuildKeyCode(wdKeyControl, wdKeyShift, wdKeyPageDown)
KeyBindings.Add _
    KeyCategory:=wdKeyCategoryCommand, _
    Command:="文字處理.生難字加上國語辭典注音", _
    KeyCode:=BuildKeyCode(wdKeyAlt, wdKeyZ)
End Sub

瀏覽器間互動：C-sharp-MSEdge_Chromium_Browser_automating/Browser.cs csharp

View Snippet

                    //https://github.com/oscarsun72/C-sharp-MSEdge_Chromium_Browser_automating/blob/master/C-sharp-MSEdge_Chromium_Browser_automating/Browser.cs
//備份耳 20210414

using Microsoft.Win32;
using System;
using System.Collections.Generic;
using System.Diagnostics;
using System.Windows.Automation;
using System.Windows.Forms;

namespace C_sharp_MSEdge_Chromium_Browser_automating
{
    class Browser
    {
        string browsername = "chrome";
        public Browser(BrowserName browserNameFrom)
        {
            switch (browserNameFrom)
            {
                case BrowserName.Chrome:
                    break;
                case BrowserName.MsEdge:
                    browsername = "msedge";
                    break;
                case BrowserName.iExplore:
                    browsername = "iexplore";
                    break;
                default:
                    break;
            }
        }

        #region fredrikhaglund/ChromeLauncher.cs
        /*fredrikhaglund/ChromeLauncher.cs
        https://gist.github.com/fredrikhaglund/43aea7522f9e844d3e7b
         */
        private const string ChromeAppKey =
            @"\Software\Microsoft\Windows\CurrentVersion\App Paths\chrome.exe";

        private static string ChromeAppFileName
        {
            get
            {
                return (string)(Registry.GetValue("HKEY_LOCAL_MACHINE" +
                    ChromeAppKey, "", null) ??
                    Registry.GetValue("HKEY_CURRENT_USER" + ChromeAppKey,
                    "", null));
            }
        }

        public void OpenLinkChrome(string url)
        {
            string chromeAppFileName = ChromeAppFileName;
            if (string.IsNullOrEmpty(chromeAppFileName))
            {
                throw new Exception("Could not find chrome.exe!");
            }
            Process.Start(chromeAppFileName, urlRegx(url));
        }
        #endregion

        string getUrl(ControlType controlType)
        {
            string urls = "";
            try
            {
                //Process[] procsChrome = Process.GetProcessesByName("chrome");
                Process[] procsBrowser = Process.GetProcessesByName(browsername);
                if (procsBrowser.Length <= 0)
                {
                    //    MessageBox.Show("Chrome is not running");
                    MessageBox.Show(browsername + " " +
                        "is not the source running browser" + "\n" +
                        "來源流覽器");
                }
                else
                {
                    foreach (Process proc in procsBrowser)
                    {
                        // the chrome process must have a window
                        if (proc.MainWindowHandle == IntPtr.Zero)
                        {
                            continue;
                        }

                        // find the automation element
                        AutomationElement elm = AutomationElement.FromHandle
                            (proc.MainWindowHandle);
                        //AutomationElement elmUrlBar =
                        //    elm.FindFirst(TreeScope.Descendants,
                        //    new PropertyCondition(AutomationElement.NameProperty,
                        //    "Address and search bar"));
                        AutomationElementCollection elmUrlBar =
                            elm.FindAll(TreeScope.Subtree,
                            new PropertyCondition(
                                AutomationElement.ControlTypeProperty,
                                controlType));//https://social.msdn.microsoft.com/Forums/en-US/f9cb8d8a-ab6e-4551-8590-bda2c38a2994/retrieve-chrome-url-using-automation-element-in-c-application?forum=csharpgeneral
                        /*要用Edit屬性才抓得到網址列,Text也不行
                         */

                        // if it can be found, get the value from the URL bar
                        if (elmUrlBar != null)
                        {
                            int i = 0;int cnt = elmUrlBar.Count;
nx:                          foreach (AutomationElement Elm in elmUrlBar)
                            {
                                try
                                {
                                    i++;if (i > cnt)break;
                                    string vp = ((ValuePattern)Elm.
                                    GetCurrentPattern(ValuePattern.Pattern)).
                                    Current.Value as string;
                                    if (urls.IndexOf(vp)==-1)
                                    urls += (vp + " ");
                                }
                                catch (Exception)
                                {
                                    goto nx;
                                    //throw;
                                }
                            }
                        }
                    }
                }
            }
            catch (Exception ex)
            {
                //textBox2.Text = ex.ToString();
                MessageBox.Show(ex.ToString());                
            }
            return urls;
        }

        private string whatWebsite(string urls)
        {
            List<string> gettextboxSiteList = new List<string> { "http://dict.revised.moe.edu.tw/" };
            foreach (string website in gettextboxSiteList)
            {
                if (urls.IndexOf(website) > -1)
                {
                    return getUrl(ControlType.Edit) +" " + Clipboard.GetText();
                    //視窗若是最小化，則也是抓不到的
                    /* 完全抓不到《國語辭典》下方的網頁網址方塊。或許與轉成文字那行程式碼有關
                     * 目前只能先用Edit了，若不行再先手動複製，由程式碼讀書剪貼簿者（如上一行）……感恩感恩　南無阿彌陀佛 20210414
                     * 《國語辭典》以下有東西：
                     * Edit：唯此較似，但仍無效
                     * Text,Hyperlink,Image 有，但都不切實際。不是該頁面的連結
                     * 以下屬性則均無
                     * Window,Pane,Button,Calendar,CheckBox,
                     * CheckBox,Custom,DataGrid,DataItem,Document,Group,
                     * Header,HeaderItem,List,ListItem,Menu,MenuBar,MenuItem,
                     * ProgressBar,RadioButton,ScrollBar,Separator,Slider,Spinner,
                     * SplitButton,StatusBar,Tab,TabItem,Table,Thumb,TitleBar,
                     * ToolBar,ToolTip,Tree,TreeItem
                     * 網頁原始碼為：
                     * <table class="referencetable1">
                        <tr><td>
                        <span >本頁網址︰</span><input type="text" value="http://dict.revised.moe.edu.tw/cgi-bin/cbdic/gsweb.cgi?o=dcbdic&searchid=Z00000016073" size=80 onclick="select()" onkeypress="select()" readonly="" >
                        </td></tr>
                        </table>
                     * 則應是text型別沒錯啊。或者看可讀選取網頁原始碼，再取得此網址即可 20210414
                     */
                }
            }
            return urls;
        }

        //public static string[] getUrl(BrowserName browserNameFrom)
        internal string[] getUrlGo()
        {//https://www.c-sharpcorner.com/forums/how-to-all-the-urls-of-the-open-tabs-of-a-browser
            string[] msg = { "", "" };
            try
            {
                ////Process[] procsChrome = Process.GetProcessesByName("chrome");
                //Process[] procsBrowser = Process.GetProcessesByName(browsername);
                //if (procsBrowser.Length <= 0)
                //{
                //    //    MessageBox.Show("Chrome is not running");
                //    MessageBox.Show(browsername + " " +
                //        "is not the source running browser" + "\n" +
                //        "來源流覽器");
                //}
                //else
                //{
                //    string urls = "";
                //    foreach (Process proc in procsBrowser)
                //    {
                //        // the chrome process must have a window
                //        if (proc.MainWindowHandle == IntPtr.Zero)
                //        {
                //            continue;
                //        }

                //        // find the automation element
                //        AutomationElement elm = AutomationElement.FromHandle
                //            (proc.MainWindowHandle);
                //        //AutomationElement elmUrlBar =
                //        //    elm.FindFirst(TreeScope.Descendants,
                //        //    new PropertyCondition(AutomationElement.NameProperty,
                //        //    "Address and search bar"));
                //        AutomationElementCollection elmUrlBar =
                //            elm.FindAll(TreeScope.Subtree,
                //            new PropertyCondition(
                //                AutomationElement.ControlTypeProperty,
                //                ControlType.Edit));//https://social.msdn.microsoft.com/Forums/en-US/f9cb8d8a-ab6e-4551-8590-bda2c38a2994/retrieve-chrome-url-using-automation-element-in-c-application?forum=csharpgeneral
                //        /*要用Edit屬性才抓得到網址列,Text也不行
                //         */

                //        // if it can be found, get the value from the URL bar
                //        if (elmUrlBar != null)
                //        {
                //            foreach (AutomationElement Elm in elmUrlBar)
                //            {
                //                string vp = ((ValuePattern)Elm.
                //                    GetCurrentPattern(ValuePattern.Pattern)).
                //                    Current.Value as string;
                //                urls += (vp + " ");
                //            }
                //        }
                //    }

                string urls = whatWebsite(getUrl(ControlType.Edit));
                if (urls == "")
                {

                }
                else
                {
                    //textBox1.Text = urls;
                    msg[0] = urls;
                    if (urls.IndexOf("https://") > -1 ||
                        urls.IndexOf("http://") > -1)
                    {
                        //openUrlChrome(@urls);//冠不冠「@」沒差
                        OpenLinkChrome(urls);
                    }
                    else
                        //openUrlChrome(@"https://" + @urls);//冠不冠「@」沒差
                        OpenLinkChrome(@"https://" + @urls);//冠不冠「@」沒差
                }
            }
            catch (Exception ex)
            {
                //textBox2.Text = ex.ToString();
                msg[1] = ex.ToString();
            }
            return msg;
        }
        void getUrl_noWork()
        //https://stackoverflow.com/questions/18897070/getting-the-current-tabs-url-from-google-chrome-using-c-sharp
        { // there are always multiple chrome processes, so we have to loop through all of them to find the
          // process with a Window Handle and an automation element of name "Address and search bar"
            Process[] procsChrome = Process.GetProcessesByName("chrome");
            string urls = "";
            foreach (Process chrome in procsChrome)
            {
                // the chrome process must have a window
                if (chrome.MainWindowHandle == IntPtr.Zero)
                {
                    continue;
                }

                // find the automation element
                AutomationElement elm = AutomationElement.FromHandle
                    (chrome.MainWindowHandle);
                AutomationElement elmUrlBar =
                    elm.FindFirst(TreeScope.Descendants,
                    new PropertyCondition(AutomationElement.NameProperty,
                    "Address and search bar"));
                /*NameProperty 這個屬性抓不到
                 * AutomationElement.ControlTypeProperty,
                ControlType.Edit));//這個個屬性才抓得到網址列，詳 getUrl()
                */

                // if it can be found, get the value from the URL bar
                if (elmUrlBar != null)
                {
                    AutomationPattern[] patterns = elmUrlBar.GetSupportedPatterns();
                    if (patterns.Length > 0)
                    {
                        ValuePattern val =
                            (ValuePattern)elmUrlBar.GetCurrentPattern(patterns[0]);
                        //Console.WriteLine("Chrome URL found: " + val.Current.Value);
                        urls += val.Current.Value;
                    }
                }
            }

        }

        void openUrlChrome(string url)
        {//https://stackoverflow.com/questions/6305388/how-to-launch-a-google-chrome-tab-with-specific-url-using-c-sharp
         //string url = @"https://stackoverflow.com/questions/6305388/how-to-launch-a-google-chrome-tab-with-specific-url-using-c-sharp/";
         //string browserFullname = @"C:\Program Files (x86)\Google\Chrome\Application\chrome.exe";
            string browserFullname = ChromeAppFileName;

            //之前可能是用到WPF所以不接受路徑中有空格，且又有存取權限的問題。這個Windows Forms應用程式則似乎都又有這樣的問題了
            //string browserFullname = @"C:\""Program Files (x86)""\Google\Chrome\Application\google_translation-ConsoleApp.exe";
            //使用空格的長檔名或路徑需要用引號括住:
            //https://docs.microsoft.com/zh-tw/troubleshoot/windows-server/deployment/filenames-with-spaces-require-quotation-mark
            //browserFullname = @"V:\softwares\PortableApps\PortableApps\GoogleChromePortable\GoogleChromePortable.exe";

            Process.Start(browserFullname, @urlRegx(url));//冠不冠「@」沒差。「"」要取代為「%22」才有效，取代為「""」也無效 20210407
                                                          //Process.Start(url);//這樣是用系統預設瀏覽器開啟
        }

        string urlRegx(string url)
        {//網址規範化-將特殊字元置換,並清除不必要之字元
            string[] replWds = { "\"", "%22" };//, "http//", "" };
            //string clearUrl = url;
            for (int i = 0; i < replWds.Length; i++)
            {
                url = url.Replace(replWds[i], replWds[++i]);
            }
            #region HTTP not HTTPs
            //List<string> webSitesHTTP = new List<string> { "dict.revised.moe.edu.tw" };
            //foreach (string websitehttp in webSitesHTTP)
            //{
            //    if (url.IndexOf(websitehttp) > -1)
            //    {
            //        url = url.Replace("https://", "http://");
            //    }

            //}
            #endregion
            return url;//url.Replace("\"", "%22");
        }

        #region MyTempRegion

        string browserFullname = getBrowserFullname(BrowserName.MsEdge);
        private static string getBrowserFullname(BrowserName browserName)
        {//https://stackoverflow.com/questions/14299382/getting-chrome-and-firefox-version-locally-c-sharp
            object path; string bFullname = "";
            switch (browserName)
            {
                case BrowserName.Chrome:
                    path = Registry.GetValue
                        (@"HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\App Paths\chrome.exe", "", null);
                    if (path != null)
                        bFullname = FileVersionInfo.GetVersionInfo(path.ToString()).FileVersion;
                    else
                        bFullname = "";
                    break;
                case BrowserName.MsEdge:
                    bFullname = "";
                    break;
                default:
                    bFullname = "";
                    break;
            }
            return bFullname;

            //path = Registry.GetValue(@"HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\firefox.exe", "", null);
            //if (path != null)
            //    Console.WriteLine("Firefox: " + FileVersionInfo.GetVersionInfo(path.ToString()).FileVersion);
        }
        #endregion
    }
}