選取區漢字排序 Word VBA
選取區漢字排序＿依部首筆畫排序
選取區文字排序＿依系統筆畫規則
Word VBA
Sub 字集筆畫排序() Application.ScreenUpdating = False 字集筆畫排序_sub MsgBox "完成！", vbInformation Application.ScreenUpdating = True End Sub Sub 字集筆畫排序_sub() 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 r.Sort ExcludeHeader:=False, FieldNumber:="段落", SortFieldType:= _ wdSortFieldStroke, SortOrder:=wdSortOrderAscending, _ CaseSensitive:=False, LanguageID:=wdTraditionalChinese 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
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
Sub 字集筆畫排序() Application.ScreenUpdating = False 字集筆畫排序_sub MsgBox "完成！", vbInformation Application.ScreenUpdating = True End Sub Sub 字集筆畫排序_sub() 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 r.Sort ExcludeHeader:=False, FieldNumber:="段落", SortFieldType:= _ wdSortFieldStroke, SortOrder:=wdSortOrderAscending, _ CaseSensitive:=False, LanguageID:=wdTraditionalChinese 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
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
留言