Oscar Sun

                    Function CharacterToPoint_PMingLiU(fontSize As Single)   '新細明體(PMingLiU)'https://zh.wikipedia.org/wiki/%E6%96%B0%E7%B4%B0%E6%98%8E%E9%AB%94
        'https://www.mrexcel.com/board/threads/converting-characters-to-points.548210/
        'https://social.msdn.microsoft.com/Forums/office/en-US/7f461fac-5b41-4049-b3c9-bb3c2ab8cbbc/spreadsheet-ml-setting-column-width-in-pixel?forum=exceldev
        CharacterToPoint_PMingLiU = fontSize '((2 + 5) * 7 - 0.5) * (fontSize / 12)  'Characters = (Pixels - 5) / 7#
         '(2 + 5) * 7 / 2 - 0.5=24=12*12 '原來12號字即12點字，點和此點單位同也！
End Function

                  

                    Sub IndentFirstLineDeleteFirstTwoSpace_PMingLiUFontSize12() '新細明體（PMingLiU）'https://zh.wikipedia.org/wiki/%E6%96%B0%E7%B4%B0%E6%98%8E%E9%AB%94
Dim rngAll As Range, p As Paragraph
Set rngAll = Selection.Range
For Each p In rngAll.Paragraphs
'    With Selection.ParagraphFormat
    With p.Range.ParagraphFormat
'        .LeftIndent = CentimetersToPoints(0)
'        .RightIndent = CentimetersToPoints(0)
'        .SpaceBefore = 1.5
'        .SpaceBeforeAuto = False
'        .SpaceAfter = 0
'        .SpaceAfterAuto = False
'        .LineSpacingRule = wdLineSpaceExactly
'        .LineSpacing = 19
'        .Alignment = wdAlignParagraphLeft
'        .WidowControl = True
'        .KeepWithNext = False
'        .KeepTogether = False
'        .PageBreakBefore = False
'        .NoLineNumber = False
'        .Hyphenation = True
'        .FirstLineIndent = CentimetersToPoints(0.35) 'https://docs.microsoft.com/zh-tw/office/vba/api/word.paragraphs.firstlineindent
        'https://www.mrexcel.com/board/threads/converting-characters-to-points.548210/
        'https://social.msdn.microsoft.com/Forums/office/en-US/7f461fac-5b41-4049-b3c9-bb3c2ab8cbbc/spreadsheet-ml-setting-column-width-in-pixel?forum=exceldev
'        .FirstLineIndent = (2 + 5) * 7 / 2 - 0.5 'Characters = (Pixels - 5) / 7#
        .FirstLineIndent = CharacterToPoint_PMingLiU(12) * 2 '(2 + 5) * 7 / 2 - 0.5 =24=12*2
'        .OutlineLevel = wdOutlineLevelBodyText
'        .CharacterUnitLeftIndent = 0
'        .CharacterUnitRightIndent = 0
'        .CharacterUnitFirstLineIndent = 2
'        .LineUnitBefore = 0.3
'        .LineUnitAfter = 0
'        .MirrorIndents = False
'        .TextboxTightWrap = wdTightNone
'        .CollapsedByDefault = False
'        .AutoAdjustRightIndent = True
'        .DisableLineHeightGrid = False
'        .FarEastLineBreakControl = True
'        .WordWrap = True
'        .HangingPunctuation = True
'        .HalfWidthPunctuationOnTopOfLine = False
'        .AddSpaceBetweenFarEastAndAlpha = True
'        .AddSpaceBetweenFarEastAndDigit = True
'        .BaseLineAlignment = wdBaselineAlignAuto
    End With
    Dim rng As Range
    Set rng = Selection.Range
    'rng.SetRange Selection.Paragraphs(1).Range.Characters(1).Start, Selection.Paragraphs(1).Range.Characters(2).End
    rng.SetRange p.Range.Characters(1).Start, p.Range.Characters(2).End
    If rng.Text = "　　" Then rng.Delete
