Novità

Help per script

  • Creatore Discussione Creatore Discussione Y10
  • Data di inizio Data di inizio
LuigiB ha scritto:
Anche a me ha fatto piacere tornare per un saluto .. vedo che la fantasia di scriptare è ancora viva .. mi fa piacere sia per chi già era bravo di suo sia per quelli a cui sono riuscito a dare un input per imparare e che ora sono gia bravi ..
un saluto e un abbraccio a tutti quanti ...
Ciao !
Clicca per espandere...
Ciao LuigiB ben tornato, non scrivo mai ma già da diversi mesi uso il tuo capolavoro, grazie io sono uno di quelli a cui sei riuscito a dare un input per imparare, preciso solo ad usarli, grazie del tuo attesissimo intervento. Un saluto a tutti ciao
 
I tuoi interventi sono come un tocco di Picasso su un foglio bianco. Mille grazie.:)
 
Cari amici , la mia passione per gli Ambi Trasposti da me conosciuti tramite il compianto Lukylotto mi porta a studiarci sempre di più , vorrei proporvi questa tecnica.

In qualsiasi estrazione prendiamo due ambi trasposti con la seguente caratteristica : che ci siano solo quelli e che la loro somma sia pari , ciò premesso li inscriviamo sul cerchio ciclometrico ed andiamo a completarli con due nuovi numeri che ci diano una figura armoniosa tali numeri li metteremo in gioco sulle due ruoto per 13 colpi.
Esempio pratico:

Estrazione del 05/11/2011 abbiamo 81.45 CA 41.85 PA , li iscriviamo sul cerchio e , creando una figura armonica otteniamo i numeri 18.63 Esito , al 5° colpo ambo secco 18.63 PA , potrei produrre altri esempi , ma servirebbe meglio allo scopo , un listato per testare la validità o meno di tale tecnica.

Un caro saluto a tutti:)
 
Proprio nessuno che voglia o possa fare questo script ? Tempo permettendo e ammesso che sia realizzabile ?.:)
 
Ciao a tutti , un saluto ai nuovi utenti.
con poche modifiche lo script che avevo fatto sembra che vada bene.C'è solo un fatto dato che non hai spiegato cosa si intende per figura armonica ho dato io una mia interpretazione da fornire al povero computer (per lui armonico puo voler dir tutto e puo voler dir niente) .
Io ho interperetato l'armonia in questo modo , dati i 4 numeri del'ambo trasposto , e ordinati gli stessi in modo crescente
si otterrà una nuova sequenza questa volta composta da 6 numeri ottenuti inserendo 2 nuovi numeri tra il primo e il secondo
e tra il terzo e e quarto dei 4 numeri originali.
Questi due nuovi numeri sono calcolati sommando al primo la distanza fratto 2 tra il primo e il secondo (o sommando al terzo la distanza/2 tra il terzo e il quarto)
Questi 2 nuovi numeri sono giocati per ambo secco sulle 2 ruote.

image.jpg


Codice: 
Option Explicit
Class clsAmbo
	Private aAmbi
	Private IdEstrazione
	Private IdRuota
	Sub GeneraAmbi(idEstr,Ruota)
		IdEstrazione = idEstr
		IdRuota = Ruota
		ReDim aN(0)
		Call GetArrayNumeriRuota(IdEstrazione,IdRuota,aN)
		'Call OrdinaMatrice ( aN ,1)
		If aN(1) > 0 Then
			aAmbi = SviluppoIntegrale(aN,2)
		Else
			ReDim aAmbi(0)
		End If
	End Sub
	Function GetQuantitaAmbi
		GetQuantitaAmbi = UBound(aAmbi)
	End Function
	Function GetAmbo(idAmbo)
		ReDim aN(2)
		aN(1) = aAmbi(idAmbo,1)
		aN(2) = aAmbi(idAmbo,2)
		GetAmbo = aN
	End Function
	Function GetRuota
		GetRuota = IdRuota
	End Function
End Class
Class clsQuartinaAmboTrasposto
	Private aNum(4)
	Public Ruota1
	Public Ruota2
	Public IdEstrazione
	Sub SetNumeri(aNumAmboR1,aNumAmboR2)
		Dim k
		For k = 1 To 4
			If k <= 2 Then
				aNum(k) = aNumAmboR1(k)
			Else
				aNum(k) = aNumAmboR2(k - 2)
			End If
		Next
	End Sub
	Function GetNumeri()
		ReDim aNumTmp(UBound(aNum))
		Dim k
		For k = 0 To UBound(aNum)
			aNumTmp(k) = aNum(k)
		Next
		GetNumeri = aNumTmp
	End Function
	Function GetRuote()
		ReDim aRuote(2)
		aRuote(1) = Ruota1
		aRuote(2) = Ruota2
		GetRuote = aRuote
	End Function
	Function IsSommaPari()
		If pari(aNum(1) + aNum(2)) Then
			If pari(aNum(3) + aNum(4)) Then
				IsSommaPari = True
			End If
		End If
	End Function
	Function QuantitaNumeriDiversi
		Dim aTmp
		Dim k,t
		aTmp = aNum
		t = 0
		Call EliminaRipetuti(aTmp)
		For k = 1 To UBound(aTmp)
			If aTmp(k) <> 0 Then
				t = t + 1
			End If
		Next
		QuantitaNumeriDiversi = t
	End Function
