Option Explicit
' Script Da Verificare
' Eliminate i filtri di nClasse x sistemi casuali .Il P.C con un elevato numero di combinazioni
' potrebbe impallarsi, anzi lo farà sicuramente
' Inserita funzione per trasformare i numeri virtuali( forse e solo Parziale e non generale)
' Un Grande grazie a Tom Richiedente lo script
' Un Grande grazie a silop che ha ampliato la ricerca con le sue conoscenze
' Un Grandissimo grazie a Luigi per i suoi INSEGNAMENTI
' Un grande saluto da I Legend [ aiutante:)]
Class clsLunghetta
Private aNumeri ' contiene i numeri della lunghetta
Private mInizio,mFine,mSorte ' parametri per il range analisi
Private mClasse ' contine la classe della lunghetta
Private aElencoRit ' conterra l'elenco dei ritardi per la lunghetta
Private aIdEstrElencoRit ' conterra l'elenco dei ritardi per la lunghetta
Private aElencoIncrRitMax ' contiene l'elnco degli incrementi del ritardo max
Private aIdEstrIncrRitMax ' conterra l'elenco degli id estrazione in
' cui si è registrato l'incremento del ritmax conosciuto
Private aRitardiAllIncremento ' contiene il valore del ritardo all'idestrazione in cui
' si è verificato l'incremento
Private mRitardo,mRitardoMax,mIncrRitMax,mFrequenza ' valori statistici
Private mIncrRitardoMaxSto,mStrIncRitSto
'Private mDist,mbPrimaEstrFissa
Public Property Get iNumIncrementi
iNumIncrementi = UBound(aElencoIncrRitMax)
End Property
Public Property Get IncrRitMaxSto
IncrRitMaxSto = mIncrRitardoMaxSto
End Property
Public Property Get strIncRitMaxSto
strIncRitMaxSto = mStrIncRitSto
End Property
Public Property Get Ritardo
Ritardo = mRitardo
End Property
Public Property Get RitardoMax
RitardoMax = mRitardoMax
End Property
Public Property Get IncrRitMax
IncrRitMax = mIncrRitMax
End Property
Public Property Get Frequenza
Frequenza = mFrequenza
End Property
Public Property Get LunghettaString
LunghettaString = StringaNumeri(aNumeri)
End Property
' inizializza le proprietà dell'oggetto
Sub Init(sLunghetta,sChrSep,RangeInizio,RangeFine,SorteInGioco)
' acquisisco i parametri per l'analisi
mInizio = RangeInizio
mFine = RangeFine
mSorte = SorteInGioco
' alimento il vettore con i numeri della lunghetta
Call AlimentaVettoreLunghetta(sLunghetta,sChrSep)
' calcolo l'elenco dei ritardi
Call ElencoRitardiSE(aNumeri,mSorte,mInizio,mFine,aElencoRit,aIdEstrElencoRit)
' alimento il vettore che contien l'elenco degli incrementi rit max
Call AlimentaVettoreIncrRitMax
End Sub
' esegue il calcolo dei valori statistici della lunghetta
Sub EseguiStatistica
Call StatisticaFormazioneSE(aNumeri,mSorte,mRitardo,mRitardoMax,mIncrRitMax,mFrequenza,mInizio,mFine)
End Sub
Private Sub AlimentaVettoreLunghetta(sLunghetta,sChrSep)
Dim k
If IsArray(sLunghetta) Then
' se la lunghetta è gia un array lo copio nel vettore locale dei numeri
ReDim aNumeri(UBound(sLunghetta))
For k = 1 To UBound(sLunghetta)
aNumeri(k) = sLunghetta(k)
Next
Else
' antepongo un carattere separatore per fare in modo che
' aNumeri si valorizzi dall'indice 1 (senno si sarebeb valorizzato dall'indice 0)
Call SplitByChar((sChrSep & sLunghetta),sChrSep,aNumeri)
End If
' valorizzo la classe della lunghetta
mClasse = UBound(aNumeri)
End Sub
Private Sub AlimentaVettoreIncrRitMax
Dim nRitMax,nIncr,nId,k
nId = 0
' inizializzo il vettore a 0 elementi
ReDim aElencoIncrRitMax(0)
ReDim aIdEstrIncrRitMax(0)
ReDim aRitardiAllIncremento(0)
' ciclo sul vettore dei ritardi
For k = 1 To UBound(aElencoRit)
' se il ritardo corrente supera il ritmax attuale..
If aElencoRit(k) > nRitMax Then
If nRitMax > 0 Then
' se il ritmax attuale è >0 (ivvero ne esiste uno)
' calcolo di quanto si è incrementato
nIncr = aElencoRit(k) - nRitMax
' incremento il contatore dei valori trovati
nId = nId + 1
' ridimensiono il vettore mantenendo i valori precedenti ma
' aggiungendone uno
ReDim Preserve aElencoIncrRitMax(nId)
' memorizzo il valore
aElencoIncrRitMax(nId) = nIncr
' ridimensiono il vettore mantnendo i valori precedenti ma
' aggiungendone uno
ReDim Preserve aIdEstrIncrRitMax(nId)
' memorizzo l'id dell'estrazione dove si è avuto l'incremento
aIdEstrIncrRitMax(nId) = aIdEstrElencoRit(k)
' ridimensiono il vettore mantnendo i valori precedenti ma
' aggiungendone uno
ReDim Preserve aRitardiAllIncremento(nId)
' memorizzo il valore del ritardo all'id dell'estrazione dove si è avuto l'incremento
aRitardiAllIncremento(nId) = aElencoRit(k)
End If
nRitMax = aElencoRit(k)
End If
Next
mStrIncRitSto = StringaNumeri(aElencoIncrRitMax,,True)
End Sub
Function IsCondizioneRispettata(nIdFiltro,nQIncr)
' verifica che l'incremento dell'ultimo ritmax sia uguale al massimo incr rit max conosciuto.
Dim nUpper
nUpper = UBound(aElencoIncrRitMax)
mIncrRitardoMaxSto = MassimoV(aElencoIncrRitMax,1,nUpper - 1)
If aElencoRit(UBound(aElencoRit)) > 0 And aIdEstrIncrRitMax(nUpper) = mFine And nUpper >= nQIncr Then
Select Case nIdFiltro
Case 0
IsCondizioneRispettata =(aElencoIncrRitMax(nUpper) = mIncrRitardoMaxSto)
Case 1
IsCondizioneRispettata =(aElencoIncrRitMax(nUpper) >= mIncrRitardoMaxSto)
Case 2
IsCondizioneRispettata =(aElencoIncrRitMax(nUpper) <= mIncrRitardoMaxSto)
End Select
Else
IsCondizioneRispettata = False
End If
End Function
'Scrivo la funzione Importo i Parametri ma non li dichiaro private sono solo nella funzione
Sub DisegnaGraficoIncrRitMax
Dim x,y,k
Dim nValoreMaxX,nValoreMaxY,nValoreMinX
Dim nStepX,nStepY
Dim nUpperVetIncrRit
nValoreMinX = MinimoV(aIdEstrIncrRitMax,1)
nValoreMaxX = aIdEstrIncrRitMax(UBound(aIdEstrIncrRitMax))
nValoreMaxY = MassimoV(aElencoRit,1)
nStepX =(nValoreMaxX -(mInizio - 1)) \10
nStepY = nValoreMaxY \10
Call PreparaGrafico("Formaziione " & StringaNumeri(aNumeri),nValoreMinX,nValoreMaxX,0,nValoreMaxY,nStepX,nStepY)
nUpperVetIncrRit = UBound(aElencoIncrRitMax)
' linea dell'incremento rit max
ReDim aV(nUpperVetIncrRit - 1,2)
For k = 1 To nUpperVetIncrRit
x = aIdEstrIncrRitMax(k)
y = aElencoIncrRitMax(k)
aV(k - 1,1) = x
aV(k - 1,2) = y
Next
Call DisegnaLineaGrafico(aV,vbRed,"IncrRitMax")
' linea dell' rit max
ReDim aV(nUpperVetIncrRit - 1,2)
For k = 1 To nUpperVetIncrRit
x = aIdEstrIncrRitMax(k)
y = aRitardiAllIncremento(k)
aV(k - 1,1) = x
aV(k - 1,2) = y
Next
Call DisegnaLineaGrafico(aV,vbBlue,"RitMax")
' scrive grafico nell'output
Call InserisciGrafico
End Sub
End Class
Sub Main
Dim Inizio,Fine,Sorte,idFiltro,qIncr
Inizio = 1
Fine = EstrazioniArchivioSE
Sorte = ScegliEsito
' decido il filtro in base al valore degli incrementi
idFiltro = GetIdFiltro
' decido di filtrare in base al numero degli incrementi
qIncr = GetQuantiIncrementi
If(Fine > Inizio) And Sorte > 0 And idFiltro > - 1 Then
Select Case ScegliTipoSviluppo
Case 1
Call AnalisiLunghetteFromFileTxt(Inizio,Fine,Sorte,idFiltro,qIncr)
Case 2
Call AnalisiLunghetteFromFileCol(Inizio,Fine,Sorte,idFiltro,qIncr)
Case 3
Call AnalisiLunghetteFromNumeriCasuali(Inizio,Fine,Sorte,idFiltro,qIncr)
Case 4
Call AnalisiLunghetteFromSceglinumeri(Inizio,Fine,Sorte,idFiltro,qIncr)
End Select
End If
End Sub
Function ScegliTipoSviluppo
ReDim aVoci(4)
aVoci(1) = "Da File .txt"
aVoci(2) = "Da File .Col"
aVoci(3) = "Da Selezione Casuale"
aVoci(4) = "Da Selezione Utente"
ScegliTipoSviluppo = ScegliOpzioneMenu(aVoci,1,"SelezionaSviluppo")
End Function
Function GetChrSepFromRiga(sRiga)
Dim k,schr
schr = ""
For k = 1 To Len(sRiga)
schr = Mid(sRiga,k,1)
If IsNumeric(schr) = False Then
Exit For
End If
Next
GetChrSepFromRiga = schr
End Function
'Function GetIdFiltro
'Dim aFiltro
'aFiltro = Array("IncrRitMaxSto=UltimoIncrRitMax","IncrRitMaxSto<=UltimoIncrRitMax","IncrRitMaxSto>=UltimoIncrRitMax")
'GetIdFiltro = ScegliOpzioneMenu(aFiltro,0,"Select Filtro Condizione")
'End Function
Function GetIdFiltro
Dim aFiltro(2)
aFiltro(0) = "aElencoIncrRitMax(nUpper) = mIncrRitardoMaxSto"
aFiltro(1) = "aElencoIncrRitMax(nUpper)>= mIncrRitardoMaxSto"
aFiltro(2) = "aElencoIncrRitMax(nUpper)<= mIncrRitardoMaxSto"
GetIdFiltro = ScegliOpzioneMenu(aFiltro,0,"Select Filtro Condizione")
End Function
Function ScriviFiltro(idFiltro)
Select Case idFiltro
Case 0
ScriviFiltro =("aElencoIncrRitMax(nUpper) = mIncrRitardoMaxSto")
Case 1
ScriviFiltro =("aElencoIncrRitMax(nUpper)>= mIncrRitardoMaxSto")
Case 2
ScriviFiltro =("aElencoIncrRitMax(nUpper)<= mIncrRitardoMaxSto")
End Select
End Function
Function GetQuantiIncrementi
GetQuantiIncrementi = CInt(InputBox("qIncr>=(NumeroIncrementiRitMaxFormazione)","Filtro Quantitaà Incrementi",5))
End Function
' Questa è la nuova routine che impedisce di scrivere i doppi
' ma non mpedisce di incrementare nTrov
'Sub AddLunghetta(collLunghette,clsL)
'On Error Resume Next
'collLunghette.Add clsL ,"k"&clsL.LunghettaString
'End Sub
Function AddLunghetta(collLunghette,clsL)
On Error Resume Next
collLunghette.Add clsL,"k" & clsL.LunghettaString
If Err = 0 Then
AddLunghetta = True
Else
AddLunghetta = False
End If
Err.Clear
End Function
Function GetValoreFraSeparatori(sFile,CharSep1,CharSep2)
Dim k
Dim i,f,sVal
i = InStr(1,sFile,CharSep1) + 1
f = InStr(i,sFile,CharSep2)
GetValoreFraSeparatori = Int(Mid(sFile,i,f - i))
End Function
Sub AnalisiLunghetteFromFileTxt(Inizio,Fine,Sorte,idFiltro,qIncr)
Dim sFile,aLunghette,nTotLunghette
Dim k,sChrSep
Dim clsL,collLunghette
Set collLunghette = GetNewCollection
sFile = ScegliFile(GetDirectoryAppData,".txt")
If FileEsistente(sFile) Then
Call LeggiRigheFileDiTesto(sFile,aLunghette)
nTotLunghette = UBound(aLunghette)
If nTotLunghette > 0 Then
sChrSep = GetChrSepFromRiga(aLunghette(1))
For k = 0 To nTotLunghette
Set clsL = New clsLunghetta
Call clsL.Init(aLunghette(k),sChrSep,Inizio,Fine,Sorte)
If clsL.IsCondizioneRispettata(idFiltro,qIncr) Then
Call clsL.EseguiStatistica
collLunghette.Add clsL
End If
If k Mod 50 = 0 Then
Call Messaggio("Righe esaminate : " & k)
Call AvanzamentoElab(1,nTotLunghette,k)
If ScriptInterrotto Then Exit For
End If
Next
Scrivi "Range analisi : " & GetInfoEstrazioneSE(Inizio) & " - " & GetInfoEstrazioneSE(Fine)
Scrivi "Filtro Esaminato : " & ScriviFiltro(idFiltro)
Scrivi "Lunghette esaminate : " & nTotLunghette + 1 & " Valide : " & collLunghette.count
Scrivi "Sorte : " & NomeSorte(Sorte)
Scrivi "Numero Minimo IncrRit : " & Format2(qIncr)
Scrivi
Scrivi FormatSpace("Lunghette ordinate per incremento ritardo max",75),True,True,RGB(25,89,76),vbWhite
Call Scrivi
If collLunghette.count > 0 Then
Call OrdinaItemCollection(collLunghette,"IncrRitMax",,,- 1)
For Each clsL In collLunghette
Call Scrivi("Numeri Formazione : " & clsL.LunghettaString)
Call Scrivi("Ritardo : " & clsL.Ritardo)
Call Scrivi("RitMax : " & clsL.RitardoMax)
Call Scrivi("Freq : " & clsL.Frequenza)
Call Scrivi("IncrRitMx : " & clsL.IncrRitMax)
Call Scrivi("IncrRitMaxSto : " & clsL.IncrRitMaxSto)
Call Scrivi("strIncrementi : " & clsL.strIncRitMaxSto)
Call Scrivi("Numero Incrementi : " & clsL.iNumIncrementi)
Call clsL.DisegnaGraficoIncrRitMax
Next
Else
Scrivi "Nessuna lunghetta rispetta le condizioni"
Scrivi "Lunghette esaminate " & nTotLunghette + 1
End If
End If
End If
End Sub
Sub AnalisiLunghetteFromNumeriCasuali(Inizio,Fine,Sorte,idFiltro,qIncr)
Dim sFile,aLunghette,nTotLunghette,nClasse
Dim nTrov,nProdotte
Dim clsL,collLunghette,uLunghette
ReDim aSelNum(0)
Set collLunghette = GetNewCollection
nTotLunghette = Int(InputBox("Quante lunghette devono essere prodotte ?",,10))
uLunghette = nTotLunghette
ScegliNumeri(aSelNum)
nClasse = Int(InputBox("Quanti numeri nella lunghetta","Sorte analizzata" & NomeSorte(Sorte),2))
If nTotLunghette > 0 And nClasse >= Sorte Then
nTrov = 0
nProdotte = 0
Do While nTotLunghette > 0
Set clsL = New clsLunghetta
ReDim aNum(nClasse)
Call GetColonnaCasuale(nClasse,aNum,aSelNum)
nProdotte = nProdotte + 1
Call clsL.Init(aNum,"",Inizio,Fine,Sorte)
If clsL.IsCondizioneRispettata(idFiltro,qIncr) Then
Call clsL.EseguiStatistica
If AddLunghetta(collLunghette,clsL) Then nTrov = nTrov + 1
End If
If nProdotte Mod 50 = 0 Then
Call Messaggio("combinazioni esaminate " & nProdotte & " valide " & nTrov)
Call AvanzamentoElab(1,uLunghette,nProdotte)
Call DoEventsEx
If ScriptInterrotto Then Exit Do
End If
nTotLunghette = nTotLunghette - 1
Loop
Scrivi "Range analisi : " & GetInfoEstrazioneSE(Inizio) & " - " & GetInfoEstrazioneSE(Fine)
Scrivi "Filtro Esaminato : " & ScriviFiltro(idFiltro)
Scrivi "Lunghette esaminate : " & nProdotte & " Valide : " & collLunghette.count
Scrivi "Sorte : " & NomeSorte(Sorte)
Scrivi "Numero Minimo IncrRit : " & Format2(qIncr)
Scrivi
Scrivi FormatSpace("Lunghette ordinate per incremento ritardo max",75),True,True,RGB(25,89,76),vbWhite
Call Scrivi
If collLunghette.count > 0 Then
Call OrdinaItemCollection(collLunghette,"IncrRitMax",,,- 1)
For Each clsL In collLunghette
Call Scrivi("Numeri Formazione : " & clsL.LunghettaString)
Call Scrivi("Ritardo : " & clsL.Ritardo)
Call Scrivi("RitMax : " & clsL.RitardoMax)
Call Scrivi("Freq : " & clsL.Frequenza)
Call Scrivi("IncrRitMx : " & clsL.IncrRitMax)
Call Scrivi("IncrRitMaxSto : " & clsL.IncrRitMaxSto)
Call Scrivi("strIncrementi : " & clsL.strIncRitMaxSto)
Call Scrivi("Numero Incrementi : " & clsL.iNumIncrementi)
Call clsL.DisegnaGraficoIncrRitMax
Next
Else
Scrivi "Nessuna lunghetta rispetta le condizioni"
Scrivi "Lunghette esaminate " & nProdotte
End If
End If
End Sub
Sub AnalisiLunghetteFromSceglinumeri(Inizio,Fine,Sorte,idFiltro,qInc)
Dim nTotLunghette
Dim k,sChrSep,nClasse
ReDim aLunghette(0)
Dim clsL,collLunghette,FiltroEsaminato
Set collLunghette = GetNewCollection
FiltroEsaminato = ScriviFiltro(idFiltro)
sChrSep = " "
ScegliNumeri(aLunghette)
nClasse = CInt(InputBox(" classe sviluppo ",,2))
nTotLunghette = InitSviluppoIntegrale(aLunghette,nClasse)
k = 0
Do While GetCombSviluppo(aLunghette)
k = k + 1
Set clsL = New clsLunghetta
Call clsL.Init(aLunghette,sChrSep,Inizio,Fine,Sorte)
If clsL.IsCondizioneRispettata(idFiltro,qIncr) Then
Call clsL.EseguiStatistica
collLunghette.Add clsL
End If
If k Mod 50 = 0 Then
Call Messaggio("Righe esaminate " & k & " valide " & collLunghette. count)
DoEventsEx
Call AvanzamentoElab(1,nTotLunghette,k)
If ScriptInterrotto Then Exit Do
End If
Loop
Scrivi "Range analisi : " & GetInfoEstrazioneSE(Inizio) & " - " & GetInfoEstrazioneSE(Fine)
Scrivi "Filtro Esaminato : " & FiltroEsaminato
Scrivi "Lunghette esaminate : " & nTotLunghette & " Valide : " & collLunghette.count
Scrivi "Sorte : " & NomeSorte(Sorte)
Scrivi "Numero Minimo IncrRit : " & Format2(qIncr)
Scrivi
Scrivi FormatSpace("Lunghette ordinate per incremento ritardo max",75),True,True,RGB(25,89,76),vbWhite
Call Scrivi
If collLunghette.count > 0 Then
Call OrdinaItemCollection(collLunghette,"IncrRitMax",,,- 1)
For Each clsL In collLunghette
Call Scrivi("Numeri Formazione : " & clsL.LunghettaString)
Call Scrivi("Ritardo : " & clsL.Ritardo)
Call Scrivi("RitMax : " & clsL.RitardoMax)
Call Scrivi("Freq : " & clsL.Frequenza)
Call Scrivi("IncrRitMx : " & clsL.IncrRitMax)
Call Scrivi("IncrRitMaxSto : " & clsL.IncrRitMaxSto)
Call Scrivi("strIncrementi : " & clsL.strIncRitMaxSto)
Call Scrivi("Numero Incrementi : " & clsL.iNumIncrementi)
Call clsL.DisegnaGraficoIncrRitMax
Next
Else
Scrivi "Nessuna lunghetta rispetta le condizioni"
Scrivi "Lunghette esaminate " & nTotLunghette
End If
End Sub
Sub AnalisiLunghetteFromFileCol(Inizio,Fine,Sorte,idFiltro,qIncr)
Dim sFile,nTotLunghette
Dim k,sChrSep
Dim clsL,collLunghette
sChrSep = " "
Set collLunghette = GetNewCollection
sFile = ScegliFile(GetDirectoryAppData & "SviluppiColonne",".col")
If FileEsistente(sFile) Then
ReDim alunghette(0)
Call LeggiColonnaSistema(alunghette,1,sFile,,nTotLunghette)
If nTotLunghette > 0 Then
For k = 1 To nTotLunghette
ReDim alunghette(0)
Call LeggiColonnaSistema(alunghette,k,sFile)
Set clsL = New clsLunghetta
Call clsL.Init(alunghette,sChrSep,Inizio,Fine,Sorte)
If clsL.IsCondizioneRispettata(idFiltro,qIncr) Then
Call clsL.EseguiStatistica
collLunghette.Add clsL
End If
If k Mod 50 = 0 Then
Call Messaggio("Colonne esaminate : " & k & " Valide : " & collLunghette.count)
Call AvanzamentoElab(1,nTotLunghette,k)
If ScriptInterrotto Then Exit For
End If
Next
Scrivi "Range analisi : " & GetInfoEstrazioneSE(Inizio) & " - " & GetInfoEstrazioneSE(Fine)
Scrivi "Filtro Esaminato : " & ScriviFiltro(idFiltro)
Scrivi "Lunghette esaminate : " & nTotLunghette + 1 & " Valide : " & collLunghette.count
Scrivi "Sorte : " & NomeSorte(Sorte)
Scrivi "Numero Minimo IncrRit : " & Format2(qIncr)
Scrivi
Scrivi FormatSpace("Lunghette ordinate per incremento ritardo max",75),True,True,RGB(25,89,76),vbWhite
Call Scrivi
If collLunghette.count > 0 Then
Call OrdinaItemCollection(collLunghette,"IncrRitMax",,,- 1)
For Each clsL In collLunghette
Call Scrivi("Numeri Formazione : " & clsL.LunghettaString)
Call Scrivi("Ritardo : " & clsL.Ritardo)
Call Scrivi("RitMax : " & clsL.RitardoMax)
Call Scrivi("Freq : " & clsL.Frequenza)
Call Scrivi("IncrRitMx : " & clsL.IncrRitMax)
Call Scrivi("IncrRitMaxSto : " & clsL.IncrRitMaxSto)
Call Scrivi("strIncrementi : " & clsL.strIncRitMaxSto)
Call Scrivi("Numero Incrementi : " & clsL.iNumIncrementi)
Call clsL.DisegnaGraficoIncrRitMax
Next
Else
Scrivi "Nessuna lunghetta rispetta le condizioni"
Scrivi "Lunghette esaminate " & nTotLunghette + 1
End If
End If
End If
End Sub
LuigiB e i legend oltre alla vostra nuova intrigante missione che ho intravisto... avreste voglia di fare anche questo? Per tentare di fare il boom con un bel 5 al superenalotto per la fine dell'anno invece di aspettare befana... 
