sistema protocollo fatture acquisto - vbs

'

' 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

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

' === ===

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

estrae valori database in base al numero di id - vbs

'

' vbs - estrae valori, utilizzando stringhe sql da un database

' in base al numero di id

'

option explicit

'

dim esito, contenutoletto, numeroreport, dataprecedentereport

' cartella in cui sono contenuti i file con i paramentri e le stringe sql necessarie.

dim dbcartellaprocedura

dbcartellaprocedura = "C:\articoli-nuovi\"

'

dim dblog, slog

dblog = dbcartellaprocedura & "log-lavori.txt"

'

dim stringasql, idarticolo, pFilePathAndName

' data ultimo report - se non esiste utilizza la data odierna

pFilePathAndName = dbcartellaprocedura & "db-data-ultimo-report.txt"

call LeggioCreaFileParametri(pFilePathAndName, date)

dataprecedentereport = contenutoletto

'

' legge la stringa sql e l'id dell'ultimo articolo estratto

'

pFilePathAndName = dbcartellaprocedura & "db-stringa-sql.txt"

stringasql = leggiparametri(pFilePathAndName)

' - legge o crea il numeratore dei report

pFilePathAndName = dbcartellaprocedura & "db-numero-report.txt"

call LeggioCreaFileParametri(pFilePathAndName, 1)

numeroreport = contenutoletto + 1

call SovraScriviFile(pFilePathAndName, numeroreport)

dblog = dbcartellaprocedura & "nuovi-articoli-report-" & numeroreport & ".txt"

'

pFilePathAndName = dbcartellaprocedura & "db-id-articolo.txt"

call LeggioCreaFileParametri(pFilePathAndName, 600000)

idarticolo = leggiparametri(pFilePathAndName)

'

' legge gli articoli dall id

stringasql = replace(stringasql, "#id_articolo#", idarticolo)

call recuperadatiSQL(stringasql)

'

' memorizza ultimo id estratto

'

pFilePathAndName = dbcartellaprocedura & "db-stringa-sql-max-id-articolo.txt"

stringasql = leggiparametri(pFilePathAndName)

stringasql = replace(stringasql, "#id_articolo#", idarticolo)

idarticolo = recuperainfoSQL(stringasql)

'

if len(trim(idarticolo)) > 0 then

pFilePathAndName = dbcartellaprocedura & "db-id-articolo.txt"

call SovraScriviFile(pFilePathAndName, idarticolo)

'

pFilePathAndName = dbcartellaprocedura & "db-data-ultimo-report.txt"

call SovraScriviFile(pFilePathAndName, date)

' === prepara il messaggio da inviare ai destinatari email =============

dim msg

msg = ""

msg = msg & "elenco articoli codificati " & vbcrlf

msg = msg & "dalla data del: " & dataprecedentereport & vbcrlf

msg = msg & "alla data del: " & date & vbcrlf

msg = msg & leggiparametri(dblog)

'

dblog = dbcartellaprocedura & "db-messaggio-corpo.txt"

call SovraScriviFile(dblog, msg)

'

dblog = dbcartellaprocedura & "db-messaggio-oggetto.txt"

slog = "report nuovi articoli numero: " & numeroreport

call SovraScriviFile(dblog, slog)

'

' === invia messaggio clienti

Dim objShell, pattesa, prgvbs

Set objShell = Wscript.CreateObject("WScript.Shell")

'

prgvbs = "C:\articoli-nuovi\invia-messaggii-email-utenti.vbs"

pattesa = objShell.Run(prgvbs, 1, true)

Set objShell = Nothing

'

else

'msgbox "niente da aggiornare"

end if

'

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

'

function recuperainfoSQL(pstringasql)

dim SQLConn, conn, adoCmd, stringasql

dim rsj, estratti, risultati, i

stringasql = pstringasql

' stringa di conn

SQLConn = "DSN=ODBC;DSN=#vostro#database#;UID=#vostra#password#;Database=#vostro#database#"

'

set conn = createobject("ADODB.Connection")

conn.open sqlconn

' time out

Set adoCmd = CreateObject("ADODB.Command")

adoCmd.CommandTimeout = 45

adoCmd.ActiveConnection = conn

'

set rsj=CreateObject("ADODB.recordset")

rsj.Open stringasql, conn, 3, 3

estratti = rsj.RecordCount

'

Do until rsj.Eof

risultati = ""

For i = 0 to RSj.Fields.Count - 1

risultati = rsj(i).Value

Next

slog = risultati

rsj.MoveNext

Loop

'

recuperainfoSQL = risultati

'

end function

' ========

' === estrae dati dal database ===

' ========

