Chi riesce a fare lo script da un vecchio metodo?

[InRicordo]

Option Explicit

Const DEFAULT_INIZIO = 1000
Const DEFAULT_COLPI_GIOCO = 12
Const DEFAULT_RITROSO = 3

Const RUOTE_DIVERSE = True
Const EVITA_DUPLICATI = True
Const USA_TABELLA = True
Const USA_GIOCATE_NATIVE = True
Const USA_GRAFICI = True

Sub Main()

Dim Es, Ini, Fin, Es2, EsMin
Dim R1, R2
Dim P1, P2, P3, P4
Dim A, B, C, D
Dim Capogioco, Doppio, Diam
Dim Caso, Casi
Dim Clp1, Ind

Dim Num(5), Nu(5)

Dim Ambata(1)
Dim Ambo1(2), Ambo2(2), Terno(3)
Dim Ruo(2)
Dim PostaAmb(1), PostaAmbo(2), PostaTerno(3)

Dim aTitoli, aRiga
Dim Chiave, SaltaCaso

Dim aKey(), nKey, capKey

Dim aPairLab(), aPairCnt(), nPair, capPair
Dim aCapLab(), aCapCnt(), nCap, capCap
Dim aCinLab(), aCinCnt(), nCin, capCin
Dim aRuotaLab(), aRuotaCnt(), nRuota, capRuota

Dim ColpoAmb, ColpoA1, ColpoA2, ColpoT
Dim TotAmb, TotA1, TotA2, TotT
Dim SommaAmb, SommaA1, SommaA2, SommaT

PostaAmb(1) = 1
PostaAmbo(2) = 1
PostaTerno(2) = 1
PostaTerno(3) = 1

Fin = EstrazioneFin

Ini = InputNumero("Inserisci l'estrazione iniziale", "Metodo Salvo50 , con percentuali", DEFAULT_INIZIO)
Clp1 = InputNumero("Per quanti colpi vuoi verificare?", "Colpi di gioco", DEFAULT_COLPI_GIOCO)
Ind = InputNumero("Quante estrazioni a ritroso vuoi cercare gli ambi?", "Estrazioni a ritroso", DEFAULT_RITROSO)

If Clp1 < 1 Then Clp1 = DEFAULT_COLPI_GIOCO
If Ind < 0 Then Ind = DEFAULT_RITROSO

Call ScegliRange(Ini, Fin, Ini, Fin)

capKey = 256
ReDim aKey(capKey)
nKey = 0

capPair = 128
ReDim aPairLab(capPair)
ReDim aPairCnt(capPair)
nPair = 0

capCap = 128
ReDim aCapLab(capCap)
ReDim aCapCnt(capCap)
nCap = 0

capCin = 128
ReDim aCinLab(capCin)
ReDim aCinCnt(capCin)
nCin = 0

capRuota = 128
ReDim aRuotaLab(capRuota)
ReDim aRuotaCnt(capRuota)
nRuota = 0

If USA_TABELLA Then

ReDim aTitoli(19)

aTitoli(1) = "Caso"
aTitoli(2) = "Estrazione 1"
aTitoli(3) = "Ruota 1"
aTitoli(4) = "Ambo 1"
aTitoli(5) = "Estrazione 2"
aTitoli(6) = "Ruota 2"
aTitoli(7) = "Ambo 2"
aTitoli(8) = "Cinquina"
aTitoli(9) = "Capogioco"
aTitoli(10) = "Doppio"
aTitoli(11) = "Diametrale"
aTitoli(12) = "Ambata"
aTitoli(13) = "Ambo A"
aTitoli(14) = "Ambo B"
aTitoli(15) = "Terno"
aTitoli(16) = "Esito Ambata"
aTitoli(17) = "Esito Ambo A"
aTitoli(18) = "Esito Ambo B"
aTitoli(19) = "Esito Terno"

Call InitTabella(aTitoli, vbCyan)

End If

