Novità

Qualcuno saprebbe....

  • Creatore Discussione Creatore Discussione Y10
  • Data di inizio Data di inizio
Y10

Y10

Advanced Member >PLATINUM<
.... modificare questo script fatto da Luigib inserendo la sorte di quaterna e tutte le 288 estrazioni giornaliere ? Grazie anticipate.:)


Option Explicit
Dim collFormazioni
Dim CollFomGiocateFreq
Dim CollFomGiocateNonFreq
Dim aColonneDL
Dim aMatriceRid
Dim aPremi
Dim aPoste
Class clsFormazione
Public nPresenze
Public sNumeri
Public aNumeri(10)
End Class
Sub Main
Dim nEstrInizio,nEstrFine
Dim DataIni,DataFin
Dim FasciaOrariaIni,FasciaOrariaFin
Dim sOraIni,sOraFin
Dim quantitaFrz
Dim nClasse,nSorte
Dim nEstrEsam,nEstrValide,nEstrNonValide
Dim bUsaRidotto
Dim sFileSistema
Call ImpostaArchivio10ELotto(2)
Call ImpostaPremi
quantitaFrz = Int(InputBox("Quantita formazioni in gioco","Quantita",2))
If quantitaFrz > 0 Then
If ChiediDataInizioFine(DataIni,DataFin,10) Then
If ChiediFasciaInizioFine(FasciaOrariaIni,FasciaOrariaFin,sOraIni,sOraFin) Then
If ChiediClasse(nClasse) Then
If ChiediSorte(nSorte) Then
If ChiediTipoSviluppo(bUsaRidotto,sFileSistema,nClasse,nSorte) Then
nEstrInizio = DataEstrToIdEstrDL(Day(DataIni),Month(DataIni),Year(DataIni),1)
nEstrFine = DataEstrToIdEstrDL(Day(DataFin),Month(DataFin),Year(DataFin),1)
If IsRangeValido(nEstrInizio,nEstrFine) Then
Call EseguiStatistica(nEstrInizio,nEstrFine,FasciaOrariaIni,FasciaOrariaFin,nClasse,nSorte,bUsaRidotto,nEstrEsam,nEstrValide,nEstrNonValide)
Call ScriviParametriRicerca(DataIni,DataFin,sOraIni,sOraFin,nEstrEsam,nEstrValide,nEstrNonValide,quantitaFrz,nClasse,nSorte)
Call MostraFormazioniPiuFre(quantitaFrz)
Call MostraFormazioniMenoFre(quantitaFrz)
Call InitAnalizzaGioco(DataFin,FasciaOrariaIni,FasciaOrariaFin,nClasse,nSorte)
End If
End If
End If
End If
End If
End If
End If
End Sub
Sub ScriviParametriRicerca(DataI,DataF,OraI,OraF,EstrEsam,Valide,NonValide,QuantitaFrz,nClasse,nSorte)
Call Scrivi("Statistica delle prime " & QuantitaFrz & " formazioni piu frequenti in " & NomeSorte(nClasse) & " per la sorte di " & NomeSorte(nSorte))
Call Scrivi
Call Scrivi("Data inizio : " & DataI)
Call Scrivi("Data fine : " & DataF)
Call Scrivi("Range Orario : " & OraI & "/" & OraF)
Call Scrivi("Estrazioni nel range : " & EstrEsam & " (Valide : " & Valide & "; NonValide : " & NonValide & ")")
Call Scrivi
End Sub
Sub MostraFormazioniPiuFre(Quantita)
Dim clsFrz
Dim k,y
Dim idFrz
Call Scrivi("Formazioni piu frequenti")
ReDim aIdFrzScelte(Quantita,1)
For Each clsFrz In collFormazioni
idFrz = idFrz + 1
For k = 1 To Quantita
If clsFrz.nPresenze >= aIdFrzScelte(k,0) Then
For y = Quantita To(k + 1) Step - 1
aIdFrzScelte(y,0) = aIdFrzScelte(y - 1,0)
aIdFrzScelte(y,1) = aIdFrzScelte(y - 1,1)
Next
aIdFrzScelte(k,0) = clsFrz.nPresenze
aIdFrzScelte(k,1) = idFrz
Exit For
End If
Next
Next
ReDim aV(2)
aV(1) = "Formazione"
aV(2) = "Presenze"
InitTabella(aV)
For k = 1 To Quantita
Set clsFrz = collFormazioni(aIdFrzScelte(k,1))
aV(1) = clsFrz.sNumeri
aV(2) = clsFrz.nPresenze
Call AddRigaTabella(aV)
Call CollFomGiocateFreq.Add(clsFrz)
Next
Call CreaTabella
End Sub
Sub MostraFormazioniMenoFre(Quantita)
Dim clsFrz
Dim k,y
Dim idFrz
Call Scrivi("Formazioni meno frequenti (tra quelle comunque uscite)")
ReDim aIdFrzScelte(Quantita,1)
For k = 1 To Quantita
aIdFrzScelte(k,0) = 10000000
Next
For Each clsFrz In collFormazioni
idFrz = idFrz + 1
For k = 1 To Quantita
If clsFrz.nPresenze <= aIdFrzScelte(k,0) Then
For y = Quantita To(k + 1) Step - 1
aIdFrzScelte(y,0) = aIdFrzScelte(y - 1,0)
aIdFrzScelte(y,1) = aIdFrzScelte(y - 1,1)
Next
aIdFrzScelte(k,0) = clsFrz.nPresenze
aIdFrzScelte(k,1) = idFrz
Exit For
End If
Next
Next
ReDim aV(2)
aV(1) = "Formazione"
aV(2) = "Presenze"
InitTabella(aV)
For k = 1 To Quantita
Set clsFrz = collFormazioni(aIdFrzScelte(k,1))
aV(1) = clsFrz.sNumeri
aV(2) = clsFrz.nPresenze
Call AddRigaTabella(aV)
Call CollFomGiocateNonFreq.Add(clsFrz)
Next
Call CreaTabella
End Sub
Sub EseguiStatistica(nEstrInizio,nEstrFine,FasciaOrariaIni,FasciaOrariaFin,nClasse,nSorte,bUsaRidotto,nEstrEsaminateTot,nEstrValide,nEstrNonValide)
Dim k,f,idEstr,idCol,y,p
Dim idFrz
Dim clsFrz
nEstrEsaminateTot = 0
nEstrValide = 0
nEstrNonValide = 0
idFrz = 0
idCol = 0
ReDim aColonneDL(GetQColonneInteressate(nEstrInizio,nEstrFine,FasciaOrariaIni,FasciaOrariaFin),90)
Set collFormazioni = GetNewCollection
Set CollFomGiocateFreq = GetNewCollection
Set CollFomGiocateNonFreq = GetNewCollection
For k = nEstrInizio To nEstrFine Step 228
Call Messaggio("Estrazione : " & k)
For f = FasciaOrariaIni To FasciaOrariaFin
idEstr =(k - 1) + f
ReDim aNum(0)
Call GetEstrazioneCompletaDL(idEstr,aNum)
If aNum(1) > 0 Then
idCol = idCol + 1
For y = 1 To 20
aColonneDL(idCol,aNum(y)) = True
Next
Call InserisciForrmazioniInColl(aNum,nClasse,nSorte,bUsaRidotto)
nEstrValide = nEstrValide + 1
Else
nEstrNonValide = nEstrNonValide + 1
End If
nEstrEsaminateTot = nEstrEsaminateTot + 1
If ScriptInterrotto Then Exit For
Next
If ScriptInterrotto Then Exit For
Next
Messaggio("Conteggio formazioni piu frequenti")
Call AvanzamentoElab(0,collFormazioni.count,idFrz)
For Each clsFrz In collFormazioni
For k = 1 To UBound(aColonneDL)
p = 0
For y = 1 To nClasse
If aColonneDL(k,clsFrz.aNumeri(y)) Then
p = p + 1
End If
Next
If p >= nSorte Then
clsFrz.nPresenze = clsFrz.nPresenze + 1
End If
Next
idFrz = idFrz + 1
If idFrz Mod 100 = 0 Then
Call AvanzamentoElab(0,collFormazioni.count,idFrz)
If ScriptInterrotto Then Exit For
End If
Next
Call AvanzamentoElab(0,collFormazioni.count,idFrz)
End Sub
Function GetQColonneInteressate(nEstrInizio,nEstrFine,FasciaOrariaIni,FasciaOrariaFin)
Dim nGg
nGg =(((nEstrFine + 1) - nEstrInizio)\228) + 1
If nGg = 0 Then nGg = 1
GetQColonneInteressate =((FasciaOrariaFin + 1) - FasciaOrariaIni) * nGg
End Function
 
