Novità

uno script per il 10 e lotto

  • Creatore Discussione Creatore Discussione LuigiB
  • Data di inizio Data di inizio
L

LuigiB

Guest
ciao ragazzi come va ? sono passato per un saluto e vi posto uno script per il 10 e lotto 5 minuti
che ricava le combinazioni piu frequenti entro un dato range dove si possono specificare sia inizio e fine del range sia la fascia oraria da analizzare.
Naturalmente se si usa un range troppo ampio o se si ha un pc del 1930 è chiaro che potrebbe risultare lento.

Buone vacanze a tutti !
Codice: 
Option Explicit

Dim collPresenze

Class clsFormazione
	Public nPresenze
	Public sNumeri

	
End Class

Sub Main
	Dim nEstrInizio,nEstrFine
	Dim DataIni,DataFin
	Dim FasciaOrariaIni,FasciaOrariaFin
	Dim sOraIni,sOraFin
	Dim quantitaFrz
	Dim nClasse
	Dim nEstrEsam,nEstrValide,nEstrNonValide
	
	Call ImpostaArchivio10ELotto(2)
	quantitaFrz = 10
	
	
	If ChiediDataInizioFine(DataIni,DataFin,10) Then
		If ChiediFasciaInizioFine(FasciaOrariaIni,FasciaOrariaFin,sOraIni,sOraFin) Then
			If ChiediClasse(nClasse) 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,nEstrEsam,nEstrValide,nEstrNonValide)
					Call ScriviParametriRicerca(DataIni,DataFin,sOraIni,sOraFin,nEstrEsam,nEstrValide,nEstrNonValide,quantitaFrz,nClasse)
					Call MostraFormazioniPiuFre(quantitaFrz)
					
				End If
			End If
		End If
	End If
End Sub
Sub ScriviParametriRicerca(DataI,DataF,OraI,OraF,EstrEsam,Valide,NonValide,QuantitaFrz,nClasse)

	Call Scrivi("Statistica delle prime " & QuantitaFrz & " formazioni piu frequenti in " & NomeSorte(nClasse))
	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
	ReDim aIdFrzScelte(Quantita,1)
	
	For Each clsFrz In collPresenze
		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 = collPresenze(aIdFrzScelte(k,1))
		aV(1) = clsFrz.sNumeri
		aV(2) = clsFrz.nPresenze
		Call AddRigaTabella(aV)
	Next
	
	Call CreaTabella
	
	
End Sub

Sub EseguiStatistica(nEstrInizio,nEstrFine,FasciaOrariaIni,FasciaOrariaFin,nClasse,nEstrEsaminateTot,nEstrValide,nEstrNonValide)

	Dim k,f,idEstr
	
	
	nEstrEsaminateTot = 0
	nEstrValide = 0
	nEstrNonValide = 0
	
	
	
	Set collPresenze = 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
				Call InserisciForrmazioniInColl(aNum,nClasse)
				nEstrValide = nEstrValide + 1
			Else
				nEstrNonValide = nEstrNonValide + 1
			End If
			nEstrEsaminateTot = nEstrEsaminateTot + 1
			If ScriptInterrotto Then Exit For

		Next
		If ScriptInterrotto Then Exit For
	
	Next
End Sub
Sub InserisciForrmazioniInColl(aNumeri,nClasse)
	Dim k,sKey
	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
		sColonna = StringaNumeri(aCol)
		sKey = "K" & sColonna
		
		If GetItemInColl(sKey,clsFrz) Then
			clsFrz.nPresenze = clsFrz.nPresenze + 1
		Else
			Set clsFrz = New clsFormazione
			clsFrz.sNumeri = sColonna
			clsFrz.nPresenze = 1
			
			Call collPresenze.add(clsFrz,sKey)
		End If
		
		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
Function GetItemInColl(sKey,cls)
	On Error Resume Next
	
	Set cls = collPresenze(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(228)
	Dim h,m
	Dim i
	For h = 5 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)
	
	
	ReDim aVoci(3)
	aVoci(1) = "Estratto"
	aVoci(2) = "Ambo"
	aVoci(3) = "Terno"
	
	nClasse = ScegliOpzioneMenu(aVoci,- 1,"Classe formazione")
	If nClasse > 0 Then
		ChiediClasse = True
	Else
		MsgBox "Classe formazione non valida"
	End If
End Function
 
