allinea archivi prima nota legge archivio - vbs

'

option explicit

'

dim cartellabase, cartelladascansionare, a

cartellabase = "C:\azioniprogrammate\archivio_digitale_verifica_esistenza_fatture\"

cartelladascansionare = "C:\ARCHIVIO_DIGITALE_2015\"

'

dim dblog, slog

dblog = cartellabase & "test-report.txt"

'call SovraScriviFile(dblog, " ")

'

dim ArrayOfTerms(), contadati

contadati = 0

'

a = ShowFolderList(cartelladascansionare, "pdf")

'

call ordina

'

' ===

'

Function ShowFolderList(folderspec, ptipo)

Dim fso, f, f1, s, sf, sfiles

Set fso = CreateObject("Scripting.FileSystemObject")

Set f = fso.GetFolder(folderspec)

Set sf = f.SubFolders

For Each f1 in sf

For Each sfiles in fso.GetFolder(f1.Path).Files

If lcase(fso.GetExtensionName(sfiles.Path)) = lcase(ptipo) then

'slog = sfiles.Path

' call ScriviFileJollyAppend(dblog, slog)

'

's = trim(RicercaRisultato(sfiles.Path, "^\d{4}_"))

s = trim(RicercaRisultato(sfiles.Name, "^\d{4}_"))

if len(s) > 0 then

slog = s & vbcrlf & sfiles.Name ' sfiles.Path

'call ScriviFileJollyAppend(dblog, slog)

'add lines

contadati = contadati + 1

redim preserve ArrayOfTerms(contadati)



ArrayOfTerms(contadati) = sfiles.Name

end if

'

End If

Next

Next

'

'

End Function

'

' ===

'

sub ordina()

dim a, j, temp

for a = UBound(ArrayOfTerms) - 1 To 0 Step -1

for j= 0 to a

if ArrayOfTerms(j)>ArrayOfTerms(j+1) then

temp=ArrayOfTerms(j+1)

ArrayOfTerms(j+1)=ArrayOfTerms(j)

ArrayOfTerms(j)=temp

end if

next

next

'

dblog = cartellabase & "db-fatture-esistenti.txt"

call SovraScriviFile(dblog, " ")

dim nrft

'

'

for a = 1 to UBound(ArrayOfTerms)

slog = ArrayOfTerms(a)

nrft = left(slog, 4)

slog = nrft

call ScriviFileJollyAppend(dblog, slog)

next

'

end sub

'

' ============

'

Function RicercaRisultato(strVal, comecercare) 'As String

Dim sParts, sPart, rPart 'As Object

Set rPart = CreateObject("VBScript.RegExp")

rPart.Global = True

rPart.IgnoreCase = True

rPart.pattern = comecercare '

'get the results

Set sParts = rPart.Execute(strVal)

'get the first match

For Each sPart In sParts

RicercaRisultato = sParts(0)

Exit For

Next 'sPart

Set sParts = Nothing

End Function

'

' === sovra scrive file ===================

'

Sub SovraScriviFile(pNomeArchivio, pcosascrivere)

dim fso, rifefile

Set fso=CreateObject("Scripting.FileSystemObject")

Set rifefile = fso.CreateTextFile(pNomeArchivio, TRUE)

rifefile.WriteLine(pcosascrivere)

rifefile.Close

set rifefile = Nothing

End Sub

'

' ==================

'

Sub ScriviFileJollyAppend(pNomeArchivio, pcosascrivere)

dim fso, rifefile

Set fso=CreateObject("Scripting.FileSystemObject")

If (fso.FileExists(pNomeArchivio)) Then

'msg = filespec & " esiste."

Set rifefile = fso.OpenTextFile(pNomeArchivio, 8)

Else

'msg = filespec & " Non esiste."

Set rifefile = fso.CreateTextFile(pNomeArchivio, TRUE)

End If

rifefile.WriteLine(pcosascrivere)

rifefile.Close

set rifefile = Nothing

End Sub

'

' =========

'