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
    venerdì 17 gennaio 2025
    Bari
    10
    87
    77
    23
    60
    Cagliari
    75
    33
    60
    24
    15
    Firenze
    45
    34
    66
    41
    17
    Genova
    05
    65
    15
    53
    86
    Milano
    20
    84
    74
    76
    01
    Napoli
    90
    29
    38
    52
    68
    Palermo
    33
    36
    02
    20
    68
    Roma
    68
    12
    59
    07
    74
    Torino
    03
    22
    29
    90
    28
    Venezia
    81
    24
    35
    18
    03
    Nazionale
    06
    31
    35
    89
    74
    Estrazione Simbolotto
    Bari
    14
    24
    17
    13
    08
    Archivio estrazioni lotto Ritardi top 15 Frequenze top 15

Ultimi Messaggi

Indietro
Alto