Scrivi "Metodo Salvo50 - Cinquine Pentagonali - Versione percentuali", 1
Scrivi "Logica originale mantenuta: distanza 18/36, ricerca a ritroso, ruote diverse.", 1
Scrivi "Range: " & InfoEstrazione(Ini) & " -> " & InfoEstrazione(Fin), 1
Scrivi "Colpi verifica: " & Clp1 & " | Ritroso: " & Ind, 1
Scrivi

Casi = 0

For Es = Ini To Fin

AvanzamentoElab Ini, Fin, Es
Caso = 0

For R1 = 1 To 12

If R1 <> 11 Then

For P1 = 1 To 4

For P2 = P1 + 1 To 5

A = Estratto(Es, R1, P1)
B = Estratto(Es, R1, P2)

If IsDistanzaPentagonale(A, B) Then

EsMin = Es - Ind

If EsMin < EstrazioneIni Then
EsMin = EstrazioneIni
End If

For Es2 = Es To EsMin Step -1

For R2 = 1 To 12

If R2 <> 11 Then

If RUOTE_DIVERSE = False Or R2 <> R1 Then

For P3 = 1 To 4

For P4 = P3 + 1 To 5

C = Estratto(Es2, R2, P3)
D = Estratto(Es2, R2, P4)

If QuattroDiversi(A, B, C, D) Then

If TuttiCollegatiPentagonali(A, B, C, D) Then

Call CostruisciCinquinaPentagonale(A, Num, Nu)

Capogioco = NumeroMancanteDaCinquina(Num, A, B, C, D)

If Capogioco > 0 Then

Doppio = Fuori90(Capogioco * 2)
Diam = Diametrale(Doppio)

Chiave = ChiaveCaso(Es, R1, A, B, Es2, R2, C, D)

SaltaCaso = False

If EVITA_DUPLICATI Then

If ChiavePresente(aKey, nKey, Chiave) Then
SaltaCaso = True
Else
Call AggiungiChiave(aKey, nKey, capKey, Chiave)
End If

End If

If SaltaCaso = False Then

Caso = Caso + 1
Casi = Casi + 1

Call VerificaProduzione(Es, Clp1, R1, R2, Capogioco, Doppio, Diam, ColpoAmb, ColpoA1, ColpoA2, ColpoT)

If ColpoAmb > 0 Then
TotAmb = TotAmb + 1
SommaAmb = SommaAmb + ColpoAmb
End If

If ColpoA1 > 0 Then
TotA1 = TotA1 + 1
SommaA1 = SommaA1 + ColpoA1
End If

If ColpoA2 > 0 Then
TotA2 = TotA2 + 1
SommaA2 = SommaA2 + ColpoA2
End If

If ColpoT > 0 Then
TotT = TotT + 1
SommaT = SommaT + ColpoT
End If

Call AggiungiConteggio(aPairLab, aPairCnt, nPair, capPair, SiglaRuota(R1) & "-" & SiglaRuota(R2))
Call AggiungiConteggio(aCapLab, aCapCnt, nCap, capCap, Format2(Capogioco))
Call AggiungiConteggio(aCinLab, aCinCnt, nCin, capCin, StringaCinquinaArray(Nu))
Call AggiungiConteggio(aRuotaLab, aRuotaCnt, nRuota, capRuota, SiglaRuota(R1))
Call AggiungiConteggio(aRuotaLab, aRuotaCnt, nRuota, capRuota, SiglaRuota(R2))

If USA_TABELLA Then

ReDim aRiga(19)

aRiga(1) = Format2(Casi)

aRiga(2) = InfoEstrazione(Es)
aRiga(3) = SiglaRuota(R1)
aRiga(4) = CoppiaOrdinata(A, B)

aRiga(5) = InfoEstrazione(Es2)
aRiga(6) = SiglaRuota(R2)
aRiga(7) = CoppiaOrdinata(C, D)

aRiga(8) = StringaCinquinaArray(Nu)
aRiga(9) = Format2(Capogioco)
aRiga(10) = Format2(Doppio)
aRiga(11) = Format2(Diam)

