Oscar Sun

                    Sub 文件詞頻() '由文件字頻改來'2015/11/28
Dim d As Document, Char, charText As String, preChar As String _
    , x() As String, xT() As Long, i As Long, j As Long, ds As Date, de As Date     '
'Dim ExcelSheet  As New Excel.Worksheet 'As Object,
Dim xlApp As Excel.Application, xlBook As Excel.Workbook, xlSheet As Excel.Worksheet
Dim ReadingLayoutB As Boolean
Static Ln
Dim xlsp As String
On Error GoTo ErrH:
Set d = ActiveDocument
'If xlsp = "" Then xlsp = 取得桌面路徑 & "" 'GetDeskDir() & ""
'If Dir(xlsp) = "" Then xlsp = 取得桌面路徑 'GetDeskDir
'xlsp = InputBox("請輸入存檔路徑及檔名(全檔名,含副檔名)!" & vbCr & vbCr & _
        "預設將以此word文件檔名 + ""詞頻.XLSX""字綴,存於桌面上", "詞頻調查", xlsp & Replace(d.Name, ".doc", "") & "詞頻" & StrConv(Time, vbWide) & ".XLSX")
'If xlsp = "" Then Exit Sub
xlsp = 取得桌面路徑 & "" & Replace(d.Name, ".doc", "") & "_詞頻" & StrConv(Time, vbWide) & ".XLSX"
If Ln = "" Then Ln = 1
Ln = InputBox("請指定詞彙長度" & vbCr & vbCr & "檔案會存在桌面上名為:" & vbCr & vbCr & Replace(d.Name, ".doc", "") & "_詞頻" & StrConv(Time, vbWide) & ".XLSX" & _
                vbCr & vbCr & "的檔案", , Ln + 1)
If Ln = "" Then Exit Sub
If Not IsNumeric(Ln) Then Exit Sub
If Ln > 11 Or Ln < 2 Then Exit Sub


ds = VBA.Timer

With d
    For Each Char In d.Characters
        Select Case Ln
            Case 2
                charText = Char & Char.Next
            Case 3
                charText = Char & Char.Next & Char.Next.Next
            Case 4
                charText = Char & Char.Next & Char.Next.Next & Char.Next.Next.Next
            Case 5
                charText = Char & Char.Next & Char.Next.Next & Char.Next.Next.Next & Char.Next.Next.Next.Next
            Case 6
                charText = Char & Char.Next & Char.Next.Next & Char.Next.Next.Next & Char.Next.Next.Next.Next & Char.Next.Next.Next.Next.Next
            Case 7
                charText = Char & Char.Next & Char.Next.Next & Char.Next.Next.Next & Char.Next.Next.Next.Next & Char.Next.Next.Next.Next.Next & Char.Next.Next.Next.Next.Next.Next
            Case 8
                charText = Char & Char.Next & Char.Next.Next & Char.Next.Next.Next & Char.Next.Next.Next.Next & Char.Next.Next.Next.Next.Next & Char.Next.Next.Next.Next.Next.Next & Char.Next.Next.Next.Next.Next.Next.Next
            Case 9
                charText = Char & Char.Next & Char.Next.Next & Char.Next.Next.Next & Char.Next.Next.Next.Next & Char.Next.Next.Next.Next.Next & Char.Next.Next.Next.Next.Next.Next & Char.Next.Next.Next.Next.Next.Next.Next & Char.Next.Next.Next.Next.Next.Next.Next.Next
            Case 10
                charText = Char & Char.Next & Char.Next.Next & Char.Next.Next.Next & Char.Next.Next.Next.Next & Char.Next.Next.Next.Next.Next & Char.Next.Next.Next.Next.Next.Next & Char.Next.Next.Next.Next.Next.Next.Next & Char.Next.Next.Next.Next.Next.Next.Next.Next & Char.Next.Next.Next.Next.Next.Next.Next.Next.Next
            Case 11
                charText = Char & Char.Next & Char.Next.Next & Char.Next.Next.Next & Char.Next.Next.Next.Next & Char.Next.Next.Next.Next.Next & Char.Next.Next.Next.Next.Next.Next & Char.Next.Next.Next.Next.Next.Next.Next & Char.Next.Next.Next.Next.Next.Next.Next.Next & Char.Next.Next.Next.Next.Next.Next.Next.Next.Next & Char.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next
        End Select
        If Not charText Like "*[-'　 。，、；：？:,;,〈〉《》 ''「」『』（）▽△？！（）【】—""()<>" _
            & ChrW(9312) & Chr(-24153) & Chr(-24152) & ChrW(8218) & Chr(13) & Chr(10) & Chr(11) & ChrW(12) & Chr(63) & Chr(9) & Chr(-24152) & Chr(-24153) & "▽□】【~/︵—]*" _
            And Not charText Like "*[a-zA-Z0-9０-９]*" And InStr(charText, ChrW(-243)) = 0 And InStr(charText, Chr(91)) = 0 And InStr(charText, Chr(93)) = 0 Then
            'If Not charText Like "[a-z1-9]" & Chr(-24153) & Chr(-24152) & " 　、'""「」『』（）－？！]" Then
