ho trovato in vecchi post di lottoced un suo script ma non funziona in spaziometria. potrebbe dirmi perchè? la ingrazio
Codice:
Option Explicit
Dim collFormazioni
Dim CollFomGiocateFreq
Dim CollFomGiocateNonFreq
Dim aColonneDL
Dim aMatriceRid
Dim aPremi
Dim aPoste
Class clsFormazione
Public nPresenze
Public sNumeri
Public aNumeri(10)
End Class
Sub Main
Dim nEstrInizio,nEstrFine
Dim DataIni,DataFin
Dim FasciaOrariaIni,FasciaOrariaFin
Dim sOraIni,sOraFin
Dim quantitaFrz
Dim nClasse,nSorte
Dim nEstrEsam,nEstrValide,nEstrNonValide
Dim bUsaRidotto
Dim sFileSistema
Call ImpostaArchivio10ELotto(2)
Call ImpostaPremi
quantitaFrz = Int(InputBox("Quantita formazioni in gioco","Quantita",2))
If quantitaFrz > 0 Then
If ChiediDataInizioFine(DataIni,DataFin,10) Then
If ChiediFasciaInizioFine(FasciaOrariaIni,FasciaOrariaFin,sOraIni,sOraFin) Then
If ChiediClasse(nClasse) Then
If ChiediSorte(nSorte) Then
If ChiediTipoSviluppo(bUsaRidotto,sFileSistema,nClasse,nSorte) Then
nEstrInizio = DataEstrToIdEstrDL(Day(DataIni),Month(DataIni),Year(DataIni),1)
nEstrFine = DataEstrToIdEstrDL(Day(DataFin),Month(DataFin),Year(DataFin),1)
If IsRangeValido(nEstrInizio,nEstrFine) Then
Call EseguiStatistica(nEstrInizio,nEstrFine,FasciaOrariaIni,FasciaOrariaFin,nClasse,nSorte,bUsaRidotto,nEstrEsam,nEstrValide,nEstrNonValide)
Call ScriviParametriRicerca(DataIni,DataFin,sOraIni,sOraFin,nEstrEsam,nEstrValide,nEstrNonValide,quantitaFrz,nClasse,nSorte)
Call MostraFormazioniPiuFre(quantitaFrz)
Call MostraFormazioniMenoFre(quantitaFrz)
Call InitAnalizzaGioco(DataFin,FasciaOrariaIni,FasciaOrariaFin,nClasse,nSorte)
End If
End If
End If
End If
End If
End If
End If
End Sub
Sub ScriviParametriRicerca(DataI,DataF,OraI,OraF,EstrEsam,Valide,NonValide,QuantitaFrz,nClasse,nSorte)
Call Scrivi("Statistica delle prime " & QuantitaFrz & " formazioni piu frequenti in " & NomeSorte(nClasse) & " per la sorte di " & NomeSorte(nSorte))
Call Scrivi
Call Scrivi("Data inizio : " & DataI)
Call Scrivi("Data fine : " & DataF)
Call Scrivi("Range Orario : " & OraI & "/" & OraF)
Call Scrivi("Estrazioni nel range : " & EstrEsam & " (Valide : " & Valide & "; NonValide : " & NonValide & ")")
Call Scrivi
End Sub
Sub MostraFormazioniPiuFre(Quantita)
Dim clsFrz
Dim k,y
Dim idFrz
Call Scrivi("Formazioni piu frequenti")
ReDim aIdFrzScelte(Quantita,1)
For Each clsFrz In collFormazioni
idFrz = idFrz + 1
For k = 1 To Quantita
If clsFrz.nPresenze >= aIdFrzScelte(k,0) Then
For y = Quantita To(k + 1) Step - 1
aIdFrzScelte(y,0) = aIdFrzScelte(y - 1,0)
aIdFrzScelte(y,1) = aIdFrzScelte(y - 1,1)
Next
aIdFrzScelte(k,0) = clsFrz.nPresenze
aIdFrzScelte(k,1) = idFrz
Exit For
End If
Next
Next
ReDim aV(2)
aV(1) = "Formazione"
aV(2) = "Presenze"
InitTabella(aV)
For k = 1 To Quantita
Set clsFrz = collFormazioni(aIdFrzScelte(k,1))
aV(1) = clsFrz.sNumeri
aV(2) = clsFrz.nPresenze
Call AddRigaTabella(aV)
Call CollFomGiocateFreq.Add(clsFrz)
Next
Call CreaTabella
End Sub
Sub MostraFormazioniMenoFre(Quantita)
Dim clsFrz
Dim k,y
Dim idFrz
Call Scrivi("Formazioni meno frequenti (tra quelle comunque uscite)")
ReDim aIdFrzScelte(Quantita,1)
For k = 1 To Quantita
aIdFrzScelte(k,0) = 10000000
Next
For Each clsFrz In collFormazioni
idFrz = idFrz + 1
For k = 1 To Quantita
If clsFrz.nPresenze <= aIdFrzScelte(k,0) Then
For y = Quantita To(k + 1) Step - 1
aIdFrzScelte(y,0) = aIdFrzScelte(y - 1,0)
aIdFrzScelte(y,1) = aIdFrzScelte(y - 1,1)
Next
aIdFrzScelte(k,0) = clsFrz.nPresenze
aIdFrzScelte(k,1) = idFrz
Exit For
End If
Next
Next
ReDim aV(2)
aV(1) = "Formazione"
aV(2) = "Presenze"
InitTabella(aV)
For k = 1 To Quantita
Set clsFrz = collFormazioni(aIdFrzScelte(k,1))
aV(1) = clsFrz.sNumeri
aV(2) = clsFrz.nPresenze
Call AddRigaTabella(aV)
Call CollFomGiocateNonFreq.Add(clsFrz)
Next
Call CreaTabella
End Sub
Sub EseguiStatistica(nEstrInizio,nEstrFine,FasciaOrariaIni,FasciaOrariaFin,nClasse,nSorte,bUsaRidotto,nEstrEsaminateTot,nEstrValide,nEstrNonValide)
Dim k,f,idEstr,idCol,y,p
Dim idFrz
Dim clsFrz
nEstrEsaminateTot = 0
nEstrValide = 0
nEstrNonValide = 0
idFrz = 0
idCol = 0
ReDim aColonneDL(GetQColonneInteressate(nEstrInizio,nEstrFine,FasciaOrariaIni,FasciaOrariaFin),90)
Set collFormazioni = GetNewCollection
Set CollFomGiocateFreq = GetNewCollection
Set CollFomGiocateNonFreq = GetNewCollection
For k = nEstrInizio To nEstrFine Step 228
Call Messaggio("Estrazione : " & k)
For f = FasciaOrariaIni To FasciaOrariaFin
idEstr =(k - 1) + f
ReDim aNum(0)
Call GetEstrazioneCompletaDL(idEstr,aNum)
If aNum(1) > 0 Then
idCol = idCol + 1
For y = 1 To 20
aColonneDL(idCol,aNum(y)) = True
Next
Call InserisciForrmazioniInColl(aNum,nClasse,nSorte,bUsaRidotto)
nEstrValide = nEstrValide + 1
Else
nEstrNonValide = nEstrNonValide + 1
End If
nEstrEsaminateTot = nEstrEsaminateTot + 1
If ScriptInterrotto Then Exit For
Next
If ScriptInterrotto Then Exit For
Next
Messaggio("Conteggio formazioni piu frequenti")
Call AvanzamentoElab(0,collFormazioni.count,idFrz)
For Each clsFrz In collFormazioni
For k = 1 To UBound(aColonneDL)
p = 0
For y = 1 To nClasse
If aColonneDL(k,clsFrz.aNumeri(y)) Then
p = p + 1
End If
Next
If p >= nSorte Then
clsFrz.nPresenze = clsFrz.nPresenze + 1
End If
Next
idFrz = idFrz + 1
If idFrz Mod 100 = 0 Then
Call AvanzamentoElab(0,collFormazioni.count,idFrz)
If ScriptInterrotto Then Exit For
End If
Next
Call AvanzamentoElab(0,collFormazioni.count,idFrz)
End Sub
Function GetQColonneInteressate(nEstrInizio,nEstrFine,FasciaOrariaIni,FasciaOrariaFin)
Dim nGg
nGg =(((nEstrFine + 1) - nEstrInizio)\228) + 1
If nGg = 0 Then nGg = 1
GetQColonneInteressate =((FasciaOrariaFin + 1) - FasciaOrariaIni) * nGg
End Function
Sub InserisciForrmazioniInColl(aNumeri,nClasse,nSorte,bUsaRidotto)
If bUsaRidotto Then
Call InserisciForrmazioniInCollRidotto(aNumeri,nClasse)
Else
Call InserisciForrmazioniInCollIntegrale(aNumeri,nClasse)
End If
End Sub
Sub InserisciForrmazioniInCollRidotto(aNumeri,nClasse)
Dim idCol,y,j
ReDim aCol(nClasse)
Dim sColonna,sKey
Dim clsFrz
Dim nTmp
For j = 1 To 19
For idCol = 1 To UBound(aMatriceRid)
Set clsFrz = New clsFormazione
For y = 1 To nClasse
aCol(y) = aNumeri(aMatriceRid(idCol,y))
clsFrz.aNumeri(y) = aCol(y)
Next
Call OrdinaMatrice(aCol,1)
sColonna = StringaNumeri(aCol)
clsFrz.sNumeri = sColonna
sKey = "K" & sColonna
Call AddItemInColl(collFormazioni,clsFrz,sKey)
If idCol Mod 10 = 0 Then
DoEventsEx
Call AvanzamentoElab(0,UBound(aMatriceRid),idCol)
If ScriptInterrotto Then Exit For
End If
Next
nTmp = aNumeri(UBound(aNumeri))
For y = UBound(aNumeri) To 2 Step - 1
aNumeri(y) = aNumeri(y - 1)
Next
aNumeri(1) = nTmp
Next
End Sub
Sub InserisciForrmazioniInCollIntegrale(aNumeri,nClasse)
Dim k,sKey,y
Dim nColonneTot
Dim aCol
Dim clsFrz
Dim sColonna
'inizializza lo sviluppo
nColonneTot = InitSviluppoIntegrale(aNumeri,nClasse)
k = 0
' ciclo che continua fino a quando le colonne non finiscono
Do While GetCombSviluppo(aCol)
k = k + 1 ' conteggio colonna corrente
' costruisco la stringa che contiene la colonna
Set clsFrz = New clsFormazione
sColonna = ""
For y = 1 To nClasse
clsFrz.aNumeri(y) = aCol(y)
sColonna = sColonna & aCol(y) & "."
Next
sColonna = Left(sColonna,Len(sColonna) - 1)
clsFrz.sNumeri = sColonna
sKey = "K" & sColonna
Call AddItemInColl(collFormazioni,clsFrz,sKey)
If k Mod 100 = 0 Then
DoEventsEx
Call AvanzamentoElab(0,nColonneTot,k)
If ScriptInterrotto Then Exit Do
End If
Loop
Call AvanzamentoElab(0,nColonneTot,k)
End Sub
Sub AddItemInColl(collX,Itm,sKey)
On Error Resume Next
Call collX.Add(Itm,sKey)
End Sub
Function GetItemInColl(sKey,cls,collX)
On Error Resume Next
Set cls = collX(sKey)
If Err.number <> 0 Then
Set cls = Nothing
GetItemInColl = False
Else
GetItemInColl = True
End If
End Function
Function IsRangeValido(Inizio,Fine)
Dim b
b = False
If Inizio > 0 And Fine > 0 Then
If Fine >= Inizio Then
b = True
End If
End If
If Not b Then
MsgBox "Range non valido , probabilemente mancano le estrazioni nella base dati " & _
vbCrLf & "EstrazioneIni : " & Inizio & vbCrLf & "EstrazioneFine : " & Fine
End If
IsRangeValido = b
End Function
Function ChiediDataInizioFine(DataI,DataF,GiorniDaAnalizzare)
If Not IsDate(DataF) Then DataF = FormattaStringa(Now,"dd/mm/yyyy")
If Not IsDate(DataI) Then DataI = FormattaStringa(DateAdd("d",-(GiorniDaAnalizzare),DataF),"dd/mm/yyyy")
DataI = InputBox("Inserire data inizio ricerca in formato GG/MM/AAAA","Data inizio",DataI)
DataF = InputBox("Inserire data fine ricerca in formato GG/MM/AAAA","Data fine",DataF)
If IsDate(DataI) And IsDate(DataF) Then
If DateDiff("d",DataI,DataF) >= 0 Then
ChiediDataInizioFine = True
Else
MsgBox "La data FINE deve essere maggiore od uguale alla data INIZIO"
End If
Else
MsgBox "Date inserite non valide"
End If
End Function
Function ChiediFasciaInizioFine(FasciaI,FasciaF,sOraIni,sOraFin)
FasciaI = ChiediFasciaOraria("Fascia oraria inizio",sOraIni)
FasciaF = ChiediFasciaOraria("Fascia oraria fine",sOraFin)
If FasciaI > 0 And FasciaF > 0 Then
If FasciaF >= FasciaI Then
ChiediFasciaInizioFine = True
Else
MsgBox "La fascia oraria Fine deve essere maggiore della fascia oraria INIZIO"
End If
Else
MsgBox "Fascie orarie non valide"
End If
End Function
Function ChiediFasciaOraria(sCaption,sRetOra)
Dim aLista(228)
Dim h,m
Dim i
For h = 5 To 23
For m = 5 To 60 Step 5
i = i + 1
If m = 60 Then
aLista(i) = Format2(h + 1) & ":00"
Else
aLista(i) = Format2(h) & ":" & Format2(m)
End If
Next
Next
aLista(i) = "23:59"
i = ScegliOpzioneMenu(aLista,- 1,sCaption)
sRetOra = aLista(i)
ChiediFasciaOraria = i
End Function
Function ChiediClasse(nClasse)
Dim k
ReDim aVoci(6)
For k = 1 To 6
aVoci(k) = k
Next
nClasse = ScegliOpzioneMenu(aVoci,- 1,"Classe formazione")
If nClasse > 0 Then
ChiediClasse = True
Else
MsgBox "Classe formazione non valida"
End If
End Function
Function ChiediSorte(nClasse)
ReDim aVoci(3)
aVoci(1) = "Estratto"
aVoci(2) = "Ambo"
aVoci(3) = "Terno"
nClasse = ScegliOpzioneMenu(aVoci,- 1,"Sorte cercata")
If nClasse > 0 Then
ChiediSorte = True
Else
MsgBox "Classe formazione non valida"
End If
End Function
Function ChiediTipoSviluppo(bUsaRidotto,sFileSistema,nClasse,nSorte)
Dim i
ReDim aVoci(2)
aVoci(1) = "Integrale (molto lento)"
aVoci(2) = "Ridotto (piu veloce)"
sFileSistema = GetDirectoryAppData & "sistemi\" & "20" & "_" & nClasse & "_" & nSorte & ".dat"
i = ScegliOpzioneMenu(aVoci,2,"Tipo sviluppo")
If i > 0 Then
If i = 2 Then
bUsaRidotto = True
Else
bUsaRidotto = False
MsgBox "Attenzione non usando il metodo ridotto oltre ad essere piu lento potrebbe capitare " & _
"un errore a causa di problemi di memoria insufficiente",vbInformation
End If
If bUsaRidotto Then
'If FileEsistente(sFileSistema) Then
ReDim aMatriceRid(0)
If GetMatriceSistemaRidotto(sFileSistema,aMatriceRid,0,0,0,0) Then
ChiediTipoSviluppo = True
Else
MsgBox "Avendo scelto lo sviuluppo ridotto è " & _
"necessaria la presenza della matrice nella cartella dei sistemi" & vbCrLf & sFileSistema
End If
'Else
' MsgBox "Avendo scelto lo sviuluppo ridotto è " & _
' "necessaria la presenza della matrice nella cartella dei sistemi" & vbCrLf & sFileSistema
'End If
Else
ChiediTipoSviluppo = True
End If
Else
MsgBox "Tipo sviluppo non valido"
End If
End Function
Sub InitAnalizzaGioco(Data,FasciaOrariaIni,FasciaOrariaFin,nClasse,nSorte)
Dim DataIni,DataFin,nEstrInizio,nEstrFine,ColMax
DataIni = FormattaStringa(DateAdd("d",1,Data),"dd/mm/yyyy")
DataFin = DataIni
nEstrInizio = DataEstrToIdEstrDL(Day(DataIni),Month(DataIni),Year(DataIni),1)
nEstrFine = DataEstrToIdEstrDL(Day(DataFin),Month(DataFin),Year(DataFin),1)
If nEstrInizio > 0 And nEstrFine > 0 Then
'If MsgBox("Desideri analizzare un ipotesi di gioco sulle estrazioni successive a quelle analizzate (un'ora di gioco il giorno successivo)",vbQuestion + vbYesNo) = vbYes Then
Scrivi "Simulazione di gioco nella data di " & DataIni
Call ImpostaPoste(nClasse,nSorte)
Call LeggiEstrazioniTestGiocata(nEstrInizio,nEstrFine,FasciaOrariaIni,FasciaOrariaFin,ColMax)
Call AnalisiGioco(ColMax,nClasse,nSorte,CollFomGiocateFreq,"Simulazione giocando le formazioni frequenti (un'ora di gioco)")
Call AnalisiGioco(ColMax,nClasse,nSorte,CollFomGiocateNonFreq,"Simulazione giocando le formazioni meno frequenti (un'ora di gioco)")
'End If
End If
End Sub
Sub LeggiEstrazioniTestGiocata(nEstrInizio,nEstrFine,FasciaOrariaIni,FasciaOrariaFin,RetCol)
Dim k,y,f,idEstr,idCol,nEstrEsaminateTot
idCol = 0
ReDim aColonneDL(GetQColonneInteressate(nEstrInizio,nEstrFine,FasciaOrariaIni,FasciaOrariaFin),90)
For k = nEstrInizio To nEstrFine Step 228
Call Messaggio("Estrazione : " & k)
For f = FasciaOrariaIni To FasciaOrariaFin
idEstr =(k - 1) + f
ReDim aNum(0)
Call GetEstrazioneCompletaDL(idEstr,aNum)
If aNum(1) > 0 Then
idCol = idCol + 1
For y = 1 To 20
aColonneDL(idCol,aNum(y)) = True
Next
End If
nEstrEsaminateTot = nEstrEsaminateTot + 1
Next
Next
RetCol = idCol
End Sub
Sub AnalisiGioco(MaxCol,nClasse,nSorte,collFrz,sTesto)
Dim clsF
Dim idCol
Dim p,k
Dim nVincita,nSpesa
Call Scrivi(sTesto)
ReDim aPuntiTot(nClasse)
For k = 1 To nClasse
aPuntiTot(k) = 0
Next
nVincita = 0
nSpesa = 0
For idCol = 1 To MaxCol
If idCol <= UBound(aPoste) Then
For Each clsF In collFrz
p = 0
For k = 1 To nClasse
If aColonneDL(idCol,clsF.aNumeri(k))Then
p = p + 1
End If
Next
aPuntiTot(p) = aPuntiTot(p) + 1
nSpesa = nSpesa + aPoste(idCol)
nVincita = nVincita +(aPremi(nClasse,p) * aPoste(idCol))
Next
End If
Next
Call Scrivi("Punteggio conseguito")
For k = 1 To nClasse
If aPremi(nClasse,k) > 0 Then
Call Scrivi("Punti : " & k & " --> " & aPuntiTot(k))
End If
Next
Call Scrivi("Spesa : " & nSpesa)
Call Scrivi("Vincita : " & nVincita)
Call Scrivi("Guadagno : " & nVincita - nSpesa)
Call Scrivi
End Sub
Sub ImpostaPremi
ReDim aPremi(10,10)
Dim k,kk
For k = 0 To 10
For kk = 0 To 10
aPremi(k,kk) = 0
Next
Next
aPremi(1,1) = 3 ' giocato 1 vinto 1
'-----------------------------------
aPremi(2,1) = 1 ' giocato 2 vinto 1
aPremi(2,2) = 7 ' giocato 2 vinto 2
'-----------------------------------
aPremi(3,2) = 2 ' giocato 3 vinto 2
aPremi(3,3) = 50 ' giocato 3 vinto 3
'-----------------------------------
aPremi(4,2) = 1 ' giocato 4 vinto 2
aPremi(4,3) = 10 ' giocato 4 vinto 3
aPremi(4,4) = 100 ' giocato 4 vinto 4
'-----------------------------------
aPremi(5,2) = 1 ' giocato 5 vinto 2
aPremi(5,3) = 4 ' giocato 5 vinto 3
aPremi(5,4) = 15 ' giocato 5 vinto 4
aPremi(5,5) = 200 ' giocato 5 vinto 5
'-----------------------------------
aPremi(6,3) = 2 ' giocato 6 vinto 3
aPremi(6,4) = 10 ' giocato 6 vinto 4
aPremi(6,5) = 100 ' giocato 6 vinto 5
aPremi(6,6) = 2000 ' giocato 6 vinto 6
'-----------------------------------
aPremi(7,4) = 4 ' giocato 7 vinto 4
aPremi(7,5) = 40 ' giocato 7 vinto 5
aPremi(7,6) = 400 ' giocato 7 vinto 6
aPremi(7,7) = 4000 ' giocato 7 vinto 7
'-----------------------------------
aPremi(8,5) = 20 ' giocato 8 vinto 5
aPremi(8,6) = 200 ' giocato 8 vinto 6
aPremi(8,7) = 1000 ' giocato 8 vinto 7
aPremi(8,8) = 20000 ' giocato 8 vinto 8
'-----------------------------------
aPremi(9,5) = 10 ' giocato 9 vinto 5
aPremi(9,6) = 40 ' giocato 9 vinto 6
aPremi(9,7) = 400 ' giocato 9 vinto 7
aPremi(9,8) = 4000 ' giocato 9 vinto 8
aPremi(9,9) = 100000 ' giocato 9 vinto 9
'-----------------------------------
aPremi(10,5) = 5 ' giocato 10 vinto 5
aPremi(10,6) = 15 ' giocato 10 vinto 6
aPremi(10,7) = 150 ' giocato 10 vinto 7
aPremi(10,8) = 1500 ' giocato 10 vinto 8
aPremi(10,9) = 30000 ' giocato 10 vinto 9
aPremi(10,10) = 1000000 ' giocato 10 vinto 10
End Sub
Sub ImpostaPoste(nClasse,nSorte)
Dim k
Dim QuantitaGiocate
QuantitaGiocate = 12 ' un 'ora di gico
ReDim aPoste(QuantitaGiocate)
' modificare i valori per la progressione nei 12 colpi e remmarre tutto il blocco select case
aPoste(1) = 1
aPoste(2) = 1
aPoste(3) = 1
aPoste(4) = 1
aPoste(5) = 1
aPoste(6) = 1
aPoste(7) = 1
aPoste(8) = 1
aPoste(9) = 1
aPoste(10) = 1
aPoste(11) = 1
aPoste(12) = 1
Select Case nClasse
Case 2
If nSorte = 1 Then
For k = 2 To 12
aPoste(k) = aPoste(k - 1) *2
Next
ElseIf nSorte = 2 Then
aPoste(8) = 2
aPoste(9) = 2
aPoste(10) = 3
aPoste(11) = 3
aPoste(12) = 4
End If
Case 3
If nSorte = 2 Then
For k = 3 To 12
If k Mod 2 <> 0 Then
aPoste(k) = aPoste(k - 1) *2
Else
aPoste(k) = aPoste(k - 1)
End If
Next
End If
Case 4
If nSorte = 2 Then
For k = 2 To 12
aPoste(k) = aPoste(k - 1) *2
Next
ElseIf nSorte = 3 Then
aPoste(11) = 2
aPoste(12) = 2
End If
Case 5
If nSorte = 2 Then
For k = 2 To 12
aPoste(k) = aPoste(k - 1) *2
Next
ElseIf nSorte = 3 Then
aPoste(4) = 2
aPoste(5) = 3
aPoste(6) = 3
aPoste(7) = 5
aPoste(8) = 5
aPoste(9) = 7
aPoste(10) = 7
aPoste(11) = 9
aPoste(12) = 11
End If
Case 6
If nSorte = 3 Then
For k = 3 To 12
If k Mod 2 <> 0 Then
aPoste(k) = aPoste(k - 1) *2
Else
aPoste(k) = aPoste(k - 1)
End If
Next
ElseIf nSorte = 4 Then
aPoste(10) = 2
aPoste(11) = 3
aPoste(12) = 4
End If
End Select
End Sub
