Novità

Script per VinciCasa

S

ste20fra

Senior Member
Salve a tutti... spulciando i vari post in quest'area ho trovato utili informazioni che tuttavia andrebbero adattate al gioco menzionato, cioè il VinciCasa. Per questo chiedo la cortesia di poter avere degli script da adattare a questo gioco, magari modificando quelli presenti nel Millionday tenendo presente che il VinciCasa prevede l'estrazione di 5 numeri su 40, anzichè 90.
Grazie a tutti per il Vostro aiuto.
 
Ciao ste20fra.
Io pure sono interessati agli script e dopo aver riletto i vecchi post
sono riuscito a creare l'archivio su Spaziom. solo che non
è aggiornato, chiedo se qualcuno lo può postare.
mi risparmierebbe un gran lavoro visto che le
estrazioni da inserire sono più di 1000
Grazie dbr (Renzo)
 
Grazie per la risposta DBR... se guardi nel dettaglio tutti i post nel thread Lotteria Millionday dovresti trovare quello che cerchi, ovviamente da adattare alle tue necessità.... diversamente, io vorrei poter avere qualche script che analizzi nel dettaglio l’andamento generale dei numeri nonché tutto ciò possa essere utile per fare delle statistiche e previsioni molto dettagliate.... Gli script che ho trovato in quella sezione sono utili ma non riesco ad interpretarli per poterli adattare a ciò che chiedo.... Spero che il buon Mike58 possa intervenire in aiuto.
Saluti.
 
Ciao, ste20fra e dbr, penso sia fattibile il mio intervento.
intanto se volete, vedete se vi funge questo script per l'aggiornamento archivio VinciCasa che preleva le estrazioni dal sito di Silop, altrimenti basta copiarle direttamente dal sito.
Poi se c'è una richiesta in particolare cominciate a farla e vedo quello che è possibile fare.

Codice: 
Option Explicit
Sub Main
   Dim k
   If ApriBaseDatiFT(AggiornaArchivioUkGetPath,5,",",40) Then
      'inserire qui il proprio codice
      ' codice di esempio ==========
      For k = 1 To EstrazioniArchivioFT
         'Call ScriviEstrazioneFT(k,True)
         Scrivi k & "," & Replace(DataEstrazioneFT(k),".","/") & "," & StringaEstrattiFT(k,",")
      Next
      '================
   End If
End Sub
Function AggiornaArchivioUkGetPath()
   Dim sFileLocal
   Dim k
   sFileLocal = GetDirectoryAppData & "VinciCasa.txt"
   AggiornaArchivioUkGetPath = ""
   If EliminaFile(sFileLocal) Then
      Call Messaggio("Scarico File Archivio")
      If DownloadFromWeb("https://www.silop.it/script/archivi/VinciCasa/ArchivioVinciCasa.txt",sFileLocal) Then
         ReDim aRighe(0)
         Call Messaggio("Conversione file in corso..")
         If LeggiRigheFileDiTesto(sFileLocal,aRighe) Then
            If EliminaFile(sFileLocal) Then
               For k = 0 To UBound(aRighe)
                  Call ScriviFile(sFileLocal,aRighe(k),False)
                  Call AvanzamentoElab(0,UBound(aRighe),k)
               Next
               LanciaFile(sFileLocal)
               Call CloseAllFileHandle
               Call Messaggio("")
               AggiornaArchivioUkGetPath = sFileLocal
            End If
         End If
      Else
         MsgBox "Impossibile scaricare il file dell'archivio"
      End If
   Else
      MsgBox "Impossibile cancellare il file esistente " & vbCrLf & sFileLocal
   End If
End Function
 
Ciao Mike58

Archivio aggiornato grazie allo script da Te postato (y)(y)(y)

Per quanto riguarda gli script direi di partire (tempo e voglia permettendo)
dalle basi piu classiche.
.
Tabellone analitico ritardi frequenze per estratto-ambo-terno-queterna e cinquina
e statistiche classiche (consecutivi-ripetuti-pari-dispari-somma-ritardo-frequenza)
diciamo le classiche che si usano anche nel lotto e giochi vari.