LuigiB ha scritto:
ciao ragazzi come va ? sono passato per un saluto e vi posto uno script per il 10 e lotto 5 minuti
che ricava le combinazioni piu frequenti entro un dato range dove si possono specificare sia inizio e fine del range sia la fascia oraria da analizzare.
Naturalmente se si usa un range troppo ampio o se si ha un pc del 1930 è chiaro che potrebbe risultare lento.

Buone vacanze a tutti !
Codice: 
Option Explicit

Dim collPresenze

Class clsFormazione
    Public nPresenze
    Public sNumeri

    
End Class

Sub Main
    Dim nEstrInizio,nEstrFine
    Dim DataIni,DataFin
    Dim FasciaOrariaIni,FasciaOrariaFin
    Dim sOraIni,sOraFin
    Dim quantitaFrz
    Dim nClasse
    Dim nEstrEsam,nEstrValide,nEstrNonValide
    
    Call ImpostaArchivio10ELotto(2)
    quantitaFrz = 10
    
    
    If ChiediDataInizioFine(DataIni,DataFin,10) Then
        If ChiediFasciaInizioFine(FasciaOrariaIni,FasciaOrariaFin,sOraIni,sOraFin) Then
            If ChiediClasse(nClasse) 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,nEstrEsam,nEstrValide,nEstrNonValide)
                    Call ScriviParametriRicerca(DataIni,DataFin,sOraIni,sOraFin,nEstrEsam,nEstrValide,nEstrNonValide,quantitaFrz,nClasse)
                    Call MostraFormazioniPiuFre(quantitaFrz)
                    
                End If
            End If
        End If
    End If
End Sub
Sub ScriviParametriRicerca(DataI,DataF,OraI,OraF,EstrEsam,Valide,NonValide,QuantitaFrz,nClasse)

    Call Scrivi("Statistica delle prime " & QuantitaFrz & " formazioni piu frequenti in " & NomeSorte(nClasse))
    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
    ReDim aIdFrzScelte(Quantita,1)
    
    For Each clsFrz In collPresenze
        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 = collPresenze(aIdFrzScelte(k,1))
        aV(1) = clsFrz.sNumeri
        aV(2) = clsFrz.nPresenze
        Call AddRigaTabella(aV)
    Next
    
    Call CreaTabella
    
    
End Sub

Sub EseguiStatistica(nEstrInizio,nEstrFine,FasciaOrariaIni,FasciaOrariaFin,nClasse,nEstrEsaminateTot,nEstrValide,nEstrNonValide)

    Dim k,f,idEstr
    
    
    nEstrEsaminateTot = 0
    nEstrValide = 0
    nEstrNonValide = 0
    
    
    
    Set collPresenze = 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
                Call InserisciForrmazioniInColl(aNum,nClasse)
                nEstrValide = nEstrValide + 1
            Else
                nEstrNonValide = nEstrNonValide + 1
            End If
            nEstrEsaminateTot = nEstrEsaminateTot + 1
            If ScriptInterrotto Then Exit For

        Next
        If ScriptInterrotto Then Exit For
    
    Next
End Sub
Sub InserisciForrmazioniInColl(aNumeri,nClasse)
    Dim k,sKey
    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
        sColonna = StringaNumeri(aCol)
        sKey = "K" & sColonna
        
        If GetItemInColl(sKey,clsFrz) Then
            clsFrz.nPresenze = clsFrz.nPresenze + 1
        Else
            Set clsFrz = New clsFormazione
            clsFrz.sNumeri = sColonna
            clsFrz.nPresenze = 1
            
            Call collPresenze.add(clsFrz,sKey)
        End If
        
        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
Function GetItemInColl(sKey,cls)
    On Error Resume Next
    
    Set cls = collPresenze(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(228)
    Dim h,m
    Dim i
    For h = 5 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)
    
    
    ReDim aVoci(3)
    aVoci(1) = "Estratto"
    aVoci(2) = "Ambo"
    aVoci(3) = "Terno"
    
    nClasse = ScegliOpzioneMenu(aVoci,- 1,"Classe formazione")
    If nClasse > 0 Then
        ChiediClasse = True
    Else
        MsgBox "Classe formazione non valida"
    End If
End Function
Clicca per espandere...

