A CHI DEI GRANDI SCRIPTER

[trivellatomariotretre33]

SE QUALCUNO RIESCE CON MODIFICA QUESTO LISTATO --- A FARE RICERCA ANCHE DEI RITARDI STORICI---
GRAZIE DI CUORE PENSO CHE LO SCRIPT SIA DEL GRANDE LUIGI
MAGARI INTERCERRA' DIRETTAMENTE .
GRAZIE A TUTTI
ECCO IL LISTATO




Option Explicit
Class ClsCombinazione
Private aNumeri
Private aRuote
Private m_ritardo
Private m_frequenza
Private m_ritardoMax
Private m_sorte
Private m_EstrIni
Private m_EstrFin
Public Property Get Ruote
Ruote = aRuote
End Property
Public Property Get Sorte
Sorte = m_sorte
End Property
Public Property Get EstrIni
EstrIni = m_EstrIni
End Property
Public Property Get EstrFin
EstrFin = m_EstrFin
End Property
Public Property Get Ritardo
Ritardo = m_ritardo
End Property
Public Property Get Frequenza
Frequenza = m_frequenza
End Property
Public Property Get RitardoMax
RitardoMax = m_ritardoMax
End Property
Sub EseguiStat(vNumeri,vRuote,Sorte,Inizio,Fine)
Dim nColTot,r
ReDim aR(1)
aNumeri = vNumeri
aRuote = vRuote
m_sorte = Sorte
m_EstrIni = Inizio
m_EstrFin = Fine
m_ritardo = 0
m_frequenza = 0
m_ritardoMax = 0
Call StatisticaFormazioneTurbo(aNumeri,aRuote,m_sorte,m_ritardo,m_ritardoMax,0,m_frequenza,m_EstrIni,m_EstrFin)
End Sub
Function StringaNum
StringaNum = StringaNumeri(aNumeri)
End Function
End Class
Sub Main
Dim nQNum,nSorte,Inizio,Fine,nFisso,idMese,nEstrAna
Dim Coll,clsCmb
Dim R,j
Dim idTipoRic
ReDim aNumeri(0)
ReDim aVTable(11)
ReDim abMesi(12)
ReDim aColoreRip(5)

Dim aVTipoRic

Call CreaArrayColori(aColoreRip)
'aColoreRip = Array ("Black" , "Cyan" , ")
aVTipoRic = Array("Frequenza","Ritardo","RitardoMax")
idMese = ScegliMese
abMesi(idMese) = True
nFisso = Sceglifisso
aVTable(1) = "Ruota"
For R = 2 To 11
aVTable(R) = "A" & R - 1
Next
Call InitTabella(aVTable)
Inizio = EstrazioneIni
Fine = EstrazioneFin
nQNum = ScegliNumeri(aNumeri)
nSorte = ScegliEsito(2)
idTipoRic = ScegliTipoRicerca
nEstrAna = AttivaEstrazioni(Inizio,Fine,abMesi)
For R = 1 To 12
If R <> 11 Then
aVTable(1) = NomeRuota(R)
Call Messaggio(aVTable(1))
Set Coll = GetNewCollection
Call EseguiStatistica(nFisso,aNumeri,R,nSorte,nSorte,Inizio,Fine,Coll)
Call OrdinaItemCollection(Coll,aVTipoRic(idTipoRic))

ReDim aNumRip(90)
Call ContaNumeriRipetuti(Coll,aNumRip)

'For j = 2 To 11
For j = 2 To Coll.count + 1
If j > 11 Then Exit For
Set clsCmb = Coll(j - 1)
If aVTipoRic(idTipoRic) = "Frequenza" Then
aVTable(j) = ColoraNumeri(clsCmb.StringaNum,aNumRip,aColoreRip) & " (" & "<font color='RED'>" & clsCmb.Frequenza & "</font>)"
ElseIf aVTipoRic(idTipoRic) = "Ritardo" Then
aVTable(j) = ColoraNumeri(clsCmb.StringaNum,aNumRip,aColoreRip) & " (" & "<font color='RED'>" & clsCmb.Ritardo & "</font>)"
ElseIf aVTipoRic(idTipoRic) = "RitardoMax" Then
aVTable(j) = ColoraNumeri(clsCmb.StringaNum,aNumRip,aColoreRip) & " (" & "<font color='RED'>" & clsCmb.RitardoMax & "</font>)"
End If
Next
Call AddRigaTabella(aVTable)
End If
Call AvanzamentoElab(1,12,R)
Next
SetTableWidth("100%")
Call Scrivi("Range analizzato : " & GetInfoEstrazione(Inizio) & " - " & GetInfoEstrazione(Fine))
Call Scrivi("Numero fisso ; " & Iif(nFisso = 0,"Nessuno",nFisso))
Call Scrivi("Mese analizzato : " & Iif(idMese = 0,"Tutti",MeseNome(idMese)))
Call Scrivi("Estrazioni tot, : " & nEstrAna)
Call Scrivi(String(100,"-"))
Call CreaTabella

Call CreaLegendaColori(aColoreRip)