End Class
Sub Main
	Dim idEstr,Ruota
	Dim Inizio,Fine
	Dim r,rr,i,ii
	Dim aNumAmbo,aNumAmboT
	Dim nDiff,nSomma
	ReDim acAmbiRuota(11)
	Dim nCasi
	Dim bQualsiasiDisp
	Dim nCasiParz
	Dim bEseguiGiocate
	Dim bEseguiStatistica
	Dim CollCasiRilevati
	Dim clsQuartina
	Inizio = EstrazioneIni
	Fine = EstrazioneFin
	bQualsiasiDisp = False
	bEseguiGiocate = True
	bEseguiStatistica = True
	nCasi = 0
	'	If MsgBox("Considerare gli ambi trasposti a prescindere dalla disposizione fisica dei numeri usciti ?",vbQuestion + vbYesNo) = vbYes Then
	'		bQualsiasiDisp = True
	'	End If
	For idEstr = Inizio To Fine
		i = 0
		nCasiParz = 0
		' prima genero per ogni ruota tutti gli ambi costituiti dai nuemeri estratti
		For r = 1 To 12
			If r <> 11 Then
				i = i + 1
				Set acAmbiRuota(i) = New clsAmbo
				Call acAmbiRuota(i).GeneraAmbi(idEstr,r)
			End If
		Next
		' poi ricerco gli ambi trasposti tra 2 ruote
		Set CollCasiRilevati = GetNewCollection
		For r = 1 To 10
			For rr = r + 1 To 11
				Call Messaggio("Estrazione : " & idEstr & " confronto ruote : " & SiglaRuota(acAmbiRuota(r).GetRuota) & " --> " & SiglaRuota(acAmbiRuota(rr).GetRuota))
				For i = 1 To acAmbiRuota(r).GetQuantitaAmbi
					aNumAmbo = acAmbiRuota(r).Getambo(i)
					For ii = 1 To acAmbiRuota(rr).GetQuantitaAmbi
						aNumAmboT = acAmbiRuota(rr).Getambo(ii)
						If IsAmboTrasposto(aNumAmbo,aNumAmboT,bQualsiasiDisp) Then
							Set clsQuartina = New clsQuartinaAmboTrasposto
							clsQuartina.Ruota1 = acAmbiRuota(r).GetRuota
							clsQuartina.Ruota2 = acAmbiRuota(rr).GetRuota
							clsQuartina.IdEstrazione = idEstr
							Call clsQuartina.SetNumeri(aNumAmbo,aNumAmboT)
							CollCasiRilevati.add clsQuartina
							If CollCasiRilevati.Count > 1 Then Exit For
						End If
					Next
				Next
				If CollCasiRilevati.Count > 1 Then Exit For
			Next
			If CollCasiRilevati.Count > 1 Then Exit For
		Next
		If CollCasiRilevati.Count = 1 Then
			Set clsQuartina = CollCasiRilevati(1)
			If clsQuartina.IsSommaPari Then
				If clsQuartina.QuantitaNumeriDiversi = 4 Then
					Dim aNumQ
					ReDim aNumC(6)
					ReDim aNumQ(0)
					aNumQ = clsQuartina.GetNumeri
					Call OrdinaMatrice(aNumQ,1)
					aNumC(1) = aNumQ(1)
					aNumC(2) = Fuori90(aNumQ(1) + Distanza(aNumQ(1),aNumQ(2))/2)
					aNumC(3) = aNumQ(2)
					aNumC(4) = aNumQ(3)
					aNumC(5) = Fuori90(aNumQ(3) + Distanza(aNumQ(3),aNumQ(4))/2)
					aNumC(6) = aNumQ(4)
					Call Scrivi("Estrazione " & GetInfoEstrazione(idEstr))
					Call Scrivi("Ruote " & SiglaRuota(clsQuartina.Ruota1) & " - " & SiglaRuota(clsQuartina.Ruota2))
					Call Scrivi(StringaNumeri(clsQuartina.GetNumeri))
					Call DisegnaCerchioCiclometrico(aNumC)
					ReDim aNum(2)
					aNum(1) = aNumC(2)
					aNum(2) = aNumC(5)
					ReDim aRuote(2)
					aRuote(1) = clsQuartina.ruota1
					aRuote(2) = clsQuartina.ruota2
					ReDim aPoste(2)
					aPoste(2) = 1
					nCasi = nCasi + 1
					nCasiParz = nCasiParz + 1
					'Call Scrivi(String(50,"=") & " Caso " & FormatSpace(nCasi,5,True))
					'Call Scrivi("Estrazione : " & GetInfoEstrazione(idEstr))
					'Call Scrivi("Condizione : " & SiglaRuota(aRuote(1)) & " " & StringaNumeri(aNumAmbo) & " - " & SiglaRuota(aRuote(2)) & " " & StringaNumeri(aNumAmboT))
					Call ImpostaGiocata(nCasi,aNum,aRuote,aPoste,13,2)
					Call Gioca(idEstr)
				End If
			End If
		End If
		'If nCasiParz > 0 And bEseguiGiocate Then
		'	Call Gioca(idEstr)
		'End If
		Call AvanzamentoElab(Inizio,Fine,idEstr)
		If ScriptInterrotto Then Exit For
	Next
	Call ScriviResoconto
End Sub
Function IsAmboTrasposto(aNumAmbo,aNumAmboT,bQualsiasiDisp)
	Dim b
	b = False
	If aNumAmboT(1) > 0 And aNumAmboT(2) > 0 Then
		If aNumAmboT(1) = Trasposizione(aNumAmbo(1),aNumAmbo(2)) Then
			If aNumAmboT(2) = Trasposizione(aNumAmbo(2),aNumAmbo(1)) Then
				b = True
			End If
		ElseIf aNumAmboT(1) = Trasposizione(aNumAmbo(2),aNumAmbo(1)) Then
			If bQualsiasiDisp Then
				If aNumAmboT(2) = Trasposizione(aNumAmbo(1),aNumAmbo(2)) Then
					b = True
				End If
			End If
		End If
	End If
	IsAmboTrasposto = b
