desideri66
Super Member >PLATINUM<
ciao keeper sei il benvenuto
Follow along with the video below to see how to install our site as a web app on your home screen.
Nota: This feature may not be available in some browsers.
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)
sFile = GetDirectoryAppData & "Estrazioni10Lotto5M.txt"
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
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
Call EsportaEstr(nEstrInizio,nEstrFine,FasciaOrariaIni,FasciaOrariaFin,sFile,sChrSep,True)
End If
Else
If EliminaFile(sFile) Then
Call EsportaEstr(nEstrInizio,nEstrFine,FasciaOrariaIni,FasciaOrariaFin,sFile,sChrSep,False)
End If
End If
End If
End If
End If
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
End Sub
Sub EsportaEstr(nEstrInizio,nEstrFine,FasciaOrariaIni,FasciaOrariaFin,sFile,sChrSep,bAggiornaXls)
Dim k,f,idEstr
Dim sRecord
Dim nProgr
Dim sDataCorr
nProgr = 0
For k = nEstrInizio To nEstrFine Step 228
Call Messaggio("Estrazione : " & k)
For f = FasciaOrariaIni To FasciaOrariaFin
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
Call AddRigaXls(sRecord,nProgr,sChrSep)
Else
Call ScriviFile(sFile,sRecord,False,True)
End If
Else
Exit For
End If
If ScriptInterrotto Then Exit For
Next
If ScriptInterrotto Then Exit For
Call AvanzamentoElab(nEstrInizio,nEstrFine,k)
Next
If bAggiornaXls = False Then
Call CloseFileHandle(sFile)
Call LanciaFile(sFile)
Else
Call AbilitaCalcoloXls (True)
xlSheet.cells(1,1).select
xlSheet.select
xlApp.WindowState = xlMaximized
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
xlApp.WindowState = xlMinimized
Call AbilitaCalcoloXls (False)
xlSheet.Cells.Select
xlSheet.Cells.ClearContents
IstanziaExcel = True
End If
End If
End Function
Sub AddRigaXls(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
scusami se intervengo luigib credo che in questo modo è più facile per ogni utente crearsi un proprio archivio personale, in quanto se inseriresti un accodamento il meno smaliziato inizarebbe con le solite domande che il foglio non funziona lo scirpt non gira, invece così uno resetta tutto e via, poi solo avatar desideri66 o altri sanno come giostrare con 20000 estrazioni, questa è solo una riflessione non credi?di nulla ... pero mi sa che ventimila sono troppe ci mettera un bel po' a scriverle .. forse si dovrebbe pensare a fare in modo che lo script invece che alimentare daccapo il foglio archivio andasse in accodamento sulle estrazioni gia esistenti aggiungendo solo le nuove , pero bisognerebe stabilire un po' la logica del tutto ... nel senso se va in accodamento deve continuare con l'ultimo numero progressivo ? Se le nuove estrazioni accodate non sono dello stesso range orario di quelle gia presenti che si deve fare e magari altre cose che ora non mi vengono in mente...
Ciao