'            If InStr(Chr(-24153) & Chr(-24152) & Chr(2) & "‧[]〔〕﹝﹞…；,，.。． 　、'""‘’`\{}｛｝「」『』（）《》〈〉－？！]", charText) = 0 Then
            If Not charText Like "*[" & ChrW(-24153) & ChrW(-24152) & Chr(2) & "‧[]〔〕﹝﹞…；,，.。． 　、'""‘’`\{}｛｝「」『』（）《》〈〉－？！‘｛｝]*" Then
            'chr(2)可能是註腳標記
                If preChar <> charText Then
                    'If UBound(X) > 0 Then
                        If preChar = "" Then 'If IsEmpty(X) Then'如果是一開始
                            GoTo 1
                        ElseIf UBound(Filter(x, charText)) Then ' <> charText Then  '如果尚無此字
1                           ReDim Preserve x(i)
                            ReDim Preserve xT(i)
                            x(i) = charText
                            xT(i) = xT(i) + 1
                            i = i + 1
                        Else
                            GoSub 詞頻加一
                        End If
                    'End If
                Else
                    GoSub 詞頻加一
                End If
                preChar = charText
            End If
        End If
    Next
End With
12
Dim Doc As New Document, Xsort() As String, U As Long ', xTsort() As Integer, k As Long, so As Long, ww As String
If U = 0 Then U = 1 '若無執行「詞頻加一:」副程序,若無超過1次的詞頻，則　Xsort(xT(j - 1)) = Xsort(xT(j - 1)) & "、" & x(j - 1) & _
                                會出錯：陣列索引超出範圍 2015/11/5

ReDim Xsort(U) As String
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)
With xlSheet.Application
    For j = 1 To i
        .Cells(j, 1) = x(j - 1)
        .Cells(j, 2) = xT(j - 1)
        Xsort(xT(j - 1)) = Xsort(xT(j - 1)) & "、" & x(j - 1) 'Xsort(xT(j - 1)) & ww '陣列排序'2010/10/29
    Next j
End With
Doc.ActiveWindow.Visible = False
If d.ActiveWindow.View.ReadingLayout Then ReadingLayoutB = True: d.ActiveWindow.View.ReadingLayout = Not d.ActiveWindow.View.ReadingLayout
'U = UBound(Xsort)
For j = U To 0 Step -1 '陣列排序'2010/10/29
    If Xsort(j) <> "" Then
        With Doc
            If Len(.Range) = 1 Then '尚未輸入內容
                .Range.InsertAfter "詞頻 = " & j & "次：（" & Len(Replace(Xsort(j), "、", "")) / Ln & "個）"
                .Range.Paragraphs(1).Range.Font.Size = 12
                .Range.Paragraphs(.Paragraphs.Count).Range.Font.Name = "新細明體"
                .Range.Paragraphs(.Paragraphs.Count).Range.Font.NameAscii = "Times New Roman"
                '.Range.Paragraphs(1).Range.Font.Bold = True
            Else
                .Range.InsertParagraphAfter
                .ActiveWindow.Selection.Range.Collapse Direction:=wdCollapseEnd
                .Range.InsertAfter "詞頻 = " & j & "次：（" & Len(Replace(Xsort(j), "、", "")) / Ln & "個）"
                .Range.Paragraphs(.Paragraphs.Count).Range.Font.Size = 12
                '.Range.Paragraphs(.Paragraphs.Count).Range.Bold = True
                .Range.Paragraphs(.Paragraphs.Count).Range.Font.Name = "新細明體"
                .Range.Paragraphs(.Paragraphs.Count).Range.Font.NameAscii = "Times New Roman"
            End If
            .Range.InsertParagraphAfter
            .ActiveWindow.Selection.Range.Collapse Direction:=wdCollapseEnd
            .Range.Paragraphs(.Paragraphs.Count).Range.Font.Size = 12