.... modificare questo script fatto da Luigib inserendo la sorte di quaterna e tutte le 288 estrazioni giornaliere ? Grazie anticipate.:)


Option Explicit
Dim collFormazioni
Dim CollFomGiocateFreq
Dim CollFomGiocateNonFreq
Dim aColonneDL
Dim aMatriceRid
Dim aPremi
Dim aPoste
Class clsFormazione
Public nPresenze
Public sNumeri
Public aNumeri(10)
End Class
Sub Main
Dim nEstrInizio,nEstrFine
Dim DataIni,DataFin
Dim FasciaOrariaIni,FasciaOrariaFin
Dim sOraIni,sOraFin
Dim quantitaFrz
Dim nClasse,nSorte
Dim nEstrEsam,nEstrValide,nEstrNonValide
Dim bUsaRidotto
Dim sFileSistema
Call ImpostaArchivio10ELotto(2)
Call ImpostaPremi
quantitaFrz = Int(InputBox("Quantita formazioni in gioco","Quantita",2))
If quantitaFrz > 0 Then
If ChiediDataInizioFine(DataIni,DataFin,10) Then
If ChiediFasciaInizioFine(FasciaOrariaIni,FasciaOrari aFin,sOraIni,sOraFin) Then
If ChiediClasse(nClasse) Then
If ChiediSorte(nSorte) Then
If ChiediTipoSviluppo(bUsaRidotto,sFileSistema,nClass e,nSorte) Then
nEstrInizio = DataEstrToIdEstrDL(Day(DataIni),Month(DataIni),Yea r(DataIni),1)
nEstrFine = DataEstrToIdEstrDL(Day(DataFin),Month(DataFin),Yea r(DataFin),1)
If IsRangeValido(nEstrInizio,nEstrFine) Then
Call EseguiStatistica(nEstrInizio,nEstrFine,FasciaOrari aIni,FasciaOrariaFin,nClasse,nSorte,bUsaRidotto,nE strEsam,nEstrValide,nEstrNonValide)
Call ScriviParametriRicerca(DataIni,DataFin,sOraIni,sOr aFin,nEstrEsam,nEstrValide,nEstrNonValide,quantita Frz,nClasse,nSorte)
Call MostraFormazioniPiuFre(quantitaFrz)
Call MostraFormazioniMenoFre(quantitaFrz)
Call InitAnalizzaGioco(DataFin,FasciaOrariaIni,FasciaOr ariaFin,nClasse,nSorte)
End If
End If
End If
End If
End If
End If
End If
End Sub
Sub ScriviParametriRicerca(DataI,DataF,OraI,OraF,EstrE sam,Valide,NonValide,QuantitaFrz,nClasse,nSorte)
Call Scrivi("Statistica delle prime " & QuantitaFrz & " formazioni piu frequenti in " & NomeSorte(nClasse) & " per la sorte di " & NomeSorte(nSorte))
Call Scrivi
Call Scrivi("Data inizio : " & DataI)
Call Scrivi("Data fine : " & DataF)
Call Scrivi("Range Orario : " & OraI & "/" & OraF)
Call Scrivi("Estrazioni nel range : " & EstrEsam & " (Valide : " & Valide & "; NonValide : " & NonValide & ")")
Call Scrivi
End Sub
Sub MostraFormazioniPiuFre(Quantita)
Dim clsFrz
Dim k,y
Dim idFrz
Call Scrivi("Formazioni piu frequenti")
ReDim aIdFrzScelte(Quantita,1)
For Each clsFrz In collFormazioni
idFrz = idFrz + 1
For k = 1 To Quantita
If clsFrz.nPresenze >= aIdFrzScelte(k,0) Then
For y = Quantita To(k + 1) Step - 1
aIdFrzScelte(y,0) = aIdFrzScelte(y - 1,0)
aIdFrzScelte(y,1) = aIdFrzScelte(y - 1,1)
Next
aIdFrzScelte(k,0) = clsFrz.nPresenze
aIdFrzScelte(k,1) = idFrz
Exit For
End If
Next
Next
ReDim aV(2)
aV(1) = "Formazione"
aV(2) = "Presenze"
InitTabella(aV)
For k = 1 To Quantita
Set clsFrz = collFormazioni(aIdFrzScelte(k,1))
aV(1) = clsFrz.sNumeri
aV(2) = clsFrz.nPresenze
Call AddRigaTabella(aV)
Call CollFomGiocateFreq.Add(clsFrz)
Next
Call CreaTabella
End Sub
Sub MostraFormazioniMenoFre(Quantita)
Dim clsFrz
Dim k,y
Dim idFrz
Call Scrivi("Formazioni meno frequenti (tra quelle comunque uscite)")
ReDim aIdFrzScelte(Quantita,1)
For k = 1 To Quantita
aIdFrzScelte(k,0) = 10000000
Next
For Each clsFrz In collFormazioni
idFrz = idFrz + 1
For k = 1 To Quantita
If clsFrz.nPresenze <= aIdFrzScelte(k,0) Then
For y = Quantita To(k + 1) Step - 1
aIdFrzScelte(y,0) = aIdFrzScelte(y - 1,0)
aIdFrzScelte(y,1) = aIdFrzScelte(y - 1,1)
Next
aIdFrzScelte(k,0) = clsFrz.nPresenze
aIdFrzScelte(k,1) = idFrz
Exit For
End If
Next
Next
ReDim aV(2)
aV(1) = "Formazione"
aV(2) = "Presenze"
InitTabella(aV)
For k = 1 To Quantita
Set clsFrz = collFormazioni(aIdFrzScelte(k,1))
aV(1) = clsFrz.sNumeri
aV(2) = clsFrz.nPresenze
Call AddRigaTabella(aV)
Call CollFomGiocateNonFreq.Add(clsFrz)
Next
Call CreaTabella
End Sub
Sub EseguiStatistica(nEstrInizio,nEstrFine,FasciaOrari aIni,FasciaOrariaFin,nClasse,nSorte,bUsaRidotto,nE strEsaminateTot,nEstrValide,nEstrNonValide)
Dim k,f,idEstr,idCol,y,p
Dim idFrz
Dim clsFrz
nEstrEsaminateTot = 0
nEstrValide = 0
nEstrNonValide = 0
idFrz = 0
idCol = 0
ReDim aColonneDL(GetQColonneInteressate(nEstrInizio,nEst rFine,FasciaOrariaIni,FasciaOrariaFin),90)
Set collFormazioni = GetNewCollection
Set CollFomGiocateFreq = GetNewCollection
Set CollFomGiocateNonFreq = GetNewCollection
For k = nEstrInizio To nEstrFine Step 228
Call Messaggio("Estrazione : " & k)
For f = FasciaOrariaIni To FasciaOrariaFin
idEstr =(k - 1) + f
ReDim aNum(0)
Call GetEstrazioneCompletaDL(idEstr,aNum)
If aNum(1) > 0 Then
idCol = idCol + 1
For y = 1 To 20
aColonneDL(idCol,aNum(y)) = True
Next
Call InserisciForrmazioniInColl(aNum,nClasse,nSorte,bUs aRidotto)
nEstrValide = nEstrValide + 1
Else
nEstrNonValide = nEstrNonValide + 1
End If
nEstrEsaminateTot = nEstrEsaminateTot + 1
If ScriptInterrotto Then Exit For
Next
If ScriptInterrotto Then Exit For
Next
Messaggio("Conteggio formazioni piu frequenti")
Call AvanzamentoElab(0,collFormazioni.count,idFrz)
For Each clsFrz In collFormazioni
For k = 1 To UBound(aColonneDL)
p = 0
For y = 1 To nClasse
If aColonneDL(k,clsFrz.aNumeri(y)) Then
p = p + 1
End If
Next
If p >= nSorte Then
clsFrz.nPresenze = clsFrz.nPresenze + 1
End If
Next
idFrz = idFrz + 1
If idFrz Mod 100 = 0 Then
Call AvanzamentoElab(0,collFormazioni.count,idFrz)
If ScriptInterrotto Then Exit For
End If
Next
Call AvanzamentoElab(0,collFormazioni.count,idFrz)
End Sub
Function GetQColonneInteressate(nEstrInizio,nEstrFine,Fasci aOrariaIni,FasciaOrariaFin)
Dim nGg
nGg =(((nEstrFine + 1) - nEstrInizio)\228) + 1
If nGg = 0 Then nGg = 1
GetQColonneInteressate =((FasciaOrariaFin + 1) - FasciaOrariaIni) * nGg
End Function
 
