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

ArraysOP vbscript

                    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
    }
}

分割表格-將原表格每列獨立成為單一表格_且抽出末欄之圖，重複標題列 vbscript

View Snippet

                    Option Explicit

Sub splitTableByEachRowTitleed()
Dim r As Long, cel As Cell, s As Long, e As Long, s1 As Long, e1 As Long, rng As Range
Dim inlsp As InlineShape
Dim rw As Row
r = 1

With Selection
    Set rng = .Range
    Do While (.Information(wdWithInTable))
        .SplitTable
        
        Set rw = .Document.Tables(1).Rows(1)
        rw.Range.Copy
        .Document.Tables(.Document.Tables.Count).Range.Characters(1).Select
        .Collapse wdCollapseStart
        .Paste
        .Document.Tables(.Document.Tables.Count).Range.Characters(1).Select
        .Collapse wdCollapseStart
        .MoveLeft
        
        
        If Selection.Document.Tables(r).Rows.Count = 1 Then
            Set cel = Selection.Document.Tables(r).Cell(1, 8)
        Else
            Set cel = Selection.Document.Tables(r).Cell(2, 8)
        End If
        
        If cel.Range.InlineShapes.Count > 0 Then
        Else
            If Selection.Document.Tables(r).Rows.Count > 1 Then _
                Set cel = Selection.Document.Tables(r).Cell(2, 8)
        End If
        s = .Start: e = .End
        rng.SetRange s, s
        If cel.Range.InlineShapes.Count > 0 Then
             cel.Range.InlineShapes(1).Select
            .Cut
'            cel.Range.InlineShapes(1).Range.Cut ' 若要用Range則記得要DoEvents讓系統剪貼簿完成工作
'            DoEvents'或許剛開始還行，久了還是會出錯。還是用Selection物件才保險、萬無一失
            s1 = .Start: e1 = .End
            If s1 > s Then
                Do While (rng.Information(wdWithInTable))
                    s1 = s1 - 1
                    rng.SetRange s1, s1
                Loop
            ElseIf s1 < s Then
                Do While (rng.Information(wdWithInTable))
                    s1 = s1 + 1
                    rng.SetRange s1, s1
                Loop
            End If
            rng.Select
            .Paste
            If .Previous.InlineShapes.Count > 0 Then
                With .Previous.InlineShapes(1)
                    .LockAspectRatio = msoTrue
                    .Height = 200
                End With
            Else
                .MoveRight wdCharacter, 1, wdExtend
                With .InlineShapes(1)
                    '.LockAspectRatio = msoTrue
                    .Height = .Height + 181
                    .Width = .Width + 181
                End With
            End If
            .ParagraphFormat.Alignment = wdAlignParagraphCenter
        End If
        Selection.Document.Tables(r).Columns(8).Cells.Delete
        r = r + 1
        If Selection.Document.Tables(r).Rows.Count > 3 Then'結束時，尚須修改。目前可以權且加幾空白列在最後一列後
            Selection.Document.Tables(r).Rows(3).Select
        Else
            Exit Do
        End If
    Loop
End With
Beep
End Sub