mercoledì 4 gennaio 2017

crea archivio digitale 2017 - vbs

' trasferito

option explicit

'

dim cartelladacansionare

cartelladacansionare = "C:\ARCHIVIO_DIGITALE_2016\"

'

dim cartelladestinazione, nomecartella, scartella

cartelladestinazione = "C:\ARCHIVIO_DIGITALE_2017\"

'

dim tipofile, ltipo, ifile, sfile

tipofile = "txt"

'

dim dblog, slog

dblog = "C:\azioniprogrammate\archivio-digitale-crea\temp-report-file.txt"

'

dim objFSO, objSuperFolder

'

Set objFSO = CreateObject("Scripting.FileSystemObject")

Set objSuperFolder = objFSO.GetFolder(cartelladacansionare)



Call ShowSubfolders (cartelladacansionare)

'

'

'

Sub ShowSubFolders(fFolder)

'

dim objFolder, colFiles, objFile

For Each objFolder In objFSO.GetFolder(fFolder).SubFolders

slog = "1: " & objFolder.Path

'call ScriviFileJollyAppend(dblog, slog)

'

nomecartella = objFolder.name

scartella = cartelladestinazione & nomecartella & "\"

'

call esistecartella(scartella, "crea")

'

Set colFiles = objFolder.Files

For Each objFile in colFiles

ltipo = UCase(objFSO.GetExtensionName(objFile.name))

If ltipo = ucase(tipofile) Then

ifile = cartelladacansionare & nomecartella & "\" & objFile.Name

sfile = scartella & objFile.Name

call esistefile(sfile, "copia")

else

if ltipo = "PDF" then

else

end if

End If

Next

'

Next

'

'

End Sub

'

' ====

'

sub esistefile(pfile, pazione)

'

'

If (objFSO.FileExists(pfile)) = true Then

' esiste!

Else

if pazione = "copia" then

objFSO.CopyFile ifile, scartella, true

end if

End If

'

'

end sub

'

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

'

sub esistecartella(strParentPath, pazione)

'

dim newFolder

'

If objFSO.FolderExists(strParentPath) = False Then

if pazione = "crea" then

Set newFolder = objFSO.CreateFolder(strParentPath)

end if

End If

'

'

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

'

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

'

mercoledì 7 dicembre 2016

prg articoli invia vendite - vbs

' trasf

option explicit

'

'

dim cartellaprocedura

cartellaprocedura = "C:\articoli-invia-vendite\"

'

dim dataoggi

dataoggi = date

'

dim dbconfigxml, jarchivio

dbconfigxml = cartellaprocedura & "config-temp.xml"

'

dim dizionario, dizionariochiave, dizionariovalore

set dizionario=CreateObject("Scripting.Dictionary")

dizionario.CompareMode=1

'

call leggixml(dbconfigxml, "parametri")

'

dim dataprima, dalladata, alladata

dataprima = dizionario.Item("data_ultima_scansione")

'

dataprima = DateAdd("d", 1, dataprima)

dalladata = sistemadata(dataprima)

alladata = sistemadata(dataoggi)

'

dim dbiniziali, iniziali, testodacambiare

dbiniziali = cartellaprocedura & "db-iniziali-articolo.txt"

iniziali = fleggitutto(dbiniziali)

'

call scriviconfigxml

'

'

dim campodacambiare

jarchivio = cartellaprocedura & dizionario.Item("file_input")

testodacambiare = fleggitutto(jarchivio)

'

call leggixml(dbconfigxml, "cose_da_cambiare")

'

jarchivio = cartellaprocedura & dizionario.Item("file_output")

call SovraScriviFile(jarchivio, testodacambiare)

'

'

' ====

'

sub leggixml(parchivioxml, ptiponodo)

Dim objDOM, rtResult, nodeList, obj, jnodo

Set objDOM = WScript.CreateObject("MSXML2.DOMDocument")

rtResult = objDOM.load(parchivioxml)

jnodo = "//*/" & ptiponodo & "/*"

If rtResult = True Then

Set nodeList = objDOM.documentElement.selectNodes(jnodo)

For Each obj In nodeList

dizionariochiave = obj.nodeName

dizionariovalore = obj.text

'

if dizionario.Exists(dizionariochiave) = true then

' Response.Write("Key exists!")

else

' Response.Write("Key does not exist!")

dizionario.Add dizionariochiave, dizionariovalore

end if

'

if ptiponodo = "cose_da_cambiare" then

campodacambiare = "<#>" & dizionariochiave & "<#>"

testodacambiare = replace(testodacambiare, campodacambiare, dizionariovalore)

end if

Next

End If

Set objDOM = Nothing

