Parole, parole, parole... il codice!

Ecco il codice della Classe e di un paio di esempi pratici, pronti all’uso. Di seguito una breve descrizione dei metodi e della proprietà più rilevanti esposti dalla Classe:

  • Occurrences(Item): restituisce il numero di occorrenze dell'elemento Item all'interno del testo base
  • Longest e Shortest: restituiscono due oggetti Collection che contengono l'insieme delle parole rispettivamente più lunghe e più corte presenti nel testo
  • SubSet(filter As String, Optional IgnoreCase As Boolean = True): restituisce un oggetto Collection che contiene un sottoinsieme del testo di partenza che soddisfi il filtro passato in argomento, eventualmente specificando se la ricerca deve essere case-sensitive.
Si noti che utilizzando questi ultimi metodi, che restituiscono oggetti Collection, si può conoscere la lunghezza in caratteri di un elemento dell'insieme senza dotare la Classe di uno specifico metodo Length, perchè questa proprietà viene ereditata dalla classe Match dell'oggetto Regular Expression (come FirstIndex, che restituisce la posizione dell'elemento trovato all'interno del testo base). Non potendo fornire i singoli elementi Item di ulteriori proprietà (ho tentato ma inutilmente, sono i limiti della trattazione degli oggetti di VB/VBA), l'unico modo per conoscere la lunghezza di un singolo elemento dell'insieme è utilizzare Len().

Importante! Per utilizzare correttamente la Classe WordsCollectionClass è necessario referenziare la libreria Microsoft VBScript Regular Expressions 5.5... oppure, se sapete come fare, utilizzate il late binding :o)

Codice della Classe "WordsCollectionClass"
(da copiare e incollare in un file di estensione .cls avente lo stesso nome, che andrà importato nel progetto)

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "WordsCollectionClass"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private Insieme As Collection

Private Sub Class_Initialize()
    Set Insieme = New Collection
End Sub

Private Sub Class_Terminate()
    Set Insieme = Nothing
End Sub

Function NewEnum() As IUnknown
Attribute NewEnum.VB_UserMemId = -4
Attribute NewEnum.VB_MemberFlags = "40"
Attribute NewEnum.VB_Description = "Consente l'enumerazione con for...each"
'serve per l'enumerazione con for...each
    Set NewEnum = Insieme.[_NewEnum]
End Function

Public Function Add(NewItem As Variant, Optional Key As Variant, Optional Before As Variant, Optional After As Variant, Optional Sort As Boolean = False)
    Insieme.Add NewItem, Key
    If Sort Then SortCollection Insieme
End Function

Public Function Remove(Index As Variant)
    Insieme.Remove Index
End Function

Public Function Item(Index As Variant) As Variant
Attribute Item.VB_Description = "Membro predefinito di ogni elemento della Collection"
Attribute Item.VB_UserMemId = 0
    On Error Resume Next
    Item = "#Nothing"
    Item = Insieme.Item(Index)
End Function

Property Get Count() As Long
    Count = Insieme.Count
End Property

Property Get Occurrences(Item As Variant) As Long
Attribute Occurrences.VB_Description = "Restituisce il n° di occorrenze della parola nel testo"
Dim v As String, s As Variant, source As String
    If TypeName(Item) = "String" Or TypeName(Item) = "Match" Then
        v = CStr(Item)
    Else
        v = CStr(Insieme.Item(Item))
    End If
       
    For Each s In Insieme
        source = source & CStr(s) & " "
    Next
    Occurrences = Len(Replace(source, v & " ", v & " *")) - Len(source)
End Property

Function Exists(Item As String) As Boolean
Attribute Exists.VB_Description = "Vero se l'elemento specificato esiste nella Collection"
    Exists = (Occurrences(Item) > 0)
End Function

Function Clear()
Attribute Clear.VB_Description = "Azzera rapidamente il contenuto della Collection"
    Set Insieme = New Collection
End Function

Function Longest() As Collection
Attribute Longest.VB_Description = "Restituisce un insieme delle parole più lunghe presenti nel testo fornito"
Dim value As Long, v As Variant, coll As Collection
    Set coll = New Collection
    value = 1  'non esisterà mai una parola minore di un carattere? :)
    For Each v In Insieme
        If Len(v) = value Then
            value = Len(v)
            coll.Add v
        ElseIf Len(v) > value Then
            If coll.Count > 0 Then Set coll = New Collection
            value = Len(v)
            coll.Add v
        End If
    Next
    Set Longest = coll
