Novità

Per Luigi

solare

solare

Advanced Member >PLATINUM<
Ciao Luigi, ti chiedo se possibile, una modifica a questo favoloso tuo listato. Modificare l'inserimento del numero fisso. adesso da solo la possibilità di inserire un solo nr. fisso. Non è possibile inserire la tabella numerica in modo da poter inserire più numeri fissi ?

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_Es trFin)
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)
Dim aVTipoRic
aVTipoRic = Array("Frequenza","Ritardo","RitardoMax")
idMese = ScegliMese
abMesi(idMese) = True
nFisso = Sceglifisso
aVTable(1) = "Ruota"
ResetTimer

For R = 2 To 11
aVTable(R) = "A" & R - 1
Next
Call InitTabella(aVTable)
Inizio = 9000'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,In izio,Fine,Coll)
Call OrdinaItemCollection(Coll,aVTipoRic(idTipoRic))
'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) = clsCmb.StringaNum & " (" & "<font color='RED'>" & clsCmb.Frequenza & "</font>)"
ElseIf aVTipoRic(idTipoRic) = "Ritardo" Then
aVTable(j) = clsCmb.StringaNum & " (" & "<font color='RED'>" & clsCmb.Ritardo & "</font>)"
ElseIf aVTipoRic(idTipoRic) = "RitardoMax" Then
aVTable(j) = clsCmb.StringaNum & " (" & "<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
Scrivi "Tempo di Elaborazione : " & TempoTrascorso,1

End Sub
Sub EseguiStatistica(nFisso,vNumeri,nRuota,Classe,Sort e,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
 
Ultima modifica:
ciao ecco la modifica

Codice: 
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,nQFissi,nSorte,Inizio,Fine,nFisso,idMese,nEstrAna
    Dim Coll,clsCmb
    Dim R,j
    Dim idTipoRic
    ReDim aNumeri(0)
    ReDim aFissi (0)
    ReDim aVTable(11)
    ReDim abMesi(12)

    Dim aVTipoRic
    Dim nClasse

    nClasse = Int(InputBox ("Sviluppa lunghette classe", , "5") )
    nQFissi =0
    aVTipoRic = Array("Frequenza","Ritardo","RitardoMax")
    idMese = ScegliMese
    abMesi(idMese) = True
    'nFisso = Sceglifisso
    aVTable(1) = "Ruota    "
    ResetTimer
    For R = 2 To 11
        aVTable(R) = "A" & R - 1 & Space(15)
    Next
    Call InitTabella(aVTable )
    Inizio = 9000'EstrazioneIni
    Fine = EstrazioneFin

    nQNum = ScegliNumeri(aNumeri)
    If MsgBox ("Scegliere dei numeri fissi ?" , vbQuestion + vbYesNo) = vbYes Then   
        nQFissi =  ScegliNumeri(aFissi  )
    End If

    If NumeriRipetutiTraVett(  aNumeri , aFissi) Then
        MsgBox "Numeri ripetuti tra fissi e variabili"
        Exit Sub
    End If
    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(aFissi,aNumeri,R, nClasse ,nSorte,Inizio,Fine,Coll)
        Call OrdinaItemCollection(Coll,aVTipoRic(idTipoRic))
        '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) = clsCmb.StringaNum & " (" & "<font color='RED'>" & clsCmb.Frequenza & "</font>)"
            ElseIf aVTipoRic(idTipoRic) = "Ritardo" Then
                aVTable(j) = clsCmb.StringaNum & " (" & "<font color='RED'>" & clsCmb.Ritardo & "</font>)"
            ElseIf aVTipoRic(idTipoRic) = "RitardoMax" Then
                aVTable(j) = clsCmb.StringaNum & " (" & "<font color='RED'>" & clsCmb.RitardoMax & "</font>)"
            End If
        Next
        Call AddRigaTabella(aVTable )
        'End If

    Next
    SetTableWidth("100%")
    Call Scrivi("Range analizzato : " & GetInfoEstrazione(Inizio) & " - " & GetInfoEstrazione(Fine))
    Call Scrivi("Numero fissi : " & Iif( nQFissi = 0 ,"Nessuno",StringaNumeri (aFissi )))
    Call Scrivi("Mese analizzato : " & Iif(idMese = 0,"Tutti",MeseNome(idMese)))
    Call Scrivi("Estrazioni tot, : " & nEstrAna)
    Call Scrivi(String(100,"-"))
    Call CreaTabella
    Scrivi "Tempo di Elaborazione : " & TempoTrascorso,1
End Sub
Sub EseguiStatistica(aFissi,vNumeri,nRuota,Classe,Sorte,Inizio,Fine,CollDest)
    Dim nColTot , nFatte
    Dim cComb
    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)
    nFatte =0
    Do While GetCombSviluppo(aCol)
        Set cComb = New ClsCombinazione
        Call cComb.EseguiStat(aCol,aR,Sorte,Inizio,Fine)
        CollDest.Add cComb
        nFatte = nFatte +1

        Call AvanzamentoElab (1,nColTot , nFatte  )

        If ScriptInterrotto Then Exit Do

    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
Function  NumeriRipetutiTraVett (aNumeri , aFissi)
    Dim ab , k , nRip  
    nRip =0
    ab=  ArrayNumeriToBool (aFissi )

    For k = 1 To UBound(aNumeri)
        If ab( aNumeri(k)) Then
            nRip = nRip +1
        End If
    Next
    NumeriRipetutiTraVett = nRip

