Oscar Sun

                  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