Attribute VB_Name = "Frq_Module"
'==============================
'語彙頻度表示マクロ
'==============================
Sub CountWords()
Dim values() As String
Dim WCount() As Integer
Dim doc_range As Range
Dim word_object As Object
Dim word_text As String
Dim num_words As Long
Dim txt As String
Dim i As Long
Dim j As Long
Dim doc As Document
Dim intCount, intTotalCount, intWordCount As Integer
Selection.HomeKey Unit:=wdStory
If Selection Is Nothing Then
MsgBox "No document is open."
Exit Sub
End If
StatusBar = "語彙数を計測します。(しばらくお待ちください。)"
If Selection.Type = wdSelectionIP Then
Set doc_range = ActiveDocument.Content
Else
Set doc_range = Selection.Range
End If
intTotalCount = doc_range.Words.Count
intCount = 0
ReDim values(0 To doc_range.Words.Count)
ReDim WCount(0 To doc_range.Words.Count)
For Each word_object In doc_range.Words
If (word_object.Style <> "_code") And (word_object.Text <> "") Then
word_text = LCase$(Trim$(word_object.Text))
If Len(Trim(word_text)) <> 0 Then
If Asc(word_text) <> 13 Then
StatusBar = "登録中(" & intCount & "/" & intTotalCount & ")"
num_words = num_words + 1
values(num_words) = word_text
intCount = intCount + 1
End If
End If
End If
Next word_object
StatusBar = "ソート中(並べ替え中)"
ShellSortStrings values(), 0, num_words
j = 1
intWordCount = 1
For i = 2 To num_words
If values(i) <> values(j) Then
j = j + 1
values(j) = values(i)
WCount(j - 1) = intWordCount
intWordCount = 1
Else
intWordCount = intWordCount + 1
End If
Next i
WCount(j) = intWordCount
num_words = j
'下の行を消し,下のコメントアウトを実行するようにしても良い。
ShellSortNumsWithStr WCount(), values(), 0, num_words
Set doc = Documents.Add
For i = 1 To num_words
Selection.TypeText values(i) & vbTab & WCount(i) & vbCrLf
Next i
'Selection.WholeStory
'Selection.Sort FieldNumber:="フィールド 2", SortFieldType:=wdSortFieldNumeric, _
'SortOrder:=wdSortOrderDescending, FieldNumber2:=""
'Selection.MoveDown Unit:=wdLine, Count:=1
Selection.TypeText "----------" & vbCrLf
Selection.TypeText num_words & " words." & vbCrLf
End Sub
Sub ShellSortStrings(values() As String, Start As Long, Count As Long)
Dim gap As Long
Dim i As Long
Dim j As Long
Dim StrTemp As String
gap = 1
While gap * 3 < Count - Start
gap = gap * 3 + 1
Wend
While gap > 0
For k = gap + 1 To Count
strTmp = values(k)
j = k
Do While j > gap
If values(j - gap) > strTmp Then
values(j) = values(j - gap)
j = j - gap
Else
Exit Do
End If
Loop
values(j) = strTmp
Next k
gap = gap / 3
Wend
End Sub
Sub ShellSortNumsWithStr(values() As Integer, Strings() As String, Start As Long, Count As Long)
Dim gap As Long
Dim i As Long
Dim j As Long
Dim Temp As Integer
Dim StrTemp As String
gap = 1
While gap * 3 < Count - Start
gap = gap * 3 + 1
Wend
While gap > 0
For k = gap + 1 To Count
Tmp = values(k)
StrTemp = Strings(k)
j = k
Do While j > gap
If values(j - gap) < Tmp Then
values(j) = values(j - gap)
Strings(j) = Strings(j - gap)
j = j - gap
Else
Exit Do
End If
Loop
values(j) = Tmp
Strings(j) = StrTemp
Next k
gap = gap / 3
Wend
End Sub