部首214所收常用字_列出 vbscript

View Snippet 
                    Sub 部首214所收常用字_列出()
Dim f As Document, bs As String  'Alt+s
Dim c  As Cell ', r As Byte
Dim b As String, flg As Boolean
If Selection.Range.Characters.Count > 1 Then Exit Sub
b = Selection.Text
'If f Is Nothing Then
    Set f = GetObject(system.SearchPath & "\macros\XXX214部首所收常用字201909.docx")
'    For Each c In f.Tables(1).Columns(2).Cells
'        bs = bs & VBA.Replace(VBA.Replace(VBA.Replace(c.Range.Text, Chr(13) & Chr(7), ""), "【", ""), "】", "")
'    Next c
'    With f.ActiveWindow
'        .WindowState = wdWindowStateMinimize
'        .Visible = True
'    End With

'End If
'r = InStr(bs, b)
For Each c In f.Tables(1).Columns(2).Cells
    If VBA.InStr(c.Range.Text, b) Then
        Exit For
        flg = True
    End If
Next c
If Not flg Then
    MsgBox "沒有此部首!", vbExclamation
Else
    If Selection.Type <> wdSelectionIP Then
        Selection.Collapse wdCollapseEnd
    Else
        Selection.MoveRight
    End If
    Selection.Range.InsertAfter VBA.Replace(c.Range.Text, Chr(13) & Chr(7), "")
End If
f.Close wdDoNotSaveChanges
Set f = Nothing
End Sub

選取處作汰重 vbscript

View Snippet 
                    Sub 選取處作汰重(Ctrl As Boolean) '，若無選取則以段落為單位
Dim rng As Range, rngR As Range, a, b, flg As Boolean ', j As Long, i As Long, s As Long
If Selection.Type = wdSelectionIP Then
    Set rng = Selection.Paragraphs(1).Range
Else
    Set rng = d.ActiveWindow.Selection.Range
End If
'If Ctrl Then
    For Each a In rng.Characters
        If a.End = rng.Document.Range.End Then Exit For
        If Not a.Next Is Nothing Then
            Set b = a.Next
        Else
            Exit For
        End If
        Set rngR = rng.Document.Range(b.Start, rng.End)
        For Each b In rngR.Characters
            If VBA.StrComp(a, b) = 0 And Asc(a) <> 13 Then
                If Ctrl Then
                    b.Delete
                    If flg = False Then flg = True
                    If rngR.Characters.Count = 1 Then
                        If Asc(b) = 13 Then Exit For
                    End If
                Else
                    b.Font.Color = 192
                    If flg = False Then flg = True
                    'Application.ScreenRefresh
                    'Application.ScreenUpdating = True
                End If
            End If
        Next b
    Next a
'Else
'    s = rng.Characters.Count
'    For Each a In rng.Characters
'        j = j + 1
'        If a.Font.Color <> 192 Then
'            For i = j To s
'                If InStr(VBA.Chr(13) & VBA.Chr(7) & VBA.Chr(9) & VBA.Chr(10), a) = 0 Then
'                    If StrComp(rng.Characters(i), a, vbTextCompare) = 0 And j <> i Then
'                        rng.Characters(i).Font.Color = 192 '深紅色
'                        'Application.ScreenRefresh
'                        'Application.ScreenUpdating = True
'                        flg = True
'                        'MsgBox "有重複!", vbExclamation
'                        'Exit Sub
'                    End If
'                End If
'            Next
'        End If
'    Next a
'End If
If flg Then
    If Ctrl Then
        MsgBox "有重複!已重複者已刪除", vbExclamation
        Ctrl = False
    Else
        MsgBox "有重複!已標成深紅字", vbExclamation
    End If
Else
    MsgBox "沒有重複!", vbInformation
End If
End Sub

選取區漢字排序＿依部首筆畫排序 vbscript

View Snippet 
                    Sub 字集部首排序()