end sub

'

' ====

'

sub scriviconfigxml()

'

dim nomerecord

'

call SovraScriviFile(dbconfigxml, "<root>" & vbcrlf & "</root>")

'

nomerecord = "parametri"

call inseriscidatixml(dbconfigxml, nomerecord, "file_input", "db-stringa-sql-modello.txt")

call inseriscidatixml(dbconfigxml, nomerecord, "file_output", "db-stringa-sql.txt")

call inseriscidatixml(dbconfigxml, nomerecord, "data_ultima_scansione", dataoggi)

'

nomerecord = "cose_da_cambiare"

call inseriscidatixml(dbconfigxml, nomerecord, "dalla_data", dalladata)

call inseriscidatixml(dbconfigxml, nomerecord, "alla_data" , alladata)

call inseriscidatixml(dbconfigxml, nomerecord, "iniziali" , iniziali)

'

'

end sub

'

' ============ 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

'

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

'

function sistemadata(pdata)

dim jgg, jmm

'

jgg = "00" & day(pdata)

jgg = right(jgg, 2)

jmm = "00" & month(pdata)

jmm = right(jmm, 2)

sistemadata = year(pdata) & "-" & jmm & "-" & jgg

'

'

end function

'

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

'

function fleggitutto(pfiledaleggere)

'

dim objFSO, objFile, contenutoletto

Set objFSO = CreateObject("Scripting.FileSystemObject")

'

If objFSO.FileExists(pfiledaleggere) Then

'esistefile = "si"

Set objFile = objFSO.OpenTextFile(pfiledaleggere, 1)

contenutoletto = objFile.Readall

contenutoletto = replace(contenutoletto, vbcrlf, "")

contenutoletto = replace(contenutoletto, vbcr, "")

contenutoletto = replace(contenutoletto, vblf, "")

objFile.Close

fleggitutto = contenutoletto

Else

'esistefile = "no"

fleggitutto = "x-no-x"

End If

Set objFSO = Nothing

'

end function

'

' =========== lavora file xml ===========

'

sub inseriscidatixml(pfilexml, precord, pnomecampo, pvalore)

'

Dim doc, root, cosainserire, rigainserire

dim livello2, livello3

'

set doc = LoadXmldoc(pfilexml)

set root = Doc.documentElement

'

Set livello2 = doc.documentElement.selectSingleNode("//" & precord)

if livello2 is Nothing then

Set livello2 = doc.createNode("element", precord, "")

end if

'

cosainserire = vbcrlf & "<" & pnomecampo & ">" & pvalore & "</" & pnomecampo & ">" & vbcrlf

set rigainserire = LoadXmlstringa(cosainserire)

set livello3 = rigainserire.documentElement

livello2.appendChild(livello3)

'

root.appendChild(livello2)

'

doc.save (pfilexml)

'

'

end sub

'

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

'

Function LoadXmldoc(path)

'

Set LoadXmldoc = CreateObject("MSXML2.DomDocument.6.0")



LoadXmlDoc.async = False

LoadXmlDoc.load path

If LoadXmlDoc.parseError.errorCode <> 0 Then

WScript.Echo "Error in XML file."

WScript.Echo LoadXmlDoc.parseError.reason

WScript.Quit 1

End If

'

'

End Function

'

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

'

Function LoadXmlstringa(path)

'

Set LoadXmlstringa = CreateObject("MSXML2.DomDocument.6.0")

LoadXmlstringa.async = False

LoadXmlstringa.loadXML path

'

'

End Function

'

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

'

'

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

'

venerdì 22 luglio 2016

cartelle modello scansiona tag nome file - vbs

' p

Option explicit

'

dim fso: set fso = CreateObject("Scripting.FileSystemObject")

dim CurrentDirectory

CurrentDirectory = fso.GetAbsolutePathName(".")

'

dim cartelladascansionare, dbcartellaprocedura, esito

dbcartellaprocedura = CurrentDirectory & "\" ' "C:\da-pub\"

'cartelladascansionare = leggiparametri(dbcartellaprocedura & "cartella-da-scansionare.txt")

cartelladascansionare = dbcartellaprocedura

'

dim fileescluso

fileescluso = "ceram.jpg"

'

dim dblog, slog

dblog = dbcartellaprocedura & "note.txt"

'

slog = "tag: " & vbcrlf

call SovraScriviFile(dblog, slog)

'

Dim dizionario, chiave

Set dizionario = CreateObject("Scripting.Dictionary")

dizionario.CompareMode = vbTextCompare

'

call PrgElencaCartelletipo(cartelladascansionare, "jpg")

'

' srivi tag

'

dim a, i