'            .Range.Paragraphs(.Paragraphs.Count).Range.Bold = False
            .Range.InsertAfter Replace(Xsort(j), "、", Chr(9), 1, 1) 'chr(9)為定位字元(Tab鍵值)
            .Range.InsertParagraphAfter
            If InStr(.Range.Paragraphs(.Paragraphs.Count).Range, "詞頻") = 0 Then
                .Range.Paragraphs(.Paragraphs.Count - 1).Range.Font.Name = "標楷體"
            Else
                .Range.Paragraphs(.Paragraphs.Count).Range.Font.Name = "新細明體"
                .Range.Paragraphs(.Paragraphs.Count).Range.Font.NameAscii = "Times New Roman"
            End If
        End With
    End If
Next j

With Doc.Paragraphs(1).Range
     .InsertParagraphBefore
     .Font.NameAscii = "times new roman"
    Doc.Paragraphs(1).Range.InsertParagraphAfter
    Doc.Paragraphs(1).Range.InsertParagraphAfter
    Doc.Paragraphs(1).Range.InsertAfter "你提供的文本共使用了" & i & "個不同的詞彙（傳統字與簡化字不予合併）"
End With

Doc.ActiveWindow.Visible = True

de = VBA.Timer
Doc.SaveAs Replace(xlsp, "XLS", "doc") '分大小寫
If ReadingLayoutB Then d.ActiveWindow.View.ReadingLayout = Not d.ActiveWindow.View.ReadingLayout
Set d = Nothing ' ActiveDocument.Close wdDoNotSaveChanges

Debug.Print Now

MsgBox "完成！" & vbCr & vbCr & "費時" & Left(de - ds, 5) & "秒!", vbInformation
xlSheet.Application.Visible = True
xlSheet.Application.UserControl = True
xlSheet.SaveAs xlsp
Exit Sub
詞頻加一:
For j = 0 To UBound(x)
    If x(j) = charText Then
        xT(j) = xT(j) + 1
        If U < xT(j) Then U = xT(j) '記下最高詞頻,以便排序(將欲排序之陣列最高元素值設為此,則不會超出陣列.
        '多此一行因為要重複判斷計算好幾次,故效能不增反減''效能還是差不多啦.
        Exit For
    End If
Next j

Return
ErrH:
Select Case Err.Number
    Case 4605 '閱讀模式不能編輯'此方法或屬性無法使用，因為此命令無法在閱讀中使用。
    '    If ActiveWindow.View.SplitSpecial = wdPaneNone Then
    '        ActiveWindow.ActivePane.View.Type = wdNormalView
    '    Else
    '        ActiveWindow.View.Type = wdNormalView
    '    End If
    '    If ActiveWindow.View.SplitSpecial = wdPaneNone Then
    '        ActiveWindow.ActivePane.View.Type = wdPrintView
    '    Else
    '        ActiveWindow.View.Type = wdPrintView
    '    End If
        'Doc.Application.ActiveWindow.View.ReadingLayout
        d.ActiveWindow.View.ReadingLayout = False ' Not d.ActiveWindow.View.ReadingLayout
        Doc.ActiveWindow.View.ReadingLayout = False
        Doc.ActiveWindow.Visible = False
        ReadingLayoutB = True
        Resume
    
    Case 91, 5941 '沒有設定物件變數或 With 區塊變數,集合中所需的成員不存在
        GoTo 12
    Case Else
        MsgBox Err.Number & Err.Description, vbCritical 'STOP: Resume
        Resume
        End
    
End Select
End Sub

                  

                    Sub replacetest0() '2012/6/5 http://blog.bestdaylong.com/2008/07/word.html
Dim a As Range, x As Long, q As String
Dim s As Date, e As Date, g, i
'Set a = ActiveDocument.Range
'Debug.Print Len(a)
s = VBA.Timer
q = ActiveDocument.Range
x = InStr(q, "翁方綱")
'x = InStr(a.Text, "翁方綱")
For Each g In ActiveDocument.Comments
g.Delete
Next
With ActiveDocument
Do Until x = 0
' .Range(x - 1, x + 3 - 1).Select
.Range(x - 1, x + Len("翁方綱") - 1).Text = "孫守真"
i = i + 1
' If i = 68 Then Stop
x = InStr(x + 1, q, "翁方綱")
If .Range(x - 1, x + 3 - 1) <> "翁方綱" Then
e = VBA.Timer
Debug.Print e - s
Debug.Print i
Stop
End If
'a.Text = Replace(a.Text, "翁方綱", "孫守真")
'a.Find.Execute "翁方綱", , , , , , , , , "孫守真", wdReplaceAll '果然太慢!!
Loop
End With
e = VBA.Timer
Debug.Print e - s