Ciao Disaronno , grazie per la risposta , spero che ora si veda tutto , attendo news. Buona giornata.:)
 
Ciao Y10, prova con lo script seguente da me modificato:

Codice: 
Option Explicit
Dim collFormazioni
Dim CollFomGiocateFreq
Dim CollFomGiocateNonFreq
Dim aColonneDL
Dim aMatriceRid
Dim aPremi
Dim aPoste
Class clsFormazione
    Public nPresenze
    Public sNumeri
    Public aNumeri(10)
End Class
Sub Main
    Dim nEstrInizio,nEstrFine
    Dim DataIni,DataFin
    Dim FasciaOrariaIni,FasciaOrariaFin
    Dim sOraIni,sOraFin
    Dim quantitaFrz
    Dim nClasse,nSorte
    Dim nEstrEsam,nEstrValide,nEstrNonValide
    Dim bUsaRidotto
    Dim sFileSistema
    Call ImpostaArchivio10ELotto(2)
    Call AggiornaArchivioDL
    Call ImpostaPremi
    quantitaFrz = Int(InputBox("Quantita formazioni in gioco","Quantita",2))
    If quantitaFrz > 0 Then
        If ChiediDataInizioFine(DataIni,DataFin,10) Then
            If ChiediFasciaInizioFine(FasciaOrariaIni,FasciaOrariaFin,sOraIni,sOraFin) Then
                If ChiediClasse(nClasse) Then
                    If ChiediSorte(nSorte) Then
                        If ChiediTipoSviluppo(bUsaRidotto,sFileSistema,nClasse,nSorte) Then
                            nEstrInizio = DataEstrToIdEstrDL(Day(DataIni),Month(DataIni),Year(DataIni),1)
                            nEstrFine = DataEstrToIdEstrDL(Day(DataFin),Month(DataFin),Year(DataFin),1)
                            If IsRangeValido(nEstrInizio,nEstrFine) Then
                                Call EseguiStatistica(nEstrInizio,nEstrFine,FasciaOrariaIni,FasciaOrariaFin,nClasse,nSorte,bUsaRidotto,nEstrEsam,nEstrValide,nEstrNonValide)
                                Call ScriviParametriRicerca(DataIni,DataFin,sOraIni,sOraFin,nEstrEsam,nEstrValide,nEstrNonValide,quantitaFrz,nClasse,nSorte)
                                Call MostraFormazioniPiuFre(quantitaFrz)
                                Call MostraFormazioniMenoFre(quantitaFrz)
                                Call InitAnalizzaGioco(DataFin,FasciaOrariaIni,FasciaOrariaFin,nClasse,nSorte)
                            End If
                        End If
                    End If
                End If
            End If
        End If
    End If