End Function
 
LuigiB ha scritto:
Ciao a tutti , un saluto ai nuovi utenti.
con poche modifiche lo script che avevo fatto sembra che vada bene.C'è solo un fatto dato che non hai spiegato cosa si intende per figura armonica ho dato io una mia interpretazione da fornire al povero computer (per lui armonico puo voler dir tutto e puo voler dir niente) .
Io ho interperetato l'armonia in questo modo , dati i 4 numeri del'ambo trasposto , e ordinati gli stessi in modo crescente
si otterrà una nuova sequenza questa volta composta da 6 numeri ottenuti inserendo 2 nuovi numeri tra il primo e il secondo
e tra il terzo e e quarto dei 4 numeri originali.
Questi due nuovi numeri sono calcolati sommando al primo la distanza fratto 2 tra il primo e il secondo (o sommando al terzo la distanza/2 tra il terzo e il quarto)
Questi 2 nuovi numeri sono giocati per ambo secco sulle 2 ruote.

image.jpg


Codice: 
Option Explicit
Class clsAmbo
	Private aAmbi
	Private IdEstrazione
	Private IdRuota
	Sub GeneraAmbi(idEstr,Ruota)
		IdEstrazione = idEstr
		IdRuota = Ruota
		ReDim aN(0)
		Call GetArrayNumeriRuota(IdEstrazione,IdRuota,aN)
		'Call OrdinaMatrice ( aN ,1)
		If aN(1) > 0 Then
			aAmbi = SviluppoIntegrale(aN,2)
		Else
			ReDim aAmbi(0)
		End If
	End Sub
	Function GetQuantitaAmbi
		GetQuantitaAmbi = UBound(aAmbi)
	End Function
	Function GetAmbo(idAmbo)
		ReDim aN(2)
		aN(1) = aAmbi(idAmbo,1)
		aN(2) = aAmbi(idAmbo,2)
		GetAmbo = aN
	End Function
	Function GetRuota
		GetRuota = IdRuota
	End Function
End Class
Class clsQuartinaAmboTrasposto
	Private aNum(4)
	Public Ruota1
	Public Ruota2
	Public IdEstrazione
	Sub SetNumeri(aNumAmboR1,aNumAmboR2)
		Dim k
		For k = 1 To 4
			If k <= 2 Then
				aNum(k) = aNumAmboR1(k)
			Else
				aNum(k) = aNumAmboR2(k - 2)
			End If
		Next
	End Sub
	Function GetNumeri()
		ReDim aNumTmp(UBound(aNum))
		Dim k
		For k = 0 To UBound(aNum)
			aNumTmp(k) = aNum(k)
		Next
		GetNumeri = aNumTmp
	End Function
	Function GetRuote()
		ReDim aRuote(2)
		aRuote(1) = Ruota1
		aRuote(2) = Ruota2
		GetRuote = aRuote
	End Function
	Function IsSommaPari()
		If pari(aNum(1) + aNum(2)) Then
			If pari(aNum(3) + aNum(4)) Then
				IsSommaPari = True
			End If
		End If
	End Function
	Function QuantitaNumeriDiversi
		Dim aTmp
		Dim k,t
		aTmp = aNum
		t = 0
		Call EliminaRipetuti(aTmp)
		For k = 1 To UBound(aTmp)
			If aTmp(k) <> 0 Then
				t = t + 1
			End If
		Next
		QuantitaNumeriDiversi = t
	End Function
