Oscar Sun

                    Option Explicit

Sub IEBrowser()
'https://youtu.be/XbhtQA6q6CY
'https://referencesource.microsoft.com/#System.Web/Configuration/BrowserCapabilitiesFactory.cs,875f9347ad596360
'https://www.google.com/search?q=CreateObject(%22internetexplorer.application%22)&rlz=1C1JRYI_zh-twTW717TW718&oq=CreateObject(%22internetexplorer.application%22)&aqs=chrome..69i57.5602j0j7&sourceid=chrome&ie=UTF-8
Dim whatWhere As String, rw As Long, URL As String
rw = ActiveCell.Row
If ActiveCell.Column > 1 Then
    Cells(rw, 1).Select
End If
whatWhere = ActiveCell.Value
Select Case whatWhere
    Case "查詢《國語辭典》"
        URL = Range("c1").Value
        If URL = "" Then URL = "http://dict.revised.moe.edu.tw/cbdic/search.htm"
    Case Else
        Exit Sub
End Select
With CreateObject("internetexplorer.application")
    .navigate URL
    Do While .Busy Or .readyState <> 4
        DoEvents
    Loop
    'DOM物件文件物件模型（Document Object Model, DOM）是HTML、XML 和SVG 文件的程式介面。
    With .document
        Select Case whatWhere
            Case "查詢《國語辭典》"
                .all("qs0").Value = Range("b" & rw).Value '.all是IE專用的方法
                .all("button").Click
            Case Else
                Exit Sub
        End Select
End With
    .Visible = True
End With
End Sub
'http://forum.twbts.com/viewthread.php?tid=10377
'Chrome:
'https://www.google.com/search?rlz=1C1JRYI_zh-twTW717TW718&sxsrf=ACYBGNRGnMYUxCpRkh5EHvYqUn1OiP49ug%3A1573272750353&ei=rjzGXfSeFeyUr7wPiOCK6Ao&q=createobject%28+chrome.application+%29&oq=CreateObject%28%22chro.application%22%29&gs_l=psy-ab.1.0.0i7i30i19l3j0i8i7i30i19l2j0i7i5i30i19l5.19331.21442..23170...0.0..0.80.260.4......0....1..gws-wiz.......0i7i30j0i8i7i30.KIl85BnsB28
'https://community.smartbear.com/t5/TestComplete-Functional-Web/How-do-I-get-a-web-element-from-Chrome-browser-using-VBScript-I/td-p/156766
'https://tomyam-yang.blogspot.com/2015/09/vbsgoogle-chromeie.html


                  

                    Option Explicit
Dim docx As Document
Sub 查詢部件字頻()
Shell SearchPath & "\!!!!部件4要檔!!!!\部件篩選器.exe", vbNormalFocus
End Sub
Function 某詞部件數查詢(rng As Range, ByRef r() As Range) As Integer
Dim a, n As Integer, zi As Integer
If rng.Characters.Count < 2 Then Exit Function
For Each a In rng.Characters
    n = n + CInt(某字部件數查詢(VBA.CStr(a), zi, r))
    zi = zi + 1
Next a
某詞部件數查詢 = n
End Function
Function 某字部件數查詢(w As String, ByVal zi As Integer, ByRef copyRng() As Range) As Byte
On Error GoTo EH
Static wArray() ', wd As String
Dim c As Cell, flg As Boolean, rng As Range, r As Integer, s As Integer
If docx Is Nothing Then
opendocx:
    Set docx = GetObject(system.SearchPath & "\!!!!部件4要檔!!!!\4808字之部件new.docm")
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)
            wArray(r - 2) = c.Range.Characters(1)
        End If
    Next c
    r = 0
    With docx.ActiveWindow
        .WindowState = wdWindowStateMinimize
        .Visible = True
    End With
End If
's = VBA.InStr(wd, w)
s = UBound(wArray)
For r = 0 To s
    If StrComp(wArray(r), w) = 0 Then
        s = r + 1
        r = 0
        Exit For
    End If
Next
If r = s + 1 Then '找不到
'    If VBA.InStr(Str.所有符號(), w) Then
'        'stay no processing
'    End If
    s = 0
    r = 0
End If
If s > 0 Then
'    For Each c In docx.Tables(1).Columns(1).Cells'this had poor performance
'        r = r + 1
'        If r > 1 Then
'            If VBA.InStr(c.Range.Text, w) Then
                Set c = docx.Tables(1).Cell(s + 1, 1)
                某字部件數查詢 = VBA.CByte(VBA.Replace(c.Next.Next.Range.Text, Chr(13) & Chr(7), ""))
                Set rng = c.Next.Next.Range
                rng.SetRange c.Next.Range.Start, c.Next.Range.End - 1
                Set copyRng(zi) = rng
                flg = True