Next p
End Sub


                  

                    Sub 中國哲學書電子化計劃_表格轉文字(ByRef r As Range)
On Error GoTo eH
'Dim d As Document
Dim tb As Table, c As Cell ', ci As Long
'Set d = ActiveDocument
If r.Tables.Count > 0 Then
    For Each tb In r.Tables
        tb.Columns(1).Delete
        Set r = tb.ConvertToText()
    Next tb
End If
Exit Sub
eH:
Select Case Err.Number
    Case 5992 '無法個別存取此集合中的各欄，因為表格中有混合的儲存格寬度。
        For Each c In tb.Range.Cells
'            ci = ci + 1
'            If ci Mod 3 = 2 Then
                'If VBA.IsNumeric(VBA.Left(c.Range.text, VBA.InStr(c.Range.text, "?") - 1)) Then
                If VBA.InStr(c.Range.text, ChrW(160) & ChrW(47)) > 0 Then
                    c.Delete  '刪除編號之儲存格
                End If
'            End If
        Next c
        Resume Next
    Case Else
        MsgBox Err.Number & Err.Description
        End
End Select
End Sub

Sub 中國哲學書電子化計劃_註文變小正文回大()
Dim slRng As Range, a
Set slRng = Selection.Range
中國哲學書電子化計劃_表格轉文字 slRng
For Each a In slRng.Characters
    Select Case a.Font.Color
        Case 34816, 8912896
            a.Font.Size = 14
        Case 0
            a.Font.Size = 30
    End Select
Next a
End Sub
Sub 中國哲學書電子化計劃_去掉註文保留正文()
Dim slRng As Range, a
If ActiveDocument.Characters.Count = 1 Then Selection.Paste
If Selection.Type = wdSelectionIP Then ActiveDocument.Select
Set slRng = Selection.Range
中國哲學書電子化計劃_表格轉文字 slRng
For Each a In slRng.Characters
    Select Case a.Font.Color
        Case 34816, 8912896
            If a.Font.Size <> 12 Then Stop
            a.Delete
        Case 254
            If a.Font.Size = 9 Then a.Delete
    End Select
Next a
Beep 'MsgBox "done!", vbInformation
End Sub
Sub 中國哲學書電子化計劃_註文前後加括弧()
Dim slRng As Range, a, flg As Boolean 'Alt+1
If Documents.Count = 0 Then GoTo a:
If ActiveDocument.Characters.Count = 1 Then
    Selection.Paste
ElseIf ActiveDocument.Characters.Count > 1 Then
    For Each a In Documents
        If a.path = "" Or a.Characters.Count = 1 Then
            a.Range.Paste
            a.Activate
            a.ActiveWindow.Activate
            flg = True
            Exit For
        End If
    Next a
    If flg = False Then GoTo a
Else
a: Documents.Add
    Selection.Paste
End If
If Selection.Type = wdSelectionIP Then ActiveDocument.Select
Set slRng = Selection.Range
中國哲學書電子化計劃_表格轉文字 slRng
For Each a In slRng.Characters
    Select Case a.Font.Color
        Case 34816, 8912896, 15776152, 34816
            If flg = False Then
                a.Select
                Selection.Range.InsertBefore "（"
                a.Font.Size = a.Next.Font.Size
                a.Font.Color = a.Next.Font.Color
                flg = True
            End If
        Case 0, 15595002, 15649962
            If flg Then
                a.Select
                Selection.Range.InsertBefore "）"
                flg = False
            End If
    End Select
Next a
slRng.Find.Execute "（（", True, , , , , , , , "（", wdReplaceAll
slRng.Find.Execute "））", True, , , , , , , , "）", wdReplaceAll
Beep
'MsgBox "done!", vbInformation
End Sub

                  

                    VERSION 5.00
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} CodeColor 
   Caption         =   "CodeColor"
   ClientHeight    =   2460
   ClientLeft      =   120
   ClientTop       =   465
   ClientWidth     =   7740
   OleObjectBlob   =   "CodeColor.frx":0000
   StartUpPosition =   1  '所屬視窗中央