End Function

Function Shortest() As Collection
Attribute Shortest.VB_Description = "Restituisce un insieme delle parole più corte presenti nel testo fornito"
Dim value As Long, v As Variant, coll As Collection
    Set coll = New Collection
    value = 999999  'non esisterà mai una parola di quasi un milione di caratteri? :)
    For Each v In Insieme
        If Len(v) = value Then
            value = Len(v)
            coll.Add v
        ElseIf Len(v) < value Then
            If coll.Count > 0 Then Set coll = New Collection
            value = Len(v)
            coll.Add v
        End If
    Next
    Set Shortest = coll
End Function

Function SubSet(filter As String, Optional IgnoreCase As Boolean = True) As Collection
Attribute SubSet.VB_Description = "Restituisce un insieme delle parole che soddisfano la condizione"
Dim coll As Collection, v As Variant, f As String
    Set coll = New Collection
    If IgnoreCase Then filter = LCase(filter)
    For Each v In Insieme
        f = CStr(v)
        If IgnoreCase Then f = LCase(f)
        If IIf(IgnoreCase, LCase(v), v) Like (filter & "*") Then
            coll.Add f
        End If
    Next
    Set SubSet = coll
End Function

Private Function SortCollection(coll As Collection) As Collection
Attribute SortCollection.VB_Description = "Riordina alfabeticamente gli elementi della Collection"
Dim i As Integer, j As Integer, temp As Variant
    For i = 1 To coll.Count - 1
        For j = i + 1 To coll.Count
            If coll(i) > coll(j) Then
                temp = coll(j)
                coll.Remove j
                coll.Add temp, , i
            End If
        Next j
    Next i
End Function

Ed ecco due semplici esempi di utilizzo della Classe; i risultati sono esposti nella Finestra Immediata.
Le Function myText e myText2 sono richiamate dalle Sub Test1 e Test2 e illustrano due possibilità d’utilizzo della Classe, con passaggio di parametri diversi.
(da copiare e incollare in un file di estensione .bas che deve poi essere importato nel progetto)

Option Explicit
Function myText(ByVal testo As String, Optional DiscardDups As Boolean = False, Optional IgnoreNums As Boolean = True) As WordsCollectionClass
'In questo esempio di utilizzo della Classe diamo la posisbilità di ignorare o conservare i duplicati e di ignorare o no i numeri
'Importante! referenziare la libreria Microsoft VBScript Regular Expressions 5.5
Dim RegEx As RegExp, ma As Match, wo As WordsCollectionClass, wo2 As WordsCollectionClass
    Set RegEx = New RegExp
    RegEx.Pattern = "([A-Za-z\u00C0-\u017F\u1e00-\u1ef9]+)"
    If Not IgnoreNums Then RegEx.Pattern = "([A-Za-z0-9\u00C0-\u017F\u1e00-\u1ef9]+)"
    RegEx.Global = True
    RegEx.IgnoreCase = True
    Set wo = New WordsCollectionClass
    On Error Resume Next    'importante per bypassare l'errore provocato da chiave duplicata!
    For Each ma In RegEx.Execute(testo)
        If DiscardDups Then
            wo.Add ma, ma
        Else
            wo.Add ma
        End If
    Next
    Set RegEx = Nothing
    Set myText = wo
End Function

Function myText2(ByVal testo As String) As WordsCollectionClass
'In questo esempio di utilizzo della Classe decidiamo di conservare i duplicati e di ignorare i numeri
'Importante! referenziare la libreria Microsoft VBScript Regular Expressions 5.5
Dim RegEx As RegExp, ma As Match, wo As WordsCollectionClass, wo2 As WordsCollectionClass
    Set RegEx = New RegExp
    RegEx.Pattern = "([A-Za-z\u00C0-\u017F\u1e00-\u1ef9]+)"
    RegEx.Global = True
    RegEx.IgnoreCase = True
   
    Set wo = New WordsCollectionClass
    For Each ma In RegEx.Execute(testo)
        wo.Add ma, Sort:=True
    Next
   
    Set RegEx = Nothing
    Set myText2 = wo
End Function

