Per il file ModAggiornaBaseDati copiare ed in incollare nel vostro, funziona per sistemi 64 bit suite office 365 ma dovrebbe andare bene per altre versioni office su sistemi win64.
Non testato per le varie suite di office opensource e bla bla.
Pour vous
Option Explicit
Option Private Module
' strutture per accedere al file della base dati estrazionale
Type STRUCT_RUOTA
aNum(1 To 5) As Integer
End Type
Type STRUCT_DATA_EST
nNumEstrazione As Integer
GG As Integer
Mm As Integer
AA As Integer
End Type
Type STRUCT_ESTRAZIONE
idEstr As Long
strctData As STRUCT_DATA_EST
aRuote(1 To 11) As STRUCT_RUOTA
End Type
Type STRUCT_INI
sUrlEstrazioni As String ' = "http://www.lottomaticaitalia.it/lotto/doc/archivio/storico.zip" ' sheetImpostazioni.Range("B2")
sPathDiLavoro As String
End Type
Public structIni As STRUCT_INI
Public glbArrNomiRuote(1 To 12) As String
Public Const QRigheIntestazioneSheetEstrazioni = 3 ' numero righe intestazionedel foglio estrazioni
Public bFermaDownload As Boolean
Option Compare Text
'Dim sPathIni As String
Private Type SHFILEOPSTRUCT
Hwnd As Long
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAborted As Boolean
hNameMaps As Long
sProgress As String
End Type
Private Const FO_COPY = &H2
Private Const FO_DELETE = &H3
Private Const FO_MOVE = &H1
Private Const FO_RENAME = &H4
Private Const FOF_ALLOWUNDO = &H40
Private Const FOF_SILENT = &H4
Private Const FOF_NOCONFIRMATION = &H10
Private Const FOF_RENAMEONCOLLISION = &H8
Private Const FOF_NOCONFIRMMKDIR = &H200
Private Const FOF_FILESONLY = &H80
Public Declare PtrSafe Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
' **** FUNZIONI DIRECTORY SISTEMA
' *******************************************
Private Declare PtrSafe Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
'............ directory di windows
Private Declare PtrSafe Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
' directory system
Private Declare PtrSafe Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Public Const MAX_PATH = 260
' **** PATH FUNCTIONS
'********************************************
Private Declare PtrSafe Function PathIsSameRoot Lib "shlwapi.dll" Alias "PathIsSameRootA" (ByVal pszPath1 As String, ByVal pszPath2 As String) As Long
Private Declare PtrSafe Function PathStripToRoot Lib "shlwapi.dll" Alias "PathStripToRootA" (ByVal pszPath As String) As Long
Private Declare PtrSafe Function PathFileExists Lib "shlwapi.dll" Alias "PathFileExistsA" (ByVal pszPath As String) As Long
Private Declare PtrSafe Function PathIsDirectory Lib "shlwapi.dll" Alias "PathIsDirectoryA" (ByVal pszPath As String) As Long
' **** FUNZIONI PER IMPOSTARE SECONDI DI PAUSA
' *******************************************
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
' **** FUNZIONI PER LEGGERE IL FILE INI
' *******************************************
'Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
'Declare Function WritePrivateProfileString& Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As String, ByVal lpFileName As String)
Declare PtrSafe Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Declare PtrSafe Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
' *** download from url
'*********************************************
'Private Declare Function IsValidURL Lib "URLMON.DLL" (ByVal pbc As Long, ByVal szURL As String, ByVal dwReserved As Long) As Long
'Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
'Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal lBuffer As Long) As Long
Private Declare PtrSafe Function IsValidURL Lib "URLMON.DLL" (ByVal pbc As Long, ByVal szURL As String, ByVal dwReserved As Long) As Long
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" ( _
ByVal pCaller As LongPtr, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As Long, _
ByVal lpfnCB As LongPtr _
) As Long
Private Declare PtrSafe Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal lBuffer As Long) As Long
' **** FUNZIONI PER LANCIARE L'APPLICAZIONE ASSOCIATA ALL 'ESTENSIONE DI UN FILE
' *******************************************
'Declare Function FindExecutable Lib "shell32.dll" Alias "FindExecutableA" (ByVal lpFile As String, ByVal lpDirectory As String, ByVal lpResult As String) As Long
'Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal Hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Declare PtrSafe Function FindExecutable Lib "shell32.dll" Alias "FindExecutableA" (ByVal lpFile As String, ByVal lpDirectory As String, ByVal lpResult As String) As Long
Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal Hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Const GWW_HINSTANCE = (-6)
Const SW_SHOWNA = 8
Const SW_SHOWNORMAL = 1
Const SW_MAXIMIZE = 3
'______________ costanti
Const c3600& = 3600
Const c60& = 60
'______________ costanti per le funzioni DI FORMATTAZIONE
Public Const vb_INCSINISTRA = 1 ' costanti per la funzione SPAZI
Public Const vb_INCDESTRA = 2
Public Const vb_INCCENTRO = 3
Public Const vb_NESSUN_ALLINEAMENTO = 4
'_____________ ritorno delle funzioni
Public Const VB_ERRORE = 1
Public Const VB_OK = 2
Public Function GetShortPath(strFileName As String) As String
'KPD-Team 1999
'URL: http://www.allapi.net/
'E-Mail: KPDTeam@Allapi.net
Dim lngRes As Long, strPath As String
'Create a buffer
strPath = String$(165, 0)
'retrieve the short pathname
lngRes = GetShortPathName(strFileName, strPath, 164)
'remove all unnecessary Chr$(0)'s
GetShortPath = Left$(strPath, lngRes)
End Function
Function DownloadFile(URL As String, LocalFilename As String, sRetErr As String) As Boolean
Dim lngRetVal As Long
If IsGoodURL(URL) Then
lngRetVal = URLDownloadToFile(0, URL, LocalFilename, 0, 0)
If lngRetVal = 0 Then
DownloadFile = True
Else
sRetErr = "Errore " & lngRetVal
End If
Else
sRetErr = "Indirizzo non valido"
End If
End Function
Function IsGoodURL(ByVal sUrl As String) As Boolean
'The IsValidURL always expects a UNICODE string, but whenever
'VB calls an API function, it converts the strings to ANSI strings.
'That's why we're going to use a trick here. Before calling the function,
'We're going to convert the unicode string to unicode so we get a double
'unicode string.
'Before VB calls the API function, it converts our double unicode string
'to a normal unicode string; exactely what IsValidURL is expecting.
sUrl = StrConv(sUrl, vbUnicode)
'Now call the function
IsGoodURL = (IsValidURL(ByVal 0&, sUrl, 0) = 0)
End Function
Function AddSlashIfNot(ByVal sPath As String) As String
' Queta Function aggiunge lo slash "\" se questo non è presente
' Ritorna il path con lo slash alla fine
sPath = Trim$(sPath)
If sPath <> "" Then
If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
End If
AddSlashIfNot = sPath
End Function
Function FileExist(sFile As String) As Boolean
On Error GoTo errUNKNOW
FileExist = PathFileExists(sFile)
errUNKNOW:
Select Case Err
Case Is = 0
' No error
Case Else
Err.Clear
End Select
End Function
Function KillFile(sFile As String) As Boolean
On Error GoTo errUNKNOW
'
If InStr(sFile, "*") = 0 Then
If FileExist(sFile) Then
Call SetAttr(sFile, vbNormal)
Kill sFile
End If
Else
Kill sFile
End If
KillFile = True
errUNKNOW:
'
Select Case Err
Case Is = 0
' No error
Case Else
'MsgBox CStr(Err.Number) & "- " & Err.Description, vbCritical, "ModFunzGeneriche.KillFile"
Err.Clear
End Select
End Function
Function RimuoviDir(ByVal sPath As String) As Boolean
On Error GoTo errUNKNOW
If DirExist(sPath) Then
If Right(sPath, 1) = "\" Then sPath = Mid$(sPath, 1, Len(sPath) - 1)
RmDir sPath
Else
RimuoviDir = True
End If
errUNKNOW:
Select Case Err
Case Is = 0
' No error
Case Else
Err.Clear
End Select
End Function
Function DirExist(ByVal Path As String) As Boolean
' Questa funzione controlla se una directory esiste o meno
' Path ---> Path della directory da verificare
' Ritorna true se la directory esiste
On Error GoTo errDIREXIST
' If Len(path) >= 3 Then
' If Len(Dir(path, vbDirectory)) > 0 Then
' DirExist = True
' End If
' End If
If PathIsDirectory(Path) Then
DirExist = True
End If
errDIREXIST:
If Err <> 0 Then
Err.Clear
Exit Function
End If
End Function
Function GetPathFile(sPathFile As String) As String
' Questa funzione restituisce la directory dove è' salvato il sPathFile file passato come parametro
' sPathFile ---> Percorso completo del file
' Ritorna la directory dove è salvato il file
Dim k As Integer
For k = Len(Trim(sPathFile)) To 1 Step -1
If Mid(sPathFile, k, 1) = "\" Then Exit For
Next k
GetPathFile = Left(sPathFile, k)
End Function
Function GetNomeFile(sPath As String) As String
' Questa Function estrae da un Path completo il nome di un file comprensivo di estensione
' sPath ---> nome completo del path + il nome file
' Ritorna il nome del file completo di estensione
'Dim k As Integer
'Dim nome As String
'For k = Len(sPath) To 1 Step -1
' If Mid(sPath, k, 1) = "\" Then Exit For
' Next k
'nome = Mid(sPath, k + 1)
'GetNomeFile = nome
Dim I As Integer
I = InStrRev(sPath, "\")
If I > 0 Then
GetNomeFile = Mid$(sPath, I + 1)
Else
GetNomeFile = sPath
End If
End Function
Function CreaPath(ByVal sPath As String) As Boolean
On Error GoTo errUNKNOW
Dim I As Integer
Dim sTmp As String
Dim n As Integer
Dim k As Long
sTmp = AddSlashIfNot(sPath)
ReDim aPath(0) As String
I = InStrRev(sTmp, "\")
Do
ReDim Preserve aPath
As String
aPath = Mid$(sPath, 1, I)
n = n + 1
I = InStrRev(sTmp, "\", I - 1, vbBinaryCompare)
Loop While I > 1
For k = 0 To UBound(aPath)
If DirExist(aPath(k)) Then
n = k
Exit For
End If
Next
For k = n - 1 To 0 Step -1
MkDir aPath(k)
Next
CreaPath = DirExist(sPath)
errUNKNOW:
Select Case Err
Case Is = 0
' No error
Case Else
Err.Clear
End Select
End Function
Function GetNomeFileSenzaEst(sPath As String) As String
Dim sNome As String
Dim I As Integer
sNome = GetNomeFile(sPath)
If sNome <> "" Then
I = InStrRev(sNome, ".")
If I > 0 Then
GetNomeFileSenzaEst = Left(sNome, I - 1)
Else
GetNomeFileSenzaEst = sNome
End If
Else
GetNomeFileSenzaEst = sPath
End If
End Function
Function Percentuale(SpazioUsato, SpazioTotale) As Integer
' Questa Procedura ottiene la percentuale relativa all 'unità spaziousato contenuta in spaziototale
' SpazioUsato ---> Quantità della quale si vuole ottenere la percentuale
' SpazioTotale ---> Quantita totale corrispettivo di 100
' Ritorna da 0 a 100
On Error Resume Next
Dim x As Integer
Const Cento = 100
' spusato : sptot = x : 100
x = Int((SpazioUsato * Cento) / SpazioTotale)
If x > 100 Then x = 100
Percentuale = x
Err.Clear
End Function
Function PercentualeCur(SpazioUsato, SpazioTotale) As Currency
' Questa Procedura ottiene la percentuale relativa all 'unità spaziousato contenuta in spaziototale
' SpazioUsato ---> Quantità della quale si vuole ottenere la percentuale
' SpazioTotale ---> Quantita totale corrispettivo di 100
' Ritorna da 0 a 100
On Error Resume Next
Dim x As Currency
Const Cento = 100
' spusato : sptot = x : 100
x = (SpazioUsato * Cento) / SpazioTotale
If x > 100 Then x = 100
PercentualeCur = x
Err.Clear
End Function
Function GetWinDir() As String
Dim sValue As String * MAX_PATH
Dim sTmp As String
Dim R As Long
R = GetWindowsDirectory(sValue, MAX_PATH)
sTmp = Left(sValue, InStr(sValue, Chr$(0)) - 1)
GetWinDir = AddSlashIfNot(sTmp)
End Function
Function GetWinSysDir() As String
Dim sValue As String * MAX_PATH
Dim sTmp As String
Dim R As Long
R = GetSystemDirectory(sValue, MAX_PATH)
sTmp = Left(sValue, InStr(sValue, Chr$(0)) - 1)
GetWinSysDir = AddSlashIfNot(sTmp)
End Function
Function GetWinTemp() As String
Dim sValue As String * MAX_PATH
Dim sTmp As String
Dim R As Long
R = GetTempPath(MAX_PATH, sValue)
sTmp = Left(sValue, InStr(sValue, Chr$(0)) - 1)
GetWinTemp = AddSlashIfNot(sTmp)
If DirExist(sTmp) = False Then
sTmp = GetWinDir
sTmp = sTmp & "temp\"
Call CreaPath(sTmp)
GetWinTemp = sTmp
End If
End Function
Sub ScriviTxtB(f As Integer, sRecord As String, ret As Integer)
' Questa Sub scrive in un file di testo il valore contenuto in sRecord
' f ---> puntatore del file
' sRecord ---> riga da aggiungere al file
' ret ---> codice di ritorno errore
On Error GoTo errAPPEND
Print #f, sRecord
ret = True
errAPPEND:
If Err > 0 Then
' MsgBox Err.Description
ret = 0
Exit Sub
End If
End Sub
Function FormattaDecimale As String
If Val = 0 Then
FormattaDecimale = 0
Else
FormattaDecimale = Format(n, "#,###,###,###,###,###,###")
End If
End Function
Sub iniScriviRigaIni(sMenu As String, keyword As String, sValueDefault As String, sPathFile As String, retval As Long)
sMenu = UCase(sMenu)
keyword = UCase(keyword)
retval = WritePrivateProfileString(sMenu, keyword, sValueDefault, sPathFile)
End Sub
Sub iniLeggiRigaIni(sMenu As String, keyword As String, sValueRitorno As String, sPathFile As String, retval As Long)
Dim stringa As String
sValueRitorno = ""
sMenu = UCase(sMenu)
keyword = UCase(keyword)
stringa = Space$(500)
retval = GetPrivateProfileString(sMenu, keyword, "", stringa, 500, sPathFile)
If retval <> 0 Then sValueRitorno = Mid$(stringa, 1, retval)
End Sub
Function FormattaSecondi(S As Single) As String
'Questa Function trasforma il numero di secondi passato come parametro in una stringa
' passando i secondi si ottengono ore minuti e secondi in formato hh:mm:ss
' s ---> Numero di secondi da formattare
' ritorna una stringa il cui formato è hh:mm:ss (la function non funziona se in totale abbiamo piu di 99 ore )
Dim hh As Single
Dim Mm As Single
Dim Ss As Single
Dim TimeStr As String
hh = S \ c3600
Mm = (S Mod c3600) \ c60
Ss = S - ((hh * c3600) + (Mm * c60))
TimeStr = Format$(hh, "00") & ":" & Format$(Mm, "00") & ":" & Format$(Ss, "00")
FormattaSecondi = TimeStr
End Function
Function FormatString(sValue As String, sFmt As String, nAllineamento As Integer) As String
Dim sTxt As String
Dim k As Integer
' 0 = allinea a sinistra
' 1 = allinea a destra
sTxt = Trim$(sValue)
If sTxt <> "" Then
If Len(sFmt) > Len(sTxt) Then
If nAllineamento = 0 Then
FormatString = sTxt & Mid$(sFmt, Len(sTxt) + 1)
Else
FormatString = Mid$(sFmt, 1, Len(sFmt) - Len(sTxt)) & sTxt
End If
Else
FormatString = sTxt
End If
Else
FormatString = sFmt
End If
End Function
Function GetDataInglese(sData As String) As String
If IsDate(sData) Then
GetDataInglese = Format(sData, "mm/dd/yyyy")
Else
GetDataInglese = "01/01/2100"
End If
End Function
Function GetNumeroFileInDirectory(ByVal sPath As String) As Long
' conta i file presenti nella directory NON controlla le subdir
Dim S As String
Dim n As Long
sPath = AddSlashIfNot(sPath)
If DirExist(sPath) Then
S = Dir(sPath & "*")
Do Until S = ""
If S <> "." And S <> ".." Then
If FileExist(sPath & S) Then
n = n + 1
End If
End If
S = Dir()
Loop
GetNumeroFileInDirectory = n
Else
GetNumeroFileInDirectory = -1
End If
End Function
Function RimuoviZeriNonSignificativi(sDato As String) As String
Dim k As Long
Dim I As Long
For k = 1 To Len(sDato)
If Mid$(sDato, k, 1) <> "0" Then
I = k
Exit For
End If
Next k
If I > 0 Then
RimuoviZeriNonSignificativi = Mid$(sDato, I)
Else
RimuoviZeriNonSignificativi = sDato
End If
End Function
Function Proporzione(A, b, C) As Double
On Error GoTo errUNKNOWN
' a : b = x : c
Proporzione = A * (C / b)
errUNKNOWN:
Select Case Err
Case Is <> 0
Err.Clear
End Select
End Function
Function RimuoviLastChar(S As String, sChr As String) As String
If Right(S, 1) = sChr Then
RimuoviLastChar = Left(S, Len(S) - 1)
Else
RimuoviLastChar = S
End If
End Function
Function GetNomeDirectory(sDir As String) As String
ReDim av(0) As String
av() = Split(RimuoviLastChar(sDir, "\"), "\")
GetNomeDirectory = av(UBound(av))
End Function
Function GetSystemRoot() As String
GetSystemRoot = Left(GetWinDir, 3)
End Function
Function GetUltimogiornoMese(nMese As Integer, nAnno As Integer) As Integer
Dim k As Long
For k = 31 To 1 Step -1
If IsDate(CStr(k) & "/" & CStr(nMese) & "/" & CStr(nAnno)) Then
GetUltimogiornoMese = k
Exit For
End If
Next
End Function
Function Dividi(A, b)
If b > 0 Then
Dividi = CDec(A / b)
Else
Dividi = 0
End If
End Function
Function ReadStringZ(S As String) As String
Dim I As Integer
I = InStr(S, Chr$(0))
If I > 0 Then
ReadStringZ = Trim$(Left(S, I - 1))
Else
ReadStringZ = Trim$(S)
End If
End Function
Sub RiduciSpazi(S As String)
Do While InStr(S, " ") > 0
S = Replace(S, " ", " ")
Loop
End Sub
Function DataHumanToDataSerial(sData As String) As String
ReDim av(0) As String
av() = Split(sData, "/")
If UBound(av) = 2 Then
DataHumanToDataSerial = av(2) & "/" & av(1) & "/" & av(0)
Else
DataHumanToDataSerial = sData
End If
End Function
Function NumeroElementiSelezionatiLb(lb As Object) As Integer
Dim k As Integer
Dim n As Integer
For k = 0 To lb.ListCount - 1
If lb.Selected(k) Then n = n + 1
Next
NumeroElementiSelezionatiLb = n
End Function
Function ContaElementiTrue(aB() As Boolean) As Integer
Dim k As Long
Dim n As Integer
For k = LBound(aB) To UBound(aB)
If aB(k) Then n = n + 1
Next
ContaElementiTrue = n
End Function
Function GetLetteraColonnaXls(idCol As Integer) As String
Dim k As Integer
Dim I As Integer, ii As Integer
Dim sLetteraTmp As String, sPrimaLet As String
Dim sRet As String
If idCol <= Len(sAlfabeto) Then
sRet = Mid$(sAlfabeto, idCol, 1)
Else
I = Len(sAlfabeto) ' 26
Do While I <> idCol
ii = ii + 1
For k = 1 To Len(sAlfabeto) '26
I = I + 1
sLetteraTmp = Mid$(sAlfabeto, k, 1)
If I = idCol Then Exit For
Next
sPrimaLet = Mid$(sAlfabeto, ii, 1)
Loop
sRet = sPrimaLet & sLetteraTmp
End If
GetLetteraColonnaXls = sRet
End Function
Sub DeleteDir(sPath As String)
Dim SHDirOp As SHFILEOPSTRUCT
Dim lFlags As Long
lFlags = lFlags Or FOF_SILENT
lFlags = lFlags Or FOF_NOCONFIRMATION
' If bDir Then lFlags = lFlags Or FOF_NOCONFIRMMKDIR
' If bFilesOnly Then lFlags = lFlags Or FOF_FILESONLY
' If bAllowUndelete Then lFlags = lFlags Or FOF_ALLOWUNDO
With SHDirOp
.fFlags = lFlags
.wFunc = FO_DELETE
.pFrom = sPath & vbNullChar & vbNullChar
.pTo = vbNullChar & vbNullChar
End With
'Delete the directory
SHFileOperation SHDirOp
End Sub
Sub ClearFoglio(sheet As Excel.Worksheet, PrimaRiga As Integer, Optional bSetColore As Boolean = False)
sheet.Range("A" & PrimaRiga & ":IV65000").Select '.ClearContents
Selection.ClearContents
If bSetColore Then
sheet.Range("A" & PrimaRiga & ":IV65000").Interior.ColorIndex = xlNone
End If
sheet.Range("A1").Select
End Sub
Sub SelezionaItemCombo(cmb As ComboBox, S As String)
Dim k As Integer
For k = 0 To cmb.ListCount - 1
If cmb.List(k) = S Then
cmb.ListIndex = k
Exit For
End If
Next
End Sub
Function TrovaIdLastRiga(sheet As Excel.Worksheet, nPrimariga As Integer)
Dim k As Long
k = nPrimariga
Do While sheet.Range("A" & k) <> ""
k = k + 1
Loop
TrovaIdLastRiga = k - 1
End Function
Function ShellDir(fName As String, Hwnd As Long) As Long
ShellDir = ShellExecute(Hwnd, "open", fName, 0, 0, SW_SHOWNORMAL)
'To explore a folder, use the following call:
'ShellExecute(handle, "explore", path_to_folder, NULL, NULL, SW_SHOWNORMAL);
End Function
Function SelezionaFileInRisorseComoputer(fName As String, Hwnd As Long) As Long
SelezionaFileInRisorseComoputer = ShellExecute(Hwnd, "explore", fName, 0, 0, SW_MAXIMIZE)
'To explore a folder, use the following call:
'ShellExecute(handle, "explore", path_to_folder, NULL, NULL, SW_SHOWNORMAL);
End Function
Function AddItemInCollection(Coll As Collection, S) As Boolean
On Error GoTo errore
Coll.Add S, "k" & S
AddItemInCollection = True
errore:
If Err <> 0 Then
Err.Clear
End If
End Function
'=================================================
Sub InitVariabili()
NomiRuote
structIni.sUrlEstrazioni = "http://www.lottomaticaitalia.it/lotto/doc/archivio/storico.zip" ' sheetImpostazioni.Range("B2")
structIni.sPathDiLavoro = AddSlashIfNot(ThisWorkbook.Path)
End Sub
Sub NomiRuote()
glbArrNomiRuote(1) = "Bari"
glbArrNomiRuote(2) = "Cagliari"
glbArrNomiRuote(3) = "Firenze"
glbArrNomiRuote(4) = "Genova"
glbArrNomiRuote(5) = "Milano"
glbArrNomiRuote(6) = "Napoli"
glbArrNomiRuote(7) = "Palermo"
glbArrNomiRuote(8) = "Roma"
glbArrNomiRuote(9) = "Torino"
glbArrNomiRuote(10) = "Venezia"
glbArrNomiRuote(11) = "Nazionale"
glbArrNomiRuote(12) = "Tutte"
End Sub
'========================================================
'========================================================
Private Sub translateSiglaRuota(sSigla As String)
Select Case sSigla
Case "BA"
sSigla = "Bari"
Case "CA"
sSigla = "Cagliari"
Case "FI"
sSigla = "Firenze"
Case "GE"
sSigla = "Genova"
Case "MI"
sSigla = "Milano"
Case "NA"
sSigla = "Napoli"
Case "PA"
sSigla = "Palermo"
Case "RM"
sSigla = "Roma"
Case "TO"
sSigla = "Torino"
Case "VE"
sSigla = "Venezia"
Case "RN"
sSigla = "Nazionale"
End Select
End Sub
Private Sub AlimentaStructE(sRecord As String, strctE As STRUCT_ESTRAZIONE)
On Error GoTo errUNKNOWN
Dim nRuota As Integer
Dim k As Long
ReDim av(0) As String
av() = Split(sRecord, Chr$(9))
For k = 1 To UBound(glbArrNomiRuote)
Call translateSiglaRuota(av(1))
If glbArrNomiRuote(k) = av(1) Then
nRuota = k
Exit For
End If
Next
If nRuota > 0 Then
For k = 1 To 5
strctE.aRuote(nRuota).aNum(k) = Val(Left(av(k + 1), 2))
Next
Else
MsgBox "Ruota non trovata " & av(1)
End If
errUNKNOWN:
Select Case Err
Case Is <> 0
If Erl = 0 Then
MsgBox CStr(Err.Number) & "- " & Err.Description, vbCritical, "ClsEstrazioni.AlimentaStructE"
Else
MsgBox CStr(Err.Number) & "- " & Err.Description & " Linea errore " & Erl, vbCritical, "ClsEstrazioni.AlimentaStructE"
End If
Err.Clear
End Select
End Sub
Function AggiornaEstrazioniEx(sFileEstr As String, sPathHtmlEstrTelevideo As String, aEstrToSave() As STRUCT_ESTRAZIONE) As Boolean
On Error GoTo errUNKNOWN
Dim strctLastE As STRUCT_ESTRAZIONE
Dim strctE As STRUCT_ESTRAZIONE
Dim strctEBlank As STRUCT_ESTRAZIONE
Dim f As Integer
Dim sRecord As String
Dim bFoundedLastEstr As Boolean
Dim sOldData As String
Dim sNewData As String
Dim sOldData2 As String
Dim sNewData2 As String
Dim nEstrAgg As Long
Dim nEstrAnno As Integer
Dim nLette As Long
Dim sAll As String
Dim k As Long
Dim nIdEstrazione As Long
Dim idLastEstr As Long
f = FreeFile
Open sFileEstr For Input As f
sAll = Input(LOF(f), f)
Close f
ReDim aEstrToSave(0) As STRUCT_ESTRAZIONE
' idLastEstr = GetLastRigaEstr
idLastEstr = 0
'If ApriBd Then
If idLastEstr < 3 Then
' se non trova ultima estr vuol dire che non c'è archivio e bisogna aggiornare dalla prima estr disponibile
bFoundedLastEstr = True
nIdEstrazione = 0
Else
Call GetEstrazione(idLastEstr, strctLastE)
'strctLastE.strctData.sData = DataHumanToDataSerial(strctLastE.strctData.sData)
nEstrAnno = strctLastE.strctData.nNumEstrazione
'sOldData = strctLastE.strctData.aa & "/" & Format$(strctLastE.strctData.Mm, "00") & "/" & Format$(strctLastE.strctData.gg, "00")
nIdEstrazione = strctLastE.idEstr
End If
ReDim aRec(0) As String
aRec() = Split(sAll, Chr$(10))
For k = 0 To UBound(aRec)
sRecord = aRec(k)
If Trim$(sRecord) <> "" Then
If bFoundedLastEstr Then
If TranslateDataEstToSerial(strctLastE.strctData) <> Left$(sRecord, 10) Then
sNewData = Left(sRecord, 10)
If sNewData <> sOldData Then
nLette = nLette + 1
If sOldData <> "" Then
'Put fBD, , strctE
ReDim Preserve aEstrToSave(nEstrAgg) As STRUCT_ESTRAZIONE
nIdEstrazione = nIdEstrazione + 1
strctE.idEstr = nIdEstrazione
LSet aEstrToSave(nEstrAgg) = strctE
nEstrAgg = nEstrAgg + 1
If nEstrAgg Mod 10 = 0 Then
FrmLog.AddLine ("Estrazioni aggiornate " & nEstrAgg)
End If
' LabEstrAgg.Caption = nEstrAgg
' LabEstrLette.Caption = nLette
DoEvents
LSet strctE = strctEBlank
End If
If Left$(sNewData, 4) <> Left$(sOldData, 4) Then
If sOldData = "" Then
nEstrAnno = nEstrAnno + 1
Else
nEstrAnno = 1
End If
Else
nEstrAnno = nEstrAnno + 1
End If
'strctE.strctData.sData = DataSerialToDataHuman(sNewData)
ReDim av(0) As String
av() = Split(sNewData, "/")
strctE.strctData.AA = av(0)
strctE.strctData.Mm = av(1)
strctE.strctData.GG = av(2)
strctE.strctData.nNumEstrazione = nEstrAnno
Call AlimentaStructE(sRecord, strctE)
Else
Call AlimentaStructE(sRecord, strctE)
End If
sOldData = sNewData
End If
Else
If TranslateDataEstToSerial(strctLastE.strctData) = Left$(sRecord, 10) Then
bFoundedLastEstr = True
End If
sNewData2 = Left$(sRecord, 10)
If sNewData2 <> sOldData2 Then
nLette = nLette + 1
DoEvents
End If
sOldData2 = sNewData2
End If
End If
Next
If strctE.strctData.nNumEstrazione > 0 Then
'Put fBD, LOF(fBD) + 1, strctE
ReDim Preserve aEstrToSave(nEstrAgg) As STRUCT_ESTRAZIONE
nIdEstrazione = nIdEstrazione + 1
strctE.idEstr = nIdEstrazione
LSet aEstrToSave(nEstrAgg) = strctE
nEstrAgg = nEstrAgg + 1
DoEvents
End If
FrmLog.AddLine ("Estrazioni aggiornate " & nEstrAgg)
FrmLog.AddLine ("Fine aggiornamento")
AggiornaEstrazioniEx = True
' End If
' Call AggiornaEstrazioniDaTelevideoRai(sPathHtmlEstrTelevideo, LabEstrAgg, LabEstrLette, LbLog, nEstrAgg)
errUNKNOWN:
Select Case Err
Case Is <> 0
If Erl = 0 Then
MsgBox CStr(Err.Number) & "- " & Err.Description, vbCritical, "ClsEstrazioni.AggiornaEstrazioni"
Else
MsgBox CStr(Err.Number) & "- " & Err.Description & " Linea errore " & Erl, vbCritical, "ClsEstrazioni.AggiornaEstrazioni"
End If
Err.Clear
End Select
End Function
Sub cancellaDirTempzip()
Dim sPath As String
Dim S As String
Dim Coll As New Collection
Dim v
'Dim fso As New Scripting.FileSystemObject
sPath = GetWinTemp
S = Dir(sPath & "*", vbHidden + vbReadOnly + vbDirectory)
Do While S <> ""
If S <> "." And S <> ".." Then
Coll.Add (sPath & S)
End If
S = Dir()
Loop
For Each v In Coll
If FileExist(CStr(v)) Then
Call DeleteDir(CStr(v))
End If
Next
End Sub
Sub AggiornaEstrazioni(bAncheDaTelevideo As Boolean)
Dim sRetErr As String
Dim sNomeFileLocal As String
Dim sDirOutput As String
Dim sRetFileTxt As String
FrmLog.Show 0
FrmLog.CommandButton1.Visible = True
Application.Calculation = xlManual
' aggiorna le impostazioni di configurazione
Call InitVariabili
' costruisce il path locale per scaricare il file
sNomeFileLocal = Trim(structIni.sPathDiLavoro) & "Estrazioni.zip"
' costruisce la directory dove scompattare il file zip
sDirOutput = Trim(structIni.sPathDiLavoro) & "Temp\"
If CreaPath(sDirOutput) Then
' cancella il contenuto della dir temporanea
Call KillFile(sDirOutput & "\*")
' cancella il file local per fare posto a quello da scaricare
If KillFile(sNomeFileLocal) Then
' scarica file dal web
If DownloadFile(Trim(structIni.sUrlEstrazioni), sNomeFileLocal, sRetErr) Then
Call cancellaDirTempzip
'unzippa il file
Call Unzip(sNomeFileLocal, sDirOutput, sRetFileTxt)
If InStr(sRetFileTxt, ".") Then
If FileExist(sRetFileTxt) Then
ReDim aRetEstr(0) As STRUCT_ESTRAZIONE
Call AggiornaBaseDati(sRetFileTxt, aRetEstr, bAncheDaTelevideo)
FrmLog.AddLine ("Aggiorno foglio estrazioni ...")
Call AggiornaSheetEstrazioni(aRetEstr)
FrmLog.AddLine ("Fatto !")
End If
Else
FrmLog.AddLine ("ERRORE ! File Zip estrazioni non valido")
End If
Else
MsgBox sRetErr, vbExclamation
End If
Else
MsgBox "Impossibile cancellare il vecchio file scaricato in precedenza ,verificare che non sia in uso." & vbCrLf & sNomeFileLocal, vbCritical
End If
Else
MsgBox "Impossibile creare un path temporaneo in " & vbCrLf & sDirOutput, vbCritical
End If
Foglio2.Select
Unload FrmLog
End Sub
Sub Unzip(sFileZip As String, sDirOutput As String, sRetFileUnzipped As String)
Dim fso As Object
Dim oApp As Object
Dim fName As Variant
Dim FileNameFolder As Variant
Dim DefPath As String
Dim strDate As String
Dim ClsZip As New ClsZip
ClsZip.ZipFileName = sFileZip ' "c:\temp\ppp.zip"
ClsZip.UnzipToFolder (sDirOutput)
Set ClsZip = Nothing
sRetFileUnzipped = sDirOutput & Dir(sDirOutput, vbNormal)
Exit Sub
'================================================
fName = sFileZip
FileNameFolder = sDirOutput
' Fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", _
MultiSelect:=False)
' If Fname = False Then
'Do nothing
' Else
'Root folder for the new folder.
'You can also use DefPath = "C:\Users\Ron\test\"
'DefPath = AddSlashIfNot(Application.DefaultFilePath)
'Create the folder name
' strDate = Format(Now, " dd-mm-yy h-mm-ss")
' FileNameFolder = DefPath & "MyUnzipFolder " & strDate & "\"
'Make the normal folder in DefPath
' MkDir FileNameFolder
'Extract the files into the newly created folder
Set oApp = CreateObject("Shell.Application")
oApp.Namespace("" & FileNameFolder).CopyHere oApp.Namespace("" & fName).items
sRetFileUnzipped = sDirOutput & Dir(sDirOutput, vbNormal)
'If you want to extract only one file you can use this:
'oApp.Namespace(FileNameFolder).CopyHere _
'oApp.Namespace(Fname).items.Item("test.txt")
' MsgBox "You find the files here: " & FileNameFolder
' On Error Resume Next
' Set FSO = CreateObject("scripting.filesystemobject")
' FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
'End If
End Sub
Sub AggiornaBaseDati(sFileTxtEstrazioni As String, aRetEstr() As STRUCT_ESTRAZIONE, bDaTelevideo As Boolean)
On Error GoTo errore
Dim sPathHtml As String
Dim sRetUltimoUrl As String
bFermaDownload = False
ReDim aRetEstr(0) As STRUCT_ESTRAZIONE
If AggiornaEstrazioniEx(sFileTxtEstrazioni, "", aRetEstr()) = False Then
MsgBox "Impossibile aggiornare le estrazioni", vbCritical
End If
If bDaTelevideo Then
sPathHtml = Trim(structIni.sPathDiLavoro) & "Lottomatica\"
If CreaPath(sPathHtml) Then
Call AggiornaEstrazioniDaLottomatica(sPathHtml, aRetEstr())
End If
End If
errore:
If Err <> 0 Then
MsgBox Err.Description
End If
End Sub
Function ConvertiDataInParametroUrlLottomatica(sData As String) As String
If IsDate(sData) Then
ConvertiDataInParametroUrlLottomatica = Year(sData) & "-" & Format(Month(sData), "00") & "-" & Format(Day(sData), "00")
End If
End Function
Sub AggiornaEstrazioniDaLottomatica(sPathDest As String, aRetEstr() As STRUCT_ESTRAZIONE)
Dim sData As String
Dim iMax As Long
Dim sUrlBase As String
Dim sDataOdierna As String
Dim sNomeFileLocal As String
sDataOdierna = Format(Now, "dd/mm/yyyy")
sUrlBase = "http://www.lottomaticaitalia.it/lotto/estrazioni/estrazioni_dettaglio.do?dataConcorso=" '2009-11-19"
iMax = UBound(aRetEstr)
sData = TranslateDataEstToHuman(aRetEstr(iMax).strctData)
Do While DateDiff("d", sData, sDataOdierna) >= 0
sData = DateAdd("d", 1, sData)
sNomeFileLocal = sPathDest & ConvertiDataInParametroUrlLottomatica(sData) & ".htm"
If DownloadFile(sUrlBase & ConvertiDataInParametroUrlLottomatica(sData), sNomeFileLocal, "") Then
Call LeggiEstrazioneLottomatica(sNomeFileLocal, aRetEstr(), sData)
End If
Loop
End Sub
Sub LeggiEstrazioneLottomatica(sFileHtm As String, aRetEstr() As STRUCT_ESTRAZIONE, sData As String)
Dim f As Integer
Dim sBuf As String
Dim iMax As Long
Dim k As Long, y As Long, e As Long
Dim idRuota As Integer
Dim UltimoAnnoLetto As Integer
Dim nNumEstrazione As Integer
iMax = UBound(aRetEstr)
UltimoAnnoLetto = aRetEstr(iMax).strctData.AA
nNumEstrazione = aRetEstr(iMax).strctData.nNumEstrazione
f = FreeFile
Open sFileHtm For Binary As f
sBuf = Space$(LOF(f))
Get f, 1, sBuf
Close f
If InStr(sBuf, "Bari") Then
iMax = iMax + 1
Call FrmLog.AddLine("Estrazioni aggiornate " & iMax + 1)
ReDim Preserve aRetEstr(iMax) As STRUCT_ESTRAZIONE
aRetEstr(iMax).idEstr = iMax + 1
aRetEstr(iMax).strctData.AA = Year(sData)
aRetEstr(iMax).strctData.Mm = Month(sData)
aRetEstr(iMax).strctData.GG = Day(sData)
If aRetEstr(iMax).strctData.AA = UltimoAnnoLetto Then
nNumEstrazione = nNumEstrazione + 1
aRetEstr(iMax).strctData.nNumEstrazione = nNumEstrazione
Else
nNumEstrazione = 1
aRetEstr(iMax).strctData.nNumEstrazione = 1
End If
UltimoAnnoLetto = aRetEstr(iMax).strctData.AA
ReDim av(0) As String
av() = Split(sBuf, vbCrLf)
For k = 0 To UBound(av)
e = 0
'If InStr(aV(k), "Bari") > 0 Then
idRuota = GetIdRuotaFromRigaHtmlLottomatica(av(k))
If idRuota > 0 Then
For y = k + 1 To k + 5
e = e + 1
aRetEstr(iMax).aRuote(idRuota).aNum(e) = LeggiNumeroFromRigaHtmlLottomatica(av
)
Next
End If
Next
Else
KillFile (sFileHtm)
End If
End Sub
Function GetIdRuotaFromRigaHtmlLottomatica(sRiga As String) As Integer
Dim k As Long
For k = 1 To 11
If InStr(sRiga, glbArrNomiRuote(k)) > 0 Then
GetIdRuotaFromRigaHtmlLottomatica = k
Exit For
End If
Next
End Function
Function LeggiNumeroFromRigaHtmlLottomatica(sRiga As String) As Integer
Dim I As Integer, ii As Integer
Dim S As String
I = InStrRev(sRiga, ">", Len(sRiga) - 1, vbTextCompare)
ii = InStr(I, sRiga, "<", vbTextCompare)
S = Mid$(sRiga, I + 1, (ii - 1) - I)
LeggiNumeroFromRigaHtmlLottomatica = Val(Trim$(S))
End Function
'Sub AggiornaBaseDatiDaTelevideo()
'
' Dim sPathHtml As String
' Dim sRetUltimoUrl As String
'
' Dim clsE As New ClsEstrazioni
' Set clsE.FormLog = frmLog
'
' sPathHtml = Trim(structini.sPathDiLavoro) & "Televideo\"
' If CreaPath(sPathHtml) Then
'
' clsE.FileBaseDati = GetNomeFileBd
' Set clsE.FormLog = frmLog
'
' Call clsE.AggiornaEstrazioniDaTelevideoRai(Trim(structini.sUrlTelevideo), sPathHtml, sRetUltimoUrl)
'
' sheetImpostazioni.Range("B5") = sRetUltimoUrl
'
'
' Else
' MsgBox "Impossibile creare il path per salvare le pagine di teleideo" & vbCrLf & sPathHtml
' End If
'
' Set clsE = Nothing
'
'
'End Sub
Sub AggiornaSheetEstrazioni(aEstr() As STRUCT_ESTRAZIONE)
Dim PrimaEstrUtile As Long
Dim strctE As STRUCT_ESTRAZIONE
Dim k As Long, R As Long, e As Long
Dim idRiga As Long, idCol As Long
Dim nUltimaEstr As Long
nUltimaEstr = GetNumeroEstrazioni
If nUltimaEstr > 0 Then
Call GetEstrazione(GetNumeroEstrazioni, strctE)
For k = UBound(aEstr) To 1 Step -1
If TranslateDataEstToHuman(aEstr(k).strctData) = TranslateDataEstToHuman(strctE.strctData) Then
PrimaEstrUtile = k + 1
Exit For
End If
Next
Else
PrimaEstrUtile = 0
End If
For k = PrimaEstrUtile To UBound(aEstr)
idRiga = k + QRigheIntestazioneSheetEstrazioni + 1
idCol = 1
Foglio2.Cells(idRiga, idCol) = aEstr(k).idEstr
idCol = 3
Foglio2.Cells(idRiga, idCol) = TranslateDataEstToHuman(aEstr(k).strctData)
For R = 1 To 11
For e = 1 To 5
idCol = idCol + 1
Foglio2.Cells(idRiga, idCol) = aEstr(k).aRuote(R).aNum(e)
Next
Next
Next
End Sub
'=======================================
Function ApriBaseDatiInMemoria(inizio As Long, fine As Long, aEstr() As STRUCT_ESTRAZIONE)
' legge dal foglio excel le estrazioni e le mette in una array
Dim k As Long
ReDim aEstr(inizio To fine) As STRUCT_ESTRAZIONE
For k = inizio To fine
Call GetEstrazione(k, aEstr(k))
Next
End Function
Sub GetEstrazione(idEstr As Long, strctE As STRUCT_ESTRAZIONE)
' legge una singola riga dal foglio estrazioni e lo salva nella struttura
Dim Ruota As Long
Dim Pos As Long
Dim sValue As String
Dim idCol As Long
Dim idRiga As Long
idRiga = idEstr + QRigheIntestazioneSheetEstrazioni
strctE.idEstr = idEstr 'IdRiga - QRigheIntestazioneSheetEstrazioni
sValue = Foglio2.Range("C" & idRiga) ' la data.
sValue = Trim$(Mid$(sValue, InStr(sValue, "-") + 1))
ReDim av(0) As String
av() = Split(sValue, "/")
strctE.strctData.AA = av(2)
strctE.strctData.Mm = av(1)
strctE.strctData.GG = av(0)
idCol = 3
For Ruota = 1 To 11
For Pos = 1 To 5
idCol = idCol + 1
strctE.aRuote(Ruota).aNum(Pos) = Val(Foglio2.Cells(idRiga, idCol))
Next
Next
End Sub
Function TranslateDataEstToSerial(strctData As STRUCT_DATA_EST) As String
TranslateDataEstToSerial = strctData.AA & "/" & Format$(strctData.Mm, "00") & "/" & Format$(strctData.GG, "00")
End Function
Function TranslateDataEstToHuman(strctData As STRUCT_DATA_EST, Optional anno2cifre As Boolean = False) As String
If anno2cifre Then
TranslateDataEstToHuman = Format$(strctData.GG, "00") & "/" & Format$(strctData.Mm, "00") & "/" & Right(CStr(strctData.AA), 2)
Else
TranslateDataEstToHuman = Format$(strctData.GG, "00") & "/" & Format$(strctData.Mm, "00") & "/" & strctData.AA
End If
End Function
Function GetDataEstrazione(idEstr As Long) As String
Dim strctE As STRUCT_ESTRAZIONE
Call GetEstrazione(idEstr, strctE)
GetDataEstrazione = TranslateDataEstToHuman(strctE.strctData)
End Function
Function GetNumeroEstrazioni() As Long
Dim n As Long
Dim idRiga As Long
idRiga = QRigheIntestazioneSheetEstrazioni + 1
Do While Foglio2.Cells(idRiga, 1) <> ""
idRiga = idRiga + 1
Loop
GetNumeroEstrazioni = idRiga - QRigheIntestazioneSheetEstrazioni - 1
End Function
Non testato per le varie suite di office opensource e bla bla.
Pour vous
Option Explicit
Option Private Module
' strutture per accedere al file della base dati estrazionale
Type STRUCT_RUOTA
aNum(1 To 5) As Integer
End Type
Type STRUCT_DATA_EST
nNumEstrazione As Integer
GG As Integer
Mm As Integer
AA As Integer
End Type
Type STRUCT_ESTRAZIONE
idEstr As Long
strctData As STRUCT_DATA_EST
aRuote(1 To 11) As STRUCT_RUOTA
End Type
Type STRUCT_INI
sUrlEstrazioni As String ' = "http://www.lottomaticaitalia.it/lotto/doc/archivio/storico.zip" ' sheetImpostazioni.Range("B2")
sPathDiLavoro As String
End Type
Public structIni As STRUCT_INI
Public glbArrNomiRuote(1 To 12) As String
Public Const QRigheIntestazioneSheetEstrazioni = 3 ' numero righe intestazionedel foglio estrazioni
Public bFermaDownload As Boolean
Option Compare Text
'Dim sPathIni As String
Private Type SHFILEOPSTRUCT
Hwnd As Long
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAborted As Boolean
hNameMaps As Long
sProgress As String
End Type
Private Const FO_COPY = &H2
Private Const FO_DELETE = &H3
Private Const FO_MOVE = &H1
Private Const FO_RENAME = &H4
Private Const FOF_ALLOWUNDO = &H40
Private Const FOF_SILENT = &H4
Private Const FOF_NOCONFIRMATION = &H10
Private Const FOF_RENAMEONCOLLISION = &H8
Private Const FOF_NOCONFIRMMKDIR = &H200
Private Const FOF_FILESONLY = &H80
Public Declare PtrSafe Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
' **** FUNZIONI DIRECTORY SISTEMA
' *******************************************
Private Declare PtrSafe Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
'............ directory di windows
Private Declare PtrSafe Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
' directory system
Private Declare PtrSafe Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Public Const MAX_PATH = 260
' **** PATH FUNCTIONS
'********************************************
Private Declare PtrSafe Function PathIsSameRoot Lib "shlwapi.dll" Alias "PathIsSameRootA" (ByVal pszPath1 As String, ByVal pszPath2 As String) As Long
Private Declare PtrSafe Function PathStripToRoot Lib "shlwapi.dll" Alias "PathStripToRootA" (ByVal pszPath As String) As Long
Private Declare PtrSafe Function PathFileExists Lib "shlwapi.dll" Alias "PathFileExistsA" (ByVal pszPath As String) As Long
Private Declare PtrSafe Function PathIsDirectory Lib "shlwapi.dll" Alias "PathIsDirectoryA" (ByVal pszPath As String) As Long
' **** FUNZIONI PER IMPOSTARE SECONDI DI PAUSA
' *******************************************
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
' **** FUNZIONI PER LEGGERE IL FILE INI
' *******************************************
'Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
'Declare Function WritePrivateProfileString& Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As String, ByVal lpFileName As String)
Declare PtrSafe Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Declare PtrSafe Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
' *** download from url
'*********************************************
'Private Declare Function IsValidURL Lib "URLMON.DLL" (ByVal pbc As Long, ByVal szURL As String, ByVal dwReserved As Long) As Long
'Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
'Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal lBuffer As Long) As Long
Private Declare PtrSafe Function IsValidURL Lib "URLMON.DLL" (ByVal pbc As Long, ByVal szURL As String, ByVal dwReserved As Long) As Long
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" ( _
ByVal pCaller As LongPtr, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As Long, _
ByVal lpfnCB As LongPtr _
) As Long
Private Declare PtrSafe Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal lBuffer As Long) As Long
' **** FUNZIONI PER LANCIARE L'APPLICAZIONE ASSOCIATA ALL 'ESTENSIONE DI UN FILE
' *******************************************
'Declare Function FindExecutable Lib "shell32.dll" Alias "FindExecutableA" (ByVal lpFile As String, ByVal lpDirectory As String, ByVal lpResult As String) As Long
'Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal Hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Declare PtrSafe Function FindExecutable Lib "shell32.dll" Alias "FindExecutableA" (ByVal lpFile As String, ByVal lpDirectory As String, ByVal lpResult As String) As Long
Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal Hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Const GWW_HINSTANCE = (-6)
Const SW_SHOWNA = 8
Const SW_SHOWNORMAL = 1
Const SW_MAXIMIZE = 3
'______________ costanti
Const c3600& = 3600
Const c60& = 60
'______________ costanti per le funzioni DI FORMATTAZIONE
Public Const vb_INCSINISTRA = 1 ' costanti per la funzione SPAZI
Public Const vb_INCDESTRA = 2
Public Const vb_INCCENTRO = 3
Public Const vb_NESSUN_ALLINEAMENTO = 4
'_____________ ritorno delle funzioni
Public Const VB_ERRORE = 1
Public Const VB_OK = 2
Public Function GetShortPath(strFileName As String) As String
'KPD-Team 1999
'URL: http://www.allapi.net/
'E-Mail: KPDTeam@Allapi.net
Dim lngRes As Long, strPath As String
'Create a buffer
strPath = String$(165, 0)
'retrieve the short pathname
lngRes = GetShortPathName(strFileName, strPath, 164)
'remove all unnecessary Chr$(0)'s
GetShortPath = Left$(strPath, lngRes)
End Function
Function DownloadFile(URL As String, LocalFilename As String, sRetErr As String) As Boolean
Dim lngRetVal As Long
If IsGoodURL(URL) Then
lngRetVal = URLDownloadToFile(0, URL, LocalFilename, 0, 0)
If lngRetVal = 0 Then
DownloadFile = True
Else
sRetErr = "Errore " & lngRetVal
End If
Else
sRetErr = "Indirizzo non valido"
End If
End Function
Function IsGoodURL(ByVal sUrl As String) As Boolean
'The IsValidURL always expects a UNICODE string, but whenever
'VB calls an API function, it converts the strings to ANSI strings.
'That's why we're going to use a trick here. Before calling the function,
'We're going to convert the unicode string to unicode so we get a double
'unicode string.
'Before VB calls the API function, it converts our double unicode string
'to a normal unicode string; exactely what IsValidURL is expecting.
sUrl = StrConv(sUrl, vbUnicode)
'Now call the function
IsGoodURL = (IsValidURL(ByVal 0&, sUrl, 0) = 0)
End Function
Function AddSlashIfNot(ByVal sPath As String) As String
' Queta Function aggiunge lo slash "\" se questo non è presente
' Ritorna il path con lo slash alla fine
sPath = Trim$(sPath)
If sPath <> "" Then
If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
End If
AddSlashIfNot = sPath
End Function
Function FileExist(sFile As String) As Boolean
On Error GoTo errUNKNOW
FileExist = PathFileExists(sFile)
errUNKNOW:
Select Case Err
Case Is = 0
' No error
Case Else
Err.Clear
End Select
End Function
Function KillFile(sFile As String) As Boolean
On Error GoTo errUNKNOW
'
If InStr(sFile, "*") = 0 Then
If FileExist(sFile) Then
Call SetAttr(sFile, vbNormal)
Kill sFile
End If
Else
Kill sFile
End If
KillFile = True
errUNKNOW:
'
Select Case Err
Case Is = 0
' No error
Case Else
'MsgBox CStr(Err.Number) & "- " & Err.Description, vbCritical, "ModFunzGeneriche.KillFile"
Err.Clear
End Select
End Function
Function RimuoviDir(ByVal sPath As String) As Boolean
On Error GoTo errUNKNOW
If DirExist(sPath) Then
If Right(sPath, 1) = "\" Then sPath = Mid$(sPath, 1, Len(sPath) - 1)
RmDir sPath
Else
RimuoviDir = True
End If
errUNKNOW:
Select Case Err
Case Is = 0
' No error
Case Else
Err.Clear
End Select
End Function
Function DirExist(ByVal Path As String) As Boolean
' Questa funzione controlla se una directory esiste o meno
' Path ---> Path della directory da verificare
' Ritorna true se la directory esiste
On Error GoTo errDIREXIST
' If Len(path) >= 3 Then
' If Len(Dir(path, vbDirectory)) > 0 Then
' DirExist = True
' End If
' End If
If PathIsDirectory(Path) Then
DirExist = True
End If
errDIREXIST:
If Err <> 0 Then
Err.Clear
Exit Function
End If
End Function
Function GetPathFile(sPathFile As String) As String
' Questa funzione restituisce la directory dove è' salvato il sPathFile file passato come parametro
' sPathFile ---> Percorso completo del file
' Ritorna la directory dove è salvato il file
Dim k As Integer
For k = Len(Trim(sPathFile)) To 1 Step -1
If Mid(sPathFile, k, 1) = "\" Then Exit For
Next k
GetPathFile = Left(sPathFile, k)
End Function
Function GetNomeFile(sPath As String) As String
' Questa Function estrae da un Path completo il nome di un file comprensivo di estensione
' sPath ---> nome completo del path + il nome file
' Ritorna il nome del file completo di estensione
'Dim k As Integer
'Dim nome As String
'For k = Len(sPath) To 1 Step -1
' If Mid(sPath, k, 1) = "\" Then Exit For
' Next k
'nome = Mid(sPath, k + 1)
'GetNomeFile = nome
Dim I As Integer
I = InStrRev(sPath, "\")
If I > 0 Then
GetNomeFile = Mid$(sPath, I + 1)
Else
GetNomeFile = sPath
End If
End Function
Function CreaPath(ByVal sPath As String) As Boolean
On Error GoTo errUNKNOW
Dim I As Integer
Dim sTmp As String
Dim n As Integer
Dim k As Long
sTmp = AddSlashIfNot(sPath)
ReDim aPath(0) As String
I = InStrRev(sTmp, "\")
Do
ReDim Preserve aPath
As StringaPath
= Mid$(sPath, 1, I)n = n + 1
I = InStrRev(sTmp, "\", I - 1, vbBinaryCompare)
Loop While I > 1
For k = 0 To UBound(aPath)
If DirExist(aPath(k)) Then
n = k
Exit For
End If
Next
For k = n - 1 To 0 Step -1
MkDir aPath(k)
Next
CreaPath = DirExist(sPath)
errUNKNOW:
Select Case Err
Case Is = 0
' No error
Case Else
Err.Clear
End Select
End Function
Function GetNomeFileSenzaEst(sPath As String) As String
Dim sNome As String
Dim I As Integer
sNome = GetNomeFile(sPath)
If sNome <> "" Then
I = InStrRev(sNome, ".")
If I > 0 Then
GetNomeFileSenzaEst = Left(sNome, I - 1)
Else
GetNomeFileSenzaEst = sNome
End If
Else
GetNomeFileSenzaEst = sPath
End If
End Function
Function Percentuale(SpazioUsato, SpazioTotale) As Integer
' Questa Procedura ottiene la percentuale relativa all 'unità spaziousato contenuta in spaziototale
' SpazioUsato ---> Quantità della quale si vuole ottenere la percentuale
' SpazioTotale ---> Quantita totale corrispettivo di 100
' Ritorna da 0 a 100
On Error Resume Next
Dim x As Integer
Const Cento = 100
' spusato : sptot = x : 100
x = Int((SpazioUsato * Cento) / SpazioTotale)
If x > 100 Then x = 100
Percentuale = x
Err.Clear
End Function
Function PercentualeCur(SpazioUsato, SpazioTotale) As Currency
' Questa Procedura ottiene la percentuale relativa all 'unità spaziousato contenuta in spaziototale
' SpazioUsato ---> Quantità della quale si vuole ottenere la percentuale
' SpazioTotale ---> Quantita totale corrispettivo di 100
' Ritorna da 0 a 100
On Error Resume Next
Dim x As Currency
Const Cento = 100
' spusato : sptot = x : 100
x = (SpazioUsato * Cento) / SpazioTotale
If x > 100 Then x = 100
PercentualeCur = x
Err.Clear
End Function
Function GetWinDir() As String
Dim sValue As String * MAX_PATH
Dim sTmp As String
Dim R As Long
R = GetWindowsDirectory(sValue, MAX_PATH)
sTmp = Left(sValue, InStr(sValue, Chr$(0)) - 1)
GetWinDir = AddSlashIfNot(sTmp)
End Function
Function GetWinSysDir() As String
Dim sValue As String * MAX_PATH
Dim sTmp As String
Dim R As Long
R = GetSystemDirectory(sValue, MAX_PATH)
sTmp = Left(sValue, InStr(sValue, Chr$(0)) - 1)
GetWinSysDir = AddSlashIfNot(sTmp)
End Function
Function GetWinTemp() As String
Dim sValue As String * MAX_PATH
Dim sTmp As String
Dim R As Long
R = GetTempPath(MAX_PATH, sValue)
sTmp = Left(sValue, InStr(sValue, Chr$(0)) - 1)
GetWinTemp = AddSlashIfNot(sTmp)
If DirExist(sTmp) = False Then
sTmp = GetWinDir
sTmp = sTmp & "temp\"
Call CreaPath(sTmp)
GetWinTemp = sTmp
End If
End Function
Sub ScriviTxtB(f As Integer, sRecord As String, ret As Integer)
' Questa Sub scrive in un file di testo il valore contenuto in sRecord
' f ---> puntatore del file
' sRecord ---> riga da aggiungere al file
' ret ---> codice di ritorno errore
On Error GoTo errAPPEND
Print #f, sRecord
ret = True
errAPPEND:
If Err > 0 Then
' MsgBox Err.Description
ret = 0
Exit Sub
End If
End Sub
Function FormattaDecimale
As StringIf Val
= 0 ThenFormattaDecimale = 0
Else
FormattaDecimale = Format(n, "#,###,###,###,###,###,###")
End If
End Function
Sub iniScriviRigaIni(sMenu As String, keyword As String, sValueDefault As String, sPathFile As String, retval As Long)
sMenu = UCase(sMenu)
keyword = UCase(keyword)
retval = WritePrivateProfileString(sMenu, keyword, sValueDefault, sPathFile)
End Sub
Sub iniLeggiRigaIni(sMenu As String, keyword As String, sValueRitorno As String, sPathFile As String, retval As Long)
Dim stringa As String
sValueRitorno = ""
sMenu = UCase(sMenu)
keyword = UCase(keyword)
stringa = Space$(500)
retval = GetPrivateProfileString(sMenu, keyword, "", stringa, 500, sPathFile)
If retval <> 0 Then sValueRitorno = Mid$(stringa, 1, retval)
End Sub
Function FormattaSecondi(S As Single) As String
'Questa Function trasforma il numero di secondi passato come parametro in una stringa
' passando i secondi si ottengono ore minuti e secondi in formato hh:mm:ss
' s ---> Numero di secondi da formattare
' ritorna una stringa il cui formato è hh:mm:ss (la function non funziona se in totale abbiamo piu di 99 ore )
Dim hh As Single
Dim Mm As Single
Dim Ss As Single
Dim TimeStr As String
hh = S \ c3600
Mm = (S Mod c3600) \ c60
Ss = S - ((hh * c3600) + (Mm * c60))
TimeStr = Format$(hh, "00") & ":" & Format$(Mm, "00") & ":" & Format$(Ss, "00")
FormattaSecondi = TimeStr
End Function
Function FormatString(sValue As String, sFmt As String, nAllineamento As Integer) As String
Dim sTxt As String
Dim k As Integer
' 0 = allinea a sinistra
' 1 = allinea a destra
sTxt = Trim$(sValue)
If sTxt <> "" Then
If Len(sFmt) > Len(sTxt) Then
If nAllineamento = 0 Then
FormatString = sTxt & Mid$(sFmt, Len(sTxt) + 1)
Else
FormatString = Mid$(sFmt, 1, Len(sFmt) - Len(sTxt)) & sTxt
End If
Else
FormatString = sTxt
End If
Else
FormatString = sFmt
End If
End Function
Function GetDataInglese(sData As String) As String
If IsDate(sData) Then
GetDataInglese = Format(sData, "mm/dd/yyyy")
Else
GetDataInglese = "01/01/2100"
End If
End Function
Function GetNumeroFileInDirectory(ByVal sPath As String) As Long
' conta i file presenti nella directory NON controlla le subdir
Dim S As String
Dim n As Long
sPath = AddSlashIfNot(sPath)
If DirExist(sPath) Then
S = Dir(sPath & "*")
Do Until S = ""
If S <> "." And S <> ".." Then
If FileExist(sPath & S) Then
n = n + 1
End If
End If
S = Dir()
Loop
GetNumeroFileInDirectory = n
Else
GetNumeroFileInDirectory = -1
End If
End Function
Function RimuoviZeriNonSignificativi(sDato As String) As String
Dim k As Long
Dim I As Long
For k = 1 To Len(sDato)
If Mid$(sDato, k, 1) <> "0" Then
I = k
Exit For
End If
Next k
If I > 0 Then
RimuoviZeriNonSignificativi = Mid$(sDato, I)
Else
RimuoviZeriNonSignificativi = sDato
End If
End Function
Function Proporzione(A, b, C) As Double
On Error GoTo errUNKNOWN
' a : b = x : c
Proporzione = A * (C / b)
errUNKNOWN:
Select Case Err
Case Is <> 0
Err.Clear
End Select
End Function
Function RimuoviLastChar(S As String, sChr As String) As String
If Right(S, 1) = sChr Then
RimuoviLastChar = Left(S, Len(S) - 1)
Else
RimuoviLastChar = S
End If
End Function
Function GetNomeDirectory(sDir As String) As String
ReDim av(0) As String
av() = Split(RimuoviLastChar(sDir, "\"), "\")
GetNomeDirectory = av(UBound(av))
End Function
Function GetSystemRoot() As String
GetSystemRoot = Left(GetWinDir, 3)
End Function
Function GetUltimogiornoMese(nMese As Integer, nAnno As Integer) As Integer
Dim k As Long
For k = 31 To 1 Step -1
If IsDate(CStr(k) & "/" & CStr(nMese) & "/" & CStr(nAnno)) Then
GetUltimogiornoMese = k
Exit For
End If
Next
End Function
Function Dividi(A, b)
If b > 0 Then
Dividi = CDec(A / b)
Else
Dividi = 0
End If
End Function
Function ReadStringZ(S As String) As String
Dim I As Integer
I = InStr(S, Chr$(0))
If I > 0 Then
ReadStringZ = Trim$(Left(S, I - 1))
Else
ReadStringZ = Trim$(S)
End If
End Function
Sub RiduciSpazi(S As String)
Do While InStr(S, " ") > 0
S = Replace(S, " ", " ")
Loop
End Sub
Function DataHumanToDataSerial(sData As String) As String
ReDim av(0) As String
av() = Split(sData, "/")
If UBound(av) = 2 Then
DataHumanToDataSerial = av(2) & "/" & av(1) & "/" & av(0)
Else
DataHumanToDataSerial = sData
End If
End Function
Function NumeroElementiSelezionatiLb(lb As Object) As Integer
Dim k As Integer
Dim n As Integer
For k = 0 To lb.ListCount - 1
If lb.Selected(k) Then n = n + 1
Next
NumeroElementiSelezionatiLb = n
End Function
Function ContaElementiTrue(aB() As Boolean) As Integer
Dim k As Long
Dim n As Integer
For k = LBound(aB) To UBound(aB)
If aB(k) Then n = n + 1
Next
ContaElementiTrue = n
End Function
Function GetLetteraColonnaXls(idCol As Integer) As String
Dim k As Integer
Dim I As Integer, ii As Integer
Dim sLetteraTmp As String, sPrimaLet As String
Dim sRet As String
If idCol <= Len(sAlfabeto) Then
sRet = Mid$(sAlfabeto, idCol, 1)
Else
I = Len(sAlfabeto) ' 26
Do While I <> idCol
ii = ii + 1
For k = 1 To Len(sAlfabeto) '26
I = I + 1
sLetteraTmp = Mid$(sAlfabeto, k, 1)
If I = idCol Then Exit For
Next
sPrimaLet = Mid$(sAlfabeto, ii, 1)
Loop
sRet = sPrimaLet & sLetteraTmp
End If
GetLetteraColonnaXls = sRet
End Function
Sub DeleteDir(sPath As String)
Dim SHDirOp As SHFILEOPSTRUCT
Dim lFlags As Long
lFlags = lFlags Or FOF_SILENT
lFlags = lFlags Or FOF_NOCONFIRMATION
' If bDir Then lFlags = lFlags Or FOF_NOCONFIRMMKDIR
' If bFilesOnly Then lFlags = lFlags Or FOF_FILESONLY
' If bAllowUndelete Then lFlags = lFlags Or FOF_ALLOWUNDO
With SHDirOp
.fFlags = lFlags
.wFunc = FO_DELETE
.pFrom = sPath & vbNullChar & vbNullChar
.pTo = vbNullChar & vbNullChar
End With
'Delete the directory
SHFileOperation SHDirOp
End Sub
Sub ClearFoglio(sheet As Excel.Worksheet, PrimaRiga As Integer, Optional bSetColore As Boolean = False)
sheet.Range("A" & PrimaRiga & ":IV65000").Select '.ClearContents
Selection.ClearContents
If bSetColore Then
sheet.Range("A" & PrimaRiga & ":IV65000").Interior.ColorIndex = xlNone
End If
sheet.Range("A1").Select
End Sub
Sub SelezionaItemCombo(cmb As ComboBox, S As String)
Dim k As Integer
For k = 0 To cmb.ListCount - 1
If cmb.List(k) = S Then
cmb.ListIndex = k
Exit For
End If
Next
End Sub
Function TrovaIdLastRiga(sheet As Excel.Worksheet, nPrimariga As Integer)
Dim k As Long
k = nPrimariga
Do While sheet.Range("A" & k) <> ""
k = k + 1
Loop
TrovaIdLastRiga = k - 1
End Function
Function ShellDir(fName As String, Hwnd As Long) As Long
ShellDir = ShellExecute(Hwnd, "open", fName, 0, 0, SW_SHOWNORMAL)
'To explore a folder, use the following call:
'ShellExecute(handle, "explore", path_to_folder, NULL, NULL, SW_SHOWNORMAL);
End Function
Function SelezionaFileInRisorseComoputer(fName As String, Hwnd As Long) As Long
SelezionaFileInRisorseComoputer = ShellExecute(Hwnd, "explore", fName, 0, 0, SW_MAXIMIZE)
'To explore a folder, use the following call:
'ShellExecute(handle, "explore", path_to_folder, NULL, NULL, SW_SHOWNORMAL);
End Function
Function AddItemInCollection(Coll As Collection, S) As Boolean
On Error GoTo errore
Coll.Add S, "k" & S
AddItemInCollection = True
errore:
If Err <> 0 Then
Err.Clear
End If
End Function
'=================================================
Sub InitVariabili()
NomiRuote
structIni.sUrlEstrazioni = "http://www.lottomaticaitalia.it/lotto/doc/archivio/storico.zip" ' sheetImpostazioni.Range("B2")
structIni.sPathDiLavoro = AddSlashIfNot(ThisWorkbook.Path)
End Sub
Sub NomiRuote()
glbArrNomiRuote(1) = "Bari"
glbArrNomiRuote(2) = "Cagliari"
glbArrNomiRuote(3) = "Firenze"
glbArrNomiRuote(4) = "Genova"
glbArrNomiRuote(5) = "Milano"
glbArrNomiRuote(6) = "Napoli"
glbArrNomiRuote(7) = "Palermo"
glbArrNomiRuote(8) = "Roma"
glbArrNomiRuote(9) = "Torino"
glbArrNomiRuote(10) = "Venezia"
glbArrNomiRuote(11) = "Nazionale"
glbArrNomiRuote(12) = "Tutte"
End Sub
'========================================================
'========================================================
Private Sub translateSiglaRuota(sSigla As String)
Select Case sSigla
Case "BA"
sSigla = "Bari"
Case "CA"
sSigla = "Cagliari"
Case "FI"
sSigla = "Firenze"
Case "GE"
sSigla = "Genova"
Case "MI"
sSigla = "Milano"
Case "NA"
sSigla = "Napoli"
Case "PA"
sSigla = "Palermo"
Case "RM"
sSigla = "Roma"
Case "TO"
sSigla = "Torino"
Case "VE"
sSigla = "Venezia"
Case "RN"
sSigla = "Nazionale"
End Select
End Sub
Private Sub AlimentaStructE(sRecord As String, strctE As STRUCT_ESTRAZIONE)
On Error GoTo errUNKNOWN
Dim nRuota As Integer
Dim k As Long
ReDim av(0) As String
av() = Split(sRecord, Chr$(9))
For k = 1 To UBound(glbArrNomiRuote)
Call translateSiglaRuota(av(1))
If glbArrNomiRuote(k) = av(1) Then
nRuota = k
Exit For
End If
Next
If nRuota > 0 Then
For k = 1 To 5
strctE.aRuote(nRuota).aNum(k) = Val(Left(av(k + 1), 2))
Next
Else
MsgBox "Ruota non trovata " & av(1)
End If
errUNKNOWN:
Select Case Err
Case Is <> 0
If Erl = 0 Then
MsgBox CStr(Err.Number) & "- " & Err.Description, vbCritical, "ClsEstrazioni.AlimentaStructE"
Else
MsgBox CStr(Err.Number) & "- " & Err.Description & " Linea errore " & Erl, vbCritical, "ClsEstrazioni.AlimentaStructE"
End If
Err.Clear
End Select
End Sub
Function AggiornaEstrazioniEx(sFileEstr As String, sPathHtmlEstrTelevideo As String, aEstrToSave() As STRUCT_ESTRAZIONE) As Boolean
On Error GoTo errUNKNOWN
Dim strctLastE As STRUCT_ESTRAZIONE
Dim strctE As STRUCT_ESTRAZIONE
Dim strctEBlank As STRUCT_ESTRAZIONE
Dim f As Integer
Dim sRecord As String
Dim bFoundedLastEstr As Boolean
Dim sOldData As String
Dim sNewData As String
Dim sOldData2 As String
Dim sNewData2 As String
Dim nEstrAgg As Long
Dim nEstrAnno As Integer
Dim nLette As Long
Dim sAll As String
Dim k As Long
Dim nIdEstrazione As Long
Dim idLastEstr As Long
f = FreeFile
Open sFileEstr For Input As f
sAll = Input(LOF(f), f)
Close f
ReDim aEstrToSave(0) As STRUCT_ESTRAZIONE
' idLastEstr = GetLastRigaEstr
idLastEstr = 0
'If ApriBd Then
If idLastEstr < 3 Then
' se non trova ultima estr vuol dire che non c'è archivio e bisogna aggiornare dalla prima estr disponibile
bFoundedLastEstr = True
nIdEstrazione = 0
Else
Call GetEstrazione(idLastEstr, strctLastE)
'strctLastE.strctData.sData = DataHumanToDataSerial(strctLastE.strctData.sData)
nEstrAnno = strctLastE.strctData.nNumEstrazione
'sOldData = strctLastE.strctData.aa & "/" & Format$(strctLastE.strctData.Mm, "00") & "/" & Format$(strctLastE.strctData.gg, "00")
nIdEstrazione = strctLastE.idEstr
End If
ReDim aRec(0) As String
aRec() = Split(sAll, Chr$(10))
For k = 0 To UBound(aRec)
sRecord = aRec(k)
If Trim$(sRecord) <> "" Then
If bFoundedLastEstr Then
If TranslateDataEstToSerial(strctLastE.strctData) <> Left$(sRecord, 10) Then
sNewData = Left(sRecord, 10)
If sNewData <> sOldData Then
nLette = nLette + 1
If sOldData <> "" Then
'Put fBD, , strctE
ReDim Preserve aEstrToSave(nEstrAgg) As STRUCT_ESTRAZIONE
nIdEstrazione = nIdEstrazione + 1
strctE.idEstr = nIdEstrazione
LSet aEstrToSave(nEstrAgg) = strctE
nEstrAgg = nEstrAgg + 1
If nEstrAgg Mod 10 = 0 Then
FrmLog.AddLine ("Estrazioni aggiornate " & nEstrAgg)
End If
' LabEstrAgg.Caption = nEstrAgg
' LabEstrLette.Caption = nLette
DoEvents
LSet strctE = strctEBlank
End If
If Left$(sNewData, 4) <> Left$(sOldData, 4) Then
If sOldData = "" Then
nEstrAnno = nEstrAnno + 1
Else
nEstrAnno = 1
End If
Else
nEstrAnno = nEstrAnno + 1
End If
'strctE.strctData.sData = DataSerialToDataHuman(sNewData)
ReDim av(0) As String
av() = Split(sNewData, "/")
strctE.strctData.AA = av(0)
strctE.strctData.Mm = av(1)
strctE.strctData.GG = av(2)
strctE.strctData.nNumEstrazione = nEstrAnno
Call AlimentaStructE(sRecord, strctE)
Else
Call AlimentaStructE(sRecord, strctE)
End If
sOldData = sNewData
End If
Else
If TranslateDataEstToSerial(strctLastE.strctData) = Left$(sRecord, 10) Then
bFoundedLastEstr = True
End If
sNewData2 = Left$(sRecord, 10)
If sNewData2 <> sOldData2 Then
nLette = nLette + 1
DoEvents
End If
sOldData2 = sNewData2
End If
End If
Next
If strctE.strctData.nNumEstrazione > 0 Then
'Put fBD, LOF(fBD) + 1, strctE
ReDim Preserve aEstrToSave(nEstrAgg) As STRUCT_ESTRAZIONE
nIdEstrazione = nIdEstrazione + 1
strctE.idEstr = nIdEstrazione
LSet aEstrToSave(nEstrAgg) = strctE
nEstrAgg = nEstrAgg + 1
DoEvents
End If
FrmLog.AddLine ("Estrazioni aggiornate " & nEstrAgg)
FrmLog.AddLine ("Fine aggiornamento")
AggiornaEstrazioniEx = True
' End If
' Call AggiornaEstrazioniDaTelevideoRai(sPathHtmlEstrTelevideo, LabEstrAgg, LabEstrLette, LbLog, nEstrAgg)
errUNKNOWN:
Select Case Err
Case Is <> 0
If Erl = 0 Then
MsgBox CStr(Err.Number) & "- " & Err.Description, vbCritical, "ClsEstrazioni.AggiornaEstrazioni"
Else
MsgBox CStr(Err.Number) & "- " & Err.Description & " Linea errore " & Erl, vbCritical, "ClsEstrazioni.AggiornaEstrazioni"
End If
Err.Clear
End Select
End Function
Sub cancellaDirTempzip()
Dim sPath As String
Dim S As String
Dim Coll As New Collection
Dim v
'Dim fso As New Scripting.FileSystemObject
sPath = GetWinTemp
S = Dir(sPath & "*", vbHidden + vbReadOnly + vbDirectory)
Do While S <> ""
If S <> "." And S <> ".." Then
Coll.Add (sPath & S)
End If
S = Dir()
Loop
For Each v In Coll
If FileExist(CStr(v)) Then
Call DeleteDir(CStr(v))
End If
Next
End Sub
Sub AggiornaEstrazioni(bAncheDaTelevideo As Boolean)
Dim sRetErr As String
Dim sNomeFileLocal As String
Dim sDirOutput As String
Dim sRetFileTxt As String
FrmLog.Show 0
FrmLog.CommandButton1.Visible = True
Application.Calculation = xlManual
' aggiorna le impostazioni di configurazione
Call InitVariabili
' costruisce il path locale per scaricare il file
sNomeFileLocal = Trim(structIni.sPathDiLavoro) & "Estrazioni.zip"
' costruisce la directory dove scompattare il file zip
sDirOutput = Trim(structIni.sPathDiLavoro) & "Temp\"
If CreaPath(sDirOutput) Then
' cancella il contenuto della dir temporanea
Call KillFile(sDirOutput & "\*")
' cancella il file local per fare posto a quello da scaricare
If KillFile(sNomeFileLocal) Then
' scarica file dal web
If DownloadFile(Trim(structIni.sUrlEstrazioni), sNomeFileLocal, sRetErr) Then
Call cancellaDirTempzip
'unzippa il file
Call Unzip(sNomeFileLocal, sDirOutput, sRetFileTxt)
If InStr(sRetFileTxt, ".") Then
If FileExist(sRetFileTxt) Then
ReDim aRetEstr(0) As STRUCT_ESTRAZIONE
Call AggiornaBaseDati(sRetFileTxt, aRetEstr, bAncheDaTelevideo)
FrmLog.AddLine ("Aggiorno foglio estrazioni ...")
Call AggiornaSheetEstrazioni(aRetEstr)
FrmLog.AddLine ("Fatto !")
End If
Else
FrmLog.AddLine ("ERRORE ! File Zip estrazioni non valido")
End If
Else
MsgBox sRetErr, vbExclamation
End If
Else
MsgBox "Impossibile cancellare il vecchio file scaricato in precedenza ,verificare che non sia in uso." & vbCrLf & sNomeFileLocal, vbCritical
End If
Else
MsgBox "Impossibile creare un path temporaneo in " & vbCrLf & sDirOutput, vbCritical
End If
Foglio2.Select
Unload FrmLog
End Sub
Sub Unzip(sFileZip As String, sDirOutput As String, sRetFileUnzipped As String)
Dim fso As Object
Dim oApp As Object
Dim fName As Variant
Dim FileNameFolder As Variant
Dim DefPath As String
Dim strDate As String
Dim ClsZip As New ClsZip
ClsZip.ZipFileName = sFileZip ' "c:\temp\ppp.zip"
ClsZip.UnzipToFolder (sDirOutput)
Set ClsZip = Nothing
sRetFileUnzipped = sDirOutput & Dir(sDirOutput, vbNormal)
Exit Sub
'================================================
fName = sFileZip
FileNameFolder = sDirOutput
' Fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", _
MultiSelect:=False)
' If Fname = False Then
'Do nothing
' Else
'Root folder for the new folder.
'You can also use DefPath = "C:\Users\Ron\test\"
'DefPath = AddSlashIfNot(Application.DefaultFilePath)
'Create the folder name
' strDate = Format(Now, " dd-mm-yy h-mm-ss")
' FileNameFolder = DefPath & "MyUnzipFolder " & strDate & "\"
'Make the normal folder in DefPath
' MkDir FileNameFolder
'Extract the files into the newly created folder
Set oApp = CreateObject("Shell.Application")
oApp.Namespace("" & FileNameFolder).CopyHere oApp.Namespace("" & fName).items
sRetFileUnzipped = sDirOutput & Dir(sDirOutput, vbNormal)
'If you want to extract only one file you can use this:
'oApp.Namespace(FileNameFolder).CopyHere _
'oApp.Namespace(Fname).items.Item("test.txt")
' MsgBox "You find the files here: " & FileNameFolder
' On Error Resume Next
' Set FSO = CreateObject("scripting.filesystemobject")
' FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
'End If
End Sub
Sub AggiornaBaseDati(sFileTxtEstrazioni As String, aRetEstr() As STRUCT_ESTRAZIONE, bDaTelevideo As Boolean)
On Error GoTo errore
Dim sPathHtml As String
Dim sRetUltimoUrl As String
bFermaDownload = False
ReDim aRetEstr(0) As STRUCT_ESTRAZIONE
If AggiornaEstrazioniEx(sFileTxtEstrazioni, "", aRetEstr()) = False Then
MsgBox "Impossibile aggiornare le estrazioni", vbCritical
End If
If bDaTelevideo Then
sPathHtml = Trim(structIni.sPathDiLavoro) & "Lottomatica\"
If CreaPath(sPathHtml) Then
Call AggiornaEstrazioniDaLottomatica(sPathHtml, aRetEstr())
End If
End If
errore:
If Err <> 0 Then
MsgBox Err.Description
End If
End Sub
Function ConvertiDataInParametroUrlLottomatica(sData As String) As String
If IsDate(sData) Then
ConvertiDataInParametroUrlLottomatica = Year(sData) & "-" & Format(Month(sData), "00") & "-" & Format(Day(sData), "00")
End If
End Function
Sub AggiornaEstrazioniDaLottomatica(sPathDest As String, aRetEstr() As STRUCT_ESTRAZIONE)
Dim sData As String
Dim iMax As Long
Dim sUrlBase As String
Dim sDataOdierna As String
Dim sNomeFileLocal As String
sDataOdierna = Format(Now, "dd/mm/yyyy")
sUrlBase = "http://www.lottomaticaitalia.it/lotto/estrazioni/estrazioni_dettaglio.do?dataConcorso=" '2009-11-19"
iMax = UBound(aRetEstr)
sData = TranslateDataEstToHuman(aRetEstr(iMax).strctData)
Do While DateDiff("d", sData, sDataOdierna) >= 0
sData = DateAdd("d", 1, sData)
sNomeFileLocal = sPathDest & ConvertiDataInParametroUrlLottomatica(sData) & ".htm"
If DownloadFile(sUrlBase & ConvertiDataInParametroUrlLottomatica(sData), sNomeFileLocal, "") Then
Call LeggiEstrazioneLottomatica(sNomeFileLocal, aRetEstr(), sData)
End If
Loop
End Sub
Sub LeggiEstrazioneLottomatica(sFileHtm As String, aRetEstr() As STRUCT_ESTRAZIONE, sData As String)
Dim f As Integer
Dim sBuf As String
Dim iMax As Long
Dim k As Long, y As Long, e As Long
Dim idRuota As Integer
Dim UltimoAnnoLetto As Integer
Dim nNumEstrazione As Integer
iMax = UBound(aRetEstr)
UltimoAnnoLetto = aRetEstr(iMax).strctData.AA
nNumEstrazione = aRetEstr(iMax).strctData.nNumEstrazione
f = FreeFile
Open sFileHtm For Binary As f
sBuf = Space$(LOF(f))
Get f, 1, sBuf
Close f
If InStr(sBuf, "Bari") Then
iMax = iMax + 1
Call FrmLog.AddLine("Estrazioni aggiornate " & iMax + 1)
ReDim Preserve aRetEstr(iMax) As STRUCT_ESTRAZIONE
aRetEstr(iMax).idEstr = iMax + 1
aRetEstr(iMax).strctData.AA = Year(sData)
aRetEstr(iMax).strctData.Mm = Month(sData)
aRetEstr(iMax).strctData.GG = Day(sData)
If aRetEstr(iMax).strctData.AA = UltimoAnnoLetto Then
nNumEstrazione = nNumEstrazione + 1
aRetEstr(iMax).strctData.nNumEstrazione = nNumEstrazione
Else
nNumEstrazione = 1
aRetEstr(iMax).strctData.nNumEstrazione = 1
End If
UltimoAnnoLetto = aRetEstr(iMax).strctData.AA
ReDim av(0) As String
av() = Split(sBuf, vbCrLf)
For k = 0 To UBound(av)
e = 0
'If InStr(aV(k), "Bari") > 0 Then
idRuota = GetIdRuotaFromRigaHtmlLottomatica(av(k))
If idRuota > 0 Then
For y = k + 1 To k + 5
e = e + 1
aRetEstr(iMax).aRuote(idRuota).aNum(e) = LeggiNumeroFromRigaHtmlLottomatica(av
)Next
End If
Next
Else
KillFile (sFileHtm)
End If
End Sub
Function GetIdRuotaFromRigaHtmlLottomatica(sRiga As String) As Integer
Dim k As Long
For k = 1 To 11
If InStr(sRiga, glbArrNomiRuote(k)) > 0 Then
GetIdRuotaFromRigaHtmlLottomatica = k
Exit For
End If
Next
End Function
Function LeggiNumeroFromRigaHtmlLottomatica(sRiga As String) As Integer
Dim I As Integer, ii As Integer
Dim S As String
I = InStrRev(sRiga, ">", Len(sRiga) - 1, vbTextCompare)
ii = InStr(I, sRiga, "<", vbTextCompare)
S = Mid$(sRiga, I + 1, (ii - 1) - I)
LeggiNumeroFromRigaHtmlLottomatica = Val(Trim$(S))
End Function
'Sub AggiornaBaseDatiDaTelevideo()
'
' Dim sPathHtml As String
' Dim sRetUltimoUrl As String
'
' Dim clsE As New ClsEstrazioni
' Set clsE.FormLog = frmLog
'
' sPathHtml = Trim(structini.sPathDiLavoro) & "Televideo\"
' If CreaPath(sPathHtml) Then
'
' clsE.FileBaseDati = GetNomeFileBd
' Set clsE.FormLog = frmLog
'
' Call clsE.AggiornaEstrazioniDaTelevideoRai(Trim(structini.sUrlTelevideo), sPathHtml, sRetUltimoUrl)
'
' sheetImpostazioni.Range("B5") = sRetUltimoUrl
'
'
' Else
' MsgBox "Impossibile creare il path per salvare le pagine di teleideo" & vbCrLf & sPathHtml
' End If
'
' Set clsE = Nothing
'
'
'End Sub
Sub AggiornaSheetEstrazioni(aEstr() As STRUCT_ESTRAZIONE)
Dim PrimaEstrUtile As Long
Dim strctE As STRUCT_ESTRAZIONE
Dim k As Long, R As Long, e As Long
Dim idRiga As Long, idCol As Long
Dim nUltimaEstr As Long
nUltimaEstr = GetNumeroEstrazioni
If nUltimaEstr > 0 Then
Call GetEstrazione(GetNumeroEstrazioni, strctE)
For k = UBound(aEstr) To 1 Step -1
If TranslateDataEstToHuman(aEstr(k).strctData) = TranslateDataEstToHuman(strctE.strctData) Then
PrimaEstrUtile = k + 1
Exit For
End If
Next
Else
PrimaEstrUtile = 0
End If
For k = PrimaEstrUtile To UBound(aEstr)
idRiga = k + QRigheIntestazioneSheetEstrazioni + 1
idCol = 1
Foglio2.Cells(idRiga, idCol) = aEstr(k).idEstr
idCol = 3
Foglio2.Cells(idRiga, idCol) = TranslateDataEstToHuman(aEstr(k).strctData)
For R = 1 To 11
For e = 1 To 5
idCol = idCol + 1
Foglio2.Cells(idRiga, idCol) = aEstr(k).aRuote(R).aNum(e)
Next
Next
Next
End Sub
'=======================================
Function ApriBaseDatiInMemoria(inizio As Long, fine As Long, aEstr() As STRUCT_ESTRAZIONE)
' legge dal foglio excel le estrazioni e le mette in una array
Dim k As Long
ReDim aEstr(inizio To fine) As STRUCT_ESTRAZIONE
For k = inizio To fine
Call GetEstrazione(k, aEstr(k))
Next
End Function
Sub GetEstrazione(idEstr As Long, strctE As STRUCT_ESTRAZIONE)
' legge una singola riga dal foglio estrazioni e lo salva nella struttura
Dim Ruota As Long
Dim Pos As Long
Dim sValue As String
Dim idCol As Long
Dim idRiga As Long
idRiga = idEstr + QRigheIntestazioneSheetEstrazioni
strctE.idEstr = idEstr 'IdRiga - QRigheIntestazioneSheetEstrazioni
sValue = Foglio2.Range("C" & idRiga) ' la data.
sValue = Trim$(Mid$(sValue, InStr(sValue, "-") + 1))
ReDim av(0) As String
av() = Split(sValue, "/")
strctE.strctData.AA = av(2)
strctE.strctData.Mm = av(1)
strctE.strctData.GG = av(0)
idCol = 3
For Ruota = 1 To 11
For Pos = 1 To 5
idCol = idCol + 1
strctE.aRuote(Ruota).aNum(Pos) = Val(Foglio2.Cells(idRiga, idCol))
Next
Next
End Sub
Function TranslateDataEstToSerial(strctData As STRUCT_DATA_EST) As String
TranslateDataEstToSerial = strctData.AA & "/" & Format$(strctData.Mm, "00") & "/" & Format$(strctData.GG, "00")
End Function
Function TranslateDataEstToHuman(strctData As STRUCT_DATA_EST, Optional anno2cifre As Boolean = False) As String
If anno2cifre Then
TranslateDataEstToHuman = Format$(strctData.GG, "00") & "/" & Format$(strctData.Mm, "00") & "/" & Right(CStr(strctData.AA), 2)
Else
TranslateDataEstToHuman = Format$(strctData.GG, "00") & "/" & Format$(strctData.Mm, "00") & "/" & strctData.AA
End If
End Function
Function GetDataEstrazione(idEstr As Long) As String
Dim strctE As STRUCT_ESTRAZIONE
Call GetEstrazione(idEstr, strctE)
GetDataEstrazione = TranslateDataEstToHuman(strctE.strctData)
End Function
Function GetNumeroEstrazioni() As Long
Dim n As Long
Dim idRiga As Long
idRiga = QRigheIntestazioneSheetEstrazioni + 1
Do While Foglio2.Cells(idRiga, 1) <> ""
idRiga = idRiga + 1
Loop
GetNumeroEstrazioni = idRiga - QRigheIntestazioneSheetEstrazioni - 1
End Function
Io le ho inserite manualmente.. 