End Sub
Sub ScriviParametriRicerca(DataI,DataF,OraI,OraF,EstrEsam,Valide,NonValide,QuantitaFrz,nClasse,nSorte)
    Call Scrivi("Statistica delle prime " & QuantitaFrz & " formazioni piu frequenti in " & NomeSorte(nClasse) & " per la sorte di " & NomeSorte(nSorte))
    Call Scrivi
    Call Scrivi("Data inizio           : " & DataI)
    Call Scrivi("Data fine             : " & DataF)
    Call Scrivi("Range Orario          : " & OraI & "/" & OraF)
    Call Scrivi("Estrazioni  nel range : " & EstrEsam & " (Valide : " & Valide & "; NonValide : " & NonValide & ")")
    Call Scrivi
End Sub
Sub MostraFormazioniPiuFre(Quantita)
    Dim clsFrz
    Dim k,y
    Dim idFrz
    Call Scrivi("Formazioni piu frequenti")
    ReDim aIdFrzScelte(Quantita,1)
    For Each clsFrz In collFormazioni
        idFrz = idFrz + 1
        For k = 1 To Quantita
            If clsFrz.nPresenze >= aIdFrzScelte(k,0) Then
                For y = Quantita To(k + 1) Step - 1
                    aIdFrzScelte(y,0) = aIdFrzScelte(y - 1,0)
                    aIdFrzScelte(y,1) = aIdFrzScelte(y - 1,1)
                Next
                aIdFrzScelte(k,0) = clsFrz.nPresenze
                aIdFrzScelte(k,1) = idFrz
                Exit For
            End If
        Next
    Next
    ReDim aV(2)
    aV(1) = "Formazione"
    aV(2) = "Presenze"
    InitTabella(aV)
    For k = 1 To Quantita
        Set clsFrz = collFormazioni(aIdFrzScelte(k,1))
        aV(1) = clsFrz.sNumeri
        aV(2) = clsFrz.nPresenze
        Call AddRigaTabella(aV)
        Call CollFomGiocateFreq.Add(clsFrz)
    Next
    Call CreaTabella
