Newsgroup: it.comp.lang.visual-basic
Titolo: codice per generare anagrammi

Ecco il codice:
Option Explicit
Dim parola As String
Dim anagramma As String
Dim num_let As Double
Dim max As Double
Dim i As Double
Dim stringa(1 To 3628800) As String
Dim x As Double
Dim j As Double
Dim z As Double
Dim ind As Double
Dim num As Integer
Dim numeri(1 To 50) As Boolean
Dim flag_trovato As Boolean
Dim prima As Boolean
Dim indice As Double
Dim trovato As Boolean
Dim valore As Double
Private Sub cmdCrea_Click()
For i = 1 To 50
  numeri(i) = False
Next i
valore = 1
flag_trovato = True
trovato = False
prima = True
parola = txtParola.Text
num_let = Len(parola)
If num_let > 7 Then
   MsgBox "non posso operare con parole più lunghe di 7 lettere"
   Exit Sub
End If
' MsgBox (parola)
'MsgBox (num_let)
max = 1
z = 1
For i = 1 To num_let
max = max * i
Next i
'MsgBox (max)
For i = 1 To max
    stringa(i) = ""
Next i
cmdCrea.Enabled = False
For i = 1 To max
'MsgBox (flag_trovato)
 Do Until Not (flag_trovato)
 'MsgBox "ciclo grande "
  For x = 1 To num_let
   Randomize Timer
     num = (Rnd * (num_let - 1)) + 1
     Do Until numeri(num) = False
      num = (Rnd * (num_let - 1)) + 1
     Loop
     numeri(num) = True
     anagramma = anagramma + Mid(parola, num, 1)
    ' MsgBox (anagramma)
    ' MsgBox (num)
     If Len(anagramma) = num_let Then
        x = num_let
     End If
  Next x
  'MsgBox "cicla"
  flag_trovato = False
  For j = 1 To max
   If anagramma = stringa(j) Then
      flag_trovato = True
      anagramma = ""
      j = max
   End If
  Next j
  If Not (flag_trovato) Then
     anagramma = anagramma + CStr(valore)
     Lista.AddItem anagramma
     valore = valore + 1
     'MsgBox (anagramma)
     For ind = 1 To max
       If Trim(stringa(ind)) = "" Then
          stringa(ind) = anagramma
          anagramma = ""
          indice = ind
          ind = max
       End If
     Next ind
  End If
 Dim k As Double
 For k = 1 To 50
  numeri(k) = False
 Next k
 Loop
 flag_trovato = True
 anagramma = ""
Next i
End Sub
Private Sub cmdReset_Click()
Lista.Clear
txtParola.Text = ""
cmdCrea.Enabled = True
End Sub
Private Sub cmdStringhe_Click()
parola = txtParola.Text
num_let = Len(parola)
max = 1
For i = 1 To num_let
max = max * i
Next i
MsgBox (max)
End Sub
Private Sub Command1_Click()
End
End Sub

 Ecco il codice:
Non voglio nemmeno cercare di capire cosa faccia il tuo codice (Rnd? boh!)
:)
Questo è un'adattamento della funzione di F. Languasco per il calcolo delle
disposizioni.
Copia in un modulo e lancia Test come prova.
Però, dato che si memorizza (e quindi alloca memoria) per ogni "anagramma",
con parole di oltre 9 lettere va in "memoria esaurita" (9 =  362880
anagrammi, e aumentano esponenzialmente. Si dovrebbe evitare di usare due
volte le lettere ripeture, es. "casa" è inutile dare "c(a1)s(a2)" e
"c(a2)s(a1)")
Per evitare questi problemi se è possibile anzichè fare i vari Redim manda
direttamente in output il risultato di ogni operazione.
Ciao
---
Option Explicit
Public Type TSerie
    Item() As Byte
End Type
Public Type TCombinazione
    Serie() As TSerie
End Type
Public Sub Test()
    Dim Serie As TSerie
    Dim combinazioni As TCombinazione
    Dim I As Long
    Dim c As Long
    Dim nComb As Long
    Dim strParola As String
    strParola = "casetta"
    Serie.Item = StrConv(strParola, vbFromUnicode)
    nComb = CalcolaDisposizioni(Len(strParola), Serie, combinazioni)
    For c = 0 To nComb - 1
        For I = 0 To Len(strParola) - 1
            Debug.Print Chr$(combinazioni.Serie(c).Item(I));
        Next I
        Debug.Print
    Next c