Se possibile uno script a parte lo dedicherei alle decine naturali(1-10 / 11-20 / 21-30 / 31-40)
che come saprai sono una mia fissa,qui mi interessa il ritardo e la frequenza per 2-3-4-5 estratti di ogni decina

Forse stò chiedendo un po troppo ma non ho problemi " la casa nuova non mi serve subito" posso aspettare ;)

Grazie dbr (Renzo)
 
Ciao dbr, benissimo che lo script per lo scarico estrazioni funziona, a me l'antivirus kaspersky lo blocca, ma lo avevo postato in quanto su altro pc senza il citato antivirus scarica normalmente.

Comincio a postare uno script per il tabellone analitico dei numeri.

Codice: 
Sub Main
   Dim Nu(5),Cad(5),aN(5),Nu2(1),Nn2,Rsl(5)
   Dim Sfile,T,V
   Sfile = GetDirectoryAppData & "archiviovincicasa2.txt"
   Call ApriBaseDatiFT(Sfile,5,",",40)
   Ini = 1
   fin = EstrazioniArchivioFT
   Scrivi "********* Lotteria VinciCasa ********* Estratti ********************* Caduti ******************* ",1,,,1,2
   T = Array(T,"Data info","Estratti","I","II","III","IV","V","Liv","Rit","RitSncLiv","C1","C2","C3","C4","C5","LivCad","CadProgress","EsitiFin","RsL / Rit","PresTeoF2","Att2")
   Call InitTabella(T)
   For es = fin To Ini Step - 1
      kk = 0
      For p = 1 To 5
         Nu(p) = EstrattoFT(es,p)
         Cad(p) = EstrattoFT(es,p)
         aN(p) = EstrattoFT(es,p)
         If EstrattoFrequenzaFT(Nu(p),es,fin) > 1 Then Nu(p) = "-"
         If EstrattoFrequenzaFT(Cad(p),es,fin) = 1 Then Cad(p) = "-"
         If EstrattoFrequenzaFT(Nu(p),es,fin) = 1 Then k = k + 1
         If Cad(p) <> "-" Then kk = kk + 1
         If EstrattoFrequenzaFT(Nu(p),es,fin) = 1 Then kkk = kkk + 1
      Next
      rit = SerieRitardoFT(Ini,fin,aN,1)
      ess = fin - es
      Call VerificaEsitoFT(aN,fin,1,,,,est)
      '............. Ritado di Livello .............................
      Mem2 = 0
      rslA = es'fin - rit
      Nn2 = Split("0." & StringaEstrattiFT(rslA),".")
      For p1 = 1 To 5
         Nu2(1) = Nn2(p1)
         rit2 = SerieRitardoFT(rsla + 1,fin,Nu2,1)'mio rdl
         spA = SeriePrimaFT(rslA + 1,fin,Nu2,1)
         If Mem2 <= spA Then Mem2 = spA
         If Mem2 = rit2 Then Mem2 = rit2
      Next
      If k < 5 Then RslA = fin - Mem2
      If k = 5 Then RslA = rit
      If k < 5 Then Rit2 = fin - Mem2
      If k = 5 Then Rit2 = rit
      presTeo = Round((5*1) *(10/11) ^ ess,4)
     ' Att2 = Round((k/(k + presteo)),3)
     Att2 = Round((Dividi(k,k + PresTeo)),3)
      '---------------------------------------------------------------
      att = Round(Dividi(RslA,ess),2)
      decd = 55 - kkk
      If k > 0 Then
         V = Array(V,GetInfoEstrazioneFT(es),StringaEstrattiFT(es),Nu(1),Nu(2),Nu(3),Nu(4),Nu(5),k,ess,RslA,Cad(1),Cad(2),Cad(3),Cad(4),Cad(5),kk,kkk,est,att,PresTeo,Att2)
         Call AddRigaTabella(V)
      End If
      For x = 3 To 7
         Call SetColoreCella((x),6,0)
      Next
      Call SetColoreCella(8,4,0)
      For xx = 11 To 15
         Call SetColoreCella((xx),6,0)
      Next
      If V(9) > 0 And V(10) = 0 Then Call SetColoreCella(18,2,4)
      k = 0
      kk = 0
   Next
   Call SetTableWidth("100%")
   CreaTabella
   Scrivi "Script By Mike58",1,1,,1,3
