L
LuigiB
Guest
Keeper mi aveva chiesto di fare una funzione nell'area sistemi .. ho preferrito fare uno script che è piu sbrigativo
Codice:
Option Explicit
Dim aNumUsati
Dim aColonne
Sub Main
Dim nLato
Dim r,c,k
Dim n
Dim s
Dim nTentativi
Dim bTrovato
Dim nScelti
Const nMinLato = 2
Const nMaxLato = 12
Const nTentativiMax = 1000
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)
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)
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,,,4)
Else
Call AddRigaTabella(aV,,,4)
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(StringaNumeri(aNumScelti,,True)))
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)
Dim n
Dim nPassaggi
Do
n = NumeroCasuale(1,90)
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)
ScegliNumero = n
End Function
Function NumeroNonValido(Numero,Riga,Colonna,aNumeri,nLato,aDiagonali)
Dim k,r,c
If Numero = 0 Then
NumeroNonValido = True
Exit Function
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
