Serpico 90
Advanced Member
Buona sera
Per tutti gii esperti costruttori di script
Ho ritrovato questo script che allego,cortesemente e possibile far fare la ricerca per una sola ruota anzichè per tutte le ruote?
Credo che sia stato elaborato molto tempo addietro e se, sempre cortesemente , mi potreste spiegare come lo posso utilizzare.
Spero in un gradita risposta
Option Explici
Class clsAmbo
Private aNumeri(2)
Private m_Presenze
Private m_Key
Private m_Ritardo
Private m_RitardoMax
Public Property Let Key(v)
m_Key = v
End Property
Public Property Get Key()
Key = m_Key
End Property
Public Property Get Presenze()
Presenze = m_Presenze
End Property
Public Property Let Presenze(v)
m_Presenze = v
End Property
Public Property Get NumeriString
NumeriString = StringaNumeri(aNumeri,,True)
End Property
Public Property Get Ritardo
Ritardo = m_Ritardo
End Property
Public Property Get RitardoMax
RitardoMax = m_RitardoMax
End Property
Sub SetNumero(id,Numero)
aNumeri(id) = Numero
End Sub
Sub StatisticaAmbo(nInizio,nFine,nRuota)
ReDim aRuota(1)
aRuota(1) = nRuota
Call StatisticaFormazione(aNumeri,aRuota,2,m_Ritardo,m_RitardoMax,0,0,nInizio,nFine)
End Sub
End Class
Class clsEstrazione
Private m_collAmbi
Private m_IdEst
Private m_Inizio
Private m_Fine
Private m_aNumRilevati
Public Property Get Inizio
Inizio = m_Inizio
End Property
Public Property Let Inizio(v)
m_Inizio = v
End Property
Public Property Get Fine
Fine = m_Fine
End Property
Public Property Let Fine(v)
m_Fine = v
End Property
Public Property Get CollAmbi
Set CollAmbi = m_collAmbi
End Property
Public Property Let IdEst(v)
m_IdEst = v
End Property
Public Property Get IdEst()
IdEst = m_IdEst
End Property
Public Property Let aNumRilevati(v)
m_aNumRilevati = v
End Property
Public Property Get aNumRilevati
aNumRilevati = m_aNumRilevati
End Property
Sub Init(idEstr)
Set m_collAmbi = GetNewCollection
m_IdEst = idEstr
m_Inizio = idEstr + 1
End Sub
Sub AddAmbo(aColonne,idColonna)
Dim cAmbo
Dim sKey
sKey = "k" & Format2(aColonne(idColonna,1)) & "-" & Format2(aColonne(idColonna,2))
Set cAmbo = GetItem(sKey,m_collAmbi)
If cAmbo Is Nothing Then
Set cAmbo = New clsAmbo
Call cAmbo.SetNumero(1,aColonne(idColonna,1))
Call cAmbo.SetNumero(2,aColonne(idColonna,2))
cAmbo.Presenze = 1
cAmbo.key = sKey
m_collAmbi.Add cAmbo,sKey
Else
cAmbo.Presenze = cAmbo.Presenze + 1
End If
End Sub
Function IsAmboPresente(sKey)
Dim cAmbo
Set cAmbo = GetItem(sKey,m_collAmbi)
If Not(cAmbo Is Nothing) Then
IsAmboPresente = True
End If
End Function
Function GetAmboPiuFreq(nRetFrq)
Dim cAmbo
If m_collAmbi.count > 0 Then
Call OrdinaItemCollection(m_collAmbi,"Presenze")
Set cAmbo = m_collAmbi(1)
GetAmboPiuFreq = cAmbo.NumeriString
nRetFrq = cAmbo.Presenze
Else
GetAmboPiuFreq = ""
End If
End Function
End Class
Sub Main
Dim nInizio,nFine,nColpi
Dim idEstr,k,e,i
Dim nRuota
Dim aColonne
Dim cAmbo,cEstr
Dim sKey
Dim CollAmbi
Dim CollEstrazioni
Dim CollAmbiTot
Dim bTrovato
Dim TipoRicerca
Dim aElemFormazione
Const RigheMaxTabAmbiFreq = 10
Const RigheMaxTabCopertura = 10
Const RigheMaxRiepilogo = 10
Dim aNumDaCercare
Dim nPuntiDaFare
Dim nClasseFrz
TipoRicerca = GetTipoRicerca
nColpi = CInt(InputBox("Inserisci colpi",,9))
nInizio = EstrazioneIni
nFine = EstrazioneFin
nRuota = ScegliRuota
Set CollAmbi = GetNewCollection
Set CollEstrazioni = GetNewCollection
Set CollAmbiTot = GetNewCollection
If TipoRicerca = 0 Then
' numero spia
ReDim aNumDaCercare(1)
aNumDaCercare(1) = CInt(InputBox("Inserisci Numero Spia"))
nPuntiDaFare = 1
ElseIf TipoRicerca = 1 Then
' punti su lunghetta
Call RichiediLunghetta(aNumDaCercare,nPuntiDaFare)
ElseIf TipoRicerca = 2 Then
' punti su elemento formazione
Call RichiediFormazione(aElemFormazione,nPuntiDaFare,nClasseFrz)
ReDim aNumDaCercare(nClasseFrz)
Else
nPuntiDaFare = 1
ReDim aNumDaCercare(1)
End If
If nColpi > 0 And nRuota > 0 And TipoRicerca >= 0 And nPuntiDaFare > 0 Then
For idEstr = nInizio To nFine
'bTrovato = IsNumeroPresenteInEstrazione(idEstr,nRuota,nSpia,0)
bTrovato = VerificaCondizione(TipoRicerca,idEstr,nRuota,aNumDaCercare,nPuntiDaFare,aElemFormazione)
If bTrovato Then
Set cEstr = New clsEstrazione
Call cEstr.Init(idEstr)
cEstr.aNumRilevati = aNumDaCercare
For i = idEstr + 1 To idEstr + nColpi
ReDim aNum(5)
Call GetArrayNumeriRuota(i,nRuota,aNum)
If aNum(1) > 0 Then
Call OrdinaMatrice(aNum,1)
aColonne = SviluppoIntegrale(aNum,2)
For k = 1 To UBound(aColonne)
Call cEstr.AddAmbo(aColonne,k)
sKey = "k" & Format2(aColonne(k,1)) & "-" & Format2(aColonne(k,2))
Set cAmbo = GetItem(sKey,CollAmbi)
If cAmbo Is Nothing Then
Set cAmbo = New clsAmbo
cAmbo.key = sKey
Call cAmbo.SetNumero(1,aColonne(k,1))
Call cAmbo.SetNumero(2,aColonne(k,2))
cAmbo.Presenze = 1
CollAmbi.Add cAmbo,sKey
Else
cAmbo.Presenze = cAmbo.Presenze + 1
End If
Next
End If
cEstr.fine = i
If TipoRicerca < 3 Then
If VerificaCondizione(TipoRicerca,i,nRuota,aNumDaCercare,nPuntiDaFare,aElemFormazione) Then
idEstr = i - 1
Exit For
End If
End If
Next
CollEstrazioni.Add cEstr,"k" & cEstr.idEst
End If
Call AvanzamentoElab(nInizio,nFine,idEstr)
If ScriptInterrotto Then Exit For
Next
Call OrdinaItemCollection(CollAmbi,"Presenze","Key")
Call CalcolaCopertura(CollAmbiTot,CollEstrazioni)
Call CreaTabRiepilogo(CollAmbi,CollAmbiTot,CollEstrazioni.count,nInizio,nFine,nRuota,RigheMaxRiepilogo)
Call CreaTabPresenze(CollAmbi,RigheMaxTabAmbiFreq)
Call CreaTabCopertura(CollAmbiTot,CollEstrazioni,RigheMaxTabCopertura)
Call CreaTabCasiRilevati(CollEstrazioni,nPuntiDaFare,nColpi,nRuota)
End If
End Sub
Function VerificaCondizione(TipoRicerca,idEstr,nRuota,aNumDaCercare,nPuntiDaFare,aElemFormazione)
Dim bTrovato,k,e
bTrovato = False
Select Case TipoRicerca
Case 0 ' numero spia
bTrovato = IsNumeroPresenteInEstrazione(idEstr,nRuota,aNumDaCercare(1),0)
Case 1 ' punti su lunghetta
ReDim aNum(5)
Call GetArrayNumeriRuota(idEstr,nRuota,aNum)
If PuntiSuArray(aNum,aNumDaCercare) >= nPuntiDaFare Then
bTrovato = True
End If
Case 2
ReDim aNum(5)
Call GetArrayNumeriRuota(idEstr,nRuota,aNum)
For k = 1 To UBound(aElemFormazione)
For e = 1 To UBound(aNumDaCercare)
aNumDaCercare(e) = aElemFormazione(k,e)
Next
If PuntiSuArray(aNum,aNumDaCercare) >= nPuntiDaFare Then
bTrovato = True
Exit For
End If
Next
Case 3 ' prima del mese
If IndiceMensile(idEstr) = 1 Then
bTrovato = True
End If
Case 4 ' ultima del Mese
If IsUltimaDelMese(idEstr) Then
bTrovato = True
End If
End Select
VerificaCondizione = bTrovato
End Function
Function GetTipoRicerca()
ReDim aVoci(4)
aVoci(0) = "Numero spia"
aVoci(1) = "Punti su lunghetta"
aVoci(2) = "Punti su formazione"
aVoci(3) = "Prima del mese"
aVoci(4) = "Ultima del mese"
GetTipoRicerca = ScegliOpzioneMenu(aVoci,0,"Selezione tipo ricerca")
End Function
Sub RichiediLunghetta(aNumDaCercare,nPuntiDaFare)
Dim s
Dim n
s = InputBox("Inserire i numeri della lunghetta separati da , (virgola)",,"1,2,3,4")
n = CInt(InputBox("Inserire i punti da realizzare sulla lunghetta",,1))
ReDim aNumDaCercare(0)
Call SplitByChar("0," & s,",",aNumDaCercare)
If n > 0 Then
nPuntiDaFare = n
End If
End Sub
Sub RichiediFormazione(aElemFormazione,nPuntiDaFare,nClasseFrz)
Dim s
Dim n
Dim id
ReDim aNomiForm(0)
Call ElencoFileInDirectory(GetDirectoryAppData & "formazioni\",aNomiForm,".frz")
id = ScegliOpzioneMenu(aNomiForm,1,"Selezione formazione")
If GetElementiFormazione(aNomiForm(id),aElemFormazione) Then
n = CInt(InputBox("Inserire i punti da realizzare su un qualsiasi elemento della formazione",,1))
nClasseFrz = GetClasseFormazione(aNomiForm(id))
End If
If n > 0 Then
nPuntiDaFare = n
End If
End Sub
Function GetItem(sKey,CollAmbi)
On Error Resume Next
Set GetItem = Nothing
Set GetItem = CollAmbi(sKey)
End Function
Sub AlimentaCollAmbiTot(collAmbi)
Dim k,sKey
Dim aColonne
Dim cAmbo
aColonne = SviluppoIntegrale(GetNumPerSviluppo,2)
For k = 1 To UBound(aColonne)
sKey = "k" & Format2(aColonne(k,1)) & "-" & Format2(aColonne(k,2))
Set cAmbo = New clsAmbo
cAmbo.key = sKey
Call cAmbo.SetNumero(1,aColonne(k,1))
Call cAmbo.SetNumero(2,aColonne(k,2))
cAmbo.Presenze = 0
collAmbi.Add cAmbo,sKey
Next
End Sub
Sub GetColoriRiga(aColori,aColDaEvid,ColoreLastCol)
ReDim aColori(12)
Dim k
For k = 1 To 12
aColori(k) = vbWhite
Next
For k = 1 To UBound(aColDaEvid)
If aColDaEvid(k) Then
aColori(k + 2) = vbYellow
End If
Next
aColori(12) = ColoreLastCol
End Sub
Sub CalcolaCopertura(CollAmbiTot,CollEstrazioni)
Dim cAmbo
Dim k
Dim cEstr
' tabella copertura
Call Messaggio("Calcolo copertura estrazioni")
Call AlimentaCollAmbiTot(CollAmbiTot)
k = 0
For Each cAmbo In CollAmbiTot
For Each cEstr In CollEstrazioni
If cEstr.IsAmboPresente(cAmbo.key) Then
cAmbo.presenze = cAmbo.presenze + 1
End If
Next
k = k + 1
Call AvanzamentoElab(1,CollAmbiTot.count,k)
If ScriptInterrotto Then Exit For
Next
Call OrdinaItemCollection(CollAmbiTot,"Presenze","Key")
End Sub
Sub CreaTabCopertura(CollAmbiTot,CollEstrazioni,nRigheMax)
Dim cAmbo
Dim k
Dim cEstr
Call Scrivi("La seguente tabella indica la copertura degli ambi sulle estrazioni rilevate dai casi (" & CollEstrazioni.count & " casi)")
Call Scrivi
' tabella copertura
ReDim aTitoli(3)
aTitoli(1) = "Ambo"
aTitoli(2) = "Estrazioni Coperte"
aTitoli(3) = "Percentuale"
Call InitTabella(aTitoli)
For Each cAmbo In CollAmbiTot
If cAmbo.presenze > 0 Then
ReDim aValori(3)
aValori(1) = cAmbo.NumeriString
aValori(2) = cAmbo.presenze
aValori(3) = Round(ProporzioneX(cAmbo.presenze,CollEstrazioni.count,100),3) & " %"
Call AddRigaTabella(aValori)
End If
Next
Call Messaggio("Creazione tabella in corso ...")
Call CreaTabella(,,,nRigheMax)
End Sub
Sub CreaTabPresenze(CollAmbi,nRigheMax)
Dim cAmbo
' tabella presenze
Call Scrivi("La seguente tabella indica la frequenza degli ambi")
Call Scrivi
'Call OrdinaItemCollection(CollAmbi,"Presenze")
ReDim aTitoli(2)
aTitoli(1) = "Ambo"
aTitoli(2) = "Presenze"
Call InitTabella(aTitoli)
For Each cAmbo In CollAmbi
ReDim aValori(2)
aValori(1) = cAmbo.NumeriString
aValori(2) = cAmbo.presenze
Call AddRigaTabella(aValori)
Next
Call Messaggio("Creazione tabella in corso ...")
Call CreaTabella(,,,nRigheMax)
End Sub
Sub CreaTabCasiRilevati(CollEstrazioni,nPuntiDaFare,nColpi,nRuota)
Dim i,k,n,nPosSpia,nFreq
Dim cEstr
' tabella casi rilevati
Call Scrivi("La seguente tabella indica i casi rilevati (" & CollEstrazioni.count & " casi)")
Call Scrivi
Call Messaggio("Riepilogo casi rilevati")
ReDim aTitoli(12)
aTitoli(1) = "Estrazione"
aTitoli(2) = "Data"
aTitoli(3) = "I"
aTitoli(4) = "II"
aTitoli(5) = "III"
aTitoli(6) = "IV"
aTitoli(7) = "V"
aTitoli(8) = "Ambo Piu Frequente"
aTitoli(9) = "Presenze"
aTitoli(10) = "InizioAnalisi"
aTitoli(11) = "FineAnalisi"
aTitoli(12) = "EstrazioniSuccessive"
i = 0
Call InitTabella(aTitoli)
For Each cEstr In CollEstrazioni
ReDim aValori(12)
aValori(1) = cEstr.idEst
aValori(2) = DataEstrazione(cEstr.idEst)
ReDim aPosTrovate(5)
For k = 1 To 5
n = Estratto(cEstr.idEst,nRuota,k)
If IsNumeroPresenteInLunghetta(cEstr.anumrilevati,n) Then
aPosTrovate(k) = True
End If
aValori(k + 2) = n
Next
aValori(8) = cEstr.GetAmboPiuFreq(nFreq)
aValori(9) = nFreq
aValori(10) = cEstr.Inizio
aValori(11) = cEstr.Fine
aValori(12) = cEstr.Fine -(cEstr.Inizio - 1)
ReDim aColori(0)
Call GetColoriRiga(aColori,aPosTrovate,Iif(aValori(12) = nColpi,vbGreen,vbYellow))
Call AddRigaTabella(aValori,aColori)
i = i + 1
Call AvanzamentoElab(1,CollEstrazioni.count,i)
If ScriptInterrotto Then Exit For
Next
Call Messaggio("Creazione tabella in corso ...")
Call CreaTabella()
End Sub
Function IsNumeroPresenteInLunghetta(aNumDaCercare,n)
Dim k
For k = 1 To UBound(aNumDaCercare)
If CInt(aNumDaCercare(k)) = CInt
Then
IsNumeroPresenteInLunghetta = True
Exit For
End If
Next
End Function
Sub CreaTabRiepilogo(CollAmbi,CollAmbiTot,nCasiTrov,nInizio,nFine,nRuota,nRigheMax)
Dim cAmboF,cAmboP
Dim i
Call Messaggio("Tabella riepilogo")
' tabella presenze
Call Scrivi("La seguente tabella indica la frequenza degli ambi e le rispettive presenze")
Call Scrivi
ReDim aTitoli(8)
aTitoli(1) = "Ambo"
aTitoli(2) = "Presenze"
aTitoli(3) = "Percentuale"
aTitoli(4) = "Frequenza"
aTitoli(5) = "Freq/Pres"
aTitoli(6) = "Ritardo"
aTitoli(7) = "RitMax"
aTitoli(8) = "Ultima"
Call InitTabella(aTitoli,vbBlue,,,vbWhite)
ReDim aColori(8)
aColori(1) = vbCyan
aColori(2) = vbGreen
aColori(3) = vbYellow
aColori(4) = vbGreen
aColori(5) = RGB(255,100,100)
aColori(6) = RGB(255,90,90)
aColori(7) = RGB(255,80,80)
aColori(8) = RGB(255,70,70)
For Each cAmboF In CollAmbi
Set cAmboP = CollAmbiTot(cAmboF.key)
Call cAmboF.StatisticaAmbo(nInizio,nFine,nRuota)
ReDim aValori(8)
aValori(1) = cAmboF.NumeriString
aValori(2) = cAmboP.presenze
aValori(3) = Round(Dividi((cAmboP.presenze * 100),nCasiTrov),3) & " %"
aValori(4) = cAmboF.presenze
aValori(5) = Round(Dividi(cAmboF.presenze,cAmboP.presenze),3)
aValori(6) = cAmboF.Ritardo
aValori(7) = cAmboF.RitardoMax
aValori(8) = nFine - cAmboF.ritardo
Call AddRigaTabella(aValori,aColori)
i = i + 1
Call AvanzamentoElab(1,nRigheMax,i)
If ScriptInterrotto Then Exit For
If i = nRigheMax Then Exit For
Next
Call Messaggio("Creazione tabella in corso ...")
Call CreaTabella(,,,nRigheMax)
End Sub
Sub CreaTabRiepilogo(CollAmbi,CollAmbiTot,nCasiTrov,nInizio,nFine,nRuota,nRigheMax)
Dim cAmboF,cAmboP
Dim i
Call Messaggio("Tabella riepilogo")
' tabella presenze
Call Scrivi("La seguente tabella indica la frequenza degli ambi e le rispettive presenze")
Call Scrivi
ReDim aTitoli(8)
aTitoli(1) = "Ambo"
aTitoli(2) = "Presenze"
aTitoli(3) = "Percentuale"
aTitoli(4) = "Frequenza"
aTitoli(5) = "Freq/Pres"
aTitoli(6) = "Ritardo"
aTitoli(7) = "RitMax"
aTitoli(8) = "Ultima"
Call InitTabella(aTitoli,vbBlue,,,vbWhite)
ReDim aColori(8)
aColori(1) = vbCyan
aColori(2) = vbGreen
aColori(3) = vbYellow
aColori(4) = vbGreen
aColori(5) = RGB(255,100,100)
aColori(6) = RGB(255,90,90)
aColori(7) = RGB(255,80,80)
aColori(8) = RGB(255,70,70)
For Each cAmboP In CollAmbiTot
Set cAmboF = CollAmbi(cAmboP.key)
Call cAmboP.StatisticaAmbo(nInizio,nFine,nRuota)
ReDim aValori(8)
aValori(1) = cAmboP.NumeriString
aValori(2) = cAmboP.presenze
aValori(3) = Round(ProporzioneX(cAmboP.presenze,nCasiTrov,10),3) & " %"
aValori(4) = cAmboF.presenze
aValori(5) = Round(Dividi(cAmboF.presenze,cAmboP.presenze),3)
aValori(6) = cAmboP.Ritardo
aValori(7) = cAmboP.RitardoMax
aValori(8) = nFine - cAmboP.ritardo
Call AddRigaTabella(aValori,aColori)
i = i + 1
Call AvanzamentoElab(1,nRigheMax,i)
If ScriptInterrotto Then Exit For
If i = nRigheMax Then Exit For
Next
Call Messaggio("Creazione tabella in corso ...")
Call CreaTabella()
End Sub
Per tutti gii esperti costruttori di script
Ho ritrovato questo script che allego,cortesemente e possibile far fare la ricerca per una sola ruota anzichè per tutte le ruote?
Credo che sia stato elaborato molto tempo addietro e se, sempre cortesemente , mi potreste spiegare come lo posso utilizzare.
Spero in un gradita risposta
Option Explici
Class clsAmbo
Private aNumeri(2)
Private m_Presenze
Private m_Key
Private m_Ritardo
Private m_RitardoMax
Public Property Let Key(v)
m_Key = v
End Property
Public Property Get Key()
Key = m_Key
End Property
Public Property Get Presenze()
Presenze = m_Presenze
End Property
Public Property Let Presenze(v)
m_Presenze = v
End Property
Public Property Get NumeriString
NumeriString = StringaNumeri(aNumeri,,True)
End Property
Public Property Get Ritardo
Ritardo = m_Ritardo
End Property
Public Property Get RitardoMax
RitardoMax = m_RitardoMax
End Property
Sub SetNumero(id,Numero)
aNumeri(id) = Numero
End Sub
Sub StatisticaAmbo(nInizio,nFine,nRuota)
ReDim aRuota(1)
aRuota(1) = nRuota
Call StatisticaFormazione(aNumeri,aRuota,2,m_Ritardo,m_RitardoMax,0,0,nInizio,nFine)
End Sub
End Class
Class clsEstrazione
Private m_collAmbi
Private m_IdEst
Private m_Inizio
Private m_Fine
Private m_aNumRilevati
Public Property Get Inizio
Inizio = m_Inizio
End Property
Public Property Let Inizio(v)
m_Inizio = v
End Property
Public Property Get Fine
Fine = m_Fine
End Property
Public Property Let Fine(v)
m_Fine = v
End Property
Public Property Get CollAmbi
Set CollAmbi = m_collAmbi
End Property
Public Property Let IdEst(v)
m_IdEst = v
End Property
Public Property Get IdEst()
IdEst = m_IdEst
End Property
Public Property Let aNumRilevati(v)
m_aNumRilevati = v
End Property
Public Property Get aNumRilevati
aNumRilevati = m_aNumRilevati
End Property
Sub Init(idEstr)
Set m_collAmbi = GetNewCollection
m_IdEst = idEstr
m_Inizio = idEstr + 1
End Sub
Sub AddAmbo(aColonne,idColonna)
Dim cAmbo
Dim sKey
sKey = "k" & Format2(aColonne(idColonna,1)) & "-" & Format2(aColonne(idColonna,2))
Set cAmbo = GetItem(sKey,m_collAmbi)
If cAmbo Is Nothing Then
Set cAmbo = New clsAmbo
Call cAmbo.SetNumero(1,aColonne(idColonna,1))
Call cAmbo.SetNumero(2,aColonne(idColonna,2))
cAmbo.Presenze = 1
cAmbo.key = sKey
m_collAmbi.Add cAmbo,sKey
Else
cAmbo.Presenze = cAmbo.Presenze + 1
End If
End Sub
Function IsAmboPresente(sKey)
Dim cAmbo
Set cAmbo = GetItem(sKey,m_collAmbi)
If Not(cAmbo Is Nothing) Then
IsAmboPresente = True
End If
End Function
Function GetAmboPiuFreq(nRetFrq)
Dim cAmbo
If m_collAmbi.count > 0 Then
Call OrdinaItemCollection(m_collAmbi,"Presenze")
Set cAmbo = m_collAmbi(1)
GetAmboPiuFreq = cAmbo.NumeriString
nRetFrq = cAmbo.Presenze
Else
GetAmboPiuFreq = ""
End If
End Function
End Class
Sub Main
Dim nInizio,nFine,nColpi
Dim idEstr,k,e,i
Dim nRuota
Dim aColonne
Dim cAmbo,cEstr
Dim sKey
Dim CollAmbi
Dim CollEstrazioni
Dim CollAmbiTot
Dim bTrovato
Dim TipoRicerca
Dim aElemFormazione
Const RigheMaxTabAmbiFreq = 10
Const RigheMaxTabCopertura = 10
Const RigheMaxRiepilogo = 10
Dim aNumDaCercare
Dim nPuntiDaFare
Dim nClasseFrz
TipoRicerca = GetTipoRicerca
nColpi = CInt(InputBox("Inserisci colpi",,9))
nInizio = EstrazioneIni
nFine = EstrazioneFin
nRuota = ScegliRuota
Set CollAmbi = GetNewCollection
Set CollEstrazioni = GetNewCollection
Set CollAmbiTot = GetNewCollection
If TipoRicerca = 0 Then
' numero spia
ReDim aNumDaCercare(1)
aNumDaCercare(1) = CInt(InputBox("Inserisci Numero Spia"))
nPuntiDaFare = 1
ElseIf TipoRicerca = 1 Then
' punti su lunghetta
Call RichiediLunghetta(aNumDaCercare,nPuntiDaFare)
ElseIf TipoRicerca = 2 Then
' punti su elemento formazione
Call RichiediFormazione(aElemFormazione,nPuntiDaFare,nClasseFrz)
ReDim aNumDaCercare(nClasseFrz)
Else
nPuntiDaFare = 1
ReDim aNumDaCercare(1)
End If
If nColpi > 0 And nRuota > 0 And TipoRicerca >= 0 And nPuntiDaFare > 0 Then
For idEstr = nInizio To nFine
'bTrovato = IsNumeroPresenteInEstrazione(idEstr,nRuota,nSpia,0)
bTrovato = VerificaCondizione(TipoRicerca,idEstr,nRuota,aNumDaCercare,nPuntiDaFare,aElemFormazione)
If bTrovato Then
Set cEstr = New clsEstrazione
Call cEstr.Init(idEstr)
cEstr.aNumRilevati = aNumDaCercare
For i = idEstr + 1 To idEstr + nColpi
ReDim aNum(5)
Call GetArrayNumeriRuota(i,nRuota,aNum)
If aNum(1) > 0 Then
Call OrdinaMatrice(aNum,1)
aColonne = SviluppoIntegrale(aNum,2)
For k = 1 To UBound(aColonne)
Call cEstr.AddAmbo(aColonne,k)
sKey = "k" & Format2(aColonne(k,1)) & "-" & Format2(aColonne(k,2))
Set cAmbo = GetItem(sKey,CollAmbi)
If cAmbo Is Nothing Then
Set cAmbo = New clsAmbo
cAmbo.key = sKey
Call cAmbo.SetNumero(1,aColonne(k,1))
Call cAmbo.SetNumero(2,aColonne(k,2))
cAmbo.Presenze = 1
CollAmbi.Add cAmbo,sKey
Else
cAmbo.Presenze = cAmbo.Presenze + 1
End If
Next
End If
cEstr.fine = i
If TipoRicerca < 3 Then
If VerificaCondizione(TipoRicerca,i,nRuota,aNumDaCercare,nPuntiDaFare,aElemFormazione) Then
idEstr = i - 1
Exit For
End If
End If
Next
CollEstrazioni.Add cEstr,"k" & cEstr.idEst
End If
Call AvanzamentoElab(nInizio,nFine,idEstr)
If ScriptInterrotto Then Exit For
Next
Call OrdinaItemCollection(CollAmbi,"Presenze","Key")
Call CalcolaCopertura(CollAmbiTot,CollEstrazioni)
Call CreaTabRiepilogo(CollAmbi,CollAmbiTot,CollEstrazioni.count,nInizio,nFine,nRuota,RigheMaxRiepilogo)
Call CreaTabPresenze(CollAmbi,RigheMaxTabAmbiFreq)
Call CreaTabCopertura(CollAmbiTot,CollEstrazioni,RigheMaxTabCopertura)
Call CreaTabCasiRilevati(CollEstrazioni,nPuntiDaFare,nColpi,nRuota)
End If
End Sub
Function VerificaCondizione(TipoRicerca,idEstr,nRuota,aNumDaCercare,nPuntiDaFare,aElemFormazione)
Dim bTrovato,k,e
bTrovato = False
Select Case TipoRicerca
Case 0 ' numero spia
bTrovato = IsNumeroPresenteInEstrazione(idEstr,nRuota,aNumDaCercare(1),0)
Case 1 ' punti su lunghetta
ReDim aNum(5)
Call GetArrayNumeriRuota(idEstr,nRuota,aNum)
If PuntiSuArray(aNum,aNumDaCercare) >= nPuntiDaFare Then
bTrovato = True
End If
Case 2
ReDim aNum(5)
Call GetArrayNumeriRuota(idEstr,nRuota,aNum)
For k = 1 To UBound(aElemFormazione)
For e = 1 To UBound(aNumDaCercare)
aNumDaCercare(e) = aElemFormazione(k,e)
Next
If PuntiSuArray(aNum,aNumDaCercare) >= nPuntiDaFare Then
bTrovato = True
Exit For
End If
Next
Case 3 ' prima del mese
If IndiceMensile(idEstr) = 1 Then
bTrovato = True
End If
Case 4 ' ultima del Mese
If IsUltimaDelMese(idEstr) Then
bTrovato = True
End If
End Select
VerificaCondizione = bTrovato
End Function
Function GetTipoRicerca()
ReDim aVoci(4)
aVoci(0) = "Numero spia"
aVoci(1) = "Punti su lunghetta"
aVoci(2) = "Punti su formazione"
aVoci(3) = "Prima del mese"
aVoci(4) = "Ultima del mese"
GetTipoRicerca = ScegliOpzioneMenu(aVoci,0,"Selezione tipo ricerca")
End Function
Sub RichiediLunghetta(aNumDaCercare,nPuntiDaFare)
Dim s
Dim n
s = InputBox("Inserire i numeri della lunghetta separati da , (virgola)",,"1,2,3,4")
n = CInt(InputBox("Inserire i punti da realizzare sulla lunghetta",,1))
ReDim aNumDaCercare(0)
Call SplitByChar("0," & s,",",aNumDaCercare)
If n > 0 Then
nPuntiDaFare = n
End If
End Sub
Sub RichiediFormazione(aElemFormazione,nPuntiDaFare,nClasseFrz)
Dim s
Dim n
Dim id
ReDim aNomiForm(0)
Call ElencoFileInDirectory(GetDirectoryAppData & "formazioni\",aNomiForm,".frz")
id = ScegliOpzioneMenu(aNomiForm,1,"Selezione formazione")
If GetElementiFormazione(aNomiForm(id),aElemFormazione) Then
n = CInt(InputBox("Inserire i punti da realizzare su un qualsiasi elemento della formazione",,1))
nClasseFrz = GetClasseFormazione(aNomiForm(id))
End If
If n > 0 Then
nPuntiDaFare = n
End If
End Sub
Function GetItem(sKey,CollAmbi)
On Error Resume Next
Set GetItem = Nothing
Set GetItem = CollAmbi(sKey)
End Function
Sub AlimentaCollAmbiTot(collAmbi)
Dim k,sKey
Dim aColonne
Dim cAmbo
aColonne = SviluppoIntegrale(GetNumPerSviluppo,2)
For k = 1 To UBound(aColonne)
sKey = "k" & Format2(aColonne(k,1)) & "-" & Format2(aColonne(k,2))
Set cAmbo = New clsAmbo
cAmbo.key = sKey
Call cAmbo.SetNumero(1,aColonne(k,1))
Call cAmbo.SetNumero(2,aColonne(k,2))
cAmbo.Presenze = 0
collAmbi.Add cAmbo,sKey
Next
End Sub
Sub GetColoriRiga(aColori,aColDaEvid,ColoreLastCol)
ReDim aColori(12)
Dim k
For k = 1 To 12
aColori(k) = vbWhite
Next
For k = 1 To UBound(aColDaEvid)
If aColDaEvid(k) Then
aColori(k + 2) = vbYellow
End If
Next
aColori(12) = ColoreLastCol
End Sub
Sub CalcolaCopertura(CollAmbiTot,CollEstrazioni)
Dim cAmbo
Dim k
Dim cEstr
' tabella copertura
Call Messaggio("Calcolo copertura estrazioni")
Call AlimentaCollAmbiTot(CollAmbiTot)
k = 0
For Each cAmbo In CollAmbiTot
For Each cEstr In CollEstrazioni
If cEstr.IsAmboPresente(cAmbo.key) Then
cAmbo.presenze = cAmbo.presenze + 1
End If
Next
k = k + 1
Call AvanzamentoElab(1,CollAmbiTot.count,k)
If ScriptInterrotto Then Exit For
Next
Call OrdinaItemCollection(CollAmbiTot,"Presenze","Key")
End Sub
Sub CreaTabCopertura(CollAmbiTot,CollEstrazioni,nRigheMax)
Dim cAmbo
Dim k
Dim cEstr
Call Scrivi("La seguente tabella indica la copertura degli ambi sulle estrazioni rilevate dai casi (" & CollEstrazioni.count & " casi)")
Call Scrivi
' tabella copertura
ReDim aTitoli(3)
aTitoli(1) = "Ambo"
aTitoli(2) = "Estrazioni Coperte"
aTitoli(3) = "Percentuale"
Call InitTabella(aTitoli)
For Each cAmbo In CollAmbiTot
If cAmbo.presenze > 0 Then
ReDim aValori(3)
aValori(1) = cAmbo.NumeriString
aValori(2) = cAmbo.presenze
aValori(3) = Round(ProporzioneX(cAmbo.presenze,CollEstrazioni.count,100),3) & " %"
Call AddRigaTabella(aValori)
End If
Next
Call Messaggio("Creazione tabella in corso ...")
Call CreaTabella(,,,nRigheMax)
End Sub
Sub CreaTabPresenze(CollAmbi,nRigheMax)
Dim cAmbo
' tabella presenze
Call Scrivi("La seguente tabella indica la frequenza degli ambi")
Call Scrivi
'Call OrdinaItemCollection(CollAmbi,"Presenze")
ReDim aTitoli(2)
aTitoli(1) = "Ambo"
aTitoli(2) = "Presenze"
Call InitTabella(aTitoli)
For Each cAmbo In CollAmbi
ReDim aValori(2)
aValori(1) = cAmbo.NumeriString
aValori(2) = cAmbo.presenze
Call AddRigaTabella(aValori)
Next
Call Messaggio("Creazione tabella in corso ...")
Call CreaTabella(,,,nRigheMax)
End Sub
Sub CreaTabCasiRilevati(CollEstrazioni,nPuntiDaFare,nColpi,nRuota)
Dim i,k,n,nPosSpia,nFreq
Dim cEstr
' tabella casi rilevati
Call Scrivi("La seguente tabella indica i casi rilevati (" & CollEstrazioni.count & " casi)")
Call Scrivi
Call Messaggio("Riepilogo casi rilevati")
ReDim aTitoli(12)
aTitoli(1) = "Estrazione"
aTitoli(2) = "Data"
aTitoli(3) = "I"
aTitoli(4) = "II"
aTitoli(5) = "III"
aTitoli(6) = "IV"
aTitoli(7) = "V"
aTitoli(8) = "Ambo Piu Frequente"
aTitoli(9) = "Presenze"
aTitoli(10) = "InizioAnalisi"
aTitoli(11) = "FineAnalisi"
aTitoli(12) = "EstrazioniSuccessive"
i = 0
Call InitTabella(aTitoli)
For Each cEstr In CollEstrazioni
ReDim aValori(12)
aValori(1) = cEstr.idEst
aValori(2) = DataEstrazione(cEstr.idEst)
ReDim aPosTrovate(5)
For k = 1 To 5
n = Estratto(cEstr.idEst,nRuota,k)
If IsNumeroPresenteInLunghetta(cEstr.anumrilevati,n) Then
aPosTrovate(k) = True
End If
aValori(k + 2) = n
Next
aValori(8) = cEstr.GetAmboPiuFreq(nFreq)
aValori(9) = nFreq
aValori(10) = cEstr.Inizio
aValori(11) = cEstr.Fine
aValori(12) = cEstr.Fine -(cEstr.Inizio - 1)
ReDim aColori(0)
Call GetColoriRiga(aColori,aPosTrovate,Iif(aValori(12) = nColpi,vbGreen,vbYellow))
Call AddRigaTabella(aValori,aColori)
i = i + 1
Call AvanzamentoElab(1,CollEstrazioni.count,i)
If ScriptInterrotto Then Exit For
Next
Call Messaggio("Creazione tabella in corso ...")
Call CreaTabella()
End Sub
Function IsNumeroPresenteInLunghetta(aNumDaCercare,n)
Dim k
For k = 1 To UBound(aNumDaCercare)
If CInt(aNumDaCercare(k)) = CInt
ThenIsNumeroPresenteInLunghetta = True
Exit For
End If
Next
End Function
Sub CreaTabRiepilogo(CollAmbi,CollAmbiTot,nCasiTrov,nInizio,nFine,nRuota,nRigheMax)
Dim cAmboF,cAmboP
Dim i
Call Messaggio("Tabella riepilogo")
' tabella presenze
Call Scrivi("La seguente tabella indica la frequenza degli ambi e le rispettive presenze")
Call Scrivi
ReDim aTitoli(8)
aTitoli(1) = "Ambo"
aTitoli(2) = "Presenze"
aTitoli(3) = "Percentuale"
aTitoli(4) = "Frequenza"
aTitoli(5) = "Freq/Pres"
aTitoli(6) = "Ritardo"
aTitoli(7) = "RitMax"
aTitoli(8) = "Ultima"
Call InitTabella(aTitoli,vbBlue,,,vbWhite)
ReDim aColori(8)
aColori(1) = vbCyan
aColori(2) = vbGreen
aColori(3) = vbYellow
aColori(4) = vbGreen
aColori(5) = RGB(255,100,100)
aColori(6) = RGB(255,90,90)
aColori(7) = RGB(255,80,80)
aColori(8) = RGB(255,70,70)
For Each cAmboF In CollAmbi
Set cAmboP = CollAmbiTot(cAmboF.key)
Call cAmboF.StatisticaAmbo(nInizio,nFine,nRuota)
ReDim aValori(8)
aValori(1) = cAmboF.NumeriString
aValori(2) = cAmboP.presenze
aValori(3) = Round(Dividi((cAmboP.presenze * 100),nCasiTrov),3) & " %"
aValori(4) = cAmboF.presenze
aValori(5) = Round(Dividi(cAmboF.presenze,cAmboP.presenze),3)
aValori(6) = cAmboF.Ritardo
aValori(7) = cAmboF.RitardoMax
aValori(8) = nFine - cAmboF.ritardo
Call AddRigaTabella(aValori,aColori)
i = i + 1
Call AvanzamentoElab(1,nRigheMax,i)
If ScriptInterrotto Then Exit For
If i = nRigheMax Then Exit For
Next
Call Messaggio("Creazione tabella in corso ...")
Call CreaTabella(,,,nRigheMax)
End Sub
Sub CreaTabRiepilogo(CollAmbi,CollAmbiTot,nCasiTrov,nInizio,nFine,nRuota,nRigheMax)
Dim cAmboF,cAmboP
Dim i
Call Messaggio("Tabella riepilogo")
' tabella presenze
Call Scrivi("La seguente tabella indica la frequenza degli ambi e le rispettive presenze")
Call Scrivi
ReDim aTitoli(8)
aTitoli(1) = "Ambo"
aTitoli(2) = "Presenze"
aTitoli(3) = "Percentuale"
aTitoli(4) = "Frequenza"
aTitoli(5) = "Freq/Pres"
aTitoli(6) = "Ritardo"
aTitoli(7) = "RitMax"
aTitoli(8) = "Ultima"
Call InitTabella(aTitoli,vbBlue,,,vbWhite)
ReDim aColori(8)
aColori(1) = vbCyan
aColori(2) = vbGreen
aColori(3) = vbYellow
aColori(4) = vbGreen
aColori(5) = RGB(255,100,100)
aColori(6) = RGB(255,90,90)
aColori(7) = RGB(255,80,80)
aColori(8) = RGB(255,70,70)
For Each cAmboP In CollAmbiTot
Set cAmboF = CollAmbi(cAmboP.key)
Call cAmboP.StatisticaAmbo(nInizio,nFine,nRuota)
ReDim aValori(8)
aValori(1) = cAmboP.NumeriString
aValori(2) = cAmboP.presenze
aValori(3) = Round(ProporzioneX(cAmboP.presenze,nCasiTrov,10),3) & " %"
aValori(4) = cAmboF.presenze
aValori(5) = Round(Dividi(cAmboF.presenze,cAmboP.presenze),3)
aValori(6) = cAmboP.Ritardo
aValori(7) = cAmboP.RitardoMax
aValori(8) = nFine - cAmboP.ritardo
Call AddRigaTabella(aValori,aColori)
i = i + 1
Call AvanzamentoElab(1,nRigheMax,i)
If ScriptInterrotto Then Exit For
If i = nRigheMax Then Exit For
Next
Call Messaggio("Creazione tabella in corso ...")
Call CreaTabella()
End Sub
