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
    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