End Sub
                  

                    Sub 插入字圖()
Dim x As String
x = InputBox("請輸入字圖位址")
If x = "" Then Exit Sub
'x = "http://glyphwiki.org/glyph/cdp-8be9.png"
Selection.InlineShapes.AddPicture x, , , Selection.Range
Selection.MoveRight wdCharacter, 1, wdExtend
Selection.InlineShapes(1).AlternativeText = x
Selection.InlineShapes(1).Height = 12.5
Selection.InlineShapes(1).Width = 12.5
End Sub

Sub tabletext()
Dim i As Long, cha
i = 1
Selection.Tables.Add Selection.Range, 1, 2
For Each cha In ActiveDocument.Tables(1).Cell(1, 2).Range.Characters
    If Asc(cha) <> 13 Then
        Selection.Tables(1).Cell(i, 1).Range = cha 'ActiveDocument.Tables(1).Cell(1, 2).Range.Characters(i)
        Selection.Tables(1).Cell(i, 2).Range.InlineShapes.AddPicture ActiveDocument.Tables(1).Cell(1, 1).Range.InlineShapes(1).AlternativeText
        Selection.Tables(1).Cell(i, 2).Range.InlineShapes(1).Height = 12.5
        Selection.Tables(1).Cell(i, 2).Range.InlineShapes(1).Width = 12.5
        Selection.Tables(1).Range.Rows.Add
    End If
    i = i + 1
Next
End Sub
Sub tabletext1()
Dim i As Long, cha
i = 1
Selection.Tables.Add Selection.Range, 1, 2
For Each cha In ActiveDocument.Tables(1).Cell(1, 2).Range.Characters
    If Asc(cha) <> 13 Then
        Selection.Tables(1).Cell(i, 1).Range = cha
        ActiveDocument.Tables(1).Cell(1, 1).Range.InlineShapes(1).Range.Copy
        Selection.Tables(1).Cell(i, 2).Range.Paste
        Selection.Tables(1).Range.Rows.Add
    End If
    i = i + 1
Next
End Sub

                  

                    Sub 檢查儲存格中的重覆()
On Error GoTo eH
Dim SR As Range
Dim cha As Range, b As Boolean
Set SR = Selection.Cells(1).Range
For Each cha In SR.Characters
    If cha = " " Then cha.Delete
    If cha.Font.Name <> "標楷體" Then cha.Delete
Next
x = SR.Text
L = SR.Characters.Count - 1 '末後是格式文字
For i = L To 1 Step -1
    y = SR.Characters(i)
    Z = Replace(x, y, "", 1, 1)
    If StrComp(y, Chr(13)) <> 0 Then
        If InStr(Z, y) > 0 Then
            SR.Characters(i).Select
            SR.Characters(i).Delete
            If InStr(SR, y) = 0 Then
                Stop
                
                SR.Document.Undo
            End If
            b = True
            Exit For
        End If
    End If
Next
If b = False Then MsgBox "沒有重覆的!", vbExclamation
Exit Sub
eH:
Select Case Err.Number
    Case 5941 '集合中所需的成員不存在。
        If ActiveDocument.Path = "" Then Set SR = Selection.Document.Range
        Resume Next
    Case Else
        MsgBox Err.Number & Err.Description
End Select
End Sub



                  

                    Sub 加入adodb引用項目()
With Application.VBE.ActiveVBProject
    For Each rf In .References
    '    Debug.Print rf.Name
        If rf.Name = "ADODB" Then GoTo 1
    Next
    .References.AddFromFile "C:\Program Files\Common Files\system\ado\msado15.dll"
End With
1
Call e
End Sub

Sub e()
Dim cnt As New ADODB.Connection
Dim rst As New ADODB.Recordset
Dim rsttable As New ADODB.Recordset
Dim cmd As New ADODB.Command
Dim BuShou As String
Dim d As New Document, U As String, uD As Document, uWordCount As Long
Dim WSShell As Object