aRiga(12) = Format2(Capogioco)
aRiga(13) = Format2(Capogioco) & "-" & Format2(Doppio)
aRiga(14) = Format2(Capogioco) & "-" & Format2(Diam)
aRiga(15) = Format2(Capogioco) & "-" & Format2(Doppio) & "-" & Format2(Diam)

aRiga(16) = TestoEsito(ColpoAmb)
aRiga(17) = TestoEsito(ColpoA1)
aRiga(18) = TestoEsito(ColpoA2)
aRiga(19) = TestoEsito(ColpoT)

Call AddRigaTabella(aRiga, , "center")

End If

If USA_GIOCATE_NATIVE Then

Ambata(1) = Capogioco

Ambo1(1) = Capogioco
Ambo1(2) = Doppio

Ambo2(1) = Capogioco
Ambo2(2) = Diam

Terno(1) = Capogioco
Terno(2) = Doppio
Terno(3) = Diam

Ruo(1) = R1
Ruo(2) = R2

ImpostaGiocata 1, Ambata, Ruo, PostaAmb, Clp1
ImpostaGiocata 2, Ambo1, Ruo, PostaAmbo, Clp1
ImpostaGiocata 3, Ambo2, Ruo, PostaAmbo, Clp1
ImpostaGiocata 4, Terno, Ruo, PostaTerno, Clp1

Gioca Es, 1

End If

End If

End If

End If

End If

Next

Next

End If

End If

Next

Next

End If

Next

Next

End If

Next

If ScriptInterrotto Then Exit Sub

Next

If Casi > 0 Then

If USA_TABELLA Then
Call CreaTabella
End If

Scrivi
Scrivi "==================== RIEPILOGO OTTIMIZZATO ====================", 1
Scrivi "Casi validi trovati: " & Casi, 1
Scrivi
Scrivi "Ambata capogioco: " & TotAmb & " su " & Casi & " (" & Percentuale(TotAmb, Casi) & ") | Media colpo: " & MediaColpo(TotAmb, SommaAmb), 1
Scrivi "Ambo A capogioco+doppio: " & TotA1 & " su " & Casi & " (" & Percentuale(TotA1, Casi) & ") | Media colpo: " & MediaColpo(TotA1, SommaA1), 1
Scrivi "Ambo B capogioco+diametrale: " & TotA2 & " su " & Casi & " (" & Percentuale(TotA2, Casi) & ") | Media colpo: " & MediaColpo(TotA2, SommaA2), 1
Scrivi "Terno capogioco+doppio+diametrale: " & TotT & " su " & Casi & " (" & Percentuale(TotT, Casi) & ") | Media colpo: " & MediaColpo(TotT, SommaT), 1
Scrivi

If USA_GRAFICI Then

Call ScriviGraficoProduzione(Casi, TotAmb, TotA1, TotA2, TotT)
Call ScriviGraficoConteggi("Coppie di ruote piu presenti", aPairLab, aPairCnt, nPair, 15)
Call ScriviGraficoConteggi("Capogiochi piu presenti", aCapLab, aCapCnt, nCap, 15)
Call ScriviGraficoConteggi("Cinquine piu presenti", aCinLab, aCinCnt, nCin, 10)
Call ScriviGraficoConteggi("Ruote piu coinvolte", aRuotaLab, aRuotaCnt, nRuota, 12)

End If

If USA_GIOCATE_NATIVE Then
Scrivi
Scrivi "==================== RESOCONTO NATIVO ====================", 1
ScriviResoconto
End If

Else

Scrivi "Nessun segnale trovato con i parametri attuali.", 1

End If

End Sub


Function InputNumero(Testo, Titolo, DefaultVal)

Dim V

V = InputBox(Testo, Titolo, DefaultVal)

If Trim(CStr(V)) = "" Then
InputNumero = DefaultVal
Exit Function
End If

If IsNumeric(V) Then
InputNumero = CLng(V)
Else
InputNumero = DefaultVal
End If

End Function


Function InfoEstrazione(ByVal Es)

