BaseDat.dat

[DATA]

a me no ,ma se tu vuoi farlo da estrazioni prima fallo pure , lottomatica ha solo dal 39 ad oggi

 

[DATA]

Perfetto esatto dal 39' ad oggi

'Aggiorna archivio lotto di Spaziometria

'Versione irrobustita per archivio vuoto / archivio esistente
'Fonte archivio: Lotto Italia
'Copertura gestita da questo script: dal 1939 a oggi
'
'Regola storica corretta:
'- fino al 03/05/2005: 10 ruote
'- dal 04/05/2005 in poi: 11 ruote (con Ruota Nazionale)
'
'Correzioni incluse:
'- gestione BOM / spazi anomali nel file testo
'- cartella temporanea dedicata e pulita a ogni esecuzione
'- verifica esito decompressione zip
'- ricerca più robusta del file storico estratto
'- validazione del file storico trovato
'- scarto righe duplicate per stessa data/ruota
'- compatibilità archivio vuoto e archivio esistente

Option Explicit

Sub Main()

Dim sDirBaseTemp,sDirZip,sDirEstrazione,sPathEstratto
Dim sLink,sFileBd
Dim sCmd
Dim sDataUltima,sDataUltimaISO
Dim sDataCorrente,sNuovaData,sSigla
Dim sNumeroFormattato
Dim nEstrTot,nSalvate
Dim nIdUltimo
Dim sAnnoUltimoSalvato
Dim bSalvaDaSubito,bTrovataUltimaData,bArchivioVuoto
Dim bRigaNumericaValida

Dim aRighe,aCampi
Dim aEstr,aRuotePresenti
Dim k,r,c
Dim nEsitoSalvataggio
Dim nRigheScartate,nEstrazioniIncomplete,nLogScartiMostrati
Dim nRuotePresenti,nRuoteAttese
Dim nExitCode

Dim oShell

'========================
' Inizializzazione contatori
'========================
nRigheScartate = 0
nEstrazioniIncomplete = 0
nLogScartiMostrati = 0

'========================
' Percorsi file
'========================
sDirBaseTemp = AssicuraBackslashFinale(GetDirectoryTemp)
sFileBd = GetDirectoryAppData & "BaseDati.dat"
sDirZip = sDirBaseTemp & "storico.zip"
sDirEstrazione = sDirBaseTemp & "storico_lotto_tmp\"

'========================
' Pulizia area temporanea
'========================
Call EliminaFile(sDirZip)
Call EliminaCartellaRicorsiva(sDirEstrazione)

If Not CreaCartellaSeManca(sDirEstrazione) Then
Call Scrivi("ERRORE: impossibile creare la cartella temporanea di estrazione.",True,,,vbRed)
Exit Sub
End If

'========================
' Download archivio ufficiale
'========================
sLink = "https://www.brightstarlottery.it/STORICO_ESTRAZIONI_LOTTO/storico.zip"
Call Messaggio("Download archivio ufficiale in corso...")

If Not DownloadFromWeb(sLink,sDirZip) Then
Call Scrivi("ERRORE: impossibile scaricare il file zip dal sito Lotto Italia / BrightStar.",True,,,vbRed)
Call EliminaCartellaRicorsiva(sDirEstrazione)
Exit Sub
End If

If Not FileEsisteConDimensione(sDirZip) Then
Call Scrivi("ERRORE: il file zip scaricato non esiste oppure è vuoto.",True,,,vbRed)
Call EliminaFile(sDirZip)
Call EliminaCartellaRicorsiva(sDirEstrazione)
Exit Sub
End If

'========================
' Decompressione zip
'========================
Call Messaggio("Decompressione archivio...")

sCmd = "powershell -NoProfile -Command ""Expand-Archive -Force -LiteralPath '" & sDirZip & "' -DestinationPath '" & sDirEstrazione & "'"""