End Class
Sub Main
	Dim idEstr,Ruota
	Dim Inizio,Fine
	Dim r,rr,i,ii
	Dim aNumAmbo,aNumAmboT
	Dim nDiff,nSomma
	ReDim acAmbiRuota(11)
	Dim nCasi
	Dim bQualsiasiDisp
	Dim nCasiParz
	Dim bEseguiGiocate
	Dim bEseguiStatistica
	Dim CollCasiRilevati
	Dim clsQuartina
	Inizio = EstrazioneIni
	Fine = EstrazioneFin
	bQualsiasiDisp = False
	bEseguiGiocate = True
	bEseguiStatistica = True
	nCasi = 0
	'	If MsgBox("Considerare gli ambi trasposti a prescindere dalla disposizione fisica dei numeri usciti ?",vbQuestion + vbYesNo) = vbYes Then
	'		bQualsiasiDisp = True
	'	End If
	For idEstr = Inizio To Fine
		i = 0
		nCasiParz = 0
		' prima genero per ogni ruota tutti gli ambi costituiti dai nuemeri estratti
		For r = 1 To 12
			If r <> 11 Then
				i = i + 1
				Set acAmbiRuota(i) = New clsAmbo
				Call acAmbiRuota(i).GeneraAmbi(idEstr,r)
			End If
		Next
		' poi ricerco gli ambi trasposti tra 2 ruote
		Set CollCasiRilevati = GetNewCollection
		For r = 1 To 10
			For rr = r + 1 To 11
				Call Messaggio("Estrazione : " & idEstr & " confronto ruote : " & SiglaRuota(acAmbiRuota(r).GetRuota) & " --> " & SiglaRuota(acAmbiRuota(rr).GetRuota))
				For i = 1 To acAmbiRuota(r).GetQuantitaAmbi
					aNumAmbo = acAmbiRuota(r).Getambo(i)
					For ii = 1 To acAmbiRuota(rr).GetQuantitaAmbi
						aNumAmboT = acAmbiRuota(rr).Getambo(ii)
						If IsAmboTrasposto(aNumAmbo,aNumAmboT,bQualsiasiDisp) Then
							Set clsQuartina = New clsQuartinaAmboTrasposto
							clsQuartina.Ruota1 = acAmbiRuota(r).GetRuota
							clsQuartina.Ruota2 = acAmbiRuota(rr).GetRuota
							clsQuartina.IdEstrazione = idEstr
							Call clsQuartina.SetNumeri(aNumAmbo,aNumAmboT)
							CollCasiRilevati.add clsQuartina
							If CollCasiRilevati.Count > 1 Then Exit For
						End If
					Next
				Next
				If CollCasiRilevati.Count > 1 Then Exit For
			Next
			If CollCasiRilevati.Count > 1 Then Exit For
		Next
		If CollCasiRilevati.Count = 1 Then
			Set clsQuartina = CollCasiRilevati(1)
			If clsQuartina.IsSommaPari Then
				If clsQuartina.QuantitaNumeriDiversi = 4 Then
					Dim aNumQ
					ReDim aNumC(6)
					ReDim aNumQ(0)
					aNumQ = clsQuartina.GetNumeri
					Call OrdinaMatrice(aNumQ,1)
					aNumC(1) = aNumQ(1)
					aNumC(2) = Fuori90(aNumQ(1) + Distanza(aNumQ(1),aNumQ(2))/2)
					aNumC(3) = aNumQ(2)
					aNumC(4) = aNumQ(3)
					aNumC(5) = Fuori90(aNumQ(3) + Distanza(aNumQ(3),aNumQ(4))/2)
					aNumC(6) = aNumQ(4)
					Call Scrivi("Estrazione " & GetInfoEstrazione(idEstr))
					Call Scrivi("Ruote " & SiglaRuota(clsQuartina.Ruota1) & " - " & SiglaRuota(clsQuartina.Ruota2))
					Call Scrivi(StringaNumeri(clsQuartina.GetNumeri))
					Call DisegnaCerchioCiclometrico(aNumC)
					ReDim aNum(2)
					aNum(1) = aNumC(2)
					aNum(2) = aNumC(5)
					ReDim aRuote(2)
					aRuote(1) = clsQuartina.ruota1
					aRuote(2) = clsQuartina.ruota2
					ReDim aPoste(2)
					aPoste(2) = 1
					nCasi = nCasi + 1
					nCasiParz = nCasiParz + 1
					'Call Scrivi(String(50,"=") & " Caso " & FormatSpace(nCasi,5,True))
					'Call Scrivi("Estrazione : " & GetInfoEstrazione(idEstr))
					'Call Scrivi("Condizione : " & SiglaRuota(aRuote(1)) & " " & StringaNumeri(aNumAmbo) & " - " & SiglaRuota(aRuote(2)) & " " & StringaNumeri(aNumAmboT))
					Call ImpostaGiocata(nCasi,aNum,aRuote,aPoste,13,2)
					Call Gioca(idEstr)
				End If
			End If
		End If
		'If nCasiParz > 0 And bEseguiGiocate Then
		'	Call Gioca(idEstr)
		'End If
		Call AvanzamentoElab(Inizio,Fine,idEstr)
		If ScriptInterrotto Then Exit For
	Next
	Call ScriviResoconto
End Sub
Function IsAmboTrasposto(aNumAmbo,aNumAmboT,bQualsiasiDisp)
	Dim b
	b = False
	If aNumAmboT(1) > 0 And aNumAmboT(2) > 0 Then
		If aNumAmboT(1) = Trasposizione(aNumAmbo(1),aNumAmbo(2)) Then
			If aNumAmboT(2) = Trasposizione(aNumAmbo(2),aNumAmbo(1)) Then
				b = True
			End If
		ElseIf aNumAmboT(1) = Trasposizione(aNumAmbo(2),aNumAmbo(1)) Then
			If bQualsiasiDisp Then
				If aNumAmboT(2) = Trasposizione(aNumAmbo(1),aNumAmbo(2)) Then
					b = True
				End If
			End If
		End If
	End If
	IsAmboTrasposto = b
End Function
Clicca per espandere...

Ciao Luigi , intanto grazie , nella mia figura armonica , il risultato dei due vertici è sempre ed esclusivamente un ambo diametrale , da porre in gioco sulle due ruote e tutte , l'esempio da me descritto sopra lo spiega facilmente , almeno spero. Tento di spiegare ancora meglio , inscrivendo i numeri dell'esmpio sul cerchio , otteniamo un rettangonlo con distanze 4.36.4.44 ora noi dobbiamo agire sulle due distanze 36 e 44 ecco il motivo di somma pari che dividendole a metà ci darà i numeri 18.63 che metteremo in gioco sulle due ruote e TT per 13 colpi. Spero sia possibile. Buona giornata.

Mauro:)
 
Ultima modifica:
vedi se cosi va bene. Ciao

Codice: 
Option Explicit
Class clsAmbo
	Private aAmbi
	Private IdEstrazione
	Private IdRuota
	Sub GeneraAmbi(idEstr,Ruota)
		IdEstrazione = idEstr
		IdRuota = Ruota
		ReDim aN(0)
		Call GetArrayNumeriRuota(IdEstrazione,IdRuota,aN)
		'Call OrdinaMatrice ( aN ,1)
		If aN(1) > 0 Then
			aAmbi = SviluppoIntegrale(aN,2)
		Else
			ReDim aAmbi(0)
		End If
	End Sub
	Function GetQuantitaAmbi
		GetQuantitaAmbi = UBound(aAmbi)
	End Function
	Function GetAmbo(idAmbo)
		ReDim aN(2)
		aN(1) = aAmbi(idAmbo,1)
		aN(2) = aAmbi(idAmbo,2)
		GetAmbo = aN
	End Function
	Function GetRuota
		GetRuota = IdRuota
	End Function