InfoEstrazione = Format2(Es) & " del " & DataEstrazione(Es)

End Function


Function IsDistanzaPentagonale(ByVal N1, ByVal N2)

IsDistanzaPentagonale = False

If Distanza(N1, N2) = 18 Then
IsDistanzaPentagonale = True
Exit Function
End If

If Distanza(N1, N2) = 36 Then
IsDistanzaPentagonale = True
Exit Function
End If

End Function


Function TuttiCollegatiPentagonali(ByVal A, ByVal B, ByVal C, ByVal D)

TuttiCollegatiPentagonali = False

If IsDistanzaPentagonale(A, C) = False Then Exit Function
If IsDistanzaPentagonale(B, C) = False Then Exit Function
If IsDistanzaPentagonale(A, D) = False Then Exit Function
If IsDistanzaPentagonale(B, D) = False Then Exit Function

TuttiCollegatiPentagonali = True

End Function


Sub CostruisciCinquinaPentagonale(ByVal NBase, ByRef Num, ByRef Nu)

Dim K

Num(1) = NBase
Nu(1) = NBase

For K = 2 To 5
Num(K) = Fuori90(Num(K - 1) + 18)
Nu(K) = Num(K)
Next

OrdinaMatrice Nu, 1

End Sub


Function NumeroMancanteDaCinquina(ByRef Num, ByVal A, ByVal B, ByVal C, ByVal D)

Dim K
Dim N

NumeroMancanteDaCinquina = 0

For K = 1 To 5

N = Num(K)

If N <> A And N <> B And N <> C And N <> D Then
NumeroMancanteDaCinquina = N
Exit Function
End If

Next

End Function


Function QuattroDiversi(ByVal A, ByVal B, ByVal C, ByVal D)

QuattroDiversi = False

If A = B Then Exit Function
If A = C Then Exit Function
If A = D Then Exit Function
If B = C Then Exit Function
If B = D Then Exit Function
If C = D Then Exit Function

QuattroDiversi = True

End Function


Function CoppiaOrdinata(ByVal N1, ByVal N2)

If N1 <= N2 Then
CoppiaOrdinata = Format2(N1) & "-" & Format2(N2)
Else
CoppiaOrdinata = Format2(N2) & "-" & Format2(N1)
End If

End Function


Function StringaCinquinaArray(ByRef Nu)

StringaCinquinaArray = _
Format2(Nu(1)) & "-" & _
Format2(Nu(2)) & "-" & _
Format2(Nu(3)) & "-" & _
Format2(Nu(4)) & "-" & _
Format2(Nu(5))

End Function


Function ChiaveCaso(ByVal Es1, ByVal R1, ByVal A, ByVal B, ByVal Es2, ByVal R2, ByVal C, ByVal D)

Dim Blocco1
Dim Blocco2

Blocco1 = CStr(Es1) & "|" & SiglaRuota(R1) & "|" & CoppiaOrdinata(A, B)
Blocco2 = CStr(Es2) & "|" & SiglaRuota(R2) & "|" & CoppiaOrdinata(C, D)

If Blocco1 <= Blocco2 Then
ChiaveCaso = Blocco1 & "||" & Blocco2
Else
ChiaveCaso = Blocco2 & "||" & Blocco1
End If

End Function


Function ChiavePresente(ByRef aKey, ByVal nKey, ByVal Chiave)

Dim I

ChiavePresente = False

For I = 1 To nKey
If aKey(I) = Chiave Then
ChiavePresente = True
Exit Function
End If
Next

End Function


Sub AggiungiChiave(ByRef aKey, ByRef nKey, ByRef capKey, ByVal Chiave)

nKey = nKey + 1

If nKey > capKey Then
capKey = capKey + 256
ReDim Preserve aKey(capKey)
End If

aKey(nKey) = Chiave

End Sub


Sub AggiungiConteggio(ByRef aLab, ByRef aCnt, ByRef N, ByRef Cap, ByVal Etichetta)

Dim I

