solare
Advanced Member >PLATINUM<
Ciao Luigi, volevo chiederti in merito ad un tuo listato per il 10elotto 5minuti il quae analizza le sortite dalle ore alle ore.
Vado ad inserire i passaggi che inserisco: numeri 1.2.3.4.5.6.7.8-------inizio ricerca 10/5/17 fine 19/5/17 ora inizio 9.45 ora fine 10.45 sviluppo classe 3 sorte 2
quantità formazione 10. Con questi inserimenti non visualizza niente.
esce una finestra dove è scritto Probabilmente mancano le estrazioni nella base dati. Io ho aggiornato le estrazioni ad oggi alle ore 11.05.
Grazie per tutto
Ecco il listato:
Option Explicit
Dim collPresenze
Class clsFormazione
Public nFre
Public nRit
Public nRitMax
Public aNumeri(90)
Private Sub Class_Initialize
Dim k
For k = 1 To 90
aNumeri(k) = False
Next
nFre = 0
nRit = 0
nRitMax = 0
End Sub
Function GetNumeri
Dim k,s
s = ""
For k = 1 To 90
If aNumeri(k) Then s = s & Format2(k) & "."
Next
If s <> "" Then s = Left(s,Len(s) - 1)
GetNumeri = s
End Function
End Class
Sub Main
Dim nEstrInizio,nEstrFine
Dim DataIni,DataFin
Dim FasciaOrariaIni,FasciaOrariaFin
Dim sOraIni,sOraFin
Dim quantitaFrz
Dim nClasse
Dim nSorte
Dim nEstrEsam,nEstrValide,nEstrNonValide
Call ImpostaArchivio10ELotto(2)
ReDim aNumBase(0)
If ChiediNumeri(aNumBase) Then
If ChiediDataInizioFine(DataIni,DataFin,10) Then
If ChiediFasciaInizioFine(FasciaOrariaIni,FasciaOrariaFin,sOraIni,sOraFin) Then
If ChiediClasse(nClasse) Then
If ChiediSorte(nSorte) Then
quantitaFrz = Int(InputBox("Inserire la quantità di formazioni da visulizzare da 1 a " & Combinazioni(UBound(aNumBase),nClasse),,10))
If quantitaFrz > 0 Then
nEstrInizio = DataEstrToIdEstrDL(Day(DataIni),Month(DataIni),Year(DataIni),1)
nEstrFine = DataEstrToIdEstrDL(Day(DataFin),Month(DataFin),Year(DataFin),1)
If AlimentaCollFrz(aNumBase,nClasse) Then
If IsRangeValido(nEstrInizio,nEstrFine) Then
Call EseguiStatistica(nEstrInizio,nEstrFine,FasciaOrariaIni,FasciaOrariaFin,nClasse,nEstrEsam,nEstrValide,nEstrNonValide,nSorte)
Call ScriviParametriRicerca(DataIni,DataFin,sOraIni,sOraFin,nEstrEsam,nEstrValide,nEstrNonValide,quantitaFrz,nClasse,aNumBase,nSorte)
Call MostraFormazioniPiuFre(quantitaFrz)
End If
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,aNumBase,nSorte)
Call Scrivi("Numeri in gioco : " & StringaNumeri(aNumBase))
Call Scrivi("Statistica delle prime " & QuantitaFrz & " formazioni piu frequenti sviluppate in " & NomeSorte(nClasse) & " per la sorte " & 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
ReDim aIdFrzScelte(Quantita,1)
For Each clsFrz In collPresenze
idFrz = idFrz + 1
For k = 1 To Quantita
If clsFrz.nFre >= 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.nFre
aIdFrzScelte(k,1) = idFrz
Exit For
End If
Next
Next
ReDim aV(4)
aV(1) = "Formazione"
aV(2) = "Frequenza"
aV(3) = "Ritardo"
aV(4) = "Ritardo max"
InitTabella(aV)
For k = 1 To Quantita
If k <= collPresenze.count Then
Set clsFrz = collPresenze(aIdFrzScelte(k,1))
aV(1) = clsFrz.GetNumeri
aV(2) = clsFrz.nFre
aV(3) = clsFrz.nRit
aV(4) = clsFrz.nRitMax
Call AddRigaTabella(aV)
End If
Next
Call CreaTabella
End Sub
Sub EseguiStatistica(nEstrInizio,nEstrFine,FasciaOrariaIni,FasciaOrariaFin,nClasse,nEstrEsaminateTot,nEstrValide,nEstrNonValide,nSorte)
Dim k,f,idEstr
Dim clsFrz
Dim p,e,nFatte
nEstrEsaminateTot = 0
nEstrValide = 0
nEstrNonValide = 0
For Each clsFrz In collPresenze
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
p = 0
For e = 1 To 20
If clsFrz.aNumeri(aNum(e)) Then
p = p + 1
End If
Next
If p >= nSorte Then
clsFrz.nRit = 0
clsFrz.nFre = clsFrz.nFre + 1
Else
clsFrz.nRit = clsFrz.nRit + 1
If clsFrz.nRit > clsFrz.nRitMax Then
clsFrz.nRitMax = clsFrz.nRit
End If
End If
If nFatte = 0 Then nEstrValide = nEstrValide + 1
Else
If nFatte = 0 Then nEstrNonValide = nEstrNonValide + 1
End If
If nFatte = 0 Then nEstrEsaminateTot = nEstrEsaminateTot + 1
If ScriptInterrotto Then Exit For
Next
Next
nFatte = nFatte + 1
If ScriptInterrotto Then Exit For
Call AvanzamentoElab(1,collPresenze.count,nFatte)
Next
End Sub
Function GetItemInColl(sKey,cls)
On Error Resume Next
Set cls = collPresenze(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)
On Error Resume Next
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)
ReDim aVoci(10)
Dim k
For k = 1 To 10
aVoci(k) = "Classe " & k
Next
nClasse = ScegliOpzioneMenu(aVoci,- 1,"Sviluppa combinazioni di classe")
If nClasse > 0 Then
ChiediClasse = True
Else
MsgBox "Classe formazione non valida"
End If
End Function
Function ChiediSorte(nSorte)
ReDim aVoci(10)
Dim k
For k = 1 To 10
aVoci(k) = "Sorte " & k
Next
nSorte = ScegliOpzioneMenu(aVoci,- 1,"Scegli sorte")
If nSorte > 0 Then
ChiediSorte = True
Else
MsgBox "Classe formazione non valida"
End If
End Function
Function ChiediNumeri(aNumBase)
Dim s,i,k
s = InputBox("Inserire da 1 a 20 numeri separandoli col punto <.>",,"1.2.3.4.5.6.7.8")
ReDim av(0)
Call SplitByChar(s,".",av)
ReDim aB(90)
For k = 0 To UBound(av)
If Int(av(k)) > 0 And Int(av(k)) <= 90 Then
aB(Int(av(k))) = True
End If
Next
For k = 1 To 90
If aB(k) Then
i = i + 1
ReDim Preserve aNumBase(i)
aNumBase(i) = k
End If
Next
If i > 0 And i <= 20 Then
ChiediNumeri = True
Else
MsgBox "Si devono selezionare da 1 a 20 numeri",vbExclamation
End If
End Function
Function AlimentaCollFrz(aNumBase,nClasse)
Dim k,e,s
ReDim aNumeri(UBound(aNumBase))
Dim aColonne
Dim clsFrz
Set collPresenze = GetNewCollection
If nClasse <= UBound(aNumBase) Then
Call Messaggio("Sviluppo combinazioni di classe " & nClasse)
For k = 1 To UBound(aNumBase)
aNumeri(k) = aNumBase(k)
Next
' sviluppo il sistema valorizzando le colonne sviluppate
aColonne = SviluppoIntegrale(aNumeri,nClasse)
' scrivo le colonne in output
For k = 1 To UBound(aColonne)
Set clsFrz = New clsFormazione
' ciclo per leggere la colonna k
For e = 1 To nClasse
clsFrz.aNumeri(aColonne(k,e)) = True
Next
collPresenze.Add clsFrz
Next
AlimentaCollFrz = True
Else
MsgBox "La classe è maggiore dei numeri in gioco"
AlimentaCollFrz = False
End If
End Function
Vado ad inserire i passaggi che inserisco: numeri 1.2.3.4.5.6.7.8-------inizio ricerca 10/5/17 fine 19/5/17 ora inizio 9.45 ora fine 10.45 sviluppo classe 3 sorte 2
quantità formazione 10. Con questi inserimenti non visualizza niente.
esce una finestra dove è scritto Probabilmente mancano le estrazioni nella base dati. Io ho aggiornato le estrazioni ad oggi alle ore 11.05.
Grazie per tutto
Ecco il listato:
Option Explicit
Dim collPresenze
Class clsFormazione
Public nFre
Public nRit
Public nRitMax
Public aNumeri(90)
Private Sub Class_Initialize
Dim k
For k = 1 To 90
aNumeri(k) = False
Next
nFre = 0
nRit = 0
nRitMax = 0
End Sub
Function GetNumeri
Dim k,s
s = ""
For k = 1 To 90
If aNumeri(k) Then s = s & Format2(k) & "."
Next
If s <> "" Then s = Left(s,Len(s) - 1)
GetNumeri = s
End Function
End Class
Sub Main
Dim nEstrInizio,nEstrFine
Dim DataIni,DataFin
Dim FasciaOrariaIni,FasciaOrariaFin
Dim sOraIni,sOraFin
Dim quantitaFrz
Dim nClasse
Dim nSorte
Dim nEstrEsam,nEstrValide,nEstrNonValide
Call ImpostaArchivio10ELotto(2)
ReDim aNumBase(0)
If ChiediNumeri(aNumBase) Then
If ChiediDataInizioFine(DataIni,DataFin,10) Then
If ChiediFasciaInizioFine(FasciaOrariaIni,FasciaOrariaFin,sOraIni,sOraFin) Then
If ChiediClasse(nClasse) Then
If ChiediSorte(nSorte) Then
quantitaFrz = Int(InputBox("Inserire la quantità di formazioni da visulizzare da 1 a " & Combinazioni(UBound(aNumBase),nClasse),,10))
If quantitaFrz > 0 Then
nEstrInizio = DataEstrToIdEstrDL(Day(DataIni),Month(DataIni),Year(DataIni),1)
nEstrFine = DataEstrToIdEstrDL(Day(DataFin),Month(DataFin),Year(DataFin),1)
If AlimentaCollFrz(aNumBase,nClasse) Then
If IsRangeValido(nEstrInizio,nEstrFine) Then
Call EseguiStatistica(nEstrInizio,nEstrFine,FasciaOrariaIni,FasciaOrariaFin,nClasse,nEstrEsam,nEstrValide,nEstrNonValide,nSorte)
Call ScriviParametriRicerca(DataIni,DataFin,sOraIni,sOraFin,nEstrEsam,nEstrValide,nEstrNonValide,quantitaFrz,nClasse,aNumBase,nSorte)
Call MostraFormazioniPiuFre(quantitaFrz)
End If
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,aNumBase,nSorte)
Call Scrivi("Numeri in gioco : " & StringaNumeri(aNumBase))
Call Scrivi("Statistica delle prime " & QuantitaFrz & " formazioni piu frequenti sviluppate in " & NomeSorte(nClasse) & " per la sorte " & 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
ReDim aIdFrzScelte(Quantita,1)
For Each clsFrz In collPresenze
idFrz = idFrz + 1
For k = 1 To Quantita
If clsFrz.nFre >= 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.nFre
aIdFrzScelte(k,1) = idFrz
Exit For
End If
Next
Next
ReDim aV(4)
aV(1) = "Formazione"
aV(2) = "Frequenza"
aV(3) = "Ritardo"
aV(4) = "Ritardo max"
InitTabella(aV)
For k = 1 To Quantita
If k <= collPresenze.count Then
Set clsFrz = collPresenze(aIdFrzScelte(k,1))
aV(1) = clsFrz.GetNumeri
aV(2) = clsFrz.nFre
aV(3) = clsFrz.nRit
aV(4) = clsFrz.nRitMax
Call AddRigaTabella(aV)
End If
Next
Call CreaTabella
End Sub
Sub EseguiStatistica(nEstrInizio,nEstrFine,FasciaOrariaIni,FasciaOrariaFin,nClasse,nEstrEsaminateTot,nEstrValide,nEstrNonValide,nSorte)
Dim k,f,idEstr
Dim clsFrz
Dim p,e,nFatte
nEstrEsaminateTot = 0
nEstrValide = 0
nEstrNonValide = 0
For Each clsFrz In collPresenze
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
p = 0
For e = 1 To 20
If clsFrz.aNumeri(aNum(e)) Then
p = p + 1
End If
Next
If p >= nSorte Then
clsFrz.nRit = 0
clsFrz.nFre = clsFrz.nFre + 1
Else
clsFrz.nRit = clsFrz.nRit + 1
If clsFrz.nRit > clsFrz.nRitMax Then
clsFrz.nRitMax = clsFrz.nRit
End If
End If
If nFatte = 0 Then nEstrValide = nEstrValide + 1
Else
If nFatte = 0 Then nEstrNonValide = nEstrNonValide + 1
End If
If nFatte = 0 Then nEstrEsaminateTot = nEstrEsaminateTot + 1
If ScriptInterrotto Then Exit For
Next
Next
nFatte = nFatte + 1
If ScriptInterrotto Then Exit For
Call AvanzamentoElab(1,collPresenze.count,nFatte)
Next
End Sub
Function GetItemInColl(sKey,cls)
On Error Resume Next
Set cls = collPresenze(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)
On Error Resume Next
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)
ReDim aVoci(10)
Dim k
For k = 1 To 10
aVoci(k) = "Classe " & k
Next
nClasse = ScegliOpzioneMenu(aVoci,- 1,"Sviluppa combinazioni di classe")
If nClasse > 0 Then
ChiediClasse = True
Else
MsgBox "Classe formazione non valida"
End If
End Function
Function ChiediSorte(nSorte)
ReDim aVoci(10)
Dim k
For k = 1 To 10
aVoci(k) = "Sorte " & k
Next
nSorte = ScegliOpzioneMenu(aVoci,- 1,"Scegli sorte")
If nSorte > 0 Then
ChiediSorte = True
Else
MsgBox "Classe formazione non valida"
End If
End Function
Function ChiediNumeri(aNumBase)
Dim s,i,k
s = InputBox("Inserire da 1 a 20 numeri separandoli col punto <.>",,"1.2.3.4.5.6.7.8")
ReDim av(0)
Call SplitByChar(s,".",av)
ReDim aB(90)
For k = 0 To UBound(av)
If Int(av(k)) > 0 And Int(av(k)) <= 90 Then
aB(Int(av(k))) = True
End If
Next
For k = 1 To 90
If aB(k) Then
i = i + 1
ReDim Preserve aNumBase(i)
aNumBase(i) = k
End If
Next
If i > 0 And i <= 20 Then
ChiediNumeri = True
Else
MsgBox "Si devono selezionare da 1 a 20 numeri",vbExclamation
End If
End Function
Function AlimentaCollFrz(aNumBase,nClasse)
Dim k,e,s
ReDim aNumeri(UBound(aNumBase))
Dim aColonne
Dim clsFrz
Set collPresenze = GetNewCollection
If nClasse <= UBound(aNumBase) Then
Call Messaggio("Sviluppo combinazioni di classe " & nClasse)
For k = 1 To UBound(aNumBase)
aNumeri(k) = aNumBase(k)
Next
' sviluppo il sistema valorizzando le colonne sviluppate
aColonne = SviluppoIntegrale(aNumeri,nClasse)
' scrivo le colonne in output
For k = 1 To UBound(aColonne)
Set clsFrz = New clsFormazione
' ciclo per leggere la colonna k
For e = 1 To nClasse
clsFrz.aNumeri(aColonne(k,e)) = True
Next
collPresenze.Add clsFrz
Next
AlimentaCollFrz = True
Else
MsgBox "La classe è maggiore dei numeri in gioco"
AlimentaCollFrz = False
End If
End Function