'                Exit For
'            End If
'        End If
'    Next
End If
If flg = False Then
'    MsgBox "沒有找到", vbExclamation
    'Debug.Print w
    某字部件數查詢 = 0
End If
Exit Function
EH:
Select Case Err.Number
    Case 5825 '物件已被刪除
        Resume opendocx
    Case 9 '陣列索引超出範圍
        Resume arr
    Case Else
        MsgBox Err.Number & Err.Description
'        Resume
End Select
End Function
Sub 某字部件數列出()
Dim w As String, wCnt As Integer, cnt As Integer 'Alt+q
Dim rng  As Range, dthis As Document
Dim iR As Range
w = Selection.Text
Set rng = Selection.Range
If Selection.Type <> wdSelectionIP Then
    Selection.Collapse wdCollapseEnd
Else
    Selection.Move wdCharacter, 1
End If
Set iR = Selection.Document.Range(Selection.Start, Selection.End)
If VBA.InStr(Str.所有符號(), w) > 0 Then Exit Sub   '符號字不處理
Set dthis = Selection.Document
wCnt = rng.Characters.Count
ReDim r(wCnt - 1) As Range
If wCnt > 1 Then
    Application.ScreenUpdating = False
    cnt = 某詞部件數查詢(rng, r) '呼叫此二函式，selection可能就會換到部件檔案去了
    '所以從此以下都不宜再用Selection了，要用也要改用dthis來調用
Else
    cnt = VBA.CInt(VBA.CStr(某字部件數查詢(w, 0, r)))
End If
If cnt > 0 Then
    If wCnt = 1 Then
        iR.InsertAfter VBA.CStr(cnt) '插入部件數
        iR.Collapse wdCollapseEnd
'        Selection.TypeText VBA.CStr(cnt)
    End If
    iR.ParagraphFormat.BaseLineAlignment = wdBaselineAlignCenter
'    Selection.ParagraphFormat.BaseLineAlignment = wdBaselineAlignCenter
    If wCnt > 1 Then '記下插入部件數及貼上部件資料前的位置remark the position before paste
        Dim rg As Range, rgNext As Range, stRg As Long, a, b
        stRg = iR.End
'        stRg = Selection.End
    End If
    某字部件列出 r, iR
    If wCnt > 1 Then
        'Set rg = Selection.Document.Range(Start:=stRg, End:=Selection.End)
        Set rg = dthis.Range(Start:=stRg, End:=iR.End) '貼上的部件資料範圍
        Set rgNext = dthis.Range(rg.Characters(2).Start, rg.End)
            '取得了range陣列貼上後,要汰重 eliminate duplicates
            For Each a In rg.Characters
                rgNext.SetRange a.Next.Start, rg.End
                For Each b In rgNext.Characters
                    If a.InlineShapes.Count = 0 Then
                        If VBA.StrComp(b, a) = 0 Then
                            b.Delete
                        End If
                    Else
                        If b.InlineShapes.Count > 0 Then
                            If VBA.StrComp(b.InlineShapes(1).AlternativeText, a.InlineShapes(1).AlternativeText) = 0 Then b.Delete
                        End If
                    End If
                Next b
            Next a
            wCnt = rg.Characters.Count
            rg.SetRange Start:=stRg, End:=stRg
            rg.InsertAfter VBA.CStr(wCnt)
            Application.ScreenUpdating = True
    End If
    iR.Collapse wdCollapseEnd
    iR.Select '呼叫Selection,讓批量呼叫本程序的開頭Selection定位
Else
    MsgBox "尚無「" & w & "」字部件!", vbExclamation
End If
End Sub

Sub 某字部件列出(r() As Range, ByRef iR As Range)
Dim e
On Error GoTo quz
Set e = r(0)
For Each e In r
    If Not e Is Nothing Then '若找不到部件則是nothing
        e.Copy
        'Selection.Paste
        iR.Paste '貼上之後仍保有選取範圍
        iR.Collapse wdCollapseEnd
    End If
Next e
quz:
End Sub
Sub 某字部件數列出_批量() 'Alt+shift+q
Dim wCnt As Integer, a As Integer, s As Long, r As Range
wCnt = Selection.Range.Characters.Count
s = Selection.Start
Selection.Collapse wdCollapseStart
Application.ScreenUpdating = False
For a = 1 To wCnt
    某字部件數列出
'    Selection.Move'某字部件數列出 執行完會自己移到尾端，故不必此
Next a
Application.ScreenUpdating = True
Set r = Selection.Range
r.SetRange s, r.End
r.Select
HwayuwenToolRef.加總 Selection, "某字部件數列出_批量"
End Sub