End Sub
Sub MostraFormazioniMenoFre(Quantita)
    Dim clsFrz
    Dim k,y
    Dim idFrz
    Call Scrivi("Formazioni meno frequenti (tra quelle comunque uscite)")
    ReDim aIdFrzScelte(Quantita,1)
    For k = 1 To Quantita
        aIdFrzScelte(k,0) = 10000000
    Next
    For Each clsFrz In collFormazioni
        idFrz = idFrz + 1
        For k = 1 To Quantita
            If clsFrz.nPresenze <= aIdFrzScelte(k,0) Then
                For y = Quantita To(k + 1) Step - 1
                    aIdFrzScelte(y,0) = aIdFrzScelte(y - 1,0)
                    aIdFrzScelte(y,1) = aIdFrzScelte(y - 1,1)
                Next
                aIdFrzScelte(k,0) = clsFrz.nPresenze
                aIdFrzScelte(k,1) = idFrz
                Exit For
            End If
        Next
    Next
    ReDim aV(2)
    aV(1) = "Formazione"
    aV(2) = "Presenze"
    InitTabella(aV)
    For k = 1 To Quantita
        Set clsFrz = collFormazioni(aIdFrzScelte(k,1))
        aV(1) = clsFrz.sNumeri
        aV(2) = clsFrz.nPresenze
        Call AddRigaTabella(aV)
        Call CollFomGiocateNonFreq.Add(clsFrz)
    Next
    Call CreaTabella
End Sub
Sub EseguiStatistica(nEstrInizio,nEstrFine,FasciaOrariaIni,FasciaOrariaFin,nClasse,nSorte,bUsaRidotto,nEstrEsaminateTot,nEstrValide,nEstrNonValide)
    Dim k,f,idEstr,idCol,y,p
    Dim idFrz
    Dim clsFrz
    nEstrEsaminateTot = 0
    nEstrValide = 0
    nEstrNonValide = 0
    idFrz = 0
    idCol = 0
    ReDim aColonneDL(GetQColonneInteressate(nEstrInizio,nEstrFine,FasciaOrariaIni,FasciaOrariaFin),90)
    Set collFormazioni = GetNewCollection
    Set CollFomGiocateFreq = GetNewCollection
    Set CollFomGiocateNonFreq = GetNewCollection
    For k = nEstrInizio To nEstrFine Step 228
        Call Messaggio("Estrazione : " & k)
        For f = FasciaOrariaIni To FasciaOrariaFin
            idEstr =(k - 1) + f
            ReDim aNum(0)
            Call GetEstrazioneCompletaDL(idEstr,aNum)
            If aNum(1) > 0 Then
                idCol = idCol + 1
                For y = 1 To 20
                    aColonneDL(idCol,aNum(y)) = True
                Next
                Call InserisciForrmazioniInColl(aNum,nClasse,nSorte,bUsaRidotto)
                nEstrValide = nEstrValide + 1
            Else
                nEstrNonValide = nEstrNonValide + 1
            End If
            nEstrEsaminateTot = nEstrEsaminateTot + 1
            If ScriptInterrotto Then Exit For
        Next
        If ScriptInterrotto Then Exit For
    Next
    Messaggio("Conteggio formazioni piu frequenti")
    Call AvanzamentoElab(0,collFormazioni.count,idFrz)
    For Each clsFrz In collFormazioni
        For k = 1 To UBound(aColonneDL)
            p = 0
            For y = 1 To nClasse
                If aColonneDL(k,clsFrz.aNumeri(y)) Then
                    p = p + 1
                End If
            Next
            If p >= nSorte Then
                clsFrz.nPresenze = clsFrz.nPresenze + 1
            End If
        Next
        idFrz = idFrz + 1
        If idFrz Mod 100 = 0 Then
            Call AvanzamentoElab(0,collFormazioni.count,idFrz)
            If ScriptInterrotto Then Exit For
        End If
    Next
    Call AvanzamentoElab(0,collFormazioni.count,idFrz)
End Sub
Function GetQColonneInteressate(nEstrInizio,nEstrFine,FasciaOrariaIni,FasciaOrariaFin)
    Dim nGg
    nGg =(((nEstrFine + 1) - nEstrInizio)\228) + 1
    If nGg = 0 Then nGg = 1
    GetQColonneInteressate =((FasciaOrariaFin + 1) - FasciaOrariaIni) * nGg
End Function
Sub InserisciForrmazioniInColl(aNumeri,nClasse,nSorte,bUsaRidotto)
    If bUsaRidotto Then
        Call InserisciForrmazioniInCollRidotto(aNumeri,nClasse)
    Else
        Call InserisciForrmazioniInCollIntegrale(aNumeri,nClasse)
    End If
End Sub
Sub InserisciForrmazioniInCollRidotto(aNumeri,nClasse)
    Dim idCol,y,j
    ReDim aCol(nClasse)
    Dim sColonna,sKey
    Dim clsFrz
    Dim nTmp
    For j = 1 To 19
        For idCol = 1 To UBound(aMatriceRid)
            Set clsFrz = New clsFormazione
            For y = 1 To nClasse
                aCol(y) = aNumeri(aMatriceRid(idCol,y))
                clsFrz.aNumeri(y) = aCol(y)
            Next
            Call OrdinaMatrice(aCol,1)
            sColonna = StringaNumeri(aCol)
            clsFrz.sNumeri = sColonna
            sKey = "K" & sColonna
            Call AddItemInColl(collFormazioni,clsFrz,sKey)
            If idCol Mod 10 = 0 Then
                DoEventsEx
                Call AvanzamentoElab(0,UBound(aMatriceRid),idCol)
                If ScriptInterrotto Then Exit For
            End If
        Next
        nTmp = aNumeri(UBound(aNumeri))
        For y = UBound(aNumeri) To 2 Step - 1
            aNumeri(y) = aNumeri(y - 1)
        Next
        aNumeri(1) = nTmp
    Next
