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

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