Sub Frequénces_de_mots()
'
' Version 0.1 du 4 juillet 2011
'
Dim S As String, W As String, Ponc As String
Dim C As Long, I As Long, P As Long, T As Long
Dim Mots(32767) As String, Freq(32767) As Integer
Dim TmpS As String, TmpI As Long
Dim Found As Boolean

'Mettre un message dans le variable S
S = "Je calcule la fréquence de chaque mot dans un texte sélectionné." _
& vbCrLf & "Puis, j'affiche une liste des mots et de leur fréquence." _
& vbCrLf & vbCrLf & "I count the frequency of every word in the selected text." _
& vbCrLf & "Then I display a list of those words and thier frequency." _

' Afficher le message; terminer au cas d'annulation
I = MsgBox(S, vbOKCancel, "Fréquence des mots du document actif")
' If the Cancel button is clicked, then terminate this macro
If I = vbCancel Then GoTo Oops

' Mettre le texte entier dans le variable S
S = ActiveWindow.ActivePane.Selection

' Alerte au manque de sélection
If Len(S) < 2 Then
    S = "Il faut sélectionner du texte à transcrire." & vbCr & vbCr & "You must first select some text to transcribe."
    I = MsgBox(S, vbCritical & vbOKOnly, "Attention!")
    GoTo Oops
End If

' Enlever toute espace blanc initiel et final; ajouter un espace final
S = Trim(S) & Chr(32)

' Enlever la pontuation
TmpS = "Ignorer la ponctuation? (Recommandé)"
I = MsgBox(TmpS, vbQuestion & vbYesNo, "Ordonner la liste?")

If I = vbYes Then
    Ponc = "~`!!@#$%^&*()_-+={[}]|\:;'<,>.?/" & ChrW(&H22) & ChrW(&HAB) _
    & ChrW(&HBB) & ChrW(&H201C) & ChrW(&H201D) & ChrW(&H2018) & ChrW(&H2019) & ChrW(&H2013) & ChrW(&H2014)
    For I = 1 To Len(Ponc)
        P = InStr(S, Mid(Ponc, I, 1))
        Do Until P = 0
            Mid(S, P, 1) = Chr(32)
            P = InStr(S, Mid(Ponc, I, 1))
        Loop
    Next I
End If

' Remplacer par un espace tous les retours à la linge
P = InStr(S, Chr(11))
Do Until (P = 0)
    Mid(S, P, 1) = Chr(32)
    P = InStr(S, Chr(11))
Loop

' Remplacer par un espace tous les espacements verticaux
P = InStr(S, Chr(13))
Do Until (P = 0)
    Mid(S, P, 1) = Chr(32)
    P = InStr(S, Chr(13))
Loop

' Remplacer tous les espaces multiples par un espace singulier
P = InStr(S, Chr(32) & Chr(32))
Do While P > 0
    S = Left(S, P) & Mid(S, P + 2)
    P = InStr(S, Chr(32) & Chr(32))
Loop

' Ouvrir un document nouveau
Documents.Add , , , True
ActiveWindow.ActivePane.Selection = "Document: " & Len(S) & " caractères, "
ActiveWindow.ActivePane.Selection.MoveRight

' Compiler la liste de mots et de leurs fréquences
P = InStr(S, Chr(32))   ' Trouver un prochain espace
Do While P > 0           'Tant qu'il y en a
    Found = False
    W = Left(S, P - 1)  ' Le mot se trouve à gauche de l'espace
    S = Mid(S, P + 1)   ' Racourcir le variable
    For I = 0 To C      ' Comparer à tous les mots retrouvés
        If Mots(I) = W Then Freq(I) = Freq(I) + 1: Found = True: Exit For
    Next I
    ' Mot nouveau
    If Found = False Then C = C + 1: Mots(C) = W: Freq(C) = 1
    P = InStr(S, Chr(32))
    T = T + 1
Loop

'Noter les totaux de mots et de mots uniques
ActiveWindow.ActivePane.Selection = T & " mots, " & C & " uniques"
ActiveWindow.ActivePane.Selection.MoveRight

'Offrir de mettre la liste en ordre alphabétique
TmpS = "Mettre la liste en ordre alphabétique?" & vbCr & "(Ceci pourrait prendre du temp.)"
I = MsgBox(TmpS, vbQuestion & vbYesNo, "Ordonner la liste?")

'Mettre la liste en ordre alphabétique
If I = vbYes Then
    For I = 2 To C
        For P = I To 2 Step -1
                If LCase(Mots(P)) < LCase(Mots(P - 1)) Then
                    TmpS = Mots(P): TmpI = Freq(P)
                    Mots(P) = Mots(P - 1): Freq(P) = Freq(P - 1)
                    Mots(P - 1) = TmpS: Freq(P - 1) = TmpI
                End If
        Next P
    Next I
End If

'Offrir de ne lister que les mots uniques
TmpS = "Ne lister que les mots uniques?" & vbCr & "(Autrement, en lister tous.)"
TmpI = MsgBox(TmpS, vbQuestion & vbYesNo, "Ordonner la liste?")

'Lister les mots et leur fréquence
For I = 1 To C
    'Insérer les données dans le nouveau document
    If TmpI = vbYes Then
        If Freq(I) = 1 Then ActiveWindow.ActivePane.Selection = vbNewLine & I & vbTab & Mots(I) & vbTab & Freq(I)
    Else
        ActiveWindow.ActivePane.Selection = vbNewLine & I & vbTab & Mots(I) & vbTab & Freq(I)
    End If
    ActiveWindow.ActivePane.Selection.MoveRight
Next I

'Terminer
Oops:
End Sub