Sub 部件數大於多少之字列出()
Dim rng As Range, a, n, z As Byte, docx As Document, sybol As String, r(1) As Range
Set rng = Selection.Range
n = InputBox("請輸入要多過多少個部件數的字才列出？", , "2")
If n = "" Then Exit Sub
If Not VBA.IsNumeric(n) Then Exit Sub
n = VBA.CByte(n)
sybol = Str.所有符號
For Each a In rng.Characters
    If VBA.InStr(sybol, a) = 0 Then '符號字不處理
        z = 某字部件數查詢(VBA.CStr(a), 0, r)
        If z > n Then
            If docx Is Nothing Then Set docx = Documents.Add
            docx.Range.InsertAfter a
        ElseIf z = 0 Then '找不到
            docx.ActiveWindow.Selection.HomeKey wdStory, wdMove
            docx.ActiveWindow.Selection.TypeText a
            docx.ActiveWindow.Selection.MoveLeft wdCharacter, 1, wdExtend
            Selection.Font.ColorIndex = wdRed
        End If
    End If
Next
End Sub

Sub 部件構字列出()
On Error GoTo EH 'alt+b
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
'If Selection.Range.Characters.Count > 1 Then Exit Sub
Set sl = Selection '.Document.ActiveWindow.Selection
b = sl.Text
If Selection.Type <> wdSelectionIP Then
    Selection.Collapse wdCollapseEnd
Else
    Selection.MoveRight
End If
If docx Is Nothing Then
    'set docx=GetObject(system.SearchPath & "\!!!!部件4要檔!!!!\!!!@@@黃沛榮部件表OKOKOK20161021@@@.docm")
opendocx:
    Set docx = GetObject(system.SearchPath & "\!!!!部件4要檔!!!!\4808字之部件new.docm")
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 c.Next.Range.Characters
                    If a.InlineShapes.Count > 0 Then
                        bj = bj & a.InlineShapes(1).AlternativeText
                    Else
                        bj = bj & a
                    End If
                Next a
                bjArray(r - 2) = 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
        .WindowState = wdWindowStateMinimize
        .Visible = True
    End With
End If

Set rng = sl.Range
For r = 0 To arrSize
    If VBA.InStr(bjArray(r), b) Then
        rng.InsertAfter wArray(r)
        If Not flg Then flg = True
    End If
Next r
If Not flg Then
    MsgBox "沒有此部件!", vbExclamation
Else
    rng.Select
    CHINAWORD.只留下黃選3000常用字_未選取則以paragraph為單位
End If
Exit Sub
EH:
Select Case Err.Number
    Case 5825 '物件已被刪除
        Resume opendocx
    Case 9 '陣列索引超出範圍
        Resume arr
    Case Else
        MsgBox Err.Number & Err.Description
End Select
End Sub


                  

                    Option Explicit

Sub 選擇類型訊息()
Dim Msg1, Msg2
    Select Case Selection.Type
    Case 1
        Msg1 = "位置"
        Msg2 = "圖形或文字方塊"
    Case 2
        Msg1 = "文字列"
        Msg2 = "表的行或列"
    Case 4, 5
        Msg1 = "表的行或列"
        Msg2 = "位置"
    Case 8
        Msg1 = "圖形或文字方塊"
        Msg2 = "文字列"
    Case Else
        Msg1 = "文件中沒有的項目"
        Msg2 = "你的最愛"
    End Select
    MsgBox "目前所選擇的是「" & Msg1 & "」！" _
        & vbCr & "請選擇「" & Msg2 & "」！" _
        , vbInformation + vbOKCancel, "選擇類型訊息"
End Sub

Sub 表格所在的位置是() '表格用!錄自Word VBA Lesson 17您現在所在的位置是
Dim MsgTitle, thisR, thisC              'row, column
    MsgTitle = "您現在所在的位置是"
    With Selection
        thisR = .Information(wdStartOfRangeRowNumber)
        thisC = .Information(wdStartOfRangeColumnNumber)
    End With
    If thisR = -1 Then
        MsgBox "游標並不在表中", vbInformation _
        , MsgTitle
    Else
        MsgBox "第" & thisR & "列" & vbCr & "第" & thisC & "欄", _
         vbInformation, MsgTitle
    End If
End Sub