End Sub

Attenzione a mettere il vostro percorso archivio il mio come si evince e in questa riga
Sfile = GetDirectoryAppData & "archiviovincicasa2.txt"
con il nome che io ho dato all'archivio, voi dovete richiamare e modificare la riga immettendo il vostro nome archivio e nella directory del programma.

ciao
 
SCRIPT su Decine

Codice: 
Sub Main
   Dim Nu(20),aN(5),sFile,T,V
   sFile = GetDirectoryAppData & "Archiviovincicasa2.txt"
   'sfile = ScegliFile("C:\.....\Desktop\.txt")
   Call ApriBaseDatiFT(sFile,5,",",40)

   'controllo = InputBox("Quante Estrazioni Controllo",,10)
   Ini = 1
   fin = EstrazioniArchivioFT
   Call ScegliRange(ini,fin,Ini,EstrazioniArchivioFT)
   dett = InputBox("Vuoi vedere il dettaglio","Si No","N")
   T = Array(T,"Giocata N","Lunghetta","PT0","PT1","PT2","PT3","PT4","PT5","Verifica Fin","Fre x 1","Fre x 2","Fre x 3","Fre x 4","Fre x 5","Rit x 1","Rit X 2","Rit X 3","Rit X 4","Rit X 5")
   Call InitTabella(T)
   pto = 0
   pt1 = 0
   pt2 = 0
   pt3 = 0
   pt4 = 0
   pt5 = 0
   For x = 1 To 4
      '-------inserimento lunghette ----------------------------
      Nu(1) = Array(0,1,2,3,4,5,6,7,8,9,10)
      Nu(2) = Array(0,11,12,13,14,15,16,17,18,19,20)
      Nu(3) = Array(0,21,22,23,24,25,26,27,28,29,30)
      Nu(4) = Array(0,31,32,33,34,35,36,37,38,39,40)
      
      

      '--- fine inserimento ------------------------------
      qn = UBound(Nu(x))
      For es = Ini To fin
         For p = 1 To 5
            aN(p) = EstrattoFT(es,p)
            pt = SerieFreqFT(es,es,Nu(x),1)
            ptt = SerieFreqFT(Ini,fin,Nu(x),1)
            ptt2 = SerieFreqFT(Ini,fin,Nu(x),2)
            ptt3 = SerieFreqFT(Ini,fin,Nu(x),3)
            ptt4 = SerieFreqFT(Ini,fin,Nu(x),4)
            ptt5 = SerieFreqFT(Ini,fin,Nu(x),5)
            
           ' rrt0 = SerieRitardoFT(es,es,Nu(x),1)
            rrt1 = SerieRitardoFT(Ini,fin,Nu(x),1)
            rrt2 = SerieRitardoFT(Ini,fin,Nu(x),2)
            rrt3 = SerieRitardoFT(Ini,fin,Nu(x),3)
            rrt4 = SerieRitardoFT(Ini,fin,Nu(x),4)
            rrt5 = SerieRitardoFT(Ini,fin,Nu(x),5)


         Next
         If pt = 0 Then pto = pto + 1
         If pt = 1 Then pt1 = pt1 + 1
         If pt = 2 Then pt2 = pt2 + 1
         If pt = 3 Then pt3 = pt3 + 1
         If pt = 4 Then pt4 = pt4 + 1
         If pt = 5 Then pt5 = pt5 + 1
         Call VerificaEsitoFT(Nu(x),es,1,1,,,es1)
         If dett = "S" Then
            Scrivi GetInfoEstrazioneFT(es) & vbTab & StringaEstrattiFT(es) & vbTab & pt & vbTab & es1
         End If
      Next
      Scrivi
      Scrivi "Giocata N " & x & vbTab & StringaNumeri(Nu(x)),1
      Scrivi "Punti Zero....... " & pto
      Scrivi "Punti Uno........ " & pt1
      Scrivi "Punti Due........ " & pt2,1
      Scrivi "Punti tre........ " & pt3,1
      Scrivi "Punti Quattro.... " & pt4,1
      Scrivi "Punti Cinque..... " & pt5,1
      Call VerificaEsitoFT(Nu(x),fin,1,1,,,es2)
      Call Scrivi("......................... " & es1)
      Scrivi
      V = Array(V,x & " - " & qn,StringaNumeri(Nu(x),,1),pto,pt1,pt2,pt3,pt4,pt5,es2,ptt,ptt2,ptt3,ptt4,ptt5,rrt1,rrt2,rrt3,rrt4,rrt5)
      Call AddRigaTabella(V)
      If pt2 > 0 Then Call SetColoreCella(5,,2)
      If pt3 > 0 Then Call SetColoreCella(6,,2)
      pto = 0
      pt1 = 0
      pt2 = 0
      pt3 = 0
      pt4 = 0
      pt5 = 0
   Next
   Scrivi "Riepilogo Finale",1,,,,3,,1
   CreaTabella