a=dizionario.Keys

for i = 0 To dizionario.Count -1

slog = a(i)

if isnumeric(slog) = false then

call ScriviFileJollyAppend(dblog, slog)

end if

next

'

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

'

Sub PrgElencaCartelletipo(pFolder, ptipofile)

'

Dim fso, cartelle, percorsocartella, nomecartella, nomefile

dim SubFolder, File, tpath

Set fso = CreateObject("Scripting.FileSystemObject")

set Cartelle = fso.GetFolder(pFolder)

'

For Each File In fso.GetFolder(pFolder).Files

If UCASE(fso.GetExtensionName(File.Name)) = UCASE(ptipofile) Then

nomefile = File.Name

if ucase(nomefile) = ucase(fileescluso) then

else

tpath = percorsocartella & nomefile

' slog = "File.Name: " & File.Name & vbcrlf & tpath

nomefile = replace(nomefile, "-", " ")

nomefile = replace(nomefile, ".jpg", ".")

slog = "- " & nomefile & vbcrlf

call ScriviFileJollyAppend(dblog, slog)

' tag

call RicercaRisultato(nomefile, "\w+")

'

end if

End If

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

chiave = trim(spart)

If dizionario.Exists(chiave) = False Then

dizionario.Add chiave, chiave

else

End If

Next 'sPart

Set sParts = Nothing

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

'

' === 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

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

' === fine ===

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

giovedì 21 luglio 2016

suddividi listino metel per marchio prodotto - vbs

' p

' suddivide un listino Metel.

' divide un file listino Metel in mase al marchio prodotto.

' crea, nella stessa cartella di origine del file, archivi con il nome:

' <sigla produttore> - <sigla marchio> - da - <nome file di origine>

'

option explicit

'

dim objArgs, Filename

'

Set objArgs = WScript.Arguments 'Vedo se ci sono degli argomenti passati allo script

if objargs.count=0 then 'altrimenti mostro come si usa il programma

msgbox "Trascinare un file sul programma per visualizzarlo", vbinformation+vbokonly, Title

wscript.quit

end if

'

Filename=wscript.arguments(0)

'

dim objFSO, objFile, nomefile

'

Set objFSO = CreateObject("Scripting.FileSystemObject")

Set objFile = objFSO.GetFile(Filename)

'

dim cartellalavori

cartellalavori = objFSO.GetParentFolderName(objFile) & "\"

nomefile = objFSO.GetFileName(Filename)

'

dim dblog, slog

'

dim sigliaproduttore, siglamarchio

'

' dizionario dei file creati per evitare di accodare dati a file già esistenti

Dim dizionariofilecreati, chiave

Set dizionariofilecreati = CreateObject("Scripting.Dictionary")

dizionariofilecreati.CompareMode = vbTextCompare

'

Dim fso, Text, txtStream, testata

'

Set fso = CreateObject("Scripting.FileSystemObject")

'

If fso.FileExists(Filename) = true Then

Set txtStream = fso.OpenTextFile(Filename) ' Apre file di testo.

testata = txtStream.ReadLine 'legge la prima riga che contiene la testata

sigliaproduttore = mid(testata, 21, 3)

Do While Not (txtStream.atEndOfStream)

Text = txtStream.ReadLine 'legge una riga

'

siglamarchio = mid(text, 1, 3)

'

dblog = cartellalavori & sigliaproduttore & "-" & siglamarchio & "-da-" & nomefile

'

' verifica iniziale se un file con il nome analogo esiste, se esiste lo cancella

chiave = dblog

If dizionariofilecreati.Exists(chiave) = False Then

dizionariofilecreati.Add chiave, chiave

call SovraScriviFile(dblog, testata)

else

End If

'

slog = Text

call ScriviFileJollyAppend(dblog, slog)

'

Loop

End If

'

' === 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)

rifefile.WriteLine(testata)

End If

rifefile.WriteLine(pcosascrivere)

rifefile.Close

set rifefile = Nothing

End Sub

'

' =========

'

mercoledì 20 luglio 2016

sposta per nome file - vbs

'p

Option explicit

'

dim tipofile, suffisso

tipofile = "jpg"

suffisso = "." & tipofile

'

dim fso: set fso = CreateObject("Scripting.FileSystemObject")

dim CurrentDirectory

CurrentDirectory = fso.GetAbsolutePathName(".")

'

dim cartelladascansionare, dbcartellaprocedura, esito

dbcartellaprocedura = CurrentDirectory & "\" ' "C:\da-pub\"

cartelladascansionare = dbcartellaprocedura

'

dim dblog, slog, parolachiave

dblog = dbcartellaprocedura & "log-lavori.txt"