End Class
Class clsQuartinaAmboTrasposto
	Private aNum(4)
	Public Ruota1
	Public Ruota2
	Public IdEstrazione
	Sub SetNumeri(aNumAmboR1,aNumAmboR2)
		Dim k
		For k = 1 To 4
			If k <= 2 Then
				aNum(k) = aNumAmboR1(k)
			Else
				aNum(k) = aNumAmboR2(k - 2)
			End If
		Next
	End Sub
	Function GetNumeri()
		ReDim aNumTmp(UBound(aNum))
		Dim k
		For k = 0 To UBound(aNum)
			aNumTmp(k) = aNum(k)
		Next
		GetNumeri = aNumTmp
	End Function
	Function GetRuote()
		ReDim aRuote(2)
		aRuote(1) = Ruota1
		aRuote(2) = Ruota2
		GetRuote = aRuote
	End Function
	Function IsSommaPari()
		If pari(aNum(1) + aNum(2)) Then
			If pari(aNum(3) + aNum(4)) Then
				IsSommaPari = True
			End If
		End If
	End Function
	Function QuantitaNumeriDiversi
		Dim aTmp
		Dim k,t
		aTmp = aNum
		t = 0
		Call EliminaRipetuti(aTmp)
		For k = 1 To UBound(aTmp)
			If aTmp(k) <> 0 Then
				t = t + 1
			End If
		Next
		QuantitaNumeriDiversi = t
	End Function
End Class
Sub Main
	Dim idEstr,Ruota
	Dim Inizio,Fine
	Dim r,rr,i,ii,k
	Dim aNumAmbo,aNumAmboT
	Dim nDiff,nSomma
	ReDim acAmbiRuota(11)
	Dim nCasi
	Dim bQualsiasiDisp
	Dim nCasiParz
	Dim bEseguiGiocate
	Dim bEseguiStatistica
	Dim CollCasiRilevati
	Dim clsQuartina
	Dim n1,n2
	Dim clsDisegno , collFigure 
	
	Inizio = EstrazioneIni
	Fine = EstrazioneFin
	bQualsiasiDisp = False
	bEseguiGiocate = True
	bEseguiStatistica = True
	nCasi = 0
	'	If MsgBox("Considerare gli ambi trasposti a prescindere dalla disposizione fisica dei numeri usciti ?",vbQuestion + vbYesNo) = vbYes Then
	'		bQualsiasiDisp = True
	'	End If
	For idEstr = Inizio To Fine
		i = 0
		nCasiParz = 0
		' prima genero per ogni ruota tutti gli ambi costituiti dai nuemeri estratti
		For r = 1 To 12
			If r <> 11 Then
				i = i + 1
				Set acAmbiRuota(i) = New clsAmbo
				Call acAmbiRuota(i).GeneraAmbi(idEstr,r)
			End If
		Next
		' poi ricerco gli ambi trasposti tra 2 ruote
		Set CollCasiRilevati = GetNewCollection
		For r = 1 To 10
			For rr = r + 1 To 11
				Call Messaggio("Estrazione : " & idEstr & " confronto ruote : " & SiglaRuota(acAmbiRuota(r).GetRuota) & " --> " & SiglaRuota(acAmbiRuota(rr).GetRuota))
				For i = 1 To acAmbiRuota(r).GetQuantitaAmbi
					aNumAmbo = acAmbiRuota(r).Getambo(i)
					For ii = 1 To acAmbiRuota(rr).GetQuantitaAmbi
						aNumAmboT = acAmbiRuota(rr).Getambo(ii)
						If IsAmboTrasposto(aNumAmbo,aNumAmboT,bQualsiasiDisp) Then
							Set clsQuartina = New clsQuartinaAmboTrasposto
							clsQuartina.Ruota1 = acAmbiRuota(r).GetRuota
							clsQuartina.Ruota2 = acAmbiRuota(rr).GetRuota
							clsQuartina.IdEstrazione = idEstr
							Call clsQuartina.SetNumeri(aNumAmbo,aNumAmboT)
							CollCasiRilevati.add clsQuartina
							If CollCasiRilevati.Count > 1 Then Exit For
						End If
					Next
				Next
				If CollCasiRilevati.Count > 1 Then Exit For
			Next
			If CollCasiRilevati.Count > 1 Then Exit For
		Next
		If CollCasiRilevati.Count = 1 Then
			Set clsQuartina = CollCasiRilevati(1)
			If clsQuartina.IsSommaPari Then
				If clsQuartina.QuantitaNumeriDiversi = 4 Then
					Dim aNumQ
					ReDim aNumC(6)
					ReDim aNumQ(0)
					aNumQ = clsQuartina.GetNumeri
					Call GetAmboDaGiocare(aNumQ,n1,n2)
					If n1 > 0 And n2 > 0 Then
						aNumC(1) = aNumQ(1)
						aNumC(2) = aNumQ(2)
						aNumC(3) = aNumQ(3)
						aNumC(4) = aNumQ(4)
						aNumC(5) = n1
						aNumC(6) = n2
						Call Scrivi("Estrazione " & GetInfoEstrazione(idEstr))
						Call Scrivi("Ruote " & SiglaRuota(clsQuartina.Ruota1) & " - " & SiglaRuota(clsQuartina.Ruota2))
						Call Scrivi(StringaNumeri(clsQuartina.GetNumeri))
						
						' eventualmente per far apparire anche la figura ottenuta con i numeri in gioco
						' levare i commenti lle linee successive
						
						'Set clsDisegno = GetNewDisegnoCiclometrico
						'For k = 1 To 6
						'	clsDisegno.AddNumero(aNumC (k))
						'Next
						'clsDisegno.ColoreBordo = vbCyan
						'Set collFigure = GetNewCollection
						'collFigure.add clsDisegno
						'Call DisegnaCerchioCiclometrico(aNumQ,True,,,collFigure )
						
						' disegna i 4 numeri dell'ambo trasposto nel cerchio e mostra le distanze
						Call DisegnaCerchioCiclometrico(aNumQ,True )
						
						' disegna il cerchio con la figura ottenuta considerando anche i numeri in gioco
						'Call DisegnaCerchioCiclometrico(aNumC )

						ReDim aNum(2)
						aNum(1) = n1
						aNum(2) = n2
						ReDim aRuote(3)
						aRuote(1) = clsQuartina.ruota1
						aRuote(2) = clsQuartina.ruota2
						aRuote(3) = TU_
						ReDim aPoste(2)
						aPoste(2) = 1
						nCasi = nCasi + 1
						nCasiParz = nCasiParz + 1
						'Call Scrivi(String(50,"=") & " Caso " & FormatSpace(nCasi,5,True))
						'Call Scrivi("Estrazione : " & GetInfoEstrazione(idEstr))
						'Call Scrivi("Condizione : " & SiglaRuota(aRuote(1)) & " " & StringaNumeri(aNumAmbo) & " - " & SiglaRuota(aRuote(2)) & " " & StringaNumeri(aNumAmboT))
						Call ImpostaGiocata(nCasi,aNum,aRuote,aPoste,13,2)
						Call Gioca(idEstr)
					End If
				End If
			End If
		End If
		'If nCasiParz > 0 And bEseguiGiocate Then
		'	Call Gioca(idEstr)
		'End If
		Call AvanzamentoElab(Inizio,Fine,idEstr)
		If ScriptInterrotto Then Exit For
	Next
	Call ScriviResoconto