End Sub
Sub EseguiStatistica(nFisso,vNumeri,nRuota,Classe,Sorte,Inizio,Fine,CollDest)
Dim nColTot
Dim cComb
ReDim aFissi(1)
aFissi(1) = nFisso
ReDim aR(1)
aR(1) = nRuota
If aFissi(1) > 0 Then
nColTot = InitSviluppoIntegrale(vNumeri,Classe,aFissi)
Else
nColTot = InitSviluppoIntegrale(vNumeri,Classe)
End If
ReDim aCol(0)
Do While GetCombSviluppo(aCol)
Set cComb = New ClsCombinazione
Call cComb.EseguiStat(aCol,aR,Sorte,Inizio,Fine)
CollDest.Add cComb
Loop
End Sub
Private Function MeseValido(idEstr,aMesi)
If aMesi(0) Then
MeseValido = True
Else
MeseValido = aMesi(Mese(idEstr))
End If
End Function
Private Function AttivaEstrazioni(Inizio,fine,aMesi)
Dim k
Dim nValide,b
nValide = 0
For k = Inizio To fine
b = MeseValido(k,aMesi)
Call ImpostaEstrazione(k,CBool(b))
If b Then
nValide = nValide + 1
End If
Next
AttivaEstrazioni = nValide
End Function
Function ScegliMese
Dim aV
aV = Array("Tutti","Gen","Feb","Mar","Apr","Mag","Giu", "Lug","Ago","Set","Ott","Nov","Dic")
ScegliMese = ScegliOpzioneMenu(aV,0)
End Function
Function Sceglifisso
ReDim aV(90)
Dim k
aV(0) = "Nessun fisso"
For k = 1 To 90
aV(k) = k
Next
Sceglifisso = ScegliOpzioneMenu(aV,0)
End Function
Function ScegliTipoRicerca
Dim aV
aV = Array("Frequenza","Ritardo","RitardoMax")
ScegliTipoRicerca = ScegliOpzioneMenu(aV,0)
End Function

Sub ContaNumeriRipetuti(Coll,aNumRip)
Dim clsCmb,j,y,n
ReDim aNumRip(90)

For j = 1 To Coll.count
If j > 10 Then Exit For
Set clsCmb = Coll(j)
ReDim aV(0)
Call SplitByChar(clsCmb.StringaNum,".",aV)

For y = 0 To UBound(aV)
n = Int(aV)
aNumRip = aNumRip + 1
Next

Next

End Sub
Function ColoraNumeri(sNumeri,aQNumRip,aColoreRip)

Dim k,n,sRet
ReDim aV(0)
Call SplitByChar(sNumeri,".",aV)

sRet = ""

For k = 0 To UBound(aV)
n = Int(aV(k))
If aQNumRip = 1 Then

sRet = sRet & Format2 & "."
ElseIf aQNumRip >= 2 And aQNumRip <= 4 Then

sRet = sRet & GetStringaColorata(Format2,aColoreRip(aQNumRip( n))) & "."

Else
sRet = sRet & GetStringaColorata(Format2,aColoreRip(5)) & "."


End If
Next
ColoraNumeri = RimuoviLastChr(sRet,".")

End Function
Function GetStringaColorata(s,Colore)
GetStringaColorata = "<font color ='" & GetColoreHtml(Colore) & "'><b>" & s & "</b></font>"
End Function
Sub CreaArrayColori(aC)
ReDim aC(5)


aC(1) = 0
aC(2) = RGB(0,128,0)
aC(3) = RGB(255,0,128)
aC(4) = RGB(255,128,64)
aC(5) = RGB(0,128,255)



End Sub

Sub CreaLegendaColori(aColori)

Dim k
ReDim av(2)

av(1) = "Colore"
av(2) = "Quantita ripetizioni per ruota"

Call InitTabella(av)

For k = 1 To UBound(aColori) - 1
av(1) = ""
av(2) = k
Call AddRigaTabella(av)
Call SetColoreCella(1,(aColori(k)))
Next
av(1) = " "
av(2) = ">=" & k
Call AddRigaTabella(av)
Call SetColoreCella(1,(aColori(k)))

Scrivi
Call SetTableWidth("30%")
Call CreaTabella


End Sub

 

[trivellatomariotretre33]

SE QUALCUNO RIESCE CON MODIFICA QUESTO LISTATO --- A FARE RICERCA ANCHE DEI RITARDI STORICI---
GRAZIE DI CUORE PENSO CHE LO SCRIPT SIA DEL GRANDE LUIGI
MAGARI INTERCERRA' DIRETTAMENTE .
GRAZIE A TUTTI
ECCO IL LISTATO
il listato quando lo lanciate dove da errore unite toglietndo lo spazio e va grazie

 

[Alien.]

ciao a me da errore qua
m _ritardo,m_ritardoMax,0,m_frequenza,m_EstrIni,m_Es trFin)
End Sub


grazie


più che uno script sembra un papiro hahahaha ciao

 

[trivellatomariotretre33]

ciao Alien dove ti da errore unisci le parole in piu volte e vedrai che lo script funziona bene scendi dalle nuvole e resta ogni tanto sulla terra hahahaha ciao

 

[Alien.]

è no grazie quassù l'aria è migliore...............senti ma a te non da nessun errorre? ho provato ma mi da di continuo errorre acc...

 

[trivellatomariotretre33]

CIAO ALIEN CONTINUA FINO ALLA FINE VEDRAI CHE ARRIVERA' LA META.

 

[salvo50]

Ciao a Tutti!

Ho fatto l'autoformattazione
non funge