Set oShell = CreateObject("WScript.Shell")
nExitCode = oShell.Run(sCmd,0,True)
Set oShell = Nothing

If nExitCode <> 0 Then
Call Scrivi("ERRORE: decompressione archivio non riuscita. Codice PowerShell: " & nExitCode,True,,,vbRed)
Call EliminaFile(sDirZip)
Call EliminaCartellaRicorsiva(sDirEstrazione)
Exit Sub
End If

sPathEstratto = TrovaFileStoricoEstratto(sDirEstrazione,"storico.txt")

If Trim(sPathEstratto) = "" Then
Call Scrivi("ERRORE: nessun file storico valido trovato dopo la decompressione.",True,,,vbRed)
Call Scrivi("Verificare che lo zip contenga davvero l'archivio testuale delle estrazioni.",True)
Call EliminaFile(sDirZip)
Call EliminaCartellaRicorsiva(sDirEstrazione)
Exit Sub
End If

'========================
' Lettura righe file testo
'========================
ReDim aRighe(0)

If Not LeggiRigheFileDiTesto(sPathEstratto,aRighe) Then
Call Scrivi("ERRORE: impossibile leggere il file storico estratto.",True,,,vbRed)
Call EliminaFile(sDirZip)
Call EliminaCartellaRicorsiva(sDirEstrazione)
Exit Sub
End If

Call EliminaFile(sDirZip)
Call EliminaCartellaRicorsiva(sDirEstrazione)

'========================
' Stato archivio corrente
'========================
nEstrTot = EstrazioniArchivio

If nEstrTot <= 0 Then
' Archivio vuoto: salviamo tutto dall'inizio del file sorgente
bArchivioVuoto = True
bSalvaDaSubito = True
bTrovataUltimaData = True
sDataUltima = ""
sDataUltimaISO = ""
nIdUltimo = 0
sAnnoUltimoSalvato = ""
Else
' Archivio esistente: salviamo solo da dopo l'ultima data presente
bArchivioVuoto = False
bSalvaDaSubito = False
bTrovataUltimaData = False

sDataUltima = DataEstrazione(nEstrTot,,,"/") ' GG/MM/AAAA
sDataUltimaISO = Right(sDataUltima,4) & "/" & Mid(sDataUltima,4,2) & "/" & Left(sDataUltima,2) ' AAAA/MM/GG
nIdUltimo = IndiceAnnuale(nEstrTot)
sAnnoUltimoSalvato = Left(sDataUltimaISO,4)
End If

'========================
' Inizializzazione buffer estrazione
'========================
ReDim aEstr(11,5)
ReDim aRuotePresenti(11)
sDataCorrente = ""
nSalvate = 0

'========================
' Formato atteso righe:
' AAAA/MM/GG [TAB/SPAZI] SIGLA [TAB/SPAZI] N1 N2 N3 N4 N5
'
' Ordine sigle nel file sorgente ufficiale:
' BA CA FI GE MI NA PA RM RN TO VE
'
' Ordine ruote Spaziometria:
' 1 BA
' 2 CA
' 3 FI
' 4 GE
' 5 MI
' 6 NA
' 7 PA
' 8 RM (Roma)
' 9 TO
' 10 VE
' 11 RN (Nazionale / NZ in Spaziometria)
'========================
For k = 0 To UBound(aRighe)

If ScriptInterrotto Then Exit For

If Trim(CStr(aRighe(k))) <> "" Then

aCampi = EstraiCampiRiga(CStr(aRighe(k)))

If HaCampiMinimi(aCampi,6) Then

sNuovaData = Trim(CStr(aCampi(0))) ' AAAA/MM/GG
sSigla = UCase(Trim(CStr(aCampi(1))))

If Not DataISOValida(sNuovaData) Then

Call RegistraScarto("riga " &(k + 1) & " con data non valida: " & CStr(aRighe(k)),nRigheScartate,nLogScartiMostrati,20)