'先讓圖排在前面
Application.ScreenUpdating = False
Str.字集筆畫排序_sub
'排好後會選取已排序的範圍以醒目
Dim sl As Selection, r As Range, iCount As Long, iParaCount As Long, iChar As Long
Dim cnt As New ADODB.Connection, rst As New ADODB.Recordset, c, w As String
Dim fieldsName As String ' ,rst簡化字小抄  As New ADODB.Recordset
Set sl = d.ActiveWindow.Selection
Set r = sl.Range
iChar = 1
'文字轉表格
iParaCount = r.Characters.Count
For iCount = 1 To iParaCount - 1
    r.Characters(iChar).InsertAfter VBA.Chr(9) & VBA.Chr(13)
    iChar = iChar + 3
Next iCount
r.ConvertToTable Chr(9), iParaCount, 2
'r.Select
cnt.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
        "Data Source=" & system.dbFile("詞典DATA.mdb", "!!@詞典附檔@!\Back-End")
rst.Open "SELECT ID, F1 " & _
        "FROM 簡化字小抄 where ID=8", cnt, adOpenDynamic, adLockReadOnly
Select Case rst.Fields("F1").Value
    Case 3, 2 '大陸版、海外版
        fieldsName = "簡化字形"
    Case 1
        fieldsName = "字"
End Select
rst.Close
rst.Open "SELECT 字." & fieldsName & " as 字, 部首.部首, 部首.部首ID, 字.部首外筆畫, 字.總筆畫 " & _
        "FROM 部首 INNER JOIN 字 ON 部首.部首ID = 字.部首ID" & _
        " ORDER BY 部首.部首ID, 字.部首外筆畫, 字.總筆畫 ", cnt, adUseClient, adOpenDynamic, adLockReadOnly
        'adUseClient，要有此引數，AbsolutePosition屬性才能被調用
For Each c In r.Tables(1).Columns(1).Cells
    rst.MoveFirst
    w = VBA.CStr(c.Range.Characters(1))