Set uD = ActiveDocument
Set d = CreateObject("word.document")
'd.UserControl = False
d.Windows(1).Visible = False
cnt.Open ("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=D:\千慮一得齋\書籍資料\圖書管理附件\查字.mdb")
'rsttable.CursorType = adOpenKeyset
'rsttable.LockType = adLockOptimistic
'rsttable.ActiveConnection = cnt
rsttable.Open "漢字總表_的複本TEST", cnt, adOpenKeyset, adLockOptimistic   '竟然原資料表名"漢字總表 的複本TEST"中間的空格還不行,會變成抓到"漢字總表"原資料表!! 2014/8/19
cmd.ActiveConnection = cnt
cmd.CommandText = "檢查已有漢字"
cmd.CommandType = adCmdTable
rst.CursorType = adOpenKeyset
For Each char In uD.Characters
    If char.Font.Color = RGB(0, 0, 255) Then GoTo 1 '直接作下一個字
    If Asc(char) <> 13 And char <> "】" Then
        If char = "【" Then GoTo exx
        uWordCount = uWordCount + 1
        If uWordCount Mod 300 = 0 Then
            d.UndoClear
            uD.UndoClear
            uD.Save
        End If
        With d.Windows(1).Selection
            .TypeText char    '取得 Unicode 字元 的 十六進位值
            .ToggleCharacterCode
            U = Mid(d.Range, 1, Len(d.Range) - 1)
            d.Range = ""
        End With
