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
    venerdì 10 gennaio 2025
    Bari
    40
    61
    11
    86
    37
    Cagliari
    31
    02
    51
    68
    87
    Firenze
    73
    55
    34
    52
    18
    Genova
    11
    40
    27
    82
    20
    Milano
    80
    71
    65
    19
    10
    Napoli
    50
    30
    03
    01
    36
    Palermo
    66
    42
    43
    76
    89
    Roma
    05
    22
    62
    35
    39
    Torino
    17
    58
    62
    86
    69
    Venezia
    43
    89
    14
    04
    40
    Nazionale
    64
    76
    35
    40
    19
    Estrazione Simbolotto
    Bari
    08
    07
    37
    33
    38
    Archivio estrazioni lotto Ritardi top 15 Frequenze top 15

Ultimi Messaggi

Indietro
Alto