For I = 1 To N
If aLab(I) = Etichetta Then
aCnt(I) = aCnt(I) + 1
Exit Sub
End If
Next

N = N + 1

If N > Cap Then
Cap = Cap + 128
ReDim Preserve aLab(Cap)
ReDim Preserve aCnt(Cap)
End If

aLab(N) = Etichetta
aCnt(N) = 1

End Sub


Sub VerificaProduzione(ByVal EsSegnale, ByVal Colpi, ByVal R1, ByVal R2, ByVal Capogioco, ByVal Doppio, ByVal Diam, ByRef ColpoAmb, ByRef ColpoA1, ByRef ColpoA2, ByRef ColpoT)

Dim C
Dim EsControllo

ColpoAmb = 0
ColpoA1 = 0
ColpoA2 = 0
ColpoT = 0

For C = 1 To Colpi

EsControllo = EsSegnale + C

If EsControllo > EstrazioneFin Then Exit For

If ColpoAmb = 0 Then
If EsceAmbataSuRuote(EsControllo, R1, R2, Capogioco) Then
ColpoAmb = C
End If
End If

If ColpoA1 = 0 Then
If EsceAmboSuRuote(EsControllo, R1, R2, Capogioco, Doppio) Then
ColpoA1 = C
End If
End If

If ColpoA2 = 0 Then
If EsceAmboSuRuote(EsControllo, R1, R2, Capogioco, Diam) Then
ColpoA2 = C
End If
End If

If ColpoT = 0 Then
If EsceTernoSuRuote(EsControllo, R1, R2, Capogioco, Doppio, Diam) Then
ColpoT = C
End If
End If

If ColpoAmb > 0 And ColpoA1 > 0 And ColpoA2 > 0 And ColpoT > 0 Then Exit For

Next

End Sub


Function EsceAmbataSuRuote(ByVal EsControllo, ByVal R1, ByVal R2, ByVal Numero)

EsceAmbataSuRuote = False

If PresenteRuota(EsControllo, R1, Numero) Then
EsceAmbataSuRuote = True
Exit Function
End If

If R2 <> R1 Then
If PresenteRuota(EsControllo, R2, Numero) Then
EsceAmbataSuRuote = True
Exit Function
End If
End If

End Function


Function EsceAmboSuRuote(ByVal EsControllo, ByVal R1, ByVal R2, ByVal N1, ByVal N2)

EsceAmboSuRuote = False

If PresenteRuota(EsControllo, R1, N1) And PresenteRuota(EsControllo, R1, N2) Then
EsceAmboSuRuote = True
Exit Function
End If

If R2 <> R1 Then
If PresenteRuota(EsControllo, R2, N1) And PresenteRuota(EsControllo, R2, N2) Then
EsceAmboSuRuote = True
Exit Function
End If
End If

End Function


Function EsceTernoSuRuote(ByVal EsControllo, ByVal R1, ByVal R2, ByVal N1, ByVal N2, ByVal N3)

EsceTernoSuRuote = False

If PresenteRuota(EsControllo, R1, N1) And PresenteRuota(EsControllo, R1, N2) And PresenteRuota(EsControllo, R1, N3) Then
EsceTernoSuRuote = True
Exit Function
End If

If R2 <> R1 Then
If PresenteRuota(EsControllo, R2, N1) And PresenteRuota(EsControllo, R2, N2) And PresenteRuota(EsControllo, R2, N3) Then
EsceTernoSuRuote = True
Exit Function
End If
End If

End Function


Function PresenteRuota(ByVal EsControllo, ByVal Ruota, ByVal Numero)

Dim P

PresenteRuota = False

For P = 1 To 5
If Estratto(EsControllo, Ruota, P) = Numero Then
PresenteRuota = True
Exit Function
End If
Next

End Function


Function TestoEsito(ByVal Colpo)

If Colpo > 0 Then
TestoEsito = "SI al colpo " & CStr(Colpo)
Else
TestoEsito = "NO nei colpi"
End If

End Function


Function Percentuale(ByVal Valore, ByVal Totale)

