Attribute VB_Name = "Excel"
Option Explicit '設定引用項目-VBA-引用Excel避免版本不合的問題，原理就是做一個叫做Excel的類別（模組）來仿真
Dim app, wb, sht '用Dim才能兼顧保留其生命週期與封裝性
Property Get Application()
If VBA.IsEmpty(app) Then Class_Initialize
Set Application = app
End Property
Property Get Workbook()
Set Workbook = wb
End Property
Property Get Worksheet()
Set Worksheet = sht
End Property
Private Sub Class_Initialize()
Set app = CreateObject("Excel.Application")
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") '分大小寫
'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 Else
MsgBox Err.Number & Err.Description, vbCritical 'STOP: Resume
'Resume
End
End Select
End Sub
留言