End Sub
 
script per estratti in posizione
Codice: 
Sub Main
   Dim sFile,T,V,nEsiti
   sFile = GetDirectoryAppData & "Archiviovincicasa2.txt"
   Call ApriBaseDatiFT(sFile,5,",",40)
   Ini = 1
   fin = EstrazioniArchivioFT
   Tot = fin - Ini
   Med = Int(Tot/11)
   Scrivi "Estrazioni Attive : " & Tot
   Scrivi "Media Frequenza   : " &(Med),1
   T = Array(T,"Numero","P1","P2","P3","P4","P5","Pres","Rit","Sto","InCr","+ Media","- Media")
   Call InitTabella(T,1,,2,5)
   For x = 1 To 40
      ReDim ff(5)
      For y = 1 To 5
         ReDim pos(5)
         pos(y) = True
         ff(y) = EstrattoFrequenzaFT(x,Ini,fin,pos)
         fft = EstrattoFrequenzaFT(x,Ini,fin)
         rit = EstrattoRitardoFT(x,Ini,fin)
         sto = EstrattoStoricoFT(x,Ini,fin)
         If ff(y) = 0 Then ff(y) = "-"
         Incr = EstrattoIncrStoricoFT(x,Ini,fin)
         If Incr = 0 Then Incr = "-"
         spMedia = fft - Med
         stMedia = Med - fft
         If spMedia >= 0 Then
         spMedia = spMedia
         Else
         spMedia = "-"
         End If
         If stMedia > 0 Then
         stMedia = stMedia
         Else
         stMedia = "-"
         End If
       
       
      Next
      V = Array(V,Format2(x),ff(1),ff(2),ff(3),ff(4),ff(5),fft,rit,sto,Incr,spMedia,stMedia)
      Call AddRigaTabella(V)
      Call SetColoreCella(7,3,0)
      Call SetColoreCella(8,7,5)
      Call SetColoreCella(9,4,0)
      Call SetColoreCella(1,1,5)
      If rit = 0 Then Call SetColoreCella(8,2,4)
      If rit = 0 Then Call SetColoreCella(1,4,2)
   Next
   Call SetTableWidth("100%")
   Call CreaTabella(,,,,1)
   aP = Array(aP,"Posizioni","Numeri Presenti","Min","Max","Q.Tà","Ritardo","Verifica")
   Call InitTabella(aP)
   For xx = 1 To 5
      ReDim aPos(5)
      aPos(xx) = True
      'aPos(2) = True
      'aPos(3) = True
      'aPos(4) = True
      'aPos(5) = True
      For nn = 1 To 55
         'Nu(1) = n
         'If SerieFreqFT(Ini,fin,Nu,1,aPos) > 0  Then
         If EstrattoFrequenzaFT(nn,Ini,fin,aPos) > 0 Then
            kk = kk + 1
            ReDim Preserve rigaP(kk)
            rigaP(kk) = nn
            min = MinimoV(rigaP,1,- 1)
            max = MassimoV(rigaP)
            sr = SerieRitardoFT(ini,fin,rigaP,1)
            Call VerificaEsitoFT(rigaP,fin,1,,esito1,,es2)
         End If
      Next
      If kk > 0 Then
         aV = Array(aV,xx,StringaNumeri(rigaP),min,max,kk,sr,es2)
         Call AddRigaTabella(aV)
      End If
      'riga = ""
      kk = 0
   Next
   Call CreaTabella()
   For yy = 1 To 40
      n = EstrattoFrequenzaFT(yy,Ini,fin)
      m = EstrattoRitardoFT(yy,Ini,fin)
      o = EstrattoStoricoFT(yy,Ini,fin)
      i = EstrattoIncrStoricoFT(yy,Ini,fin)
      If n > Med Then
         kn = kn + 1
         ReDim Preserve aNum(kn)
         aNum(kn) = yy
         ReDim Preserve aRit(kn)
         'aRit(kn) = m
         riga = riga & Format2(m) & " "
      End If
   Next
   Scrivi "Numeri per Gioco  : " & StringaNumeri(aNum,,1) & " ( " & kn & " )",1
   'Scrivi "Numeri in Ritardo : " & StringaNumeri(aRit,,1),1,,,1
   Scrivi "Numeri in Ritardo : " & riga,1,,,1
   ess = fin - 30
   Scrivi
   Scrivi "Ultimi Esiti Numeri in Esame"
   Scrivi String(60,"-")
   Scrivi "Pr            Info Data             Esiti       Esito "
   Scrivi String(60,"-")
   For ex = ess To fin
      Call VerificaEsitoFT(aNum,ex,1,1,esito,clp,es1,id)
      If esito <> "" Then
         k = k + 1
         Scrivi k & vbTab,0,0
         Scrivi GetInfoEstrazioneFT(id) & vbTab,0,0
         Scrivi es1 & vbTab,0,0
         Scrivi esito
         If esito = "Ambo" Then am = am + 1
         If esito = "Terno" Then Ter = Ter + 1
         If esito = "Quaterna" Then qua = qua + 1
         If esito = "Cinquina" Then cinq = cinq + 1
      End If
   Next
   Scrivi
   Scrivi "Ambi.......... " & am
   Scrivi "Terni......... " & Ter
   Scrivi "Quaterne...... " & qua
   Scrivi "Cinquina...... " & cinq