'

' parola presente nel nome file

parolachiave = inputbox("parola cercata", "parola cercata", " ")

'

dim cartelladestinazione

cartelladestinazione = dbcartellaprocedura & parolachiave & "\"

msgbox ReportFolderStatus(cartelladestinazione)

'

call PrgElencaCartelletipo(cartelladascansionare, tipofile)

'

Function ReportFolderStatus(cartelladestinazione)

Dim fso, msg, f

Set fso = CreateObject("Scripting.FileSystemObject")

If (fso.FolderExists(cartelladestinazione)) Then

msg = cartelladestinazione & " exists."

Else

msg = cartelladestinazione & " doesn't exist."

Set f = fso.CreateFolder(cartelladestinazione)

End If

ReportFolderStatus = msg

End Function

'

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

'

Sub PrgElencaCartelletipo(pFolder, ptipofile)

'

Dim fso, cartelle, percorsocartella, nomecartella, nomefile

dim SubFolder, File, tpath, presente

Set fso = CreateObject("Scripting.FileSystemObject")

set Cartelle = fso.GetFolder(pFolder)

'

For Each File In fso.GetFolder(pFolder).Files

If UCASE(fso.GetExtensionName(File.Name)) = UCASE(ptipofile) Then

nomefile = File.Name

tpath = percorsocartella & nomefile

presente = instr(ucase(nomefile), ucase(parolachiave))

if presente > 0 then

' slog = "File.Name: " & File.Name & vbcrlf & tpath

nomefile = replace(nomefile, "-", " ")

nomefile = replace(nomefile, suffisso , ".")

slog = "- " & nomefile & vbcrlf

call ScriviFileJollyAppend(dblog, slog)

'

fso.MoveFile tpath, cartelladestinazione

end if

'

End If

Next

'

'

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 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

'

' === 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

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

' ===

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

martedì 19 luglio 2016

Importa Metel cross reference - vbs

'

' carica il File Metel Cross Reference

'

Set OXl = createobject ("Excel.Application")

'

Set objArgs = WScript.Arguments 'Vedo se ci sono degli argomenti passati allo script

if objargs.count=0 then 'altrimenti mostro come si usa il programma

msgbox "Trascinare un file sul programma per visualizzarlo", vbinformation+vbokonly, Title

wscript.quit

end if

'

Filename=wscript.arguments(0)

'

dim archiviomacro

archiviomacro = "C:\macro-importazione-cross-reference.txt"

'

oXL.Visible = true

'oXL.workbooks.OpenText Filename,,,1,,,False,,True,,False,,,,"."