End
Attribute VB_Name = "CodeColor"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Option Explicit


Private Sub SelectionFontColor(colorNum_VBARGB As Long)
With Selection.Font
    .Color = colorNum_VBARGB
    .Name = system.CodeFontName  '"consolas" '"verdana"'"jetbrains mono"
End With
Me.Hide 'Unload Me
End Sub

==========================
Attribute VB_Name = "system"
Option Explicit


Property Get CodeFontName() As String
If strCodeFontName = "" Then
    'Application.FontNames property (Word)'https://docs.microsoft.com/zh-tw/office/vba/api/word.application.fontnames?f1url=https%3A%2F%2Fmsdn.microsoft.com%2Fquery%2Fdev11.query%3FappId%3DDev11IDEF1%26l%3Dzh-TW%26k%3Dk(vbawd10.chm158334987)%3Bk(TargetFrameworkMoniker-Office.Version%3Dv15)%26rd%3Dtrue
    For Each strCodeFontName In Word.Application.FontNames 'if the num of fonts installed in the OS is too much, it'll be a long time to search
            If strCodeFontName = "JetBrains Mono" Then Exit For 'case sensitive for comparing
    Next strCodeFontName
End If
If Not strCodeFontName = "JetBrains Mono" Then strCodeFontName = "Consolas" 'case insensitive for setting
CodeFontName = strCodeFontName 'encapsulate the field strCodeFontName
End Property




                  

                    Attribute VB_Name = "Excel"
Option Explicit '設定引用項目-VBA-引用Excel避免版本不合的問題，原理就是做一個叫做Excel的類別（模組）來仿真
Dim app As Object, wb As Object, sht As Object   '用Dim才能兼顧保留其生命週期與封裝性
'後期綁定(後期繫結） late bound
'https://dotblogs.com.tw/regionbbs/2016/10/13/concepts-in-late-binding
'https://docs.microsoft.com/zh-tw/previous-versions/office/troubleshoot/office-developer/binding-type-available-to-automation-clients
'https://docs.microsoft.com/zh-tw/dotnet/visual-basic/programming-guide/language-features/early-late-binding/

Property Get Application()
'Stop
'If VBA.IsEmpty(app) Then Class_Initialize
If app Is Nothing Then Class_Initialize
Set Application = app
End Property
Property Set Application(appOrNothing)
Set app = appOrNothing 'can't be Empty! because once the app was set to Application object it'll be object type no longer be a variant type. Only the variant type could be the value of Empty.
End Property

Property Get Workbook()
Set Workbook = wb
End Property
Property Get Worksheet()
Set Worksheet = sht
End Property

Private Sub Class_Initialize()
'Stop
Set app = VBA.CreateObject("Excel.Application")
app.UserControl = False 'for closing the app by user,this must be set to false or it will end until the word application close. https://docs.microsoft.com/zh-tw/office/vba/api/excel.application.usercontrol
Set wb = app.workbooks.Add() 'https://docs.microsoft.com/zh-tw/office/vba/api/excel.workbooks.add
Set sht = wb.sheets.Add()
End Sub

'================以下為建置此類別及應用範例======