sub recuperadatiSQL(pstringasql)

dim SQLConn, conn, adoCmd, stringasql

dim rsj, estratti, risultati, i, nrcampi

stringasql = pstringasql

' stringa di conn

SQLConn = "DSN=ODBC;DSN=#vostro#database#;UID=#vostra#password#;Database=#vostro#database#"

'

set conn = createobject("ADODB.Connection")

conn.open sqlconn

' time out

Set adoCmd = CreateObject("ADODB.Command")

adoCmd.CommandTimeout = 45

adoCmd.ActiveConnection = conn

'

set rsj=CreateObject("ADODB.recordset")

rsj.Open stringasql, conn, 3, 3

estratti = rsj.RecordCount

'

nrcampi = RSj.Fields.Count - 1

'

Do until rsj.Eof

risultati = ""

For i = 0 to RSj.Fields.Count - 1

risultati = risultati & trim(rsj(i).Name) & ":" & vbtab & rsj(i).Value & vbcrlf

Next

slog = risultati

call ScriviFileJollyAppend(dblog, slog)

rsj.MoveNext

Loop

'

'

end sub

'

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

'

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 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 LeggioCreaFileParametri(sFileName, valoredefault)

'

dim objFSO, objFile, strLine

Set objFSO = CreateObject("Scripting.FileSystemObject")

If objFSO.FileExists(sFilename) Then

'esistefile = "si"

Set objFile = objFSO.OpenTextFile(sFileName, 1)

'contenutoletto = objFile.Readall

contenutoletto = objFile.ReadLine

Else

'esistefile = "no"

contenutoletto = valoredefault

Set objFile = objFSO.CreateTextFile(sFileName, TRUE)

objFile.WriteLine(valoredefault)

End If

'

Set objFile = Nothing

Set objFSO = 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

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

' === fine ===

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

vbs invia messaggii email utenti - vbs

'

' vbs - invia circoloare email

' indirizzi contenuti in un file di testo

option explicit

'

dim dbelencoutenti, toggetto, tcorpo, contenutoletto, dbarchiviomsg, dboggetto

'

Dim EmailValidator : Set EmailValidator = GetEmailValidator() ' per verificare indirizzo email

'

dbelencoutenti="C:\articoli-nuovi\db-email-utenti-da-avvisare.txt"

dbarchiviomsg="C:\articoli-nuovi\db-messaggio-corpo.txt"

dboggetto="C:\articoli-nuovi\db-messaggio-oggetto.txt"



' corpo del messaggio

call leggitutto(dbarchiviomsg)

tcorpo = contenutoletto

' oggetto messaggio

call leggitutto(dboggetto)

toggetto = contenutoletto

' legge elenco indirizzi email

call leggielenco(dbelencoutenti)

' ====

sub leggielenco(filedaleggere)

dim objFSO, objFile, strLine

Set objFSO = CreateObject("Scripting.FileSystemObject")

Set objFile = objFSO.OpenTextFile(filedaleggere, 1)

'

Do While objFile.AtEndOfStream = False

strLine = objFile.ReadLine

if EmailValidator.Test(strline) = true then

call invaemail(strLine)

'msgbox strline

end if

Loop

'

objFile.Close

Set objFSO = Nothing

Set objFile = Nothing

'

end sub

' ====

'

sub invaemail(indirizzoemail)

dim objEmail

Set objEmail = CreateObject("CDO.Message")

objEmail.From = "articoli-nuovi@#vostro-dominio#.#suffisso#"

objEmail.To = indirizzoemail

objEmail.Subject = toggetto

objEmail.Textbody = tcorpo

objEmail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 ' 1

objEmail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpserver") = " #vostro#server#di#posta#"

objEmail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25

objEmail.Configuration.Fields.Update

objEmail.Send

'

end sub

'

'

Function GetEmailValidator()

Set GetEmailValidator = CreateObject("VBScript.RegExp") 'New RegExp

GetEmailValidator.Pattern = "^((?:[A-Z0-9_%+-]+\.?)+)@((?:[A-Z0-9-]+\.)+[A-Z]{2,4})$"

GetEmailValidator.IgnoreCase = True

End Function

'

' =========

sub leggitutto(pfiledaleggere)

'

dim objFSO, objFile

Set objFSO = CreateObject("Scripting.FileSystemObject")

If objFSO.FileExists(pfiledaleggere) Then

'esistefile = "si"

Set objFile = objFSO.OpenTextFile(pfiledaleggere, 1)

contenutoletto = objFile.Readall

objFile.Close

Else

'esistefile = "no"

contenutoletto = ""

End If

Set objFSO = Nothing

'

end sub

' ====



'