Sub 所在位置標題() 'Alt+Z
Dim a As Paragraph, t As String, tn As String, cl As Boolean, rng As Range
On Error GoTo ErrH:
If Selection.Information(wdInFootnote) Then ActiveWindow.Panes(1).Close: cl = True '如果插入點在註腳視窗中
Set a = Selection.Paragraphs(1)
tn = a.Style
Set rng = a.Range
Do Until a.Style = "標題 1"
    Set a = a.Previous
    If Left(a.Style, 2) = "標題" And Right(tn, 1) > Right(a.Style, 1) Then 'Exit Do
        rng.SetRange a.Range.Characters(2).Start, a.Range.Characters(a.Range.Characters.Count - 1).End
        If a.Range.Characters(1) <> "頁" And Not IsNumeric(rng) Then
            t = a.Style & " : " & a.Range & vbCr & Space(Right(a.Style, 1) * 2) & t
            tn = a.Style
        End If
    End If
Loop 'a.Range會包括段落字元,要去除可用：Left(a.Range, Len(a.Range) - 1)
MsgBox ActiveDocument.path & vbCr & vbCr & "目前標題為：" & vbCr & vbCr & t & _
        vbCr & vbCr & vbCr & "目前頁碼：" & Selection.Information(wdActiveEndAdjustedPageNumber), _
        vbInformation
If cl Then '如果插入點原在註腳視窗中
    '
' 巨集7 巨集
' 巨集錄製於 2011/6/23，錄製者 Oscar Sun
'
    If ActiveWindow.ActivePane.View.Type = wdPrintView Or ActiveWindow. _
        ActivePane.View.Type = wdWebView Or ActiveWindow.ActivePane.View.Type = _
        wdPrintPreview Then
        ActiveWindow.View.SeekView = wdSeekFootnotes
    Else
        ActiveWindow.View.SplitSpecial = wdPaneFootnotes
    End If

End If
Exit Sub
ErrH:
Select Case Err.Number
    Case 91 '沒有設定物件變數或 With 區塊變數
        MsgBox "本文件沒有標題樣式!", vbExclamation
End Select
End Sub



                  

                    Sub 聲符構字列出()
'Alt+8
Dim db As String, cnt As New ADODB.Connection, rst As New ADODB.Recordset, sf As String, rng As Range, flg As Boolean
db = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbFile("諧聲字檢索系統", "")
If Selection.Characters.Count > 1 Then Exit Sub
sf = Selection.Text
If Selection.Type = wdSelectionIP Then
    Selection.MoveRight
Else
    Selection.Collapse wdCollapseEnd
End If
cnt.Open db
rst.Open "SELECT DISTINCT 形聲字.形聲字, 聲符,序號 " & _
        "FROM 聲符 INNER JOIN 形聲字 ON 聲符.聲符ID = 形聲字.聲符ID " & _
        "WHERE (((StrComp(聲符,""" & sf & """))=0)and(instr(序號,""00"")=0)) " & _
        "ORDER BY 形聲字.形聲字;", cnt
Set rng = Selection.Range
Do Until rst.EOF
    rng.InsertAfter rst.Fields("形聲字").Value
    flg = True
    rst.MoveNext
Loop
If flg Then
    rng.Select
    CHINAWORD.只留下黃選3000常用字_未選取則以paragraph為單位
Else
    MsgBox "尚無此聲符！", vbExclamation
End If
rst.Close: cnt.Close: Set rst = Nothing: Set cnt = Nothing
End Sub


                  

                    Sub 部件構字列出()
On Error GoTo EH 'alt+b
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
'If Selection.Range.Characters.Count > 1 Then Exit Sub
Set sl = Selection '.Document.ActiveWindow.Selection
b = sl.Text
If Selection.Type <> wdSelectionIP Then
    Selection.Collapse wdCollapseEnd
Else
    Selection.MoveRight
End If

If docx Is Nothing Then
    'set docx=GetObject(system.SearchPath & "\!!!!部件4要檔!!!!\!!!@@@黃沛榮部件表OKOKOK20161021@@@.docm")
opendocx:
    Set docx = GetObject(system.SearchPath & "\!!!!部件4要檔!!!!\4808字之部件new.docm")
    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 c.Next.Range.Characters
                    If a.InlineShapes.Count > 0 Then
                        bj = bj & a.InlineShapes(1).AlternativeText
                    Else
                        bj = bj & a
                    End If
                Next a
                bjArray(r - 2) = 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
        .WindowState = wdWindowStateMinimize
        .Visible = True
    End With
End If

Set rng = sl.Range
For r = 0 To arrSize
    If VBA.InStr(bjArray(r), b) Then
        rng.InsertAfter wArray(r)
        If Not flg Then flg = True
    End If
Next r
If Not flg Then
    MsgBox "沒有此部件!", vbExclamation
Else
    rng.Select
    CHINAWORD.只留下黃選3000常用字_未選取則以paragraph為單位
End If
Exit Sub
EH:
Select Case Err.Number
    Case 5825 '物件已被刪除
        Resume opendocx
    Case Else
        MsgBox Err.Number & Err.Description
End Select
End Sub