Modifica script cruciverba

tigre62 · 28 Marzo 2023

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]

giomi · 28 Marzo 2023

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.

questa e' la linea da cambiare

Codice:

   For idEstr = EstrazioneIni To EstrazioneFin Step Colpi

tigre62 · 28 Marzo 2023

giomi ha scritto:
questa e' la linea da cambiare

Codice:

For idEstr = EstrazioneIni To EstrazioneFin Step Colpi

grazie mille

Cerca

Cerca

Modifica script cruciverba

tigre62

Junior Member

giomi

Banned

tigre62

Junior Member

Ultima estrazione Lotto

Ultimi Messaggi