Cerco uno script per cruciverba

[alessandro63]

Qualcuno di voi possiede uno script 3 per 3

 

[*blacklotto*]

io ce l'ho, e che ci fai con uno script 3 x 3 ?

 

[alessandro63]

Volevo solo capire come si incolonnano una decina di numeri a differenza di un ridoto ambo in terzina.

 

[*blacklotto*]

Prova se ti va bene, buon studio.

Anticipazione (Spoiler)

Option Explicit
Dim aNumUsati
Dim aColonne
Dim aNumScelti
Sub Main
Dim nLato
Dim r,c,k
Dim n
Dim s
Dim nTentativi
Dim bTrovato
Dim nScelti
Dim bUnaPresenzaSola
Const nMinLato = 2
Const nMaxLato = 12
Const nTentativiMax = 1000
bUnaPresenzaSola = False
nLato = Int(InputBox("Inserire la quantita di numeri per il lato del cruciverba","Lato Cruciverba",6))
If nLato < nMinLato Or nLato > nMaxLato Then
MsgBox "Il lato dve essere compreso tra " & nMinLato & " e " & nMaxLato
Exit Sub
End If
ReDim aNumScelti(0)
nScelti = ScegliNumeri(aNumScelti)
If nScelti >= nLato * nLato Then
bUnaPresenzaSola = True
End If
Call DoEventsEx
If nScelti <= nLato Then
MsgBox "Selezionare piu numeri",vbInformation
Exit Sub
End If
aNumUsati = ArrayNumeriToBool(aNumScelti)
ReDim aDiagonali(nLato,nLato)
Call CalcolaDiagonali(aDiagonali,nLato)
Do While bTrovato = False
ReDim aNumeri(nLato,nLato)
For r = 1 To nLato
For c = 1 To nLato
n = ScegliNumero(r,c,aNumeri,nLato,aDiagonali,bUnaPresenzaSola)
If n = 0 Then Exit For
aNumeri(r,c) = n
Next
If n = 0 Then Exit For
Next
If colonneDuplicate(aNumeri,nLato,aDiagonali) = False Then
bTrovato = True
Else
nTentativi = nTentativi + 1
If nTentativi > nTentativiMax Then Exit Do
End If
If ScriptInterrotto Then Exit Do
Call Messaggio("Cruciverba Generati " & nTentativi)
DoEventsEx
Loop
For r = 1 To nLato
ReDim aV(nLato)
For c = 1 To nLato
aV(c) = Format2(Int(aNumeri(r,c)))
Next
If r = 1 Then
Call InitTabella(aV,,,6)
Else
Call AddRigaTabella(aV,,,6)
End If
Next
If nTentativi > nTentativiMax Or colonneDuplicate(aNumeri,nLato,aDiagonali) Then
Call Scrivi("ATTENZIONE CRUCIVERBA NON VALIDO",True,,,vbRed)
End If
Call Scrivi("Cruciverba " & nLato & "x" & nLato,True)
Call Scrivi
Call Scrivi("Si vince con le righe , le colonne e le diagonali")
Call CreaTabella
Call Scrivi
Call Scrivi("Colonne in gioco",True)
For k = 1 To UBound(aColonne)
Call Scrivi(FormatSpace(k,5,True) & ") " & aColonne(k))
Next
Call Scrivi
Call Scrivi("Numeri usati",True)
Call Scrivi(SpezzaStringaNumeri(GetNumRealmenteUsati(aNumeri,nLato)),,True)
Call Scrivi
Call ScriviTabellaFreq(aNumeri,nLato)
End Sub
Sub CalcolaDiagonali(aDiagonali,nLato)
Dim r,c
For r = 1 To nLato
c = c + 1
aDiagonali(r,c) = True
Next
c = nLato + 1
For r = 1 To nLato
c = c - 1
If aDiagonali(r,c) Then
aDiagonali(r,c) = 1
Else
aDiagonali(r,c) = True
End If
Next
End Sub
Function ScegliNumero(Riga,Colonna,aNumeri,nLato,aDiagonali,bUnaVoltaSola)
Dim n
Dim nPassaggi
Do
n = aNumScelti(NumeroCasuale(1,UBound(aNumScelti)))
nPassaggi = nPassaggi + 1
If nPassaggi > 1000 Then
n = 0
Exit Do
End If
If ScriptInterrotto Then
n = 0
Exit Do
End If
Call DoEventsEx
Loop While NumeroNonValido(n,Riga,Colonna,aNumeri,nLato,aDiagonali,bUnaVoltaSola)
ScegliNumero = n
End Function
Function NumeroNonValido(Numero,Riga,Colonna,aNumeri,nLato,aDiagonali,bUnaVoltaSola)
Dim k,r,c
If Numero = 0 Then
NumeroNonValido = True
Exit Function
End If
If bUnaVoltaSola Then
For r = 1 To nLato
For c = 1 To nLato
If aNumeri(r,c) = Numero Then
NumeroNonValido = True
Exit Function
End If
Next
Next
End If
If aNumUsati(Numero) = False Then
NumeroNonValido = True
Exit Function
End If
For k = 1 To nLato
If aNumeri(Riga,k) = Numero Then
NumeroNonValido = True
Exit Function
End If
Next
For k = 1 To nLato
If aNumeri(k,Colonna) = Numero Then
NumeroNonValido = True
Exit Function
End If
Next
If aDiagonali(Riga,Colonna) Then
'If Riga = Colonna Or ((Riga = nLato/2)And (Colonna = nLato/2)) Then
If Riga = Colonna Then
c = Colonna + 1
For r = Riga To 1 Step - 1
c = c - 1
If aNumeri(r,c) = Numero Then
NumeroNonValido = True
Exit Function
End If
Next
c = Colonna - 1
For r = Riga + 1 To nLato
c = c + 1
If aNumeri(r,c) = Numero Then
NumeroNonValido = True
Exit Function
End If
Next
End If
If Riga <> Colonna Or aDiagonali(Riga,Colonna) = 1 Then
c = Colonna - 1
For r = Riga To 1 Step - 1
c = c + 1
If aNumeri(r,c) = Numero Then
NumeroNonValido = True
Exit Function
End If
Next
c = Colonna + 1
For r = Riga + 1 To nLato
c = c - 1
If aNumeri(r,c) = Numero Then
NumeroNonValido = True
Exit Function
End If
Next
End If
End If
End Function
Function colonneDuplicate(aNumeri,nLato,aDiagonali)
Dim nColonneTot
Dim r,c,i
Dim k,kk
nColonneTot = nLato * 2 + 2
ReDim aColonne(nColonneTot)
For r = 1 To nLato
ReDim aN(nLato)
For c = 1 To nLato
aN(c) = aNumeri(r,c)
Next
i = i + 1
Call OrdinaMatrice(aN,1,1)
aColonne(i) = StringaNumeri(aN,,True)
Next
For c = 1 To nLato
ReDim aN(nLato)
For r = 1 To nLato
aN(r) = aNumeri(r,c)
Next
i = i + 1
Call OrdinaMatrice(aN,1,1)
aColonne(i) = StringaNumeri(aN,,True)
Next
ReDim aN(nLato)
c = 0
For r = 1 To nLato
c = c + 1
aN(r) = aNumeri(r,c)
Next
i = i + 1
Call OrdinaMatrice(aN,1,1)
aColonne(i) = StringaNumeri(aN,,True)
ReDim aN(nLato)
c = nLato + 1
For r = 1 To nLato
c = c - 1
aN(r) = aNumeri(r,c)
Next
i = i + 1
Call OrdinaMatrice(aN,1,1)
aColonne(i) = StringaNumeri(aN,,True)
For k = 1 To nColonneTot - 1
For kk = k + 1 To nColonneTot
If aColonne(k) = aColonne(kk) Then
colonneDuplicate = True
Exit Function
End If
Next
Next
For k = 1 To nColonneTot
If Len(aColonne(k)) < nLato *2 +(nLato - 1) Then
colonneDuplicate = True
Exit Function
End If
Next
End Function
Function SpezzaStringaNumeri(sStringa)
Dim k
Dim s,i
ReDim aV(0)
Call SplitByChar(sStringa,".",aV)
s = ""
For k = 0 To UBound(aV)
i = i + 1
s = s & aV(k) & "."
If i Mod 20 = 0 Then
s = s & vbCrLf
End If
Next
SpezzaStringaNumeri = Left(s,Len(s) - 1)
End Function
Function GetNumRealmenteUsati(aNumeri,nLato)
Dim r,c,k
Dim s
ReDim aB(90)
For r = 1 To nLato
For c = 1 To nLato
aB(aNumeri(r,c)) = True
Next
Next
For k = 1 To 90
If aB(k) Then
s = s & Format2(k) & "."
End If
Next
If s <> "" Then
s = Left(s,Len(s) - 1)
End If
GetNumRealmenteUsati = s
End Function
Sub ScriviTabellaFreq(aNumeri,nLato)
Dim r,c,k
Dim s
Dim nNumeriPoss
nNumeriPoss = nLato * nLato
ReDim aN(90,2)
For r = 1 To 90
aN(r,1) = r
Next
For r = 1 To nLato
For c = 1 To nLato
aN(aNumeri(r,c),2) = aN(aNumeri(r,c),2) + 1
Next
Next
Call OrdinaMatrice(aN,- 1,2)
ReDim aT(3)
aT(1) = "Numero"
aT(2) = "Presenze"
aT(3) = " % "
Call InitTabella(aT)
For k = 1 To 90
If aN(k,2) > 0 Then
ReDim aV(3)
aV(1) = aN(k,1)
aV(2) = aN(k,2)
aV(3) = Round((aN(k,2)*100)/nNumeriPoss,3) & " %"
Call AddRigaTabella(aV)
End If
Next
Call Scrivi("Presenze numeri in gioco nel cruciverba")
Call CreaTabella
End Sub

 

[alessandro63]

Grazie Black.

 

[alessandro63]

Propio quello che cercavo, nuovamente GRAZIEEE

 

[*blacklotto*]

Bene, mi fa piacere che vada bene.
Quando vedo richieste inascoltate, se posso, cerco di accontentare.