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

                  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
View Oscar's Profile