'        cmd.Parameters("q").Value = char '查詢所根據的資料表若更名 Access名稱自動校正無法生效,必須重開才行
'        rst.Open cmd
        rst.Open "SELECT 漢字總表_的複本TEST.ID,漢字總表_的複本TEST.漢字,漢字總表_的複本TEST.[Alt+X], 漢字總表_的複本TEST.字元集 FROM 漢字總表_的複本TEST WHERE (((StrComp([漢字],""" & char & """))=0));", cnt, , adLockPessimistic
        If rst.RecordCount = 0 Then
            With rsttable
                .AddNew
                .Fields("漢字").Value = char
                If Len(char) > 1 Then
                    If Len(char) > 2 Then Stop
                    .Fields("Ascw1").Value = AscW(Mid(char, 1, 1))
                    .Fields("Ascw2").Value = AscW(Mid(char, 2, 1))
                    .Fields("Alt+X").Value = U
                    .Fields("字元集").Value = "D"
                    .Fields("備註").Value = "黃老師<!!!!Unicode字表.doc>漏掉了"
                Else
                    rsttable.Fields("Ascw1").Value = AscW(char)
                    rsttable.Fields("Ascw2").Value = 0
                    .Fields("Alt+X").Value = U
                    .Fields("字元集").Value = "D"
                    .Fields("備註").Value = "黃老師<!!!!Unicode字表.doc>漏掉了"
                End If
                '.Fields("部首").Value = BuShou
                .Update
            End With
        Else
'            char.Select
'            Stop
            If rst.RecordCount > 1 Then Stop
            With rst '直播用查詢增補記錄好像資料庫會變得超肥大!!2014.8.26
                '.Index = "PrimaryKey"
                '.Seek
                If IsNull(.Fields("Alt+X").Value) Then
                    .Fields("Alt+X").Value = U  '十六進位值,Word VBA 有 ToggleCharacterCode 方法;Word插入符號裡叫字元代碼。  U+,hexadecimal value
                    .Update
                End If
                If IsNull(.Fields("字元集").Value) Then
                    .Fields("字元集").Value = "D" '擴充-B(ExtB)等等
                    .Update
                End If
            End With
        End If
        rst.Close
        char.Font.Color = RGB(0, 0, 255)
1   End If
Next
If rst.State = adStateOpen Then rst.Close
rsttable.Close
cnt.Close
Set cmd = Nothing
Set rst = Nothing
Set rsttable = Nothing
Set cnt = Nothing
d.Close wdDoNotSaveChanges
Set d = Nothing
Set uD = Nothing
Set WSShell = CreateObject("WScript.Shell")
WSShell.PopUp "完成", , , 64
'MsgBox "完成"
Exit Sub
exx:
char.Select
BuShou = char.Next
GoTo 1
End Sub



Sub z1_CJK_Unified_Ideographs_Extension_C() 'Modified on 21/06/2011'http://club.excelhome.net/thread-733771-1-1.html
  Dim t As Date
  Dim n As Single
  Dim WSShell As Object
  Dim btn As String
  Dim Title As String
  Title = "CJK Unified Ideographs Extension C " & ChrW$(&H5B57) & ChrW$(&H7B26) & ChrW$(&H96C6)
  Set WSShell = CreateObject("WScript.Shell")
  t = Now
  Selection.Font.NameFarEast = "Sun-ExtB"
  Selection.Font.NameAscii = "Sun-ExtB"
  Selection.Font.Size = 14
  For i = &H2A700 To &H2B734
    n = n + 1
    Selection.TypeText Text:=Hex(i)
    Selection.ToggleCharacterCode
  Next
  Selection.TypeText Text:=vbCrLf
  Selection.TypeText Text:=n
  btn = WSShell.PopUp(ChrW$(&H8FD0) & ChrW$(&H884C) & ChrW$(&H65F6) & ChrW$(&H95F4) & ChrW$(&HFF1A) & DateDiff("s", t, Now) & ChrW$(&H20) & ChrW$(&H79D2), 5, Title, 64)
End Sub

Sub z2_CJK_Unified_Ideographs_Extension_D() 'Modified on 21/06/2011
  Dim t As Date
  Dim n As Single
  Dim WSShell As Object
  Dim btn As String
  Dim Title As String
  Title = "CJK Unified Ideographs Extension D " & ChrW$(&H5B57) & ChrW$(&H7B26) & ChrW$(&H96C6)
  Set WSShell = CreateObject("WScript.Shell")
  t = Now
  Selection.Font.NameFarEast = "Sun-ExtB"
  Selection.Font.NameAscii = "Sun-ExtB"
  Selection.Font.Size = 14
  For i = &H2B740 To &H2B81D
    n = n + 1
    Selection.TypeText Text:=Hex(i)
    Selection.ToggleCharacterCode
  Next
  Selection.TypeText Text:=vbCrLf
  Selection.TypeText Text:=n
  btn = WSShell.PopUp(ChrW$(&H8FD0) & ChrW$(&H884C) & ChrW$(&H65F6) & ChrW$(&H95F4) & ChrW$(&HFF1A) & DateDiff("s", t, Now) & ChrW$(&H20) & ChrW$(&H79D2), 5, Title, 64)
End Sub

Sub z8_CJK_Unified_Ideographs_Extension_A()
  Dim n As Single
  Dim WSShell As Object
  Dim btn As String
  Dim Title As String
  t = Now
  Title = "CJK Unified Ideographs Extension A " & ChrW$(&H5B57) & ChrW$(&H7B26) & ChrW$(&H96C6)
  Set WSShell = CreateObject("WScript.Shell")
  Selection.Font.NameFarEast = "Sun-ExtA"
  Selection.Font.NameAscii = "Sun-ExtA"
  Selection.Font.Size = 12
  For i = &H3400 To &H4DB5
    n = n + 1
    Selection.TypeText Text:=Hex(i)
    Selection.ToggleCharacterCode
  Next
  Selection.TypeParagraph
  Selection.TypeText Text:=n
  btn = WSShell.PopUp(ChrW$(&H8FD0) & ChrW$(&H884C) & ChrW$(&H65F6) & ChrW$(&H95F4) & ChrW$(&HFF1A) & DateDiff("s", t, Now) & ChrW$(&H20) & ChrW$(&H79D2), 5, Title, 64)
End Sub

Sub z9_CJK_Unified_Ideographs_Extension_B()
  Dim t As Date
  Dim n As Single
  Dim WSShell As Object
  Dim btn As String
  Dim Title As String
  Title = "CJK Unified Ideographs Extension B " & ChrW$(&H5B57) & ChrW$(&H7B26) & ChrW$(&H96C6)
  Set WSShell = CreateObject("WScript.Shell")
  t = Now
  Selection.Font.NameFarEast = "Sun-ExtB"
  Selection.Font.NameAscii = "Sun-ExtB"
  Selection.Font.Size = 12
  Selection.Font.ColorIndex = wdAuto
  For i = &H20000 To &H2A6D6
    n = n + 1
    Selection.TypeText Text:=Hex(i)
    Selection.ToggleCharacterCode
  Next
  Selection.TypeParagraph
  Selection.TypeText Text:=n
  btn = WSShell.PopUp(ChrW$(&H8FD0) & ChrW$(&H884C) & ChrW$(&H65F6) & ChrW$(&H95F4) & ChrW$(&HFF1A) & DateDiff("s", t, Now) & ChrW$(&H20) & ChrW$(&H79D2), 5, Title, 64)
End Sub