'
' vbs - trova il numero di protocollo delle fatture d'acquisto.
' scansiona cartella archivio digitale delle fatture di acquisto.
' le fatture sono i file pdf inviati dai fornitori, il nome del file è quello attribuito da fornitore.
' tramite una espressione regolare trova il numero della fattura di acquisto presente nel nome del file,
' sempre che il fornitore vi inserisca questa informazione.
' il criterio di ricerca è archiviato in un file con il nome della cartella, la manca presenza
' di questo file evita che il programma effettui la ricerca.
' con il numero di fattura si effettua una ricerca nella contabilità aziendale per trovare il numero
' con cui è stato protocollato il documento.
' il conto fornitore è stato trovato da un precedente programma, che convertendo il file pdf
' in testo, ricerca la partita iva del fornitore nella anagrafica aziendale.
'
option explicit
'
dim dbcartella, dbannosql, dbpercorsobase, dbstringasql, dbcartelladascansionare
dim dbjollylog, slog, archiviocontofornitore, esito, a, contofornitore
dim annosql, percorsobase, stringasqlbase, tcriterio, criterioricerca
dim nomefornitore, cartellainlavoro, nomefileinricerca, dbcartellaricerca
Dim filenellacartella, tchiave, tchiavi, risultato, tquantek
Set filenellacartella = CreateObject("Scripting.Dictionary")
filenellacartella.CompareMode = vbTextCompare
' ==========================
dbcartella = "C:\sistema-protocollo\"
dbcartellaricerca = "C:\sistema-protocollo\ricerca\"
dbpercorsobase = dbcartella & "db-percorso-base.txt"
dbannosql = dbcartella & "db-anno-sql.txt"
dbstringasql = dbcartella & "db-stringa-sql.txt"
dbcartelladascansionare = dbcartella & "db-cartelle-da-scansionare.txt"
archiviocontofornitore = "fornitore-conto-anagrafica.txt"
'
dbjollylog = "C:\sistema-protocollo\log-jolly.txt"
' ---
esito = 0
'
' ===============
' carica anno
annosql = leggiparametri(dbannosql)
' ========================
' leggi path base
percorsobase = leggiparametri(dbpercorsobase)
' =======
' leggi stringasqlbase
stringasqlbase = leggiparametri(dbstringasql)
'
if esito = 0 then
esito = 0
call leggielencocartelledascansionare(dbcartelladascansionare)
end if
'
slog = "Terminato: " & Time
call ScriviFileJollyAppend(dbjollylog, slog)
' msgbox "terminato"
'
' =========
'
sub leggielencocartelledascansionare(Pfiledaleggere)
dim objFSO, objFile, strLine
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile(pfiledaleggere, 1)
'
Do While objFile.AtEndOfStream = False
strLine = trim(objFile.ReadLine)
if len(strLine) > 0 then
nomefornitore = strLine
cartellainlavoro = percorsobase & strLine & "\"
'
set filenellacartella = ShowFileListTipo(cartellainlavoro, ".pdf")
'
tchiavi = filenellacartella.Keys
For Each tchiave In tchiavi
tcriterio = "\d{4}_" & trim(nomefornitore) & ".pdf"
risultato = RimouvoCodificati(tchiave, tcriterio)
Next
'
criterioricerca = leggiparametri(dbcartellaricerca & "ricerca-" & nomefornitore & ".txt")
'
tchiavi = filenellacartella.Keys
For Each tchiave In tchiavi
nomefileinricerca = tchiave
risultato = TrovaValore(tchiave, criterioricerca)
risultato = TrovaValore(risultato, "\d+")
if len(risultato) > 0 then
contofornitore = leggiparametri(cartellainlavoro & archiviocontofornitore)
call recuperadatiSQL(risultato)
if len(trim(contofornitore)) = 0 then
slog = cartellainlavoro & vbcrlf & archiviocontofornitore & vbcrlf & "contofornitore: " & contofornitore
call ScriviFileJollyAppend("C:\sistema-protocollo\manca-conto-fornitore.txt", slog)
end if
end if
Next
'
end if
Loop
'
'
end sub
' ========
' === estrae dati dal database ===
' ========
sub recuperadatiSQL(valoredatrovare)
dim SQLConn, conn, adoCmd, stringasql
dim rsj, estratti
dim nrdoc, partita, jnrdoc, lunghezza
' stringa di conn
SQLConn = "DSN=ODBC;DSN=#????#;UID=#????#;Database=#????#"
'
set conn = createobject("ADODB.Connection")
conn.open sqlconn
' time out
Set adoCmd = CreateObject("ADODB.Command")
adoCmd.CommandTimeout = 45
adoCmd.ActiveConnection = conn
'
stringasql = stringasqlbase
stringasql = replace(stringasql, "#contofornitore#", contofornitore)
stringasql = replace(stringasql, "#annoesercizio#", annosql)
stringasql = replace(stringasql, "#numerodacercare#", valoredatrovare)
'
if len(trim(contofornitore)) = 0 then
exit sub
end if
'
set rsj=CreateObject("ADODB.recordset")
rsj.Open stringasql, conn, 3, 3
estratti = rsj.RecordCount
'
if estratti = 1 then
nrdoc = trim(rsj(2).value)
'
jnrdoc = "000000000" & nrdoc
lunghezza = len(valoredatrovare)
jnrdoc = right(jnrdoc, lunghezza)
'
partita = "0000" & trim(rsj(3).value)
partita = right(partita,4)
if nrdoc = valoredatrovare then
call rinominafile(partita)
else
if jnrdoc = valoredatrovare then
call rinominafile(partita)
end if
end if
end if
'
end sub
'
'================
'
Sub rinominafile(nuovonome)
dim FSO, strFile, strRename
Set FSO = CreateObject("Scripting.FileSystemObject")
strFile = cartellainlavoro & nomefileinricerca
strRename = cartellainlavoro & nuovonome & "_" & nomefornitore & ".PDF"
If FSO.FileExists(strFile) Then
If FSO.FileExists(strRename) = False THEN
FSO.MoveFile strFile, strRename
' msgbox strFile & vbcrlf & strRename
slog = "proposta rinomina: " & strFile & " : " & strRename
call ScriviFileJollyAppend("C:\sistema-protocollo\log-proposta-rinomina.txt", slog)
else
slog = "fattura doppia: " & strFile & ":" & strRename
call ScriviFileJollyAppend("C:\sistema-protocollo\log-fatture-doppie.txt", slog)
end if
End If
Set FSO = Nothing
End Sub
'
' ========
'
Function TrovaValore(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
TrovaValore = sParts(0)
Exit For
Next 'sPart
Set sParts = Nothing
End Function
'
' ========
'
function RimouvoCodificati(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
risultato = spart
if trim(strval) = trim(spart) then
filenellacartella.Remove(strVal)
end if
Next 'sPart
Set sParts = Nothing
End function
'
' ========================
'
Sub ElencaDizionario(pdizionario)
Dim dizionarioj, chiavi, chiave, quantek
Set dizionarioj = CreateObject("Scripting.Dictionary")
dizionarioj.CompareMode = vbTextCompare
set dizionarioj = pdizionario
chiavi = dizionarioj.Keys
quantek = dizionarioj.count
'
For Each chiave In chiavi
call ScriviFileJollyAppend("C:\sistema-protocollo\a-d3.txt", chiave)
Next
'
End Sub
'
' ====================
'
Function ShowFileListTipo(folderspec, tipofile)
'
Dim fso, f, f1, fc, s, snome, suffisso, tchiavi, tquantek
'
Dim Tfilenellacartella
Set Tfilenellacartella = CreateObject("Scripting.Dictionary")
Tfilenellacartella.CompareMode = vbTextCompare
'
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFolder(folderspec)
Set fc = f.Files
For Each f1 In fc
snome = f1.Name
'
if len(ucase(snome)) > len(ucase(tipofile)) then
suffisso = right(snome, len(tipofile))
if ucase(suffisso) = ucase(tipofile) then
if ucase(trim(f1.Name)) = trim(ucase("fatturetutte.pdf")) then
else
If Tfilenellacartella.Exists(f1.Name) = False Then
Tfilenellacartella.Add f1.Name, True
End If
end if
end if
end if
Next
'
set ShowFileListTipo = Tfilenellacartella
tchiavi = Tfilenellacartella.Keys
tquantek = Tfilenellacartella.count
'
End Function
'
' ======================
'
function leggiparametri(sFilePathAndName)
dim sFileContents, oFS, oTextStream
Set oFS = CreateObject("Scripting.FileSystemObject")
If oFS.FileExists(sFilePathAndName) = True Then
Set oTextStream = oFS.OpenTextFile(sFilePathAndName,1)
sFileContents = trim(oTextStream.ReadAll)
oTextStream.Close
Set oTextStream = nothing
else
esito = esito + 1
End if
Set oFS = nothing
leggiparametri = sFileContents
'
if len(sFileContents) = 0 then
esito = esito + 1
end if
'
end function
'
' ========================
'
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
' ====================
' === ===
' ====================================