End Sub
Public Function CalcolaDisposizioni(ByVal k As Long, ByRef Valori As TSerie,
ByRef OutDisposizioni As TCombinazione) As Long
'   Ritorna, nella matrice OutDisposizioni(Dnk(N, K)).Item(K) con N >= K
'   e K > 0, le disposizioni semplici di N oggetti della classe K.
'   Se K = N calcola le permutazioni di N oggetti.
'   Questa versione sacrifica la compattezza del codice alla velocita'
'   di esecuzione:
    Dim R As Long
    Dim NR As Long
    Dim c As Long
    Dim cr As Long
    Dim P As Long
    Dim I As Long
    Dim J As Long
    Dim L As Long
    Dim NG1 As Long
    Dim DG1 As Long
    Dim NG2 As Long
    Dim DG2 As Long  ' Numero e dimensioni dei sottogruppi.
    Dim n As Long
    n = UBound(Valori.Item) - LBound(Valori.Item) + 1
    NR = Dnk(n, k)   ' Numero delle righe.
    ReDim OutDisposizioni.Serie(0 To NR - 1)
    ' Scrivo la prima colonna:
    R = 0
    P = 0
    NG2 = n
    DG2 = NR / NG2
    For J = 1 To NG2
        For I = 1 To DG2
            ReDim OutDisposizioni.Serie(R).Item(0 To k - 1)
            OutDisposizioni.Serie(R).Item(0) = P
            'OutDisposizioni(R, 1) = P
            R = R + 1
        Next I
        P = P + 1
    Next J
    ' Colonne rimanenti:
    For c = 1 To k - 1
        R = 0
        NG1 = NR / DG2
        DG1 = DG2
        NG2 = n - c '+ 2
        DG2 = DG1 / NG2
        For L = 1 To NG1
            P = OutDisposizioni.Serie(R).Item(c - 1) + 1
            For J = 1 To NG2
                Do  ' Convalida P o cerca un altro valore.
                    If P >= n Then P = 0
                    For cr = 0 To c - 2
                        If P = OutDisposizioni.Serie(R).Item(cr) Then
                            P = P + 1
                            Exit For
                        End If
                    Next cr
                Loop Until cr = c - 1
                For I = 1 To DG2
                    If (c > 0) Then
                        ' Reindirizza il risultato
                        OutDisposizioni.Serie(R).Item(c) = Valori.Item(P)
                    Else
                        OutDisposizioni.Serie(R).Item(0) = P
                    End If
                    R = R + 1
                Next I
                P = P + 1
            Next J
        Next L
    Next c
    For R = 0 To NR - 1
        OutDisposizioni.Serie(R).Item(0) =
Valori.Item(OutDisposizioni.Serie(R).Item(0))
    Next R
    CalcolaDisposizioni = NR
End Function
Public Function Dnk(ByVal n As Long, ByVal k As Long) As Long
'   D(n|k)
'   Ritorna il numero delle disposizioni semplici
'   di N oggetti presi a gruppi di K:
    Dnk = CLng(Fattoriale(n, n - k + 1))
End Function
Public Function Fattoriale(ByVal n As Long, Optional ByVal iTo As Long = 2)
As Double
'   Ritorna il prodotto dei numeri, consecutivi, interi e positivi,
'   da N1 a N2 (0 < N1 <= N2). Se N1 > N2 ritorna 1.
'   Se N1 manca, ritorna il Fattoriale di N2; in questo caso puo'
'   anche essere N2 = 0 perche', per definizione, e' 0! = 1:
    Dim I As Long
    Fattoriale = 1#
    For I = iTo To n
        Fattoriale = Fattoriale * CDbl(I)
    Next I
End Function
--
y = f(
http://neodatatype.interfree.it/index.html
)

Ehm, Zanna, sono in "ferie a metą" e pensavo fosse facile-facile.
Mi sono concesso qualche ora per scrivere, da 0, la mia versione.
Non ce l'ho fatta.
Prova, anche con la tua, con la parola "12345"...

Non va, produce persino parole più lunghe (e forse anche più corte, ma
questo non l'ho verificato) dell'originale.
Provare con "12345"

 Provare con "12345"
Eheh, colpa della solita ottimizzazione dell'ultimo minuto :)
La sub CalcolaDisposizioni deve terminare cosě:
                ' sostituisci tutto quello che seguiva
                ' "For I = 1 To DG2", For compreso, con questo
                For I = 1 To DG2
                    OutDisposizioni.Serie(R).Item(c) = P
                    R = R + 1
                Next I
                P = P + 1
            Next J
        Next L
    Next c
    For R = 0 To NR - 1
        For c = 0 To k - 1
            OutDisposizioni.Serie(R).Item(c) =
Valori.Item(OutDisposizioni.Serie(R).Item(c))
        Next c
    Next R
    CalcolaDisposizioni = NR
Ciao