Sub 文件字頻()
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,
'這是之前以先期引用的方式，在設定引用項目中手動加入的寫法:https://hankvba.blogspot.com/2018/03/vba.html  、 http://markc0826.blogspot.com/2012/07/blog-post.html
'Dim xlApp As Excel.Application, xlBook As Excel.Workbook, xlSheet As Excel.Worksheet
''這就是後期引用，以自訂新仿Excel類別的方法來實作(如此寫的緣故是原來要改寫的程式碼就會比較少，變動較小，且也不必再New出一個執行個體才能執行：
Dim xlApp, xlBook, xlSheet
Set xlApp = Excel.Application
Set xlBook = Excel.Workbook
Set xlSheet = Excel.Worksheet
Dim ReadingLayoutB As Boolean
Static xlsp As String
On Error GoTo ErrH:
'xlsp = "C:\Documents and Settings\Superwings\桌面\"
Set d = ActiveDocument
xlsp = 取得桌面路徑 & "\" 'GetDeskDir() & "\"
If Dir(xlsp) = "" Then xlsp = 取得桌面路徑 'GetDeskDir ' "C:\Users\Wong\Desktop\" '& Replace(ActiveDocument.Name, ".doc", "") & "字頻.XLS"
'If Dir(xlsp) = "" Then xlsp = "C:\Documents and Settings\Superwings\桌面\" & Replace(ActiveDocument.Name, ".doc", "") & "字頻.XLS"
'xlsp = "C:\Documents and Settings\Superwings\桌面\" & Replace(ActiveDocument.Name, ".doc", "") & "字頻.XLS"
xlsp = InputBox("請輸入存檔路徑及檔名(全檔名,含副檔名)!" & vbCr & vbCr & _
        "預設將以此word文件檔名 + ""字頻.XLSX""字綴,存於桌面上", "字頻調查", xlsp & Replace(ActiveDocument.Name, ".doc", "") & "字頻" & StrConv(Time, vbWide) & ".XLSX")
If xlsp = "" Then Exit Sub

ds = VBA.Timer

With d
    For Each Char In d.Characters
        charText = Char
        If InStr("()：>" & Chr(13) & Chr(9) & Chr(10) & Chr(11) & ChrW(12), charText) = 0 And charText <> "-" And Not charText Like "[a-zA-Z0-9０-９]" 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 InStr(ChrW(9312) & ChrW(-24153) & ChrW(-24152) & Chr(2) & "‧[]〔〕﹝﹞…；,，.。． 　、'""‘’`\{}｛｝「」『』（）《》〈〉－？！]▽□】【~/︵—" & Chr(-24152) & Chr(-24153), charText) = 0 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 = Char
            End If
        End If
    Next Char
End With

Dim Doc As New Document, Xsort() As String, U As Long ', xTsort() As Integer, k As Long, so As Long, ww As String
'ReDim Xsort(i) As String ', xtsort(i) as Integer
'ReDim Xsort(d.Characters.Count) 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 ExcelSheet = CreateObject("Excel.Sheet")
'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
'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), "、", "")) & "字）"
                .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), "、", "")) & "字）"
                .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
'

'U = UBound(xT)
'ReDim Xsort(U) As String, xTsort(U) As Long
'
'i = d.Characters
'For j = 1 To i '用數字相比
'    For k = 0 To U 'xT陣列中每個元素都與j比
'        If xT(k) = j Then
'            Xsort(so) = x(k)
'            xTsort(so) = xT(k)
'            so = so + 1
'        End If
'    Next k
'Next j

'With doc
'    .Range.InsertAfter "字頻=0001"
'    .Range.InsertParagraphAfter
'End With


' Cells.Select
'    Selection.Sort Key1:=Range("B1"), Order1:=xlDescending, Header:=xlGuess, _
'        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom


'Set ExcelSheet = Nothing'此行會使消失
'Set d = Nothing
de = VBA.Timer
If ReadingLayoutB Then d.ActiveWindow.View.ReadingLayout = Not d.ActiveWindow.View.ReadingLayout
MsgBox "完成！" & vbCr & vbCr & "費時" & Left(de - ds, 5) & "秒!", vbInformation
xlSheet.Application.Visible = True
xlSheet.Application.UserControl = True
xlSheet.SaveAs xlsp '"C:\Macros\守真TEST.XLS"
Doc.SaveAs Replace(xlsp, "XLS", "doc") '分大小寫
Set Excel.Application = Nothing
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 = Not d.ActiveWindow.View.ReadingLayout
        Doc.ActiveWindow.View.ReadingLayout = False
        Doc.ActiveWindow.Visible = False
        ReadingLayoutB = True
        Resume
    Case Else
        MsgBox Err.Number & Err.Description, vbCritical 'STOP: Resume
        'Resume
        End
    
End Select
End Sub