End Sub
Sub InserisciForrmazioniInCollIntegrale(aNumeri,nClasse)
    Dim k,sKey,y
    Dim nColonneTot
    Dim aCol
    Dim clsFrz
    Dim sColonna
    'inizializza lo sviluppo
    nColonneTot = InitSviluppoIntegrale(aNumeri,nClasse)
    k = 0
    ' ciclo che continua fino a quando le colonne non finiscono
    Do While GetCombSviluppo(aCol)
        k = k + 1 ' conteggio colonna corrente
        ' costruisco la stringa che contiene la colonna
        Set clsFrz = New clsFormazione
        sColonna = ""
        For y = 1 To nClasse
            clsFrz.aNumeri(y) = aCol(y)
            sColonna = sColonna & aCol(y) & "."
        Next
        sColonna = Left(sColonna,Len(sColonna) - 1)
        clsFrz.sNumeri = sColonna
        sKey = "K" & sColonna
        Call AddItemInColl(collFormazioni,clsFrz,sKey)
        If k Mod 100 = 0 Then
            DoEventsEx
            Call AvanzamentoElab(0,nColonneTot,k)
            If ScriptInterrotto Then Exit Do
        End If
    Loop
    Call AvanzamentoElab(0,nColonneTot,k)
End Sub
Sub AddItemInColl(collX,Itm,sKey)
    On Error Resume Next
    Call collX.Add(Itm,sKey)
End Sub
Function GetItemInColl(sKey,cls,collX)
    On Error Resume Next
    Set cls = collX(sKey)
    If Err.number <> 0 Then
        Set cls = Nothing
        GetItemInColl = False
    Else
        GetItemInColl = True
    End If
End Function
Function IsRangeValido(Inizio,Fine)
    Dim b
    b = False
    If Inizio > 0 And Fine > 0 Then
        If Fine >= Inizio Then
            b = True
        End If
    End If
    If Not b Then
        MsgBox "Range non valido , probabilemente mancano le estrazioni nella base dati " & _
        vbCrLf & "EstrazioneIni : " & Inizio & vbCrLf & "EstrazioneFine  : " & Fine
    End If
    IsRangeValido = b
End Function
Function ChiediDataInizioFine(DataI,DataF,GiorniDaAnalizzare)
    If Not IsDate(DataF) Then DataF = FormattaStringa(Now,"dd/mm/yyyy")
    If Not IsDate(DataI) Then DataI = FormattaStringa(DateAdd("d",-(GiorniDaAnalizzare),DataF),"dd/mm/yyyy")
    DataI = InputBox("Inserire data inizio ricerca in formato GG/MM/AAAA","Data inizio",DataI)
    DataF = InputBox("Inserire data fine ricerca in formato GG/MM/AAAA","Data fine",DataF)
    If IsDate(DataI) And IsDate(DataF) Then
        If DateDiff("d",DataI,DataF) >= 0 Then
            ChiediDataInizioFine = True
        Else
            MsgBox "La data FINE deve essere maggiore od uguale alla data INIZIO"
        End If
    Else
        MsgBox "Date inserite non valide"
    End If
End Function
Function ChiediFasciaInizioFine(FasciaI,FasciaF,sOraIni,sOraFin)
    FasciaI = ChiediFasciaOraria("Fascia oraria inizio",sOraIni)
    FasciaF = ChiediFasciaOraria("Fascia oraria fine",sOraFin)
    If FasciaI > 0 And FasciaF > 0 Then
        If FasciaF >= FasciaI Then
            ChiediFasciaInizioFine = True
        Else
            MsgBox "La fascia oraria Fine deve essere maggiore della fascia oraria INIZIO"
        End If
    Else
        MsgBox "Fascie orarie non valide"
    End If
End Function
Function ChiediFasciaOraria(sCaption,sRetOra)
    Dim aLista(288)
    Dim h,m
    Dim i
    For h = 0 To 23
        For m = 5 To 60 Step 5
            i = i + 1
            If m = 60 Then
                aLista(i) = Format2(h + 1) & ":00"
            Else
                aLista(i) = Format2(h) & ":" & Format2(m)
            End If
        Next
    Next
    aLista(i) = "23:59"
    i = ScegliOpzioneMenu(aLista,- 1,sCaption)
    sRetOra = aLista(i)
    ChiediFasciaOraria = i
End Function
Function ChiediClasse(nClasse)
    Dim k
    ReDim aVoci(6)
    For k = 1 To 6
        aVoci(k) = k
    Next
    nClasse = ScegliOpzioneMenu(aVoci,- 1,"Classe formazione")
    If nClasse > 0 Then
        ChiediClasse = True
    Else
        MsgBox "Classe formazione non valida"
    End If
End Function
Function ChiediSorte(nClasse)
    ReDim aVoci(4)
    aVoci(1) = "Estratto"
    aVoci(2) = "Ambo"
    aVoci(3) = "Terno"
    aVoci(4) = "Quaterna"
    nClasse = ScegliOpzioneMenu(aVoci,- 1,"Sorte cercata")
    If nClasse > 0 Then
        ChiediSorte = True
    Else
        MsgBox "Classe formazione non valida"
    End If
