Oscar Sun

                  Sub 文件字頻(xlsxSkip As Boolean)
Dim 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 xlApp As Object, xlBook As Object, xlSheet As Object
Dim ReadingLayoutB As Boolean

Static xlsp As String
On Error GoTo ErrH:
'xlsp = "C:\Documents and Settings\Superwings\桌面\"
xlsp = GetDeskDir & "\" 'GetDeskDir() & "\"
If Dir(xlsp) = "" Then xlsp = GetDeskDir '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", "") & "字頻" & VBA.StrConv(VBA.Time, vbWide) & ".XLSX")
If xlsp = "" Then Exit Sub
'If MsgBox("確定不匯出excel檔？", vbQuestion + vbOKCancel) = vbOK Then xlsxSkip = True

ds = VBA.Timer

'For Each Char In d.Characters
'    If InStr(" 　()：>" & vba.Chr(13) & vba.Chr(10) & vba.Chr(11) & vba.ChrW(12) & vba.Chr(94) & vba.Chr(-23991) & vba.Chr(-24205) & vba.Chr(64), Char) > 0 Or Char = "-" Or Char Like "[a-zA-Z0-9０-９!-*""~""-"")""！-＊]" Then
'        Char.Delete
'    ElseIf InStr(vba.ChrW(-24153) & vba.ChrW(-24152) & vba.Chr(2) & "‧[]〔〕﹝﹞…；,，.。． 　、'""‘’`/\{}｛｝「」『』（）《》〈〉－？！]`‵～", Char) > 0 Then
'        Char.Delete
'    End If
'            'vba.Chr(2)可能是註腳標記
'Next
    
    '先清理文本
Str.clearSymbol d.Range, Str.Symbol_withoutEnter

With d

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

If xlsxSkip = False Then
    
    '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), "、", VBA.Chr(9), 1, 1) 'vba.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

End If

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 & "費時" & VBA.Left(de - ds, 5) & "秒!", vbInformation
If xlsxSkip = False Then
    xlSheet.Application.Visible = True
    xlSheet.Application.UserControl = True
    xlSheet.SaveAs xlsp '"C:\Macros\守真TEST.XLS"
End If
Doc.SaveAs Replace(xlsp, "XLSX", "docx") '分大小寫
'Doc.SaveAs "c:\test1.doc"
'AppActivate "microsoft excel"
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 4198 '指令失敗
    Case Else
        MsgBox Err.Number & Err.Description, vbCritical 'STOP: Resume
        'Resume
        End
    
End Select
End Sub