Else

'---------------------------------
' Se cambia la data, prima chiudo
' l'estrazione precedente
'---------------------------------
If sNuovaData <> sDataCorrente Then

If sDataCorrente <> "" Then

nEsitoSalvataggio = SalvaEstrazioneCorrente(_
bSalvaDaSubito,_
sDataCorrente,_
aRuotePresenti,_
aEstr,_
sAnnoUltimoSalvato,_
nIdUltimo,_
sFileBd)

Select Case nEsitoSalvataggio
Case 1
nSalvate = nSalvate + 1
Call Messaggio(nSalvate)

Case - 1
nEstrazioniIncomplete = nEstrazioniIncomplete + 1
nRuotePresenti = ContaRuotePresenti(aRuotePresenti)
nRuoteAttese = NumeroRuoteAttese(sDataCorrente)
ColoreTesto 2
Call Scrivi("ATTENZIONE: estrazione incompleta ignorata in data " & sDataCorrente & _
" (ruote presenti: " & nRuotePresenti & "/" & nRuoteAttese & ")",True)
ColoreTesto 0

Case - 2
ColoreTesto 2
Call Scrivi("ATTENZIONE: errore di salvataggio per l'estrazione del " & sDataCorrente,True)
ColoreTesto 0
End Select

' Se l'estrazione appena chiusa è l'ultima già presente
' nell'archivio, da quella successiva in poi si salva
If(Not bSalvaDaSubito) Then
If sDataCorrente = sDataUltimaISO Then
bSalvaDaSubito = True
bTrovataUltimaData = True
End If
End If

End If

' Reset buffer per la nuova data
ReDim aEstr(11,5)
ReDim aRuotePresenti(11)
sDataCorrente = sNuovaData

End If

'---------------------------------
' Mappa sigla ruota -> indice riga
'---------------------------------
r = MappaRuota(sSigla)

If r <= 0 Then

Call RegistraScarto("riga " &(k + 1) & " con sigla ruota sconosciuta: " & sSigla,nRigheScartate,nLogScartiMostrati,20)

ElseIf aRuotePresenti(r) = 1 Then

Call RegistraScarto("riga " &(k + 1) & " duplicata per data " & sNuovaData & " e ruota " & sSigla,nRigheScartate,nLogScartiMostrati,20)

Else

bRigaNumericaValida = True

For c = 1 To 5
If SafeFormatNumero(aCampi(c + 1),sNumeroFormattato) Then
aEstr(r,c) = sNumeroFormattato
Else
bRigaNumericaValida = False
Exit For
End If
Next

If bRigaNumericaValida Then
aRuotePresenti(r) = 1
Else
Call RegistraScarto("riga " &(k + 1) & " con numeri non validi: " & CStr(aRighe(k)),nRigheScartate,nLogScartiMostrati,20)
End If

End If

End If

Else
Call RegistraScarto("riga " &(k + 1) & " con campi insufficienti: " & CStr(aRighe(k)),nRigheScartate,nLogScartiMostrati,20)
End If

End If

Call AvanzamentoElab(0,UBound(aRighe),k)

Next

'========================
' Salvataggio ultima estrazione letta
'========================
If sDataCorrente <> "" Then

nEsitoSalvataggio = SalvaEstrazioneCorrente(_
bSalvaDaSubito,_
sDataCorrente,_
aRuotePresenti,_
aEstr,_
sAnnoUltimoSalvato,_
nIdUltimo,_
sFileBd)

Select Case nEsitoSalvataggio
Case 1
nSalvate = nSalvate + 1

Case - 1
nEstrazioniIncomplete = nEstrazioniIncomplete + 1
nRuotePresenti = ContaRuotePresenti(aRuotePresenti)
nRuoteAttese = NumeroRuoteAttese(sDataCorrente)
ColoreTesto 2
Call Scrivi("ATTENZIONE: ultima estrazione incompleta ignorata in data " & sDataCorrente & _
" (ruote presenti: " & nRuotePresenti & "/" & nRuoteAttese & ")",True)
ColoreTesto 0

Case - 2
ColoreTesto 2
Call Scrivi("ATTENZIONE: errore di salvataggio per l'ultima estrazione del " & sDataCorrente,True)
ColoreTesto 0

Case Else
' Caso archivio esistente ma ultima data non trovata nel file sorgente
If(Not bArchivioVuoto) Then
If sDataCorrente = sDataUltimaISO Then
bTrovataUltimaData = True
End If
End If
End Select

End If

'========================
' Riepilogo finale
'========================
If nSalvate > 0 Then

AllineaArchivi

Call Scrivi()
Call Scrivi("Script per Spaziometria - Aggiornamento da Lotto Italia ",True,,,vbBlue)
Call Scrivi()
Call Scrivi("Sono state aggiunte " & nSalvate & " estrazioni")
Call Scrivi()
Call Scrivi("Estrazioni totali: " & EstrazioniArchivio)
Call Scrivi()

If nRigheScartate > 0 Then
Call Scrivi("Righe sorgente scartate: " & nRigheScartate)
End If

If nEstrazioniIncomplete > 0 Then
Call Scrivi("Estrazioni incomplete ignorate: " & nEstrazioniIncomplete)
End If

If nLogScartiMostrati >= 20 And nRigheScartate > 20 Then
Call Scrivi("Mostrati solo i primi 20 scarti a video.")
End If

Call Scrivi()
Call Scrivi("Fonte: www.lotto-italia ")
Call Scrivi()
Call Scrivi("Yes",True,,,vbBlue)

Else

If(Not bArchivioVuoto) And(Not bTrovataUltimaData) Then
Call Scrivi("ATTENZIONE: l'ultima data presente in archivio non è stata trovata nel file sorgente.",True,,,vbRed)
Call Scrivi("Verificare la coerenza di BaseDati.dat oppure ricostruire l'archivio da zero.",True)
Else
Call Scrivi("NON HO TROVATO NUOVE ESTRAZIONI !",True,,,2)
End If

If nRigheScartate > 0 Then
Call Scrivi("Righe sorgente scartate: " & nRigheScartate,True)
End If

If nEstrazioniIncomplete > 0 Then
Call Scrivi("Estrazioni incomplete ignorate: " & nEstrazioniIncomplete,True)
End If

End If

End Sub

'========================================================
' Restituisce l'indice ruota usato da Spaziometria
'========================================================
Function MappaRuota(ByVal sSigla)

MappaRuota = 0

Select Case UCase(Trim(sSigla))
Case "BA": MappaRuota = 1
Case "CA": MappaRuota = 2
Case "FI": MappaRuota = 3
Case "GE": MappaRuota = 4
Case "MI": MappaRuota = 5
Case "NA": MappaRuota = 6
Case "PA": MappaRuota = 7
Case "RM": MappaRuota = 8 ' Roma
Case "TO": MappaRuota = 9
Case "VE": MappaRuota = 10
Case "RN": MappaRuota = 11 ' Nazionale
End Select

End Function

'========================================================
' Calcola il prossimo indice annuale
'========================================================
Function ProssimoIndiceAnnuale(ByVal sAnnoUltimoSalvato,ByVal sDataCorrente,ByVal nIdUltimo)

If Trim(sAnnoUltimoSalvato) = "" Then
ProssimoIndiceAnnuale = 1
ElseIf Left(sDataCorrente,4) <> Trim(sAnnoUltimoSalvato) Then
ProssimoIndiceAnnuale = 1
Else
ProssimoIndiceAnnuale = nIdUltimo + 1
End If

End Function

'========================================================
' Restituisce quante ruote devono essere presenti
' per considerare completa l'estrazione.
'
' Archivio ufficiale gestito:
' - dal 1939 al 03/05/2005 -> 10 ruote
' - dal 04/05/2005 in poi -> 11 ruote
'========================================================
Function NumeroRuoteAttese(ByVal sDataCorrente)

If Trim(sDataCorrente) = "" Then
NumeroRuoteAttese = 0
ElseIf sDataCorrente < "2005/05/04" Then
NumeroRuoteAttese = 10
Else
NumeroRuoteAttese = 11
End If

End Function

'========================================================
' Verifica che l'estrazione sia completa rispetto
' alla data storica del file ufficiale BrightStar
'========================================================
Function EstrazioneCompleta(ByVal sDataCorrente,ByRef aRuotePresenti,ByRef aEstr)

Dim rr,cc
Dim nMaxRuote

nMaxRuote = NumeroRuoteAttese(sDataCorrente)

If nMaxRuote <= 0 Then
EstrazioneCompleta = False
Exit Function
End If

EstrazioneCompleta = True

For rr = 1 To nMaxRuote

If aRuotePresenti(rr) <> 1 Then
EstrazioneCompleta = False
Exit Function
End If

For cc = 1 To 5
If Trim(CStr(aEstr(rr,cc))) = "" Then
EstrazioneCompleta = False
Exit Function
End If
Next

Next

End Function

'========================================================
' Salva l'estrazione corrente se siamo già nella fase
' di salvataggio. Restituisce:
' 1 = salvata
' 0 = non da salvare
' -1 = incompleta
' -2 = errore salvataggio
'========================================================
Function SalvaEstrazioneCorrente(ByVal bSalvaDaSubito,ByVal sDataCorrente,ByRef aRuotePresenti,ByRef aEstr,ByRef sAnnoUltimoSalvato,ByRef nIdUltimo,ByVal sFileBd)

Dim nIdDaSalvare
Dim sDataEstr

SalvaEstrazioneCorrente = 0

If Not bSalvaDaSubito Then Exit Function

If Not EstrazioneCompleta(sDataCorrente,aRuotePresenti,aEstr) Then
SalvaEstrazioneCorrente = - 1
Exit Function
End If

nIdDaSalvare = ProssimoIndiceAnnuale(sAnnoUltimoSalvato,sDataCorrente,nIdUltimo)
sDataEstr = Right(sDataCorrente,2) & "/" & Mid(sDataCorrente,6,2) & "/" & Left(sDataCorrente,4)

If SalvaEstrazione(aEstr,sDataEstr,nIdDaSalvare,sFileBd) Then
nIdUltimo = nIdDaSalvare
sAnnoUltimoSalvato = Left(sDataCorrente,4)
SalvaEstrazioneCorrente = 1
Else
SalvaEstrazioneCorrente = - 2
End If

End Function

'========================================================
' Conta quante ruote risultano presenti nel buffer
'========================================================
Function ContaRuotePresenti(ByRef aRuotePresenti)

Dim i,nTot
nTot = 0

For i = 1 To UBound(aRuotePresenti)
If aRuotePresenti(i) = 1 Then nTot = nTot + 1
Next

ContaRuotePresenti = nTot

End Function

'========================================================
' Pulisce una riga sorgente:
' - rimuove BOM UTF-8 / Unicode
' - normalizza tab, CR, LF e spazi multipli
'========================================================
Function PulisciRigaInput(ByVal sRiga)

sRiga = CStr(sRiga)

' BOM UTF-8 eventualmente letto come caratteri ANSI
sRiga = Replace(sRiga,Chr(239) & Chr(187) & Chr(191),"")

' BOM Unicode / spazi non standard
On Error Resume Next
sRiga = Replace(sRiga,ChrW(65279),"")
sRiga = Replace(sRiga,ChrW(160)," ")
On Error GoTo 0

sRiga = Replace(sRiga,vbTab," ")
sRiga = Replace(sRiga,vbCr," ")
sRiga = Replace(sRiga,vbLf," ")

Do While InStr(sRiga," ") > 0
sRiga = Replace(sRiga," "," ")
Loop

PulisciRigaInput = Trim(sRiga)

End Function

'========================================================
' Parsing robusto di una riga:
' estrae i token non vuoti anche se separati da tab o spazi
'========================================================
Function EstraiCampiRiga(ByVal sRiga)

Dim aTmp

sRiga = PulisciRigaInput(sRiga)

If sRiga = "" Then
EstraiCampiRiga = Null
Exit Function
End If

aTmp = Split(sRiga," ")
EstraiCampiRiga = aTmp

End Function

'========================================================
' Verifica che un array abbia almeno l'indice richiesto
'========================================================
Function HaCampiMinimi(ByRef vArray,ByVal nIndiceMinimo)

On Error Resume Next

HaCampiMinimi = False

If IsArray(vArray) Then
If UBound(vArray) >= nIndiceMinimo Then
HaCampiMinimi = True
End If
End If

On Error GoTo 0

End Function

'========================================================
' Valida una data in formato AAAA/MM/GG
'========================================================
Function DataISOValida(ByVal sDataISO)

Dim nAnno,nMese,nGiorno
Dim dTest

DataISOValida = False

sDataISO = Trim(CStr(sDataISO))

If Not RegexTest(sDataISO,"^\d{4}/\d{2}/\d{2}$") Then Exit Function

nAnno = CInt(Left(sDataISO,4))
nMese = CInt(Mid(sDataISO,6,2))
nGiorno = CInt(Right(sDataISO,2))

On Error Resume Next
dTest = DateSerial(nAnno,nMese,nGiorno)

If Err.Number <> 0 Then
Err.Clear
On Error GoTo 0
Exit Function
End If

On Error GoTo 0

If Year(dTest) = nAnno And Month(dTest) = nMese And Day(dTest) = nGiorno Then
DataISOValida = True
End If

End Function

'========================================================
' Valida un numero lotto e lo restituisce in formato 2 cifre
'========================================================
Function SafeFormatNumero(ByVal vValore,ByRef sNumeroFormattato)

Dim sValore,nValore

SafeFormatNumero = False
sNumeroFormattato = ""

sValore = Trim(CStr(vValore))

If Not RegexTest(sValore,"^\d{1,2}$") Then Exit Function

nValore = CLng(sValore)

If nValore < 1 Or nValore > 90 Then Exit Function

sNumeroFormattato = Format2(CInt(nValore))
SafeFormatNumero = True

End Function

'========================================================
' Test regex generico
'========================================================
Function RegexTest(ByVal sTesto,ByVal sPattern)

Dim oRe

Set oRe = CreateObject("VBScript.RegExp")
oRe.Pattern = sPattern
oRe.Global = False
oRe.IgnoreCase = True

RegexTest = oRe.Test(CStr(sTesto))

Set oRe = Nothing

End Function

'========================================================
' Registra uno scarto e mostra solo i primi N a video
'========================================================
Sub RegistraScarto(ByVal sMessaggio,ByRef nContatoreScarti,ByRef nLogMostrati,ByVal nMaxLog)

nContatoreScarti = nContatoreScarti + 1

If nLogMostrati < nMaxLog Then
ColoreTesto 2
Call Scrivi("SCARTO: " & sMessaggio,True)
ColoreTesto 0
nLogMostrati = nLogMostrati + 1
End If

End Sub

'========================================================
' Garantisce il backslash finale di una cartella
'========================================================
Function AssicuraBackslashFinale(ByVal sPercorso)

sPercorso = Trim(CStr(sPercorso))

If sPercorso <> "" Then
If Right(sPercorso,1) <> "\" Then
sPercorso = sPercorso & "\"
End If
End If

AssicuraBackslashFinale = sPercorso

End Function

'========================================================
' Crea una cartella se non esiste
'========================================================
Function CreaCartellaSeManca(ByVal sCartella)

Dim oFSO

CreaCartellaSeManca = False

On Error Resume Next

Set oFSO = CreateObject("Scripting.FileSystemObject")

If Not oFSO.FolderExists(sCartella) Then
oFSO.CreateFolder sCartella
End If

If Err.Number = 0 Then
If oFSO.FolderExists(sCartella) Then
CreaCartellaSeManca = True
End If
End If

Set oFSO = Nothing
On Error GoTo 0

End Function

'========================================================
' Elimina una cartella ricorsivamente se esiste
'========================================================
Sub EliminaCartellaRicorsiva(ByVal sCartella)

Dim oFSO

On Error Resume Next

Set oFSO = CreateObject("Scripting.FileSystemObject")

If oFSO.FolderExists(sCartella) Then
oFSO.DeleteFolder sCartella,True
End If

Set oFSO = Nothing

On Error GoTo 0

End Sub

'========================================================
' Verifica che un file esista e abbia dimensione > 0
'========================================================
Function FileEsisteConDimensione(ByVal sPercorsoFile)

Dim oFSO,oFile

FileEsisteConDimensione = False

On Error Resume Next

Set oFSO = CreateObject("Scripting.FileSystemObject")

If oFSO.FileExists(sPercorsoFile) Then
Set oFile = oFSO.GetFile(sPercorsoFile)
If CLng(oFile.Size) > 0 Then
FileEsisteConDimensione = True
End If
Set oFile = Nothing
End If

Set oFSO = Nothing

On Error GoTo 0

End Function

'========================================================
' Cerca il file storico estratto:
' 1) prova nome esatto e valida il contenuto
' 2) prova un .txt con "storico" nel nome e valida
' 3) prende il .txt valido più grande
'========================================================
Function TrovaFileStoricoEstratto(ByVal sCartellaBase,ByVal sNomePreferito)

Dim oFSO
Dim sPercorso
Dim nSizeMax

TrovaFileStoricoEstratto = ""

Set oFSO = CreateObject("Scripting.FileSystemObject")

If Not oFSO.FolderExists(sCartellaBase) Then
Set oFSO = Nothing
Exit Function
End If

sPercorso = CercaFilePerNome(oFSO.GetFolder(sCartellaBase),LCase(Trim(sNomePreferito)))
If Trim(sPercorso) <> "" Then
If FileStoricoValido(sPercorso) Then
TrovaFileStoricoEstratto = sPercorso
Set oFSO = Nothing
Exit Function
End If
End If

sPercorso = CercaFileTxtValidoPerNome(oFSO.GetFolder(sCartellaBase),"storico")
If Trim(sPercorso) <> "" Then
TrovaFileStoricoEstratto = sPercorso
Set oFSO = Nothing
Exit Function
End If

nSizeMax = - 1
sPercorso = CercaFileTxtValidoPiuGrande(oFSO.GetFolder(sCartellaBase),nSizeMax)
If Trim(sPercorso) <> "" Then
TrovaFileStoricoEstratto = sPercorso
End If

Set oFSO = Nothing

End Function

'========================================================
' Verifica che un file .txt sia davvero uno storico lotto valido
'========================================================
Function FileStoricoValido(ByVal sPathFile)

Dim aTestRighe,aCampi
Dim i,c
Dim nNonVuote,nValide
Dim sDummy

FileStoricoValido = False

If Trim(sPathFile) = "" Then Exit Function
If LCase(Trim(GetEstensioneFile(sPathFile))) <> "txt" Then Exit Function

ReDim aTestRighe(0)

If Not LeggiRigheFileDiTesto(sPathFile,aTestRighe) Then Exit Function

nNonVuote = 0
nValide = 0

For i = 0 To UBound(aTestRighe)

If Trim(CStr(aTestRighe(i))) <> "" Then

nNonVuote = nNonVuote + 1
aCampi = EstraiCampiRiga(CStr(aTestRighe(i)))

If HaCampiMinimi(aCampi,6) Then
If DataISOValida(CStr(aCampi(0))) Then
If MappaRuota(CStr(aCampi(1))) > 0 Then

sDummy = ""
If SafeFormatNumero(aCampi(2),sDummy) Then
If SafeFormatNumero(aCampi(3),sDummy) Then
If SafeFormatNumero(aCampi(4),sDummy) Then
If SafeFormatNumero(aCampi(5),sDummy) Then
If SafeFormatNumero(aCampi(6),sDummy) Then
nValide = nValide + 1
End If
End If
End If
End If
End If

End If
End If
End If

If nNonVuote >= 50 Then Exit For

End If

Next

If nValide >= 3 Then
FileStoricoValido = True
End If

End Function

'========================================================
' Cerca ricorsivamente un file per nome esatto
'========================================================
Function CercaFilePerNome(ByVal oFolder,ByVal sNomeRicercato)

Dim oFile,oSub,sPercorso

CercaFilePerNome = ""

For Each oFile In oFolder.Files
If LCase(Trim(oFile.Name)) = sNomeRicercato Then
CercaFilePerNome = oFile.Path
Exit Function
End If
Next

For Each oSub In oFolder.SubFolders
sPercorso = CercaFilePerNome(oSub,sNomeRicercato)
If Trim(sPercorso) <> "" Then
CercaFilePerNome = sPercorso
Exit Function
End If
Next

End Function

'========================================================
' Cerca ricorsivamente un file .txt valido che contenga
' una parola nel nome
'========================================================
Function CercaFileTxtValidoPerNome(ByVal oFolder,ByVal sParteNome)

Dim oFile,oSub,sPercorso

CercaFileTxtValidoPerNome = ""

For Each oFile In oFolder.Files
If LCase(Trim(GetEstensioneFile(oFile.Name))) = "txt" Then
If InStr(1,LCase(Trim(oFile.Name)),LCase(Trim(sParteNome)),vbTextCompare) > 0 Then
If FileStoricoValido(oFile.Path) Then
CercaFileTxtValidoPerNome = oFile.Path
Exit Function
End If
End If
End If
Next

For Each oSub In oFolder.SubFolders
sPercorso = CercaFileTxtValidoPerNome(oSub,sParteNome)
If Trim(sPercorso) <> "" Then
CercaFileTxtValidoPerNome = sPercorso
Exit Function
End If
Next

End Function

'========================================================
' Cerca ricorsivamente il file .txt valido più grande
'========================================================
Function CercaFileTxtValidoPiuGrande(ByVal oFolder,ByRef nSizeMax)

Dim oFile,oSub,sPercorso,sBest

sBest = ""

For Each oFile In oFolder.Files
If LCase(Trim(GetEstensioneFile(oFile.Name))) = "txt" Then
If CLng(oFile.Size) > CLng(nSizeMax) Then
If FileStoricoValido(oFile.Path) Then
nSizeMax = CLng(oFile.Size)
sBest = oFile.Path
End If
End If
End If
Next

For Each oSub In oFolder.SubFolders
sPercorso = CercaFileTxtValidoPiuGrande(oSub,nSizeMax)
If Trim(sPercorso) <> "" Then
sBest = sPercorso
End If
Next

CercaFileTxtValidoPiuGrande = sBest

End Function

'========================================================
' Restituisce l'estensione di un file
'========================================================
Function GetEstensioneFile(ByVal sNomeFile)

Dim nPos

GetEstensioneFile = ""
sNomeFile = Trim(CStr(sNomeFile))
nPos = InStrRev(sNomeFile,".")

If nPos > 0 Then
GetEstensioneFile = Mid(sNomeFile,nPos + 1)
End If

End Function

 

[DATA]