End Sub
 
Ultima modifica:
Ciao ottimo, anche se non riesco a far funzionare l'archivio,l'ho inserito in spazio ma mi dice
il file di testo non esiste,dove ho errato?,grazie.
poi per lo script,facile ,facile quale è la frequenza della formula PARI E DISPARI uscita in ogni estrazione da input dal...... al.....
es: 32 =3pari e2dispari , 41=4pari e 1dispari ecc................grazie.:alien:(y)??
 
un fuori tema,è possibile tirare fuori con uno script tutti i nomi degli stessi che ho in archivio su spazio ?grazie.
 
Alien, assicurati che il percorso sia giusto e che l'archivio corrisponde al nome che tu gli hai dato.
Il mio e archiviovincicasa2 e si trova nella directory di spaziometria dove ci sono gli altri archivi.
Poi assicurati anche che il carattere separatore sia "Virgola" perché è questo che è splittato come carattere.

Lo script di tua richiesta è facile da fare, ma andrei con ordina, altrimenti si fa confusione.
La prima cosa da fare e che utilizziate correttamente gli script con funzione FT, tutto il resto viene da se.

Ciao
 
io ho,VinciCasa.txt adesso l'ho cambiato in archiviovincicasa0.txt ma nulla da fare...altro errore.....
cosa è questa funzione FT ?
 