'''oXl.workbooks.add

set fichxl=oXL.workbooks.add

'

dim vir, ecomm

vir = chr(34)

ecomm = chr(38)

'

Set mdle = fichxl.VBProject.VBComponents.Add(1)

'

Dim fso, Text, testo, txtStream, conta

dim dacambiare

dacambiare = "#nomeFileDaImportare#"

conta = 3

'

Set fso = CreateObject("Scripting.FileSystemObject")

'

If fso.FileExists(archiviomacro) = true Then

Set txtStream = fso.OpenTextFile(archiviomacro) ' Apre file di testo.

Do While Not (txtStream.atEndOfStream)

Text = txtStream.ReadLine 'legge una riga

testo = replace(Text,dacambiare,Filename)

mdle.CodeModule.InsertLines conta, testo

conta = conta + 1

Loop

End If

'

oXL.Run "ImportaCrossReference"

'

wscript.quit

'*** End ***

'

'

'

' testo archiviomacro = "C:\macro-importazione-cross-reference.txt"

'

'

' macro importazione Metel cross reference.

'



Sub ImportaCrossReference()

'

'

'

With ActiveSheet.QueryTables.Add(Connection:= _

"TEXT;#nomeFileDaImportare#", Destination:=Range("A1"))

.Name = "DATIIMPORTATI"

.FieldNames = True

.RowNumbers = False

.FillAdjacentFormulas = False

.PreserveFormatting = True

.RefreshOnFileOpen = False

.RefreshStyle = xlInsertDeleteCells

.SavePassword = False

.SaveData = True

.AdjustColumnWidth = True

.RefreshPeriod = 0

.TextFilePromptOnRefresh = False

.TextFilePlatform = xlWindows

.TextFileStartRow = 1

.TextFileParseType = xlFixedWidth

.TextFileTextQualifier = xlTextQualifierDoubleQuote

.TextFileConsecutiveDelimiter = False

.TextFileTabDelimiter = True

.TextFileSemicolonDelimiter = False

.TextFileCommaDelimiter = False

.TextFileSpaceDelimiter = False

.TextFileColumnDataTypes = Array(2, 2, 2, 2, 2, 2, 2, 2, 2)

.TextFileFixedColumnWidths = Array(3, 16, 3, 16, 1, 30, 30)

.Refresh BackgroundQuery:=False

End With

'

' intestazione

Range("A1").Value = "Sigla Marchio"

Range("B1").Value = "Codice Prodotto"

Range("C1").Value = "Sigla Marchio"

Range("D1").Value = "Codice Prodotto"

Range("E1").Value = "Funzione"

Range("F1").Value = "Note"

Range("G1").Value = "Filler"

'

Range("h1").Value = "descrizione_Funzione"

Range("h2").Value = "0=ABBINAMENTO - 1=ALTERNATIVA"



'

Sheets(ActiveSheet.Name).Select

Sheets(ActiveSheet.Name).Name = "Cross_Reference"

'

End Sub

'

'

'

lunedì 18 luglio 2016

salva allegati posta file pdf - vbs

'

option explicit

'

' salva gli allegati in formato pdf nella casella di posta in arrivo.

'

dim cartellaprocedura, dbdata, dboggettomessaggi, slog

cartellaprocedura = "C:\Pubblica\allegati-posta\"

dbdata = cartellaprocedura & "db-data-ultima-scansione.txt" ' parametro data ultima scansione eseguita

dboggettomessaggi = cartellaprocedura & "log-oggettomessaggi.txt" ' memorizza nome allegato e oggetto messagio

'

dim LocalPath, CartellaOutlook, AttachName

LocalPath = cartellaprocedura & "allegati\"

CartellaOutlook = "Posta in arrivo"

'

dim tipofile, suffisso, flagdata, primadata

tipofile = "pdf"

flagdata = 0

'

dim datapartenza, oggettomessaggio, differenza

datapartenza = leggiparametritogli(dbdata)

'

dim DataRicezioneEmail, NomeAllegato, sfile

'Dichiarazione costanti

Dim Outlook, olkInbox, olkItem, olkAttach

Const olFolderInbox = 6

'

'riferimenti casella

Set Outlook = CreateObject("Outlook.Application")

'Set olkInbox = OutLook.Session.GetDefaultFolder(olFolderInbox).Folders(CartellaOutlook)

Set olkInbox = OutLook.Session.GetDefaultFolder(olFolderInbox)



'Esegue anche se outlook è chiuso

Outlook.Session.Logon

'

'--- ciclo su tuute le email ----------------------------

'

For Each olkItem In olkInbox.Items

'DataRicezioneEmail = olkItem.ReceivedTime

DataRicezioneEmail = olkItem.CreationTime

oggettomessaggio = ucase(olkItem.Subject)

'

if flagdata = 0 then

call SovraScriviFile(dbdata, DataRicezioneEmail)

flagdata = 1

end if

'

differenza = DateDiff( "n", datapartenza, DataRicezioneEmail)

if differenza > 0 then

'

If olkItem.Attachments.Count > 0 Then

For Each olkAttach In olkItem.Attachments

' Salva allegato/allegati

NomeAllegato = olkAttach.FileName

suffisso = right(NomeAllegato, 3)

if ucase(suffisso) = ucase(tipofile) then

'olkAttach.SaveAsFile LocalPath & NomeAllegato

NomeAllegato = esistefile(NomeAllegato) ' verifica se esiste file dal nome analogo

olkAttach.SaveAsFile NomeAllegato ' salva allegato

'

slog = sfile & "|" & oggettomessaggio

call ScriviFileJollyAppend(dboggettomessaggi, slog)

'

end if

Next

End If

else

exit for

end if

Next

'

'------------------------------------------------------

'

Set Outlook = nothing

Set OlkInbox = nothing

'

wscript.quit

'

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

'

function esistefile(parchivio)

dim contali, archiviodaverificare

dim fs

archiviodaverificare = LocalPath & parchivio

esistefile = archiviodaverificare

sfile = parchivio

contali = 0

'

set fs=CreateObject("Scripting.FileSystemObject")

while fs.FileExists(archiviodaverificare) = true

contali = contali + 1

sfile = "esisteva-" & contali & "-" & parchivio

archiviodaverificare = LocalPath & sfile

wend

esistefile = archiviodaverificare

set fs=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

'

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

'

function leggiparametritogli(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



End if

Set oFS = nothing

sFileContents = replace(sFileContents, vbcrlf, "")

sFileContents = replace(sFileContents, vbcr, "")

sFileContents = replace(sFileContents, vblf, "")

leggiparametritogli = sFileContents

'

'

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

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

' === fine ===

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