End Function
Function ChiediTipoSviluppo(bUsaRidotto,sFileSistema,nClasse,nSorte)
    Dim i
    ReDim aVoci(2)
    aVoci(1) = "Integrale (molto lento)"
    aVoci(2) = "Ridotto (piu veloce)"
    sFileSistema = GetDirectoryAppData & "sistemi\" & "20" & "_" & nClasse & "_" & nSorte & ".dat"
    i = ScegliOpzioneMenu(aVoci,2,"Tipo sviluppo")
    If i > 0 Then
        If i = 2 Then
            bUsaRidotto = True
        Else
            bUsaRidotto = False
            MsgBox "Attenzione non usando il metodo ridotto oltre ad essere piu lento potrebbe capitare " & _
            "un errore a causa di problemi di memoria insufficiente",vbInformation
        End If
        If bUsaRidotto Then
            'If FileEsistente(sFileSistema) Then
            ReDim aMatriceRid(0)
            If GetMatriceSistemaRidotto(sFileSistema,aMatriceRid,0,0,0,0) Then
                ChiediTipoSviluppo = True
            Else
                MsgBox "Avendo scelto lo sviluppo ridotto è " & _
                "necessaria la presenza della matrice nella cartella dei sistemi" & vbCrLf & sFileSistema
            End If
            'Else
            '    MsgBox "Avendo scelto lo sviluppo ridotto è " & _
            '    "necessaria la presenza della matrice nella cartella dei sistemi" & vbCrLf & sFileSistema
            'End If
        Else
            ChiediTipoSviluppo = True
        End If
    Else
        MsgBox "Tipo sviluppo non valido"
    End If
End Function
Sub InitAnalizzaGioco(Data,FasciaOrariaIni,FasciaOrariaFin,nClasse,nSorte)
    Dim DataIni,DataFin,nEstrInizio,nEstrFine,ColMax
    DataIni = FormattaStringa(DateAdd("d",1,Data),"dd/mm/yyyy")
    DataFin = DataIni
    nEstrInizio = DataEstrToIdEstrDL(Day(DataIni),Month(DataIni),Year(DataIni),1)
    nEstrFine = DataEstrToIdEstrDL(Day(DataFin),Month(DataFin),Year(DataFin),1)
    If nEstrInizio > 0 And nEstrFine > 0 Then
        'If MsgBox("Desideri analizzare un ipotesi di gioco sulle estrazioni successive a quelle analizzate (un'ora di gioco il giorno successivo)",vbQuestion + vbYesNo) = vbYes Then
        Scrivi "Simulazione di gioco nella data di " & DataIni
        Call ImpostaPoste(nClasse,nSorte)
        Call LeggiEstrazioniTestGiocata(nEstrInizio,nEstrFine,FasciaOrariaIni,FasciaOrariaFin,ColMax)
        Call AnalisiGioco(ColMax,nClasse,nSorte,CollFomGiocateFreq,"Simulazione giocando le formazioni frequenti (un'ora di gioco)")
        Call AnalisiGioco(ColMax,nClasse,nSorte,CollFomGiocateNonFreq,"Simulazione giocando le formazioni meno frequenti (un'ora di gioco)")
        'End If
    End If
End Sub
Sub LeggiEstrazioniTestGiocata(nEstrInizio,nEstrFine,FasciaOrariaIni,FasciaOrariaFin,RetCol)
    Dim k,y,f,idEstr,idCol,nEstrEsaminateTot
    idCol = 0
    ReDim aColonneDL(GetQColonneInteressate(nEstrInizio,nEstrFine,FasciaOrariaIni,FasciaOrariaFin),90)
    For k = nEstrInizio To nEstrFine Step 288
        Call Messaggio("Estrazione : " & k)
        For f = FasciaOrariaIni To FasciaOrariaFin
            idEstr =(k - 1) + f
            ReDim aNum(0)
            Call GetEstrazioneCompletaDL(idEstr,aNum)
            If aNum(1) > 0 Then
                idCol = idCol + 1
                For y = 1 To 20
                    aColonneDL(idCol,aNum(y)) = True
                Next
            End If
            nEstrEsaminateTot = nEstrEsaminateTot + 1
        Next
    Next
    RetCol = idCol
End Sub
Sub AnalisiGioco(MaxCol,nClasse,nSorte,collFrz,sTesto)
    Dim clsF
    Dim idCol
    Dim p,k
    Dim nVincita,nSpesa
    Call Scrivi(sTesto)
    ReDim aPuntiTot(nClasse)
    For k = 1 To nClasse
        aPuntiTot(k) = 0
    Next
    nVincita = 0
    nSpesa = 0
    For idCol = 1 To MaxCol
        If idCol <= UBound(aPoste) Then
            For Each clsF In collFrz
                p = 0
                For k = 1 To nClasse
                    If aColonneDL(idCol,clsF.aNumeri(k))Then
                        p = p + 1
                    End If
                Next
                aPuntiTot(p) = aPuntiTot(p) + 1
                nSpesa = nSpesa + aPoste(idCol)
                nVincita = nVincita +(aPremi(nClasse,p) * aPoste(idCol))
            Next
        End If
    Next
    Call Scrivi("Punteggio conseguito")
    For k = 1 To nClasse
        If aPremi(nClasse,k) > 0 Then
            Call Scrivi("Punti : " & k & " --> " & aPuntiTot(k))
        End If
    Next
    Call Scrivi("Spesa    : " & nSpesa)
    Call Scrivi("Vincita  : " & nVincita)
    Call Scrivi("Guadagno : " & nVincita - nSpesa)
    Call Scrivi
