Option Explicit
Option Explicit
Dim xlApp ' oggetto excel
Dim xlBook ' insieme di cartelle di lavoro
Dim xlSheet ' foglio di lavoro
Const xlCalculationManual = - 4135 '(&HFFFFEFD9)
Const xlCalculationAutomatic = - 4105 '(&HFFFFEFF7)
Const xlMaximized = - 4137 '(&HFFFFEFD7)
Const xlMinimized = - 4140 '(&HFFFFEFD4)
Sub Main
Dim nEstrInizio,nEstrFine
Dim DataIni,DataFin
Dim FasciaOrariaIni,FasciaOrariaFin
Dim sFile
Dim sChrSep
sChrSep = "|"
If MsgBox("Vuoi aggiornare le estrazioni prima di eseguire l'export ?",vbQuestion + vbYesNo) = vbYes Then
Call AggiornaArchivioDL
End If
Call ImpostaArchivio10ELotto(2)
If MsgBox("Vuoi aggiornare direttamente il foglio excel ?" & vbCrLf & "Premendo NO verrà creato il file di testo" & _
vbCrLf & "Se premi SI il foglio SPIAMO I NUMERI deve essere aperto",vbQuestion + vbYesNo) = vbYes Then
If IstanziaExcel Then
xlApp.WindowState = xlMinimized
Call AbilitaCalcoloXls(False)
Call AggiornaExcel(sChrSep)
Call AbilitaCalcoloXls(True)
xlApp.WindowState = xlMaximized
End If
Else
sFile = GetDirectoryAppData & "Estrazioni10Lotto5M.txt"
If EliminaFile(sFile) Then
If ChiediDataInizioFine(DataIni,DataFin) Then
If ChiediFasciaInizioFine(FasciaOrariaIni,FasciaOrariaFin) Then
nEstrInizio = DataEstrToIdEstrDL(Day(DataIni),Month(DataIni),Year(DataIni),1)
nEstrFine = DataEstrToIdEstrDL(Day(DataFin),Month(DataFin),Year(DataFin),1)
If IsRangeValido(nEstrInizio,nEstrFine) Then
Call EsportaEstr(nEstrInizio,nEstrFine,FasciaOrariaIni,FasciaOrariaFin,sFile,sChrSep,False,0,0,0)
End If
End If
End If
End If
End If
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
End Sub
Sub AggiornaExcel(sChrSep)
Dim sOrario,nEstrInizio,nEstrFine,FasciaOrariaIni,FasciaOrariaFin
Dim DataIni,DataFin
Dim bChiedi
Dim sLastData,nLastId,nProgr,idRigaXls
sOrario = GetRangeOrarioDaFoglioXls(FasciaOrariaIni,FasciaOrariaFin)
If sOrario <> "" Then
Call GetLastDataIdProgr(sLastData,nLastId,nProgr,idRigaXls)
If MsgBox("E' stato rilevato il range orario " & sOrario & vbCrLf & _
"L'ultima data in archivio risulta : " & sLastData & _
vbCrLf & "L'ultima giocata oraria è : " & GetOrario(nLastId) & _
vbCrLf & "Accodare le estrazioni nuove nel range orario previsto ?" & _
vbCrLf & "Premendo NO , il foglio archivio verra aggiornato" & _
" daccapo e sara possibile scegliere il range ",vbQuestion + vbYesNo) = vbYes Then
bChiedi = False
Else
bChiedi = True
End If
Else
bChiedi = True
End If
If bChiedi Then
If ChiediDataInizioFine(DataIni,DataFin) Then
If ChiediFasciaInizioFine(FasciaOrariaIni,FasciaOrariaFin) Then
nEstrInizio = DataEstrToIdEstrDL(Day(DataIni),Month(DataIni),Year(DataIni),1)
nEstrFine = DataEstrToIdEstrDL(Day(DataFin),Month(DataFin),Year(DataFin),1)
If IsRangeValido(nEstrInizio,nEstrFine) Then
xlSheet.Cells.Select
xlSheet.Cells.Range("A7:Z30000").ClearContents
Call EsportaEstr(nEstrInizio,nEstrFine,FasciaOrariaIni,FasciaOrariaFin,"",sChrSep,True,6,0,0)
End If
End If
End If
Else
DataIni = FormattaStringa(sLastData,"dd/mm/yyyy")
DataFin = FormattaStringa(Now,"dd/mm/yyyy")
nEstrInizio = DataEstrToIdEstrDL(Day(DataIni),Month(DataIni),Year(DataIni),1)
nEstrFine = DataEstrToIdEstrDL(Day(DataFin),Month(DataFin),Year(DataFin),1)
xlSheet.Cells.Select
Call EsportaEstr(nEstrInizio,nEstrFine,FasciaOrariaIni,FasciaOrariaFin,"",sChrSep,True,idRigaXls,nProgr,nLastId)
End If
End Sub
Sub EsportaEstr(nEstrInizio,nEstrFine,FasciaOrariaIni,FasciaOrariaFin,sFile,sChrSep,bAggiornaXls,nPrimaRigaXls,nProgrXls,nLastFasciaOrario)
Dim k,f,idEstr
Dim sRecord
Dim nProgr
Dim sDataCorr
Dim idRigaXls
idRigaXls = nPrimaRigaXls
nProgr = nProgrXls
For k = nEstrInizio To nEstrFine Step 228
Call Messaggio("Estrazione : " & k)
For f = FasciaOrariaIni To FasciaOrariaFin
If f > nLastFasciaOrario Then
idEstr =(k - 1) + f
ReDim aNum(0)
If GetEstrazioneCompletaDL(idEstr,aNum) Then
nProgr = nProgr + 1
sDataCorr = Replace(DataEstrazioneDL(idEstr),".","/")
sRecord = FormatSpace(nProgr,9,True) & sChrSep
sRecord = sRecord & FormatSpace(f,3,True) & sChrSep
sRecord = sRecord & GetOrario(f) & sChrSep
sRecord = sRecord & Format2(Day(sDataCorr)) & sChrSep
sRecord = sRecord & FormattaStringa(sDataCorr,"dd mmm yyyy") & sChrSep
sRecord = sRecord & sChrSep
sRecord = sRecord & StringaNumeri(aNum,sChrSep,True)
If bAggiornaXls Then
idRigaXls = idRigaXls + 1
Call AddRigaXls(idRigaXls,sRecord,nProgr,sChrSep)
Else
Call ScriviFile(sFile,sRecord,False,True)
End If
Else
Exit For
End If
End If
If ScriptInterrotto Then Exit For
Next
nLastFasciaOrario = 0
If ScriptInterrotto Then Exit For
Call AvanzamentoElab(nEstrInizio,nEstrFine,k)
Next
If bAggiornaXls = False Then
Call CloseFileHandle(sFile)
Call LanciaFile(sFile)
Else
xlSheet.cells(1,1).select
xlSheet.select
End If
End Sub
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)
If Not IsDate(DataF) Then DataF = FormattaStringa(Now,"dd/mm/yyyy")
If Not IsDate(DataI) Then DataI = FormattaStringa(DateAdd("d",-(30),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 GetOrario(id)
Dim h,m
h = id \12
m = id Mod 12
If h = 0 Then
h = 5
Else
h = 5 + h
End If
If m = 12 Then
GetOrario = Format2(h) & ":00"
Else
If h = 24 Then
GetOrario = "23:59"
Else
GetOrario = Format2(h) & ":" & Format2(m * 5)
End If
End If
End Function
Function ChiediFasciaInizioFine(FasciaI,FasciaF)
FasciaI = ChiediFasciaOraria("Fascia oraria inizio",1)
FasciaF = ChiediFasciaOraria("Fascia oraria fine",228)
If FasciaI > 0 And FasciaF > 0 Then
If FasciaF >= FasciaI Then
ChiediFasciaInizioFine = True
Else
MsgBox "La fascia oraria Fien deve essere maggiore della fascia oraria INIZIO"
End If
Else
MsgBox "Fascie orarie non valide"
End If
End Function
Function ChiediFasciaOraria(sCaption,nSel)
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"
ChiediFasciaOraria = ScegliOpzioneMenu(aLista,nSel,sCaption)
End Function
Function GetFoglioArchivio
On Error Resume Next
Set xlBook = xlApp.Workbooks(1)
Set xlSheet = xlBook.sheets("archivio")
If Err.number <> 0 Then
MsgBox "Il foglio excel SPIAMO I GIORNI deve essere aperto e contenere il foglio di nome <archivio>"
Else
GetFoglioArchivio = True
End If
End Function
Function GetExcel
On Error Resume Next
Set xlApp = GetObject(,"Excel.Application")
If Err.number <> 0 Then
MsgBox "Il foglio excel SPIAMO I GIORNI deve essere aperto"
Else
GetExcel = True
End If
End Function
Function IstanziaExcel
If GetExcel Then
If GetFoglioArchivio Then
IstanziaExcel = True
End If
End If
End Function
Sub AddRigaXls(idRiga,sRecord,nProgr,sChrSep)
'Dim idRiga
Dim k
ReDim aV(0)
Call Messaggio("Aggiungo estrazione : " & nProgr)
Call SplitByChar(sRecord,sChrSep,aV)
'idRiga = nProgr +(7 - 1)
For k = 0 To UBound(aV)
xlSheet.cells(idRiga,k + 1) = aV(k)
Next
End Sub
Sub AbilitaCalcoloXls(b)
Dim xlSh
For Each xlSh In xlBook.worksheets
xlSh.enablecalculation = b
Next
If b Then
xlApp.calculation = xlCalculationAutomatic
Else
xlApp.calculation = xlCalculationManual
End If
End Sub
Function GetRangeOrarioDaFoglioXls(nStart,nEnd)
Dim k
Call Messaggio("Lettura archivio precedente")
nStart = 0
nEnd = 0
k = 7
nStart = Int(xlSheet.cells(k,2))
Do
nEnd = Int(xlSheet.cells(k,2))
k = k + 1
Loop While nEnd < Int(xlSheet.cells(k,2))
If nStart > 0 And nEnd > 0 Then
GetRangeOrarioDaFoglioXls = GetOrario(nStart) & "-" & GetOrario(nEnd)
Else
GetRangeOrarioDaFoglioXls = ""
End If
End Function
Function GetLastDataIdProgr(sLastData,nLastId,nProgr,idRigaXls)
Dim k,i
Call Messaggio("Lettura archivio precedente")
sLastData = ""
nLastId = 0
nProgr = 0
idRigaXls = 0
Do
k = k + 100
Loop While xlSheet.cells(k,1) <> ""
For i = k To 1 Step - 1
If xlSheet.cells(i,1) <> "" Then
sLastData = xlSheet.cells(i,5)
nLastId = Int(xlSheet.cells(i,2))
nProgr = Int(xlSheet.cells(i,1))
idRigaXls = i
Exit For
End If
Next
End Function