End Sub
Function IsAmboTrasposto(aNumAmbo,aNumAmboT,bQualsiasiDisp)
	Dim b
	b = False
	If aNumAmboT(1) > 0 And aNumAmboT(2) > 0 Then
		If aNumAmboT(1) = Trasposizione(aNumAmbo(1),aNumAmbo(2)) Then
			If aNumAmboT(2) = Trasposizione(aNumAmbo(2),aNumAmbo(1)) Then
				b = True
			End If
		ElseIf aNumAmboT(1) = Trasposizione(aNumAmbo(2),aNumAmbo(1)) Then
			If bQualsiasiDisp Then
				If aNumAmboT(2) = Trasposizione(aNumAmbo(1),aNumAmbo(2)) Then
					b = True
				End If
			End If
		End If
	End If
	IsAmboTrasposto = b
End Function
Function GetAmboDaGiocare(aNumQ,n1,n2)
	Dim d
	ReDim aQDist(45)
	Dim k
	n1 = 0
	n2 = 0
	Call OrdinaMatrice(aNumQ,1)
	d = Distanza(aNumQ(1),aNumQ(2))
	aQDist(d) = aQDist(d) + 1
	d = Distanza(aNumQ(2),aNumQ(3))
	aQDist(d) = aQDist(d) + 1
	d = Distanza(aNumQ(3),aNumQ(4))
	aQDist(d) = aQDist(d) + 1
	d = Distanza(aNumQ(4),aNumQ(1))
	aQDist(d) = aQDist(d) + 1
	For k = 1 To 45
		If aQDist(k) = 1 Then
			If n1 = 0 Then
				n1 = k / 2
			Else
				n2 = k / 2
			End If
		End If
	Next
End Function
 
vedi se cosi va bene. Ciao

Codice: 
Option Explicit
Class clsAmbo
	Private aAmbi
	Private IdEstrazione
	Private IdRuota
	Sub GeneraAmbi(idEstr,Ruota)
		IdEstrazione = idEstr
		IdRuota = Ruota
		ReDim aN(0)
		Call GetArrayNumeriRuota(IdEstrazione,IdRuota,aN)
		'Call OrdinaMatrice ( aN ,1)
		If aN(1) > 0 Then
			aAmbi = SviluppoIntegrale(aN,2)
		Else
			ReDim aAmbi(0)
		End If
	End Sub
	Function GetQuantitaAmbi
		GetQuantitaAmbi = UBound(aAmbi)
	End Function
	Function GetAmbo(idAmbo)
		ReDim aN(2)
		aN(1) = aAmbi(idAmbo,1)
		aN(2) = aAmbi(idAmbo,2)
		GetAmbo = aN
	End Function
	Function GetRuota
		GetRuota = IdRuota
	End Function
End Class
Class clsQuartinaAmboTrasposto
	Private aNum(4)
	Public Ruota1
	Public Ruota2
	Public IdEstrazione
	Sub SetNumeri(aNumAmboR1,aNumAmboR2)
		Dim k
		For k = 1 To 4
			If k <= 2 Then
				aNum(k) = aNumAmboR1(k)
			Else
				aNum(k) = aNumAmboR2(k - 2)
			End If
		Next
	End Sub
	Function GetNumeri()
		ReDim aNumTmp(UBound(aNum))
		Dim k
		For k = 0 To UBound(aNum)
			aNumTmp(k) = aNum(k)
		Next
		GetNumeri = aNumTmp
	End Function
	Function GetRuote()
		ReDim aRuote(2)
		aRuote(1) = Ruota1
		aRuote(2) = Ruota2
		GetRuote = aRuote
	End Function
	Function IsSommaPari()
		If pari(aNum(1) + aNum(2)) Then
			If pari(aNum(3) + aNum(4)) Then
				IsSommaPari = True
			End If
		End If
	End Function
	Function QuantitaNumeriDiversi
		Dim aTmp
		Dim k,t
		aTmp = aNum
		t = 0
		Call EliminaRipetuti(aTmp)
		For k = 1 To UBound(aTmp)
			If aTmp(k) <> 0 Then
				t = t + 1
			End If
		Next
		QuantitaNumeriDiversi = t
	End Function