End Sub
Sub ImpostaPremi
    ReDim aPremi(10,10)
    Dim k,kk
    For k = 0 To 10
        For kk = 0 To 10
            aPremi(k,kk) = 0
        Next
    Next
    aPremi(1,1) = 3 ' giocato 1 vinto 1
    '-----------------------------------
    aPremi(2,1) = 1 ' giocato 2 vinto 1
    aPremi(2,2) = 7 ' giocato 2 vinto 2
    '-----------------------------------
    aPremi(3,2) = 2 ' giocato 3 vinto 2
    aPremi(3,3) = 50 ' giocato 3 vinto 3
    '-----------------------------------
    aPremi(4,2) = 1 ' giocato 4 vinto 2
    aPremi(4,3) = 10 ' giocato 4 vinto 3
    aPremi(4,4) = 100 ' giocato 4 vinto 4
    '-----------------------------------
    aPremi(5,2) = 1 ' giocato 5 vinto 2
    aPremi(5,3) = 4 ' giocato 5 vinto 3
    aPremi(5,4) = 15 ' giocato 5 vinto 4
    aPremi(5,5) = 200 ' giocato 5 vinto 5
    '-----------------------------------
    aPremi(6,3) = 2 ' giocato 6 vinto 3
    aPremi(6,4) = 10 ' giocato 6 vinto 4
    aPremi(6,5) = 100 ' giocato 6 vinto 5
    aPremi(6,6) = 2000 ' giocato 6 vinto 6
    '-----------------------------------
    aPremi(7,4) = 4 ' giocato 7 vinto 4
    aPremi(7,5) = 40 ' giocato 7 vinto 5
    aPremi(7,6) = 400 ' giocato 7 vinto 6
    aPremi(7,7) = 4000 ' giocato 7 vinto 7
    '-----------------------------------
    aPremi(8,5) = 20 ' giocato 8 vinto 5
    aPremi(8,6) = 200 ' giocato 8 vinto 6
    aPremi(8,7) = 1000 ' giocato 8 vinto 7
    aPremi(8,8) = 20000 ' giocato 8 vinto 8
    '-----------------------------------
    aPremi(9,5) = 10 ' giocato 9 vinto 5
    aPremi(9,6) = 40 ' giocato 9 vinto 6
    aPremi(9,7) = 400 ' giocato 9 vinto 7
    aPremi(9,8) = 4000 ' giocato 9 vinto 8
    aPremi(9,9) = 100000 ' giocato 9 vinto 9
    '-----------------------------------
    aPremi(10,5) = 5 ' giocato 10 vinto 5
    aPremi(10,6) = 15 ' giocato 10 vinto 6
    aPremi(10,7) = 150 ' giocato 10 vinto 7
    aPremi(10,8) = 1500 ' giocato 10 vinto 8
    aPremi(10,9) = 30000 ' giocato 10 vinto 9
    aPremi(10,10) = 1000000 ' giocato 10 vinto 10
End Sub
Sub ImpostaPoste(nClasse,nSorte)
    Dim k
    Dim QuantitaGiocate
    QuantitaGiocate = 12 ' un 'ora di gico
    ReDim aPoste(QuantitaGiocate)
    ' modificare i valori per la progressione nei 12 colpi e remmarre tutto il blocco select case
    aPoste(1) = 1
    aPoste(2) = 1
    aPoste(3) = 1
    aPoste(4) = 1
    aPoste(5) = 1
    aPoste(6) = 1
    aPoste(7) = 1
    aPoste(8) = 1
    aPoste(9) = 1
    aPoste(10) = 1
    aPoste(11) = 1
    aPoste(12) = 1
    Select Case nClasse
    Case 2
        If nSorte = 1 Then
            For k = 2 To 12
                aPoste(k) = aPoste(k - 1) *2
            Next
        ElseIf nSorte = 2 Then
            aPoste(8) = 2
            aPoste(9) = 2
            aPoste(10) = 3
            aPoste(11) = 3
            aPoste(12) = 4
        End If
    Case 3
        If nSorte = 2 Then
            For k = 3 To 12
                If k Mod 2 <> 0 Then
                    aPoste(k) = aPoste(k - 1) *2
                Else
                    aPoste(k) = aPoste(k - 1)
                End If
            Next
        End If
    Case 4
        If nSorte = 2 Then
            For k = 2 To 12
                aPoste(k) = aPoste(k - 1) *2
            Next
        ElseIf nSorte = 3 Then
            aPoste(11) = 2
            aPoste(12) = 2
        End If
    Case 5
        If nSorte = 2 Then
            For k = 2 To 12
                aPoste(k) = aPoste(k - 1) *2
            Next
        ElseIf nSorte = 3 Then
            aPoste(4) = 2
            aPoste(5) = 3
            aPoste(6) = 3
            aPoste(7) = 5
            aPoste(8) = 5
            aPoste(9) = 7
            aPoste(10) = 7
            aPoste(11) = 9
            aPoste(12) = 11
        End If
    Case 6
        If nSorte = 3 Then
            For k = 3 To 12
                If k Mod 2 <> 0 Then
                    aPoste(k) = aPoste(k - 1) *2
                Else
                    aPoste(k) = aPoste(k - 1)
                End If
            Next
        ElseIf nSorte = 4 Then
            aPoste(10) = 2
            aPoste(11) = 3
            aPoste(12) = 4
        End If
    End Select
End Sub

Attenzione: Lo script, fatto da Luigi per funzionare in sviluppo ridotto è necessaria la presenza della matrice nella cartella dei sistemi di Spaziometria.
 
Devi accedere o registrarti per poter rispondere.

Ultima estrazione Lotto

  • Estrazione del lotto
    giovedì 23 gennaio 2025
    Bari
    86
    50
    83
    38
    78
    Cagliari
    11
    36
    52
    31
    74
    Firenze
    56
    59
    86
    27
    84
    Genova
    03
    61
    53
    11
    38
    Milano
    13
    14
    79
    87
    47
    Napoli
    21
    90
    48
    55
    37
    Palermo
    56
    46
    59
    02
    53
    Roma
    74
    13
    07
    38
    77
    Torino
    27
    54
    62
    36
    81
    Venezia
    09
    14
    69
    28
    62
    Nazionale
    32
    73
    27
    11
    51
    Estrazione Simbolotto
    Bari
    36
    27
    19
    08
    24
    Archivio estrazioni lotto Ritardi top 15 Frequenze top 15

Ultimi Messaggi

Indietro
Alto