Alien. ha scritto:
io ho,VinciCasa.txt adesso l'ho cambiato in archiviovincicasa0.txt ma nulla da fare...altro errore.....
cosa è questa funzione FT ?
Clicca per espandere...

Alien, una volta per tutte vi do delle dritte.
FT = file di Testo - tutti i codici vbscript hanno come suffisso il terminale FT per agire su file di testo
Una volta creato l'archivio con il suo carattere separatore prima di salvarlo non andata a capo altrimenti prende una riga vuota e lo script non riconosce la riga vuota.
esempio 100,31/1/2020,11,22,33,39,40 salvate il file con il cursore in questa ultima riga senza andare a capo.

assicuratevi poi che il file abbia tutti i 3 parametri richiesti
1 indice progressivo
2 data con il formato gg/mm/anno
3 estratti separati con il carattere voluto
poi pero richiamato come split nello script da codice
Call ApriBaseDatiFT(sFile,5,",",40)
ciao
 
Ciao a tutti... ringrazio di cuore Mike58 per i Suoi preziosissimi contributi e confermo che gli script postati funzionano correttamente... Nel rispetto dei tempi utili spero che possiamo incrementare i vari script possibili ed utili per le giuste previsioni da mettere in gioco con questa lotteria.
Saluti,
Francesco.
 
Ciao Francesco, è chiaro che cambiando l'archivio da allacciare si possono adattare tutti gli script che avevo postato per il millionday, ma la scelta è difficile in quanto ognuno di noi ha le sue preferenze nelle scelte o visione statistica.

Io vi posto uno script originale con cruciverba

Codice: 
'Option Explicit
Dim aNumUsati
Dim aColonne
Dim aNumScelti
Dim sFile,fin
sFile = GetDirectoryAppData & "Archiviovincicasa2.txt"
Call ApriBaseDatiFT(sFile,5,",",40)
Sub Main
   Dim nLato
   Dim r,c,k
   Dim n,es1
   Dim s
   Dim nTentativi
   Dim bTrovato
   Dim nScelti
   Dim bUnaPresenzaSola
   Const nMinLato = 2
   Const nMaxLato = 12
   Const nTentativiMax = 1000
   bUnaPresenzaSola = False
   fin = EstrazioniArchivioFT
   nLato = Int(InputBox("Inserire la quantita di numeri per il lato del cruciverba","Lato Cruciverba",5))
   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("Si vince con le righe , le colonne e le diagonali")
   Call Scrivi
   Call CreaTabella
   Call Scrivi
   Call Scrivi("Colonne in gioco",True)
   For k = 1 To UBound(aColonne)
      Call Scrivi(FormatSpace(k,5,True) & ") " & aColonne(k) & vbTab & es1)
   Next
   Call Scrivi
   Call Scrivi("Numeri usati",True)
   Call Scrivi(SpezzaStringaNumeri(GetNumRealmenteUsati(aNumeri,nLato)),,True)
   Call Scrivi
   Call ScriviTabellaFreq(aNumeri,nLato)
   Call SalvaFileColonne
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
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
 