End Class
Sub Main
	Dim idEstr,Ruota
	Dim Inizio,Fine
	Dim r,rr,i,ii,k
	Dim aNumAmbo,aNumAmboT
	Dim nDiff,nSomma
	ReDim acAmbiRuota(11)
	Dim nCasi
	Dim bQualsiasiDisp
	Dim nCasiParz
	Dim bEseguiGiocate
	Dim bEseguiStatistica
	Dim CollCasiRilevati
	Dim clsQuartina
	Dim n1,n2
	Dim clsDisegno , collFigure 
	
	Inizio = EstrazioneIni
	Fine = EstrazioneFin
	bQualsiasiDisp = False
	bEseguiGiocate = True
	bEseguiStatistica = True
	nCasi = 0
	'	If MsgBox("Considerare gli ambi trasposti a prescindere dalla disposizione fisica dei numeri usciti ?",vbQuestion + vbYesNo) = vbYes Then
	'		bQualsiasiDisp = True
	'	End If
	For idEstr = Inizio To Fine
		i = 0
		nCasiParz = 0
		' prima genero per ogni ruota tutti gli ambi costituiti dai nuemeri estratti
		For r = 1 To 12
			If r <> 11 Then
				i = i + 1
				Set acAmbiRuota(i) = New clsAmbo
				Call acAmbiRuota(i).GeneraAmbi(idEstr,r)
			End If
		Next
		' poi ricerco gli ambi trasposti tra 2 ruote
		Set CollCasiRilevati = GetNewCollection
		For r = 1 To 10
			For rr = r + 1 To 11
				Call Messaggio("Estrazione : " & idEstr & " confronto ruote : " & SiglaRuota(acAmbiRuota(r).GetRuota) & " --> " & SiglaRuota(acAmbiRuota(rr).GetRuota))
				For i = 1 To acAmbiRuota(r).GetQuantitaAmbi
					aNumAmbo = acAmbiRuota(r).Getambo(i)
					For ii = 1 To acAmbiRuota(rr).GetQuantitaAmbi
						aNumAmboT = acAmbiRuota(rr).Getambo(ii)
						If IsAmboTrasposto(aNumAmbo,aNumAmboT,bQualsiasiDisp) Then
							Set clsQuartina = New clsQuartinaAmboTrasposto
							clsQuartina.Ruota1 = acAmbiRuota(r).GetRuota
							clsQuartina.Ruota2 = acAmbiRuota(rr).GetRuota
							clsQuartina.IdEstrazione = idEstr
							Call clsQuartina.SetNumeri(aNumAmbo,aNumAmboT)
							CollCasiRilevati.add clsQuartina
							If CollCasiRilevati.Count > 1 Then Exit For
						End If
					Next
				Next
				If CollCasiRilevati.Count > 1 Then Exit For
			Next
			If CollCasiRilevati.Count > 1 Then Exit For
		Next
		If CollCasiRilevati.Count = 1 Then
			Set clsQuartina = CollCasiRilevati(1)
			If clsQuartina.IsSommaPari Then
				If clsQuartina.QuantitaNumeriDiversi = 4 Then
					Dim aNumQ
					ReDim aNumC(6)
					ReDim aNumQ(0)
					aNumQ = clsQuartina.GetNumeri
					Call GetAmboDaGiocare(aNumQ,n1,n2)
					If n1 > 0 And n2 > 0 Then
						aNumC(1) = aNumQ(1)
						aNumC(2) = aNumQ(2)
						aNumC(3) = aNumQ(3)
						aNumC(4) = aNumQ(4)
						aNumC(5) = n1
						aNumC(6) = n2
						Call Scrivi("Estrazione " & GetInfoEstrazione(idEstr))
						Call Scrivi("Ruote " & SiglaRuota(clsQuartina.Ruota1) & " - " & SiglaRuota(clsQuartina.Ruota2))
						Call Scrivi(StringaNumeri(clsQuartina.GetNumeri))
						
						' eventualmente per far apparire anche la figura ottenuta con i numeri in gioco
						' levare i commenti lle linee successive
						
						'Set clsDisegno = GetNewDisegnoCiclometrico
						'For k = 1 To 6
						'	clsDisegno.AddNumero(aNumC (k))
						'Next
						'clsDisegno.ColoreBordo = vbCyan
						'Set collFigure = GetNewCollection
						'collFigure.add clsDisegno
						'Call DisegnaCerchioCiclometrico(aNumQ,True,,,collFigure )
						
						' disegna i 4 numeri dell'ambo trasposto nel cerchio e mostra le distanze
						Call DisegnaCerchioCiclometrico(aNumQ,True )
						
						' disegna il cerchio con la figura ottenuta considerando anche i numeri in gioco
						'Call DisegnaCerchioCiclometrico(aNumC )

						ReDim aNum(2)
						aNum(1) = n1
						aNum(2) = n2
						ReDim aRuote(3)
						aRuote(1) = clsQuartina.ruota1
						aRuote(2) = clsQuartina.ruota2
						aRuote(3) = TU_
						ReDim aPoste(2)
						aPoste(2) = 1
						nCasi = nCasi + 1
						nCasiParz = nCasiParz + 1
						'Call Scrivi(String(50,"=") & " Caso " & FormatSpace(nCasi,5,True))
						'Call Scrivi("Estrazione : " & GetInfoEstrazione(idEstr))
						'Call Scrivi("Condizione : " & SiglaRuota(aRuote(1)) & " " & StringaNumeri(aNumAmbo) & " - " & SiglaRuota(aRuote(2)) & " " & StringaNumeri(aNumAmboT))
						Call ImpostaGiocata(nCasi,aNum,aRuote,aPoste,13,2)
						Call Gioca(idEstr)
					End If
				End If
			End If
		End If
		'If nCasiParz > 0 And bEseguiGiocate Then
		'	Call Gioca(idEstr)
		'End If
		Call AvanzamentoElab(Inizio,Fine,idEstr)
		If ScriptInterrotto Then Exit For
	Next
	Call ScriviResoconto
