Public Sub MyScriptRoutine()
Call initScriptRiduzioneLunghette
End Sub
Sub initScriptRiduzioneLunghette()
' IN QUESTA ROUTINE VA SCRITTO IL PROPRIO CODICE COME SE FOSSE LA SUB MAIN DI SPAZIOMETRIA
' ATTENZIONE NON CAMBIARE NOME ALLA ROUTINE
Dim f As Integer ' puntatore per aprire il file delle lunghette
Dim sFileLunghette As String ' percorso del file delle lunghette
Dim sRecord As String ' stringa per leggere il file delle lunghette
Dim strBld As ClsStringBuilder ' conterrà tutte le lunghette trovate sottoforma di stringa , le lunghette verranno poi salvate su file
Dim sLunghetta As String ' lunghetta originale che ha generatola riduzione
Dim nPassaggiMaxRiduzione As Integer ' determina i passaggi di riduzione massima
Dim sFileOut As String ' è il percorso dove viene scritto l'output
Dim aRuote As Variant ' contiene gli indici delle ruote coinvolte
Dim nSorteCercata As Long ' identifica la sorte con cui opera la statistica
Dim idEstrIni As Long, idEstrFine As Long ' range analisi
Dim sChrSep As String ' carattere separatore dei numeri nel record della lunghetta
Dim TipoRicerca As eTipoRicerca 'specifica i ltipo di ricerca
Dim nCicliMinimiDiRiduzione As Integer ' indica qanti cicli di riduzione devesuperare la lunghetta per essere riportata nel report
Dim nTrovate As Long ' lunghette trovate
Dim nAnalizzate As Long ' contatore analizzate
Dim nValoreMinRichiesto As Integer ' valore minimo statistico da spoerare o eguagliare per riportare la lunghetta nel report
Dim nEstrRange As Long ' estrazioni del range
Dim frz As STRUCT_FRZ_STATISTICA_SINGOLO_ESITO ' contiene i risultati della statistica
Dim nCombSvilTot As Long ' colonne sviluppate totali
Set strBld = New ClsStringBuilder
'********************************* MODIFICARE I PARAMETRI **************************************
'================================================================================================
TipoRicerca = Presenze
nCicliMinimiDiRiduzione = 1 ' la clase devescendere almeno di 1 senno la lunghetta non è riportata
idEstrIni = EstrazioneIni
idEstrFine = EstrazioneFin
nSorteCercata = 1
nPassaggiMaxRiduzione = 3
sFileLunghette = "C:\Users\admin\Desktop\CTWEENBASIC237\FrameworkScriptGiochi\Matrici\c30.txt"
sFileOut = "C:\Users\admin\Desktop\CTWEENBASIC237\FrameworkScriptGiochi\risultato.txt"
aRuote = Array(1) ' ruota di bari
sChrSep = "."
nEstrRange = idEstrFine - (idEstrIni - 1)
nValoreMinRichiesto = Proporzione(30, 100, nEstrRange) ' calcolo il valore minimo con la percentuale sulle estrazioni totali il 30%
'================================================================================================
Call ImpostaNomeScript("Riduzione lunghette da file di testo")
If FileExist(sFileLunghette) Then
If KillFile(sFileOut) Then
f = FreeFile ' apro un puntatore libero
Open sFileLunghette For Input As f ' apre i lfile
Do Until EOF(f) ' cicla finche non diventa End Of File
Line Input #f, sRecord
sLunghetta = sRecord
If Riduciunghetta(sRecord, aRuote, nSorteCercata, nPassaggiMaxRiduzione, idEstrIni, idEstrFine, sChrSep, nCicliMinimiDiRiduzione, nValoreMinRichiesto, nCombSvilTot, TipoRicerca) Then
Call strBld.AddLinea("Orig : " & sLunghetta)
Call StatisticaSingoloEsito(sRecord, idEstrIni, idEstrFine, nSorteCercata, frz, aRuote)
If TipoRicerca = eTipoRicerca.Presenze Then
Call strBld.AddLinea("Rid : " & sRecord & " --> " & frz.RetValori.Presenze)
ElseIf TipoRicerca = eTipoRicerca.PresenzeMultiple Then
Call strBld.AddLinea("Rid : " & sRecord & " --> " & frz.RetValori.PresenzeMultiple)
End If
nTrovate + = 1
If nTrovate Mod 1000 = 0 Then
Call strBld.SaveToFile(sFileOut, True)
strBld.Reset
End If
End If
nAnalizzate += 1
If nAnalizzate Mod 100 = 0 Then
Messaggio ("Trovate " & nTrovate & " Analizzate : " & nAnalizzate & " Sviluppate : " & nCombSvilTot)
DoEvents
If bScriptInterrotto Then Exit Do
End If
Loop
Close f ' chiude il file
If nTrovate Mod 1000 <> 0 Then ' salvo le trovate rimanenti non salvate
strBld.SaveToFile (sFileOut, True)
strBld.Reset
End If
MsgBox "Trovate " & nTrovate & " lunghette in " & CStr (TempoElaborazioneSecondi) & " secondi", vbInformation
Else
MsgBox "Impossibile eliminare il file reort output forse è aperto !", vbExclamation
End If
Else
MsgBox "File input non trovato", vbExclamation
End If
End Sub
Function Riduciunghetta(sLunghetta As String, aRuote As Variant, nSorteCercata As Long, nPassaggiMaxRiduzione As Integer, idEstrIni As Long, idEstrFine As Long, sChrSep As String, nCicliMinimiDiRiduzione As Integer, nValoreMinRichiesto As Integer, nCombSvilTot As Long, TipoRicerca As eTipoRicerca) As Boolean
Dim nClasse As Long ' calcola la classe della lunghetta
Dim av As Variant ' contiene i numeri splittati dal record della lunghetta
Dim nCicli As Long 'serve per sapere quante volte è stata ridotta la lunghetta
av = SplitXX(sLunghetta, sChrSep)
nClasse = UBound(av) + 1
Do While RiduciunghettaEx(sLunghetta, aRuote, nSorteCercata, nPassaggiMaxRiduzione, idEstrIni, idEstrFine, sChrSep, nClasse, nValoreMinRichiesto, nCombSvilTot, TipoRicerca)
nClasse -= 1
nCicli + = 1
nSorteCercata + = 1
If bScriptInterrotto Then Exit Do
'If nClasse <= nSorteCercata Then Exit Do
If nClasse <= 10 Or nSorteCercata > 5 Or nClasse <= nSorteCercata Then Exit Do
Loop
Return nCicli >= nCicliMinimiDiRiduzione ' torna false per le lunghette che non sono state ridotte del numero di cicli previsti ad ogni ciclo scende di 1 la classe di sviluppo
End Function
Function RiduciunghettaEx(sLunghetta As String, aRuote As Variant, ByVal nSorteCercata As Long, nPassaggiMaxRiduzione As Integer, idEstrIni As Long, idEstrFine As Long, sChrSep As String, ByVal nClasse As Long, nValoreMinRichiesto As Integer, nCombSvilTot As Long, TipoRicerca As eTipoRicerca) As Boolean
Dim k As Long, j As Long
Dim an() As Long ' ccontiene i numeri delal lunghetta da passare alal funzione di sviluppo
Dim av As Variant ' contiene i numeri splittati dal record della lunghetta
Dim aCol As Variant ' colonna sviluppata
Dim aColMaxCorrente () As Long ' colonna col valore piu alto
Dim nValore As Long, nValoreMax As Long, nQValoriMax As Long
Dim frz As STRUCT_FRZ_STATISTICA_SINGOLO_ESITO ' contiene i risultati della statistica
Dim nPassaggi As Long ' conteggia i passaggi di riduzione
Dim nClasseOrig As Integer = nClasse
av = SplitXX(sLunghetta, sChrSep)
ReDim an(UBound(av) + 1)
For k = 0 To UBound(av)
an(k + 1) = Val(av(k))
Next
Do
nPassaggi = 0
nClasse = nClasseOrig
Do
nClasse -= 1
nPassaggi + = 1
nQValoriMax = 0
nValoreMax = 0
ReDim aCol(nClasse)
ReDim aColMaxCorrente(nClasse)
If InitSviluppoIntegrale(an, nClasse) Then
'do While GetCombSviluppoCls(colSvil)
Do While GetCombSviluppo(aCol)
nCombSvilTot + = 1
'Call StatisticaSingoloEsito(colSvil.aNumeeri, idEstrIni, idEstrFine, nSorteCercata, frz, aRuote)
Call StatisticaSingoloEsito(aCol, idEstrIni, idEstrFine, nSorteCercata, frz, aRuote)
If TipoRicerca = eTipoRicerca.Presenze Then
nValore = frz.RetValori.Presenze
ElseIf TipoRicerca = eTipoRicerca.PresenzeMultiple Then
nValore = frz.RetValori.PresenzeMultiple
End If
If nValore > nValoreMax Then
nValoreMax = nValore
nQValoriMax = 1
For j = 1 To nClasse
aColMaxCorrente (j) = aCol (j)
Next
ElseIf nValore = nValoreMax Then
nQValoriMax + = 1
End If
If nCombSvilTot Mod 100 Then
If bScriptInterrotto Then Exit Do
DoEvents
End If
Loop
Else
Exit Do
End If
Loop While nQValoriMax > 1 AndAlso nPassaggi < nPassaggiMaxRiduzione
nSorteCercata + = 1
Loop While nSorteCercata <= 5 AndAlso nQValoriMax > 1
If nQValoriMax = 1 And nValoreMax >= nValoreMinRichiesto Then
sLunghetta = StringaNumeri (aColMaxCorrente, sChrSep)
Return True
End If
Return False
End Function
che si trova nella penultima DLL distribuita (la 5 mi pare).