x alien
Pari e dispari e interruzioni
Codice: 
Sub Main
   Dim sFile,T,V,Nu(5),FormulaPD(5)
   sFile = GetDirectoryAppData & "Archiviovincicasa2.txt"
   Call ApriBaseDatiFT(sFile,5,",",40)
   Ini = 1
   fin = EstrazioniArchivioFT
   Scrivi "Lotteria MillionDay ****  Elenco Estrazioni con SommaEstratti & Pari-Dispari, Formula P/D & Interruzioni & Riepilogo Finale",1
   Scrivi Chr(169) & " Mike58 " & Chr(174),1,,,1,4
   T = Array(T,"Info Data","Estratti","Peso","Pari","Dispari","Formula P/D","Interruzioni")
   Call InitTabella(T)
   For es = ini To fin
      For p = 1 To 5
         Nu(p) = EstrattoFT(es,p)
         sm = SommaEstrattiFT(es)
         If pari(Nu(p)) Then par = par + 1
         If dispari(Nu(p)) Then dis = dis + 1
         If pari(Nu(p)) Then FormulaPD(p) = "P"
         If dispari(Nu(p)) Then FormulaPD(p) = "D"
         If FormulaPD(1) = FormulaPD(2) Then Inter1 = 0 : Else Inter1 = 1 : End If
         If FormulaPD(2) = FormulaPD(3) Then Inter2 = 0 : Else Inter2 = 1 : End If
         If FormulaPD(3) = FormulaPD(4) Then Inter3 = 0 : Else Inter3 = 1 : End If
         If FormulaPD(4) = FormulaPD(5) Then Inter4 = 0 : Else Inter4 = 1 : End If
         Interruzioni = Inter1 + Inter2 + Inter3 + Inter4
      Next
      If par = 0 Then par0 = par0 + 1
      If par = 1 Then par1 = par1 + 1
      If par = 2 Then par2 = par2 + 1
      If par = 3 Then par3 = par3 + 1
      If par = 4 Then par4 = par4 + 1
      If par = 5 Then par5 = par5 + 1
      '-------------------------------
      If dis = 0 Then dis0 = dis0 + 1
      If dis = 1 Then dis1 = dis1 + 1
      If dis = 2 Then dis2 = dis2 + 1
      If dis = 3 Then dis3 = dis3 + 1
      If dis = 4 Then dis4 = dis4 + 1
      If dis = 5 Then dis5 = dis5 + 1
      '---------------------------------
      If par = 0 Then p0 = fin - es
      If par = 1 Then p1 = fin - es
      If par = 2 Then p2 = fin - es
      If par = 3 Then p3 = fin - es
      If par = 4 Then p4 = fin - es
      If par = 5 Then p5 = fin - es
      '---------------------------------
      If dis = 0 Then d0 = fin - es
      If dis = 1 Then d1 = fin - es
      If dis = 2 Then d2 = fin - es
      If dis = 3 Then d3 = fin - es
      If dis = 4 Then d4 = fin - es
      If dis = 5 Then d5 = fin - es
      '--------------------------------
      If Interruzioni = 0 Then k1 = k1 + 1
      If Interruzioni = 1 Then k2 = k2 + 1
      If Interruzioni = 2 Then k3 = k3 + 1
      If Interruzioni = 3 Then k4 = k4 + 1
      If Interruzioni = 4 Then k5 = k5 + 1
      '------------------------------------
      If Interruzioni = 0 Then dz0 = fin - es
      If Interruzioni = 1 Then dz1 = fin - es
      If Interruzioni = 2 Then dz2 = fin - es
      If Interruzioni = 3 Then dz3 = fin - es
      If Interruzioni = 4 Then dz4 = fin - es
      Call Messaggio("Elaboro Estrazioni..... " & es)
      Call AvanzamentoElab(Ini,fin,es)
      V = Array(V,GetInfoEstrazioneFT(es),StringaNumeri(Nu,,1),sm,par,dis,StringaNumeri(FormulaPD),Interruzioni)
      Call AddRigaTabella(V)
      par = 0
      dis = 0
   Next
   CreaTabella
   Scrivi "------ Riepilogo Finale ----- ",1
   Tt = Array(Tt,"Pari","0","1","2","3","4","5","--","Dispari","0","1","2","3","4","5")
   Call InitTabella(Tt)
   vv = Array(vv,"Q.tà",par0,par1,par2,par3,par4,par5,"--","Q.tà",dis0,dis1,dis2,dis3,dis4,dis5)
   vvv = Array(vvv,"RitPari",p0,p1,p2,p3,p4,p5,"--","RitDisp",d0,d1,d2,d3,d4,d5)
   V1 = Array(V1,"interr_Pres",k1,k2,k3,k4,k5,"-","--","interr_Rit",dz0,dz1,dz2,dz3,dz4,"-")
   Call AddRigaTabella(vv)
   Call AddRigaTabella(vvv)
   Call AddRigaTabella(V1)
   Call CreaTabella(0,0,0,0,0)