End Sub
Function IsAmboTrasposto(aNumAmbo,aNumAmboT,bQualsiasiDisp)
	Dim b
	b = False
	If aNumAmboT(1) > 0 And aNumAmboT(2) > 0 Then
		If aNumAmboT(1) = Trasposizione(aNumAmbo(1),aNumAmbo(2)) Then
			If aNumAmboT(2) = Trasposizione(aNumAmbo(2),aNumAmbo(1)) Then
				b = True
			End If
		ElseIf aNumAmboT(1) = Trasposizione(aNumAmbo(2),aNumAmbo(1)) Then
			If bQualsiasiDisp Then
				If aNumAmboT(2) = Trasposizione(aNumAmbo(1),aNumAmbo(2)) Then
					b = True
				End If
			End If
		End If
	End If
	IsAmboTrasposto = b
End Function
Function GetAmboDaGiocare(aNumQ,n1,n2)
	Dim d
	ReDim aQDist(45)
	Dim k
	n1 = 0
	n2 = 0
	Call OrdinaMatrice(aNumQ,1)
	d = Distanza(aNumQ(1),aNumQ(2))
	aQDist(d) = aQDist(d) + 1
	d = Distanza(aNumQ(2),aNumQ(3))
	aQDist(d) = aQDist(d) + 1
	d = Distanza(aNumQ(3),aNumQ(4))
	aQDist(d) = aQDist(d) + 1
	d = Distanza(aNumQ(4),aNumQ(1))
	aQDist(d) = aQDist(d) + 1
	For k = 1 To 45
		If aQDist(k) = 1 Then
			If n1 = 0 Then
				n1 = k / 2
			Else
				n2 = k / 2
			End If
		End If
	Next
End Function
 
Bem tornato Luigi B,Grazie per tutto quello che fai per noi,solo una semplice domanda ,ho scaricato lo Script che gentilmente hai costruito,per favore mi puoi indicare come fare per iniziare a far girare lo script dalle ultime 100 estrazioni? perchè quando lo avvio parte dalla prima estrazione del 1871 .
Grazie se mi puoi rispondere
Saluti
Serpico
 
lo script prende il range direttamente dal programma percio ti basta impostare col mouse le estrazioni del range quelle della barra rosa in basso , imposti quellle e vedrai che lo script girerà con quelle , ciao
 
Grazie Luigi,come diceva un noto attore SEI TROPPO FORTEEEEEEEE.
Ho risolto ,come al solito anche CHIARO nell'esposizione.
Ti auguro tanta serenità
Buona domenica
Saluti
Serpico
 
Ciao Luigi , intanto grazie , nella mia figura armonica , il risultato dei due vertici è sempre ed esclusivamente un ambo diametrale , da porre in gioco sulle due ruote e tutte , l'esempio da me descritto sopra lo spiega facilmente , almeno spero. Tento di spiegare ancora meglio , inscrivendo i numeri dell'esmpio sul cerchio , otteniamo un rettangonlo con distanze 4.36.4.44 ora noi dobbiamo agire sulle due distanze 36 e 44 ecco il motivo di somma pari che dividendole a metà ci darà i numeri 18.63 che metteremo in gioco sulle due ruote e TT per 13 colpi. Spero sia possibile. Buona giornata.

Mauro

Ciao Luigi , forse sono io che mi esprimo male ma l'ambo da giocare deve essere sempre un ambo diametrale cioè distanza 45 come da esempio. Fai con tutta calma , non voglio portarti via tutto il tuo tempo.
 
avevo capito che bisognava dividere le distanze per 2 ... vabbe la modifica riguarda 2 o 3 linee pure di meno la lascio agli interessati
 
Devi accedere o registrarti per poter rispondere.

Ultima estrazione Lotto

  • Estrazione del lotto
    giovedì 31 luglio 2025
    Bari
    42
    35
    89
    51
    34
    Cagliari
    54
    34
    02
    77
    57
    Firenze
    73
    01
    07
    15
    04
    Genova
    71
    28
    17
    03
    67
    Milano
    72
    37
    26
    09
    63
    Napoli
    04
    46
    83
    68
    31
    Palermo
    62
    18
    36
    34
    52
    Roma
    37
    44
    49
    67
    32
    Torino
    51
    17
    56
    48
    41
    Venezia
    36
    04
    85
    81
    41
    Nazionale
    08
    52
    01
    24
    05
    Estrazione Simbolotto
    Nazionale
    21
    19
    01
    17
    43
    Archivio estrazioni lotto Ritardi top 15 Frequenze top 15

Ultimi Messaggi

Indietro
Alto