If Totale <= 0 Then
Percentuale = "0%"
Else
Percentuale = FormatNumber((Valore / Totale) * 100, 2) & "%"
End If

End Function


Function MediaColpo(ByVal TotaleSortite, ByVal SommaColpi)

If TotaleSortite <= 0 Then
MediaColpo = "-"
Else
MediaColpo = FormatNumber(SommaColpi / TotaleSortite, 2)
End If

End Function


Sub ScriviGraficoProduzione(ByVal Casi, ByVal TotAmb, ByVal TotA1, ByVal TotA2, ByVal TotT)

Scrivi
Scrivi "-------------------- Produzione esiti --------------------", 1
Call RigaGraficoProduzione("Ambata", TotAmb, Casi)
Call RigaGraficoProduzione("Ambo A", TotA1, Casi)
Call RigaGraficoProduzione("Ambo B", TotA2, Casi)
Call RigaGraficoProduzione("Terno", TotT, Casi)

End Sub


Sub RigaGraficoProduzione(ByVal Nome, ByVal Valore, ByVal Totale)

Dim BarLen

If Totale <= 0 Then
BarLen = 0
Else
BarLen = CInt((Valore / Totale) * 30)
End If

If Valore > 0 And BarLen < 1 Then BarLen = 1

Scrivi PadRight(Nome, 12) & " " & String(BarLen, "#") & " " & Valore & "/" & Totale & " - " & Percentuale(Valore, Totale), 1

End Sub


Sub ScriviGraficoConteggi(ByVal Titolo, ByRef aLab, ByRef aCnt, ByVal N, ByVal MaxRighe)

Dim I, J
Dim tmpLab, tmpCnt
Dim MaxVal
Dim Scala
Dim BarLen
Dim aL(), aC()

If N <= 0 Then Exit Sub

ReDim aL(N)
ReDim aC(N)

For I = 1 To N
aL(I) = aLab(I)
aC(I) = aCnt(I)
Next

For I = 1 To N - 1
For J = I + 1 To N

If aC(J) > aC(I) Then

tmpCnt = aC(I)
aC(I) = aC(J)
aC(J) = tmpCnt

tmpLab = aL(I)
aL(I) = aL(J)
aL(J) = tmpLab

End If

Next
Next

MaxVal = aC(1)

Scrivi
Scrivi "-------------------- " & Titolo & " --------------------", 1

For I = 1 To N

If I > MaxRighe Then Exit For

If MaxVal > 0 Then
Scala = aC(I) / MaxVal
Else
Scala = 0
End If

BarLen = CInt(Scala * 30)

If BarLen < 1 Then BarLen = 1

Scrivi PadRight(aL(I), 24) & " " & String(BarLen, "#") & " " & aC(I), 1

Next

End Sub


Function PadRight(ByVal Testo, ByVal Lunghezza)

Testo = CStr(Testo)

If Len(Testo) >= Lunghezza Then
PadRight = Left(Testo, Lunghezza)
Else
PadRight = Testo & Space(Lunghezza - Len(Testo))
End If

End Function

Egregio Sig. Data
una cosa le dev'esser Data, grazie a Lei e al suo splendito Script (che ho spudoratamente utilizzato per correggere la Macro del piffero che avevo )
ora ottengo, esattamente gli stessi suoi risultati, non so come, tantomeno perché, però devo ammetterlo sono bravo a sfruttare il lavoro altrui.
Scherzo, naturalmente. Il suo è un piccolo capolavoro possibile solo a chi, oltre a conoscere gli Script, capisce perfettamente quello che fa al contrario di me che non conosco neanche me stesso.
l



Le auguro di diventare miliardario (in questo caso non dimentichi la canzon: "Non ti scordar di me...)

 

[DATA]

dammi del tu , ciao , ti ringrazio, comunque gli scripts sono pacchetti da tagliare e assemblare per i nostri usi , giusto prenderli e usarli ...

tutti insieme possiamo aiutandoci , ideare e costruire cose

un saluto a tutti quelli che hanno aiutato a fare questo