End Sub
 
Mike58 ha scritto:
Ciao Francesco, è chiaro che cambiando l'archivio da allacciare si possono adattare tutti gli script che avevo postato per il millionday, ma la scelta è difficile in quanto ognuno di noi ha le sue preferenze nelle scelte o visione statistica.

Io vi posto uno script originale con cruciverba

Codice: 
'Option Explicit
Dim aNumUsati
Dim aColonne
Dim aNumScelti
Dim sFile,fin
sFile = GetDirectoryAppData & "Archiviovincicasa2.txt"
Call ApriBaseDatiFT(sFile,5,",",40)
Sub Main
   Dim nLato
   Dim r,c,k
   Dim n,es1
   Dim s
   Dim nTentativi
   Dim bTrovato
   Dim nScelti
   Dim bUnaPresenzaSola
   Const nMinLato = 2
   Const nMaxLato = 12
   Const nTentativiMax = 1000
   bUnaPresenzaSola = False
   fin = EstrazioniArchivioFT
   nLato = Int(InputBox("Inserire la quantita di numeri per il lato del cruciverba","Lato Cruciverba",5))
   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("Si vince con le righe , le colonne e le diagonali")
   Call Scrivi
   Call CreaTabella
   Call Scrivi
   Call Scrivi("Colonne in gioco",True)
   For k = 1 To UBound(aColonne)
      Call Scrivi(FormatSpace(k,5,True) & ") " & aColonne(k) & vbTab & es1)
   Next
   Call Scrivi
   Call Scrivi("Numeri usati",True)
   Call Scrivi(SpezzaStringaNumeri(GetNumRealmenteUsati(aNumeri,nLato)),,True)
   Call Scrivi
   Call ScriviTabellaFreq(aNumeri,nLato)
   Call SalvaFileColonne
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
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
Clicca per espandere...
Grazie Mike58... in merito a questo script cruciverba, come va usato ?? Perchè segnando solo 5 numeri mi da errore invitandomi a segnarne di più ??
 
ste20fra ha scritto:
Grazie Mike58... in merito a questo script cruciverba, come va usato ?? Perchè segnando solo 5 numeri mi da errore invitandomi a segnarne di più ??
Clicca per espandere...
devi selezionare almeno 12 numeri da far girare nel cruciverba.

ste20fra ha scritto:
Un'altra info veloce: come si può esportare l'output del codice su excel ???
Clicca per espandere...
per esporatre in excel se lo script è in tabella basta modificare il codice alla fine dello script
creatabella in creatabellaordinabile e da qui si può esportare tutto in excel.
 
Devi accedere o registrarti per poter rispondere.

Ultima estrazione Lotto

  • Estrazione del lotto
    sabato 11 gennaio 2025
    Bari
    73
    43
    01
    58
    81
    Cagliari
    69
    60
    18
    02
    10
    Firenze
    25
    32
    18
    55
    54
    Genova
    48
    05
    40
    34
    69
    Milano
    10
    07
    70
    44
    79
    Napoli
    11
    89
    01
    34
    80
    Palermo
    37
    80
    82
    44
    77
    Roma
    78
    04
    38
    39
    56
    Torino
    08
    13
    30
    27
    24
    Venezia
    56
    75
    36
    18
    70
    Nazionale
    63
    83
    19
    31
    80
    Estrazione Simbolotto
    Bari
    35
    34
    12
    23
    20
    Archivio estrazioni lotto Ritardi top 15 Frequenze top 15

Ultimi Messaggi

Indietro
Alto