'    If VBA.Len(w) > 1 Then
'        rst.Find "VBA.left(字,1)=""" & VBA.Left(w, 1) & """ and " & _
'            "VBA.right(字,1)=""" & VBA.Right(w, 1) & """"
''    rst.Find "strcomp(字,""" & c.Range.Characters(1) & """)=0"
'    Else
        rst.Find "字 = '" & w & "'" 'ADO Find方法可以正確判斷擴充字集長度len()為2的字，就不必再另外比對了
'    End If
    If Not rst.EOF And Not rst.BOF Then
        c.Next.Range.Text = VBA.CStr(rst.AbsolutePosition)  'https://docs.microsoft.com/en-us/sql/ado/reference/ado-api/absoluteposition-and-cursorlocation-properties-example-vb?view=sql-server-ver15
        'https://docs.microsoft.com/en-us/sql/ado/reference/ado-api/absoluteposition-property-ado?view=sql-server-ver15
    End If
Next c
rst.Close
cnt.Close
r.Tables(1).Sort FieldNumber:=2, ExcludeHeader:=False, SortFieldType:= _
        wdSortFieldNumeric, SortOrder:=wdSortOrderAscending, _
         CaseSensitive:=False
r.Tables(1).ConvertToText Chr(9)
For Each c In r.Characters
    If VBA.StrComp(c, Chr(9)) = 0 Or VBA.StrComp(c, Chr(13)) = 0 Or VBA.IsNumeric(c) Then c.Delete
Next c
r.Select
Set cnt = Nothing: Set rst = Nothing
Application.ScreenUpdating = True
MsgBox "完成！", vbInformation
End Sub

選取區文字排序＿依系統筆畫規則 vbscript

View Snippet 
                    Sub 字集筆畫排序(ByRef Ctrl As Boolean)
Application.ScreenUpdating = False
字集筆畫排序_sub Ctrl
MsgBox "完成！", vbInformation
Application.ScreenUpdating = True
Ctrl = False
End Sub
Sub 字集筆畫排序_sub(Ctrl As Boolean)
Dim IPflg As Boolean, s As Selection, r As Range, rstart As Long
Dim rChr13InsertCount As Long, rChr13InsertedCount As Long
Set s = d.ActiveWindow.Selection
If s.Type = wdSelectionIP Then IPflg = True
If IPflg Then
    Set r = d.Range
Else
    Set r = s.Range
End If
rstart = r.Start '記下選取區的開始位置
rChr13InsertCount = r.Characters.Count '乃利用Word中「排序」指令，故須先分段
'記下分段數

Dim Char
Dim e As Long
On Error GoTo ErrH
With r
    e = .End '因為插入後文件長度變動,故不能取靜態者!
'    If CLng(i) > e Then Exit Sub
    If VBA.InStr(VBA.Left(.Text, VBA.IIf(r.Characters(r.Characters.Count) = Chr(13), e - 1, e)), VBA.Chr(13)) Then
        GoSub clearP
        rChr13InsertCount = r.Characters.Count '記下有多少字要處理，就是要插入多少段落符號
    End If
    If Not IPflg Then '若有選取區者
        r.InsertParagraphBefore
        rstart = rstart + 1
        r.SetRange rstart, .End
        rChr13InsertCount = r.Characters.Count - 1
        Char = 1 '計數器
    Else
        Char = 1
    End If
    Do Until rChr13InsertedCount = rChr13InsertCount
        r.Characters(Char).InsertAfter Chr(13)
        rChr13InsertedCount = rChr13InsertedCount + 1
        Char = Char + 2
    Loop
    r.InsertAfter Chr(13)
    ' r.Sort ExcludeHeader:=False, FieldNumber:="段落", SortFieldType:= _
        wdSortFieldStroke, SortOrder:=wdSortOrderAscending, FieldNumber2:="", _
        SortFieldType2:=wdSortFieldStroke, SortOrder2:=wdSortOrderAscending, _
        FieldNumber3:="", SortFieldType3:=wdSortFieldStroke, SortOrder3:= _
        wdSortOrderAscending, Separator:=wdSortSeparateByTabs, SortColumn:=False, _
         CaseSensitive:=False, LanguageID:=wdTraditionalChinese
    If Ctrl Then
         r.Sort ExcludeHeader:=False, FieldNumber:="段落", SortFieldType:= _
        wdSortFieldStroke, SortOrder:=wdSortOrderAscending, _
         CaseSensitive:=False, LanguageID:=wdSimplifiedChinese
    Else
        r.Sort ExcludeHeader:=False, FieldNumber:="段落", SortFieldType:= _
            wdSortFieldStroke, SortOrder:=wdSortOrderAscending, _
             CaseSensitive:=False, LanguageID:=wdTraditionalChinese
    End If

    GoSub clearP
    r.InsertAfter Chr(13) '若後面尚有文本可作區隔
    If Not IPflg Then r.SetRange rstart, e
    r.Select '選取已排序的範圍以醒目
End With
Exit Sub
ErrH:
Select Case Err.Number
    Case Else
        MsgBox Err.Number & Err.Description, vbCritical: Resume Next
End Select
Exit Sub

clearP:
    With r
'               較全部取代快了快三倍!!
'            StatusBar = "清除段落中..."
            For Each Char In .Characters
                If Char = VBA.Chr(13) Then Char.Delete
            Next
            e = .End '再取一次現在文件之長度
'            StatusBar = "清除段落完畢!!"
    End With
Return
End Sub

列出漢字部件數及其部件；可以將選取的漢字詞句，其部件總數及部件列出（會汰重） vbscript

View Snippet 
                    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")
    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 Else
        MsgBox Err.Number & Err.Description
End Select
End Function
Sub 某字部件數列出()
Dim w As String, wCnt As Integer, cnt As Integer 'Alt+s.  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
For a = 1 To wCnt
    某字部件數列出
'    Selection.Move'某字部件數列出 執行完會自己移到尾端，故不必此
Next a
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
← Prev Page Next Page →