End Function
 
LuigiB;n2102176 ha scritto:
ciao ecco la modifica

Codice: 
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,nQFissi,nSorte,Inizio,Fine,nFisso,idMese,nEstrAna
Dim Coll,clsCmb
Dim R,j
Dim idTipoRic
ReDim aNumeri(0)
ReDim aFissi (0)
ReDim aVTable(11)
ReDim abMesi(12)

Dim aVTipoRic
Dim nClasse

nClasse = Int(InputBox ("Sviluppa lunghette classe", , "5") )
nQFissi =0
aVTipoRic = Array("Frequenza","Ritardo","RitardoMax")
idMese = ScegliMese
abMesi(idMese) = True
'nFisso = Sceglifisso
aVTable(1) = "Ruota "
ResetTimer
For R = 2 To 11
aVTable(R) = "A" & R - 1 & Space(15)
Next
Call InitTabella(aVTable )
Inizio = 9000'EstrazioneIni
Fine = EstrazioneFin

nQNum = ScegliNumeri(aNumeri)
If MsgBox ("Scegliere dei numeri fissi ?" , vbQuestion + vbYesNo) = vbYes Then
nQFissi = ScegliNumeri(aFissi )
End If

If NumeriRipetutiTraVett( aNumeri , aFissi) Then
MsgBox "Numeri ripetuti tra fissi e variabili"
Exit Sub
End If
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(aFissi,aNumeri,R, nClasse ,nSorte,Inizio,Fine,Coll)
Call OrdinaItemCollection(Coll,aVTipoRic(idTipoRic))
'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) = clsCmb.StringaNum & " (" & "<font color='RED'>" & clsCmb.Frequenza & "</font>)"
ElseIf aVTipoRic(idTipoRic) = "Ritardo" Then
aVTable(j) = clsCmb.StringaNum & " (" & "<font color='RED'>" & clsCmb.Ritardo & "</font>)"
ElseIf aVTipoRic(idTipoRic) = "RitardoMax" Then
aVTable(j) = clsCmb.StringaNum & " (" & "<font color='RED'>" & clsCmb.RitardoMax & "</font>)"
End If
Next
Call AddRigaTabella(aVTable )
'End If

Next
SetTableWidth("100%")
Call Scrivi("Range analizzato : " & GetInfoEstrazione(Inizio) & " - " & GetInfoEstrazione(Fine))
Call Scrivi("Numero fissi : " & Iif( nQFissi = 0 ,"Nessuno",StringaNumeri (aFissi )))
Call Scrivi("Mese analizzato : " & Iif(idMese = 0,"Tutti",MeseNome(idMese)))
Call Scrivi("Estrazioni tot, : " & nEstrAna)
Call Scrivi(String(100,"-"))
Call CreaTabella
Scrivi "Tempo di Elaborazione : " & TempoTrascorso,1
End Sub
Sub EseguiStatistica(aFissi,vNumeri,nRuota,Classe,Sorte,Inizio,Fine,CollDest)
Dim nColTot , nFatte
Dim cComb
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)
nFatte =0
Do While GetCombSviluppo(aCol)
Set cComb = New ClsCombinazione
Call cComb.EseguiStat(aCol,aR,Sorte,Inizio,Fine)
CollDest.Add cComb
nFatte = nFatte +1

Call AvanzamentoElab (1,nColTot , nFatte )

If ScriptInterrotto Then Exit Do

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
Function NumeriRipetutiTraVett (aNumeri , aFissi)
Dim ab , k , nRip
nRip =0
ab= ArrayNumeriToBool (aFissi )
sca
For k = 1 To UBound(aNumeri)
If ab( aNumeri(k)) Then
nRip = nRip +1
End If
Next
NumeriRipetutiTraVett = nRip

End Function
Clicca per espandere...

Minghia che roba!!!! velocità pazzesca in relazionealla moledei dati:eek::eek:
 
Hai ragione filotto......mi chiedo ma Luigi è umano ? scherzo ovviamente........secondo me una dote pazzesca nella programmazione.
Una cosa è certa ci ha regalato una bomba di programma.....se qualcuno non l'avessi capito.......GRATISSSSSSSSSSSSSSSSSS
ai giorni d'oggi chi fa così tanto gratis........
Grazie Luigi
 
Devi accedere o registrarti per poter rispondere.

Ultima estrazione Lotto

  • Estrazione del lotto
    sabato 12 luglio 2025
    Bari
    67
    30
    66
    89
    47
    Cagliari
    06
    66
    33
    32
    37
    Firenze
    43
    25
    78
    21
    23
    Genova
    34
    20
    85
    52
    33
    Milano
    36
    19
    02
    70
    77
    Napoli
    21
    72
    74
    15
    53
    Palermo
    32
    08
    37
    02
    86
    Roma
    27
    32
    12
    67
    06
    Torino
    45
    47
    08
    13
    32
    Venezia
    29
    34
    19
    51
    53
    Nazionale
    34
    18
    56
    47
    85
    Estrazione Simbolotto
    Nazionale
    02
    26
    01
    08
    17
    Archivio estrazioni lotto Ritardi top 15 Frequenze top 15

Ultimi Messaggi

Indietro
Alto