Novità

Modifica script cruciverba

tigre62

tigre62

Junior Member
Buon pomeriggio. Tempo fa avevo recuperato uno script qui nel forum per l'elaborazione di un cruciverba ma con Spaziometria 1.6.41 mi da errore in NumeroCasuale. Ma credo che ce ne sono anche altri comandi che evidentemente non funzionano con Spaziometria.
Mi potreste dare una soluzione ?
grazie infinite
Codice: 
Option Explicit
 

Dim aNumUsati
Dim aColonne
Dim aNumScelti

Sub Main
   Dim nLato,nScelti
   Const nMinLato = 2
   Const nMaxLato = 12
   ReDim aRuote(1)
   ReDim aPoste(2)
   Dim Sorte,Colpi
   Dim idEstr
   Dim RuotaDiRil
  
   RuotaDiRil = BA_
   aPoste(2) = 1
   aRuote(1) = RuotaDiRil
   Sorte = 2
   Colpi = 1
   nLato = 5
  
  
   nLato = Int(InputBox("Inserire la quantita di numeri per il lato del cruciverba","Lato Cruciverba",nLato))
   If nLato < nMinLato Or nLato > nMaxLato Then
      MsgBox "Il lato dve essere compreso tra " & nMinLato & " e " & nMaxLato
      Exit Sub
   End If
  
  
   ReDim aDiagonali(nLato,nLato)
   Call CalcolaDiagonali(aDiagonali,nLato)
  
   For idEstr = EstrazioneIni To EstrazioneFin Step Colpi
      Call Messaggio("Estrazione " & idEstr)
      ReDim aNumScelti(0)
      Call AlimentaNumScelti(aNumScelti,idEstr,RuotaDiRil,nLato)
     
      Call GiocaCruciverba(aNumScelti,nLato,aDiagonali,aRuote,aPoste,Colpi,Sorte,idEstr)
     
      If ScriptInterrotto Then Exit For
     
   Next
  
   Call ScriviResoconto
  
End Sub
Sub AlimentaNumScelti(aNumScelti,idEstr,RuotaDiRil,nLato)

   Dim k,e,n,t
   Dim nNumDaTrov
  
   ReDim aB(90)
   t = 0
   nNumDaTrov = nLato * nLato
     
   For k = idEstr To 1 Step - 1
      For e = 1 To 5
         n = Vert(Estratto(k,RuotaDiRil,e))
         If aB(n) = False Then
            aB(n) = True
            t = t + 1
            If t >= nNumDaTrov Then Exit For
         End If
        
      Next
      If t >= nNumDaTrov Then Exit For
   Next
  
   If t >= nNumDaTrov Then
      ReDim aNumScelti(t)
      t = 0
      For k = 1 To 90
         If aB(k) Then
            t = t + 1
            aNumScelti(t) = k
         End If
      Next
  
   End If
  
End Sub
Sub GiocaCruciverba(aNumScelti,nLato,aDiagonali,aRuote,aPoste,Colpi,Sorte,idEstr)
  
   Dim r,c,k
   Dim n
   Dim s
   Dim nTentativi
   Dim bTrovato
   Dim nScelti
   Dim bUnaPresenzaSola
  
   Const nTentativiMax = 1000
   bUnaPresenzaSola = False
  
  
   nScelti = UBound(aNumScelti)
   If nScelti >= nLato * nLato Then
      bUnaPresenzaSola = True
   End If
   Call DoEventsEx
  
   aNumUsati = ArrayNumeriToBool(aNumScelti)
  
   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)
  
   Else
      Call CreaTabella
     
   End If
  
   For k = 1 To UBound(aColonne)
      ReDim aN(0)
      Call SplitByChar("0." & aColonne(k),".",aN)
      Call ImpostaGiocata(k,aN,aRuote,aPoste,Colpi,Sorte)
   Next
   Call Gioca(idEstr)



  
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
Sub SalvaFileColonne
  
   Dim sFile
   Dim k
  
   sFile = GetDirectoryTemp & "Cruciverba.csv"
   If EliminaFile(sFile) Then
      For k = 1 To UBound(aColonne)
         Call ScriviFile(sFile,Replace(aColonne(k),".",";"),,False)
      Next
  
   End If

   Call Scrivi("Le colonne da giocare sono state salvate nel file : " & sFile)
End Sub





[/ code]
 
LuigiB ha scritto:
quel'errore che dite capta pure a me ma solo se seleziono un range dove non esistono estrazioni come ad esempio l'inizio archivio
dove Bari non esisteva.
Cambiate range da programma (visto che lo script si basa proprio sul range impostato nel programma) e vedrete che funziona.
Clicca per espandere...
questa e' la linea da cambiare
Codice: 
   For idEstr = EstrazioneIni To EstrazioneFin Step Colpi
 
Devi accedere o registrarti per poter rispondere.

Ultima estrazione Lotto

  • Estrazione del lotto
    giovedì 16 ottobre 2025
    Bari
    03
    66
    37
    18
    61
    Cagliari
    26
    22
    85
    20
    43
    Firenze
    29
    61
    85
    67
    75
    Genova
    40
    63
    74
    19
    78
    Milano
    43
    80
    34
    54
    70
    Napoli
    18
    78
    89
    15
    27
    Palermo
    38
    84
    88
    06
    62
    Roma
    60
    14
    40
    84
    43
    Torino
    51
    62
    58
    65
    52
    Venezia
    07
    61
    48
    63
    87
    Nazionale
    60
    36
    11
    28
    31
    Estrazione Simbolotto
    29
    02
    24
    03
    37
    Archivio estrazioni lotto Ritardi top 15 Frequenze top 15

Ultimi Messaggi

Indietro
Alto