Ciao LuigiB buone Vacanze il script 10 & Lotto 5 minuti mi da degli errori li ho cancellati
pero' non so se e' normale dopo funziona mi da 10 terzine piu' freguente domanda valide 33 ( non Valide 33 )
che signica sono valide o no ? Bisogna giocare tutte o no ?

Statistica delle prime 10 formazioni piu frequenti in Terno

Data inizio : 31/07/2012
Data fine : 10/08/2012
Range Orario : 13:50/14:00
Estrazioni nel range : 33 (Valide : 33; NonValide : 33)



[TD="bgcolor: #ffffff"] Formazione
[/TD]
[TD="bgcolor: #ffffff"] Presenze
[/TD]

[TD="bgcolor: #ffffff"] 12.58.87
[/TD]
[TD="bgcolor: #ffffff"] 5
[/TD]

[TD="bgcolor: #ffffff"] 6.34.58
[/TD]
[TD="bgcolor: #ffffff"] 5
[/TD]

[TD="bgcolor: #ffffff"] 6.33.58
[/TD]
[TD="bgcolor: #ffffff"] 5
[/TD]

[TD="bgcolor: #ffffff"] 3.6.33
[/TD]
[TD="bgcolor: #ffffff"] 5
[/TD]

[TD="bgcolor: #ffffff"] 6.12.33
[/TD]
[TD="bgcolor: #ffffff"] 5
[/TD]

[TD="bgcolor: #ffffff"] 33.58.87
[/TD]
[TD="bgcolor: #ffffff"] 4
[/TD]

[TD="bgcolor: #ffffff"] 21.58.66
[/TD]
[TD="bgcolor: #ffffff"] 4
[/TD]

[TD="bgcolor: #ffffff"] 10.21.66
[/TD]
[TD="bgcolor: #ffffff"] 4
[/TD]

[TD="bgcolor: #ffffff"] 44.58.87
[/TD]
[TD="bgcolor: #ffffff"] 4
[/TD]

[TD="bgcolor: #ffffff"] 21.29.58
[/TD]
[TD="bgcolor: #ffffff"] 4
[/TD]
 
Ultima modifica:
ciao , nel range analizzato possono essere presenti delle estrazioni mancanti dato che la lottomatica
non aggiorna puntualmente tutte le estrazioni del 10 elotto 5m quindi al termine lo script
indica il conteggio dei parziali , ovvero le estrazioni totali analizzate , quelle valide cioeè quelle
di cui si sanno i numeri usciti e infine quelle non valide cioè la quantita di estrazioni che non soono presenti nell'archivio.
Al termine lo script elenca comunque le prime formazioni piu frequenti sulle colonne che è riuscito ad analizzare.
 
ciao luigi , su lottoced ho seguito il tuo grande lavoro, il programma spaziometria

grandissimo programma complimenti e grazie per il lavoro svolgi
 
ciao Gennaro aggiungo il risultato che da a me senza nessun errore.
Per me devi aggiornare l'archivio.
Grazie Avatar , ormai non svolgo piu molto .. pero si è stato un bel lavoro durato un paio di anni.

ecco il risultato che da a me
Immagine.jpg
 
bho .. mai giocato aql 10 e lotto in vita mia .. lo script l'ho fatto per passatempo non so darti consigli di gioco... ciao
 
Ciao Luigi Buone Vacanze anche a tè, volevo chiederti se ti erapossibile, inserire nello script l’opzione,
con quanti numeri viene ricercata ambata, ambo o terno.
Per ambata max 2 numeri
Per ambo max 4 numeri
Per terno max 6 numeri
 
Codice: 
Option Explicit
Dim collFormazioni
Dim aColonneDL
Dim aMatriceRid
Class clsFormazione
	Public nPresenze
	Public sNumeri
	Private mNumeri(10)
	Public Property Let aNumeri(id,value)
		mNumeri(id) = value
	End Property
	Public Property Get aNumeri(id)
		aNumeri = mNumeri(id)
	End Property
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)
	quantitaFrz = 10
	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)
						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
	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)
	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
	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(228)
	Dim h,m
	Dim i
	For h = 5 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(3)
	aVoci(1) = "Estratto"
	aVoci(2) = "Ambo"
	aVoci(3) = "Terno"
	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
			If nClasse = nSorte Then
				MsgBox "Se la sorte cercata coincide con la classe formazione voluta è impossibile usare lo sviluppo ridotto"
				i = 1
				bUsaRidotto = False

			Else
				bUsaRidotto = True
			End If
		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 sviuluppo ridotto è " & _
				"necessaria la presenza della matrice nella cartella dei sistemi" & vbCrLf & sFileSistema
			End If
			'Else
			'	MsgBox "Avendo scelto lo sviuluppo 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
 
Ultima modifica di un moderatore:
gennaro52 ha scritto:
Ciao LuigiB buone Vacanze il script 10 & Lotto 5 minuti mi da degli errori li ho cancellati
pero' non so se e' normale dopo funziona mi da 10 terzine piu' freguente domanda valide 33 ( non Valide 33 )
che signica sono valide o no ? Bisogna giocare tutte o no ?

Statistica delle prime 10 formazioni piu frequenti in Terno

Data inizio : 31/07/2012
Data fine : 10/08/2012
Range Orario : 13:50/14:00
Estrazioni nel range : 33 (Valide : 33; NonValide : 33)



[TD="bgcolor: #FFFFFF"] Formazione
[/TD]
[TD="bgcolor: #FFFFFF"] Presenze
[/TD]

[TD="bgcolor: #FFFFFF"] 12.58.87
[/TD]
[TD="bgcolor: #FFFFFF"] 5
[/TD]

[TD="bgcolor: #FFFFFF"] 6.34.58
[/TD]
[TD="bgcolor: #FFFFFF"] 5
[/TD]

[TD="bgcolor: #FFFFFF"] 6.33.58
[/TD]
[TD="bgcolor: #FFFFFF"] 5
[/TD]

[TD="bgcolor: #FFFFFF"] 3.6.33
[/TD]
[TD="bgcolor: #FFFFFF"] 5
[/TD]

[TD="bgcolor: #FFFFFF"] 6.12.33
[/TD]
[TD="bgcolor: #FFFFFF"] 5
[/TD]

[TD="bgcolor: #FFFFFF"] 33.58.87
[/TD]
[TD="bgcolor: #FFFFFF"] 4
[/TD]

[TD="bgcolor: #FFFFFF"] 21.58.66
[/TD]
[TD="bgcolor: #FFFFFF"] 4
[/TD]

[TD="bgcolor: #FFFFFF"] 10.21.66
[/TD]
[TD="bgcolor: #FFFFFF"] 4
[/TD]

[TD="bgcolor: #FFFFFF"] 44.58.87
[/TD]
[TD="bgcolor: #FFFFFF"] 4
[/TD]

[TD="bgcolor: #FFFFFF"] 21.29.58
[/TD]
[TD="bgcolor: #FFFFFF"] 4
[/TD]
Clicca per espandere...
................................
Ciao gennaro52,
vorrei sapere se hai avuto lo stesso mio errore e come lo hai risolto (cosa hai cancellato? )
il mio errore che ho anche con il secondo script di LuigiB è il seguente :
Range non valido, probabilmente mancano le estrazioni nella base dati
EstrazioneIni : 103513
EstrazioneFine : 0


.....................
Dopo questo errore non mi fa più andare avanti.
Ti ringrazio anticipatamente per la risposta.

Buona giornata

Silop:)
 
silop2005 ha scritto:
................................
Ciao gennaro52,
vorrei sapere se hai avuto lo stesso mio errore e come lo hai risolto (cosa hai cancellato? )
il mio errore che ho anche con il secondo script di LuigiB è il seguente :
Range non valido, probabilmente mancano le estrazioni nella base dati
EstrazioneIni : 103513
EstrazioneFine : 0


.....................
Dopo questo errore non mi fa più andare avanti.
Ti ringrazio anticipatamente per la risposta.

Buona giornata

Silop:)
Clicca per espandere...

ciao silop2005 i 2 listati vanno bene ti spiego come fare
inizio 01-08-2012
fine 11-08-2012 non devi mettere la data odierna ma il giorno prima
se metti il giorno di oggi il 12-08-20012 il programma gira se metti un orario gia passato
esempio ora sono le 18.45 io metto dalle 18,00 alle 18,20 lo script mi elabora la previsione ma x il giorno dopo
se invece metto dalle 19,00 alle 19,10 mi da errore
 
Ragazzi il problema che dite dipende davvero dal fatto che manchi l'estrazione,
In pratica seguite questo esempio so ora sono le 18 e io faccio un analisi dalla data che ne so 25/07/2012 ad oggi 12/08/2012 e metto un range che va dalle 17.50 alle 18.10 e ovvio che le estrazioni di oggi relative alle 18.05 e 18.10 ancora non esistono .. percio il secondo limite torna 0 e da errore !
 
silop2005 ha scritto:
................................
Ciao gennaro52,
vorrei sapere se hai avuto lo stesso mio errore e come lo hai risolto (cosa hai cancellato? )
il mio errore che ho anche con il secondo script di LuigiB è il seguente :
Range non valido, probabilmente mancano le estrazioni nella base dati
EstrazioneIni : 103513
EstrazioneFine : 0


.....................
Dopo questo errore non mi fa più andare avanti.
Ti ringrazio anticipatamente per la risposta.

Buona giornata

Silop:)
Clicca per espandere...

Gli errori Erano Dovuti all 'argiornamento dell ' archivio del 10 & Lotto 5 minuti non Aggiornato . Una volta aggiornato si e' Risolto
Scusami se ti rispondo adesso non mi e' arrivato la notifica.. Ciao
 
ho ampliato lo script ...
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 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(228)
	Dim h,m
	Dim i
	For h = 5 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(3)
	aVoci(1) = "Estratto"
	aVoci(2) = "Ambo"
	aVoci(3) = "Terno"
	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 sviuluppo ridotto è " & _
				"necessaria la presenza della matrice nella cartella dei sistemi" & vbCrLf & sFileSistema
			End If
			'Else
			'	MsgBox "Avendo scelto lo sviuluppo 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 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
			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
 
Ciao Luigi,
bello lo script e grazie al tuo nuovo aggiornamento ho potuto " toccare con mano"
qualche dato statistico in più ma quello che voglio dire dire è che mi manca la possibilità di
fare qualche statistica e cioè: qual'è l'intervallo migliore di ricerca da fare ( es. 10 munuti
oppure 1/2 ora o 1 ora ) oppure sarebbe più probabile giocare la mattina, il pomeriggio o la sera.
Appena lancio lo script mi chiede la quantità di formazioni in gioco( preimpostato a 2 ) ma io non so
a priori "dire" se è più conveniente o più probabile giocare 2/3/4 .. formazioni se prima non provo
a fare dei test all'indietro per capire quali probabilità ho di centrare la vincita giocando 2/3/4 formazioni
per ambo o terno ecc. e cosi la data di inizio e la data di fine non so quale potrebbe essere l'intervallo
"migliore" che potrebbe regalarmi la soddisfazione della vincita e così la stessa cosa vale per la fascia oraria
oppure se è meglio giocare le combinazioni più frequenti o quelle più ritardate.
Non so se mi sono spiegato bene.. insomma vorrei utilizzare il computer non solo per fare girare dei programmi
ma anche poterlo sfruttare in tutte le ricerche possibili e immaginabili sullo storico e darmi come risultato dei
termini di paragoni. Visto che devo giocare cerco di giocare aumentanto al massimo il mio vantaggio sul banco!
Non so se è realizzabile e comunque grazie per il tuo interessamento.
Saluti
 
Ciao Luigib,
solo per notizia, adesso inspiegabilmente mi funzionano tutti i tuoi script senza aver fatto nulla.
Grazie comunque per la tua disponibilità.

Seppure con ritardo ringrazio anche gli utenti vidoque e gennaro52 per le risposte che mi hanno scritte.
BUON ferragosto a tutti.

Silop:)
 
Devi accedere o registrarti per poter rispondere.

Ultima estrazione Lotto

  • Estrazione del lotto
    sabato 18 gennaio 2025
    Bari
    24
    76
    02
    72
    12
    Cagliari
    21
    08
    77
    04
    17
    Firenze
    74
    84
    07
    12
    72
    Genova
    13
    07
    33
    47
    18
    Milano
    01
    34
    09
    55
    48
    Napoli
    46
    23
    25
    03
    06
    Palermo
    44
    07
    01
    46
    84
    Roma
    88
    78
    64
    74
    04
    Torino
    07
    87
    67
    38
    53
    Venezia
    31
    25
    04
    18
    02
    Nazionale
    49
    82
    59
    65
    67
    Estrazione Simbolotto
    Bari
    03
    13
    31
    23
    35
    Archivio estrazioni lotto Ritardi top 15 Frequenze top 15

Ultimi Messaggi

Indietro
Alto