Sub Test1()
Dim stringa As String, wo As Variant, phrase As WordsCollectionClass, SubSet As Collection
    Set phrase = New WordsCollectionClass
    Set SubSet = New Collection
   
    stringa = "Sereno non è, Sereno sarà, se non è sereno, si rasserenerà! Inoltre 2+2 fa 4!"
    Set phrase = myText(stringa)
   
    Debug.Print "Sto analizzando la frase '" & stringa & "'."
    Debug.Print "Ci sono in tutto " & phrase.Count & " parole (anche ripetute), esclusi i numeri."
    Set phrase = myText(stringa, True)
    Debug.Print "Eliminati i duplicati, le parole diverse sono " & myText(stringa, True).Count & "."
    Set phrase = myText(stringa, , False)
    Debug.Print "Nella frase ci sono " & phrase.Count & " parole (anche ripetute), compresi nel conteggio i numeri."
   
    Debug.Print "Altre statistiche parola per parola! In questa frase (escludendo i numeri):"
    Set phrase = myText(stringa)
    For Each wo In myText(stringa, True)
        Debug.Print "- la parola '" & wo; "' ricorre "; phrase.Occurrences(wo) & " volte."
    Next
   
    Set phrase = myText(stringa, True)
    Debug.Print "La parola più lunga ha " & phrase.Longest(1).Length & " lettere. "
    Debug.Print "Ci sono " & myText(stringa, False).Longest.Count & " parole (potrebbero essere ripetute) di questa lunghezza: ";
    For Each wo In phrase.Longest
        Debug.Print wo & "; ";
    Next
    Debug.Print
   
    Debug.Print "La parola più corta ha " & phrase.Shortest(1).Length & " lettere. "
    Debug.Print "Ci sono " & myText(stringa, False).Shortest.Count & " parole (potrebbero essere ripetute) di questa lunghezza: ";
    For Each wo In phrase.Shortest
        Debug.Print wo & "; ";
    Next
    Debug.Print
   
    Set SubSet = phrase.SubSet("S", True)
    Debug.Print "Ci sono " & SubSet.Count & " parole che iniziano con 's' (case-insensitive). Le parole sono:"
    For Each wo In SubSet
        Debug.Print wo & " (ricorre " & myText(stringa, False).Occurrences(CStr(wo)) & " volte); ";
    Next
    Debug.Print
   
    Set SubSet = phrase.SubSet("S", False)
    Debug.Print "Ci sono " & SubSet.Count & " parole che iniziano con 'S' maiuscola (case-sensitive). Le parole sono:"
    For Each wo In SubSet
        Debug.Print wo & " (ricorre " & myText(stringa).Occurrences(CStr(wo)) & " volte); ";
    Next
   
    Set phrase = Nothing
    Set SubSet = Nothing
End Sub

Sub Test2()
Dim stringa As String, wo As Variant, phrase As WordsCollectionClass, SubSet As Collection
    Set phrase = New WordsCollectionClass
    Set SubSet = New Collection
   
    stringa = "Sereno non è, Sereno sarà, se non è sereno, si rasserenerà! Inoltre 2+2 fa 4!"
    Set phrase = myText2(stringa)
   
    Debug.Print "La frase iniziale è:"
    Debug.Print stringa
    Debug.Print
    Debug.Print "Le parole della frase, riordinate alfabeticamente, compresi i duplicati e ignorando i numeri, sono:"
    For Each wo In phrase
        Debug.Print wo; " ";
    Next
End Sub


posted @ venerdì 8 febbraio 2008 13:15

Print

Comments on this entry:

# Parole, parole, parole... il Contastorie

Left by Il blog di Francesco Cadin at 08/02/2008 13:17
Gravatar

# re: Parole, parole, parole... il codice!

Left by Giuseppe Bravo at 23/02/2010 18:02
Gravatar
Ciao, complimeti per il codice. Mi sembri molto ferrato sulla manipolazione di stringhe e sulle espressioni regolari. Se vuoi cimentarti in qualcosa di proficuo io avrei un esigenza particolare. Avrei bisogno di una routine in VB6.0 che faccia la seguente attività: dovendo filtrare una chat pubblica da una serie di parole "proibite" (tipo parolacce, bestemmie, ecc...) avrei bisogno di una funzione che data in input la stringa da controllare verifichi la presenza di parole proibite (da una lista che contiene la radice della parola proibita o qualcosa di simile) e restituisca un flag di bontà o non bontà della stringa stessa. Se ti interessa puoi contattarmi con pbravo59@hotmail.com
Saluti, Jo

Your comment:



 (will not be displayed)


 
 
 
Please add 2 and 7 and type the answer here:
 

Live Comment Preview: