Option Explicit
Sub Main
Dim k,r,e
Dim sFileTxt,sFileZip
Dim aEstr
Dim sRecord
Dim aSiglaR
aSiglaR = Array("","BA","CA","FI","GE","MI","NA","PA","RM","TO","VE","RN")
sFileTxt = GetDirectoryAppData & "storico.txt"
sFileZip = GetDirectoryAppData & "storicoZip.zip"
Call EliminaFile(sFileTxt)
Call EliminaFile(sFileZip)
For k = 1 To EstrazioniArchivio
Call GetEstrazioneCompleta(k,aEstr)
For r = 1 To 11
sRecord = FormattaStringa(DataEstrazione(k,,,"/"),"yyyy/mm/dd")
sRecord = sRecord & vbTab
sRecord = sRecord & aSiglaR(r)
sRecord = sRecord & vbTab
For e = 1 To 5
sRecord = sRecord & aEstr(r,e)
If e < 5 Then
sRecord = sRecord & vbTab
End If
Next
Call ScriviFile(sFileTxt,sRecord)
Next
Call Messaggio("Scritte " & k)
Next
Call CloseAllFileHandle
If WindowsZip(sFileTxt,sFileZip) Then
Call ApriDirectory(GetDirectoryAppData)
End If
End Sub
Function WindowsZip(sFile,sZipFile)
'This script is provided under the Creative Commons license located
'at http://creativecommons.org/licenses/by-nc/2.5/ . It may not
'be used for commercial purposes with out the expressed written consent
'of NateRice.com
Dim oZipShell,oZipFSO,oZipApp,oShell
Dim sZipFileCount,aFileName,sFileName,sFileNameInZip,sDupe,sLoop
Set oZipShell = CreateObject("WScript.Shell")
Set oZipFSO = CreateObject("Scripting.FileSystemObject")
If Not oZipFSO.FileExists(sZipFile) Then
NewZip(sZipFile)
End If
Set oZipApp = CreateObject("Shell.Application")
sZipFileCount = oZipApp.NameSpace(sZipFile).items.Count
aFileName = Split(sFile,"\")
sFileName =(aFileName(UBound(aFileName)))
'listfiles
sDupe = False
For Each sFileNameInZip In oZipApp.NameSpace(sZipFile).items
If LCase(sFileName) = LCase(sFileNameInZip) Then
sDupe = True
Exit For
End If
Next
If Not sDupe Then
oZipApp.NameSpace(sZipFile).Copyhere sFile
'Keep script waiting until Compressing is done
On Error Resume Next
sLoop = 0
Do Until sZipFileCount < oZipApp.NameSpace(sZipFile).Items.Count
Call Aspetta(100)
sLoop = sLoop + 1
If ScriptInterrotto Then Exit Do
Loop
On Error GoTo 0
If oZipApp.NameSpace(sZipFile).Items.Count > 0 Then
WindowsZip = True
End If
End If
End Function
Sub NewZip(sNewZip)
'This script is provided under the Creative Commons license located
'at http://creativecommons.org/licenses/by-nc/2.5/ . It may not
'be used for commercial purposes with out the expressed written consent
'of NateRice.com
Dim oNewZipFSO,oNewZipFile,oShell
Set oNewZipFSO = CreateObject("Scripting.FileSystemObject")
Set oNewZipFile = oNewZipFSO.CreateTextFile(sNewZip)
oNewZipFile.Write Chr(80) & Chr(75) & Chr(5) & Chr(6) & String(18,0)
oNewZipFile.Close
Set oNewZipFSO = Nothing
Call Aspetta(500)
End Sub
Sub Aspetta(nMillisec)
Dim n
n = Timer
Do While Timer - n >= nMillisec
DoEventsEx
Loop
End Sub
