Oscar Sun

                  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