SCRIPT 10 & LOTTO 5 MIN

[Roby]

Ciao a tutti,vorrei chiedere agli esperti,è possibile creare uno script per il 10 e lotto 5min in modo che si possa impostare un range di giorni e orario e vedere i numeri più frequenti in quel determinato lasso di tempo? faccio un esempio,se io volessi sapere negli ultimi 5 giorni i numeri più frequenti usciti dalle ore 17 alle ore 20..si può fare? grazie a chi saprà rispondermi

 

[baikal]

questo è uno script del sig. luigib veda se fa al caso suo era presente in vecchi post del sito

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

 

[adispo2000]

ciao baikal...ma questo script non funziona...quando faccio ricerca mi dice che il range e sbagliato....poi ho notato che quando avvio e inserso la data mi da data iniziale il 22/5/2015...bho

 

[baikal]

Salve ha qualche problema con il suo archivio dovrebbe troncarlo e aggiornare a me funziona correttamente queste sono state anche le indicazioni del sig luigib quando ho avuto lo stesso problema

 

[adispo2000]

Ciao Baikal.....ho letto un post..che e' interessante ma ci vorrebe qualcuno che ci aiutasse a realizzare uno script ho un foglio exel..io non sono capace....e poi mettere le nostre esperienze per migliorarlo....tu puoi contattare qualcuno per realizzarlo e capire al meglio il procedimento in quanto chi ha iniziato poi e scomparso ....ti lascio il post
http://forum.lottoced.com/f13/gioco-speculativo-10-e-lotto-5-minuti-2020/

 

[baikal]

conosco il foglio sig. adispo200 e ora non funziona in quanto va cambiata la macro di aggiornamento

 

[adispo2000]

Io non l'ho potuto trovare...mi potresti postare?

 

[baikal]

non c'è l'ho ma credo che non servi a niente ho letto di un foglio dell'utente avatar che dicono sia ottimo

 

[adispo2000]

qual'e'? io sapevo di genius..ma gli archivi sono tutti sballati...poi ho sentito di genius 2....ma non ho saputo piu' niente...tu sai qualche cosa in piu' di me?

 

[Moro_80]

Ciao adispo2000 e baikal,
provate con lo script che trovate sotto rivisto da me, oltre ad averlo sistemato l'ho anche "adattato" al range orario dalle 00:05 alle 23:59 e alle 288 estrazioni attuali (prima era previsto con 228 estrazioni con range orario dalle 05:05 alle 23:59).

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
Call Scrivi(" Script by LuigiB - Revised by Moro_80 ",True,True,,2,2)
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 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
				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(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 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

Fatemi sapere poi se Vi funziona!

Ciao

 

[adispo2000]

Ciao Moro....elenco problemi che prima non dava e ora che ho aggiornato mi da:
- data inizio da default mi da a oggi 23/08/2015....quindi la devo correggere manualmente mm/gg/yy..... ,
- data fine da default mi da la data giusta...ma devo sempre inserirla manualmente mm/gg/yy ;
- poi quando vado a fare la ricerca x ridotti mi spunta: AVENDOSCEDLTO LO SVILUPPO RIDOTTO E NECESSESARIA LA MATRICE NELLA CARTELLA SISTEMI ma ilpeercorso e giusto e i file dat ci sono....

ciao

 

[Moro_80]

Ciao adispo2000,
guarda quello che dici Tu a me non accade, sotto puoi vedere le schermate che appaiono a me lanciando lo script:



Come vedi la data inizio a me la da corretta:



e anche la data fine:













Qui ti chiede che tipo di elaborazione vuoi fare, se scegli ridotto DEVI avere nella cartella sistemi il file matrice con estensione .dat, altrimenti scegli integrale e lui lo rielabora da zero.



Questo poi il risultato:




Ciao

 

[adispo2000]

non riesco a capire....prima tutto ok poi nisba....scusa le date da dove li prende lo script? ...poi per il ridotto indica c:\user\ ecc... invece da me dovrebbe essere c:\utenti\ ecc...ne capisci niente

 

[Moro_80]

Le data inizio la "prende" dalla data sistema di windows con la funzione:

FormattaStringa(Now,"dd/mm/yyyy")

poi 10 giorni indietro con questa:

FormattaStringa(DateAdd("d",-(GiorniDaAnalizzare),DataF),"dd/mm/yyyy")

Per il percorso dovresti avere questo:

C:\Users\XXXXXXX\AppData\Roaming\spaziometria\sistemi

Ciao

 

[adispo2000]

data sistema ok......percordp ridotto ok....provato anche su un samsung i5 64 bit.....e su acer i3 32bit...bho

 

[LuigiB]

io non ho capito quale sia l'errore quindi pur volendo non posso aiutare nessuno .. recentemente con la gestione del numero oro il formato dell'archivio 10 e llotto
è cambiato , bisogna eliminare il file delle vecchie estrazioni e ricaricare tutto daccapo .. non so se possa essere legato a questo fatto il problema riscontrato...

 

[Moro_80]

io non ho capito quale sia l'errore quindi pur volendo non posso aiutare nessuno .. recentemente con la gestione del numero oro il formato dell'archivio 10 e llotto
è cambiato , bisogna eliminare il file delle vecchie estrazioni e ricaricare tutto daccapo .. non so se possa essere legato a questo fatto il problema riscontrato...

Ciao Luigi, grazie per l'intervento in questo post...anche io sono d'accordo con te e credo che il problema sia tutto nell' archivio estrazioni.
D'altro canto adispo2000 dovrebbe essere più chiaro e spiegare bene che problema riscontra al lancio script.

Un saluto

 

[adispo2000]

Moro, volevo solo segnalare dei problemi cioe' le date le devo mettere manualmente e in versione americana prima il mese poi ilgiornoe l'anno mm/gg/yy....ma questol'horiscontro in due pc...poi il percorso de lridotto non l'ho trova anche se controllando e tutto a posto....comunque vi ringrazio sempre perche' siete unici e professionali...ciao

 

[Moro_80]

Moro, volevo solo segnalare dei problemi cioe' le date le devo mettere manualmente e in versione americana prima il mese poi ilgiornoe l'anno mm/gg/yy....ma questol'horiscontro in due pc...poi il percorso de lridotto non l'ho trova anche se controllando e tutto a posto....comunque vi ringrazio sempre perche' siete unici e professionali...ciao

Ciao adispo2000, mi sa che devi fare la procedura per l'archivio estrazioni dopo che è stata aggiunta la gestione del numero oro al 10eLotto.

Come indicato da Luigi, la procedura è questa:

ho fatto le modifiche per gestire il nmero oro del 10 e lotto.
E' necessario aggiornare gli archivi sia del 10 e lotto tradizionale sia quello 5 minuti.
Per farlo eseguire questo script dopo aver installato almeno la versione 1.5.6

ed ecco il codice da lanciare:

Option Explicit
Sub Main
	Dim sFileBd
	Dim sMsg 
	
	sMsg = "Questo script elimina gli archivi del 10 e lotto" & vbCrLf
	sMsg = sMsg & "sia tradizionale che 5M poi li aggiorna nuovamente" & vbCrLf
	sMsg = sMsg & "per consentire la modifica Numero Oro. Proseguire ?" & vbCrLf
	

	If MsgBox( sMsg , vbQuestion + vbYesNo ) = vbYes Then
		sFileBd = GetDirectoryAppData & "BaseDati10Elotto.Dat"
		Call EliminaFile(sFileBd)
		sFileBd = GetDirectoryAppData & "BaseDati10Elotto5M.Dat"
		Call EliminaFile(sFileBd)
		Call AggiornaArchivio
		Call AggiornaArchivioDL
		ImpostaArchivio10ELotto(1)
		Call ScriviEstrazioneDL(EstrazioniArchivioDL,True)
		ImpostaArchivio10ELotto(2)
		Call ScriviEstrazioneDL(EstrazioniArchivioDL,True)
	End If
End Sub

Penso che dopo aver fatto ciò si risolve il Tuo problema.....


Saluti

 

[adispo2000]

ciao moro oppue mike ...si puo' realizzare uno script dove:
vado a scegliere la lunghezza (ambo-terno-quat. ecc), poi quante casi desideri (2,3,4 ecc), scegliere num. frequenze,scegliere num. presenze, in quanti estrazioni le vuoi ricercare partendo dall'ultima in archivio, e impostarle in ordine di uscita....non so' se sono stato chiaro.
E' fattibile..parlo sempre di 10elotto5min