copa file a intervalli periodici - vbs

'

Option Explicit

' vbs - copia ad intervalli predefini i file elencati in un file di testo

' fnomearchivio: contiene il path completro dei file da copiare.

' fileultimalettura: contiene la data dell'ultima copia eseguita.

' cartelladovescrivere: il mome della cartella dove copiare i file.

' dopogiorni: in giorni la periodicità della copia

'

dim fileultimalettura, contenutoletto, dataultimocontrollo, dataoggi, differenzagiorni, dopogiorni, fnomearchivio, cartelladovescrivere

fileultimalettura = "C:\installazioni-in-lavorazione\data-ultima-copia.txt"

' solo copia - configurazione

fnomearchivio = "C:\installazioni-in-lavorazione\elenco-file-installazione.txt"

cartelladovescrivere = "C:\cartella-di-sincronizzazione\installazioni-da-distribuire\"

dopogiorni = 7 ' il numero dei giorni di attesa prima di una nuova copia

dataoggi = Now ' data odierna

' = legge il file parametri - se non esiste lo crea con il valore di default passato

Call LeggioCreaFileParametri(fileultimalettura, dataoggi)

'

dataultimocontrollo = contenutoletto

'

differenzagiorni = DateDiff("y", dataultimocontrollo, dataoggi)

if differenzagiorni >= dopogiorni then

'Msgbox "da fare"

call leggielenco(fnomearchivio)

Call ScriviFileJolly(fileultimalettura, dataoggi)

end if

'

' === legge i nomi dei file da copiare ===

sub leggielenco(filedaleggere)

dim objFSO, objFile, strLine, nomearchivio

'

Set objFSO = CreateObject("Scripting.FileSystemObject")

Set objFile = objFSO.OpenTextFile(filedaleggere, 1)

'

Do While objFile.AtEndOfStream = False

strLine = trim(objFile.ReadLine)

if len(strLine) > 0 then

nomearchivio = objFSO.GetFileName(strLine)

objFSO.CopyFile strLine, cartelladovescrivere & nomearchivio

end if

'

Loop

'

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 ScriviFileJolly(NomeArchivio, cosascrivere)

dim fso, rifefile

Set fso=CreateObject("Scripting.FileSystemObject")

Set rifefile = fso.CreateTextFile(NomeArchivio, TRUE)

rifefile.WriteLine(cosascrivere)

rifefile.Close

set rifefile = Nothing

End Sub

'

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

spegni il computer - vbs

'

option explicit

'

'' -s SHUTDOWN (spegne computer)' -r REBOOT (riavvia)' -t (secondi di attesa prima dello spegnimento o del riavvio)



dim objShell

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

objShell.run ("shutdown -s -t 0")

Scrive elenco email controlla indirizzi

Attribute VB_Name = "Scrive_eleno_email_controlla"

'

Option Explicit

'

'

' vba - scrive in un file di testo gli indirizzi email presenti nel foglio

' ci sono tre colonne che contengono indirizzi email

' toglie gli indirizzi dupulicati.

' esclude i nominativi presenti nel foglio esclusi.

'

Sub ScriviEmailFoglioClientiTogleEsclusi()

Dim quanterighe, contarighe, foglio

Dim testo, contali, contocliente, posizione2, nomefoglio

Dim emailcommerciale, emailamministrazione, altraemail, colonnaconto

nomefoglio = "lista"

Set foglio = Sheets(nomefoglio)

'

quanterighe = Range(foglio.UsedRange.Cells(foglio.UsedRange.Rows.Count, 1).Address).Row

'

colonnaconto = "A" ' colonna con il conto cliente

contarighe = 1

testo = ""

contali = 0

While contarighe <= quanterighe

contocliente = foglio.Cells(contarighe, colonnaconto).Value

emailcommerciale = CStr(Trim(foglio.Cells(contarighe, "C").Value))

emailamministrazione = CStr(Trim(foglio.Cells(contarighe, "D").Value))

altraemail = CStr(Trim(foglio.Cells(contarighe, "E").Value))

If Len(emailcommerciale) = 0 Then

emailcommerciale = emailamministrazione

End If

posizione2 = Application.Match(contocliente, Worksheets("esclusi").Range("A:A"), 0)

If IsError(posizione2) Then

' MsgBox "Not Found"

testo = testo & estraiEmail(CStr(Trim(emailcommerciale))) ' email

testo = testo & estraiEmail(CStr(Trim(altraemail))) ' email

contali = contali + 1

Else

' MsgBox "Found"

End If

'

contarighe = contarighe + 1

Wend

' === il tuo indirizzo email

testo = testo & " indirizzo @ dominio . it - com ;"

'

' === elminani indirizzi email duplicati

testo = trovaunici(testo, ";")

'

' === scrivi risultato in file di testo

Dim fs, a

Set fs = CreateObject("Scripting.FileSystemObject")

Set a = fs.CreateTextFile("C:\" & nomefoglio & ".txt", True)

a.WriteLine (testo)

a.Close

'

'

End Sub

'

'

' === vba. verifica che il testo passato sia un indirizzo email.

'

Function estraiEmail(text As String) As String



Dim result As String, i, j

Dim allMatches As Object

Dim RE As Object

Set RE = CreateObject("vbscript.regexp")



'RE.Pattern = "^\b[A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}\b$"

RE.Pattern = "[A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}"

RE.Global = True

RE.IgnoreCase = True

Set allMatches = RE.Execute(text)

'

result = ""

'

For i = 0 To allMatches.Count - 1

result = result & allMatches.Item(i) & "; "

Next

'

estraiEmail = result

'

End Function

'

'

' vba. toglie gli indirizzi duplicati.

'

Function trovaunici(pvalori, separatore)

Dim valori, contali, quanti, valore, dizionario

valori = Split(pvalori, separatore)

quanti = UBound(valori)

Set dizionario = CreateObject("Scripting.Dictionary")

dizionario.CompareMode = vbTextCompare

For contali = 0 To quanti

valore = valori(contali)

If (dizionario.Exists(valore) = False) Then

dizionario.Add valore, True

End If

Next contali

'

Dim trovati, trovato, testo

trovati = dizionario.Keys

testo = ""

'

For Each trovato In trovati

testo = testo & trovato & "; "

Next

'

trovaunici = testo

'

End Function

taglia pdf - vbs

'

Option explicit

'

' vbs - drag and drop

' utilizza Ghostscript per ritagliare una parte di un file pdf.

'

' FORMAT_A4 PDF = 595.28 841.89

'

Dim objA

Set objA = Wscript.Arguments

if objA.count = 0 Then

Wscript.Echo "Serve almeno 1 file pdf " ' verifica che ci siano argomenti

Wscript.Quit

End If

'

Dim objFSO

Set objFSO = CreateObject("Scripting.FileSystemObject")

dim quantifile, contali, nomefile, filepdf, suffisso, nomefilepdf

'

quantifile = objA.count - 1

' ricerca file pdf passatti come argomenti

for contali = 0 to quantifile

nomefile = trim(obja(contali))

suffisso = lcase(objFSO.GetExtensionName(nomefile))

if suffisso = "pdf" then

filepdf = nomefile

nomefilepdf = objFSO.GetFileName(nomefile)

call croppdf(filepdf, nomefilepdf)

end if

next

'

sub croppdf(filedatagliare, pnomefilepdf)

'

Dim wsh, esegui, attesa

Set wsh = CreateObject("WScript.Shell")

'

esegui = ""

esegui = esegui & "C:\Programmi\gs\gs8.64\bin\gswin32 -sDEVICE=pdfwrite -o "

esegui = esegui & " C:\pdf\" & pnomefilepdf

' [da sinistra] [dal basso] [da destra ] [dall alto]

esegui = esegui & " -c ""[/CropBox [0 610 595 841 ] /PAGES pdfmark"" -f "

esegui = esegui & filedatagliare

attesa = wsh.Run (esegui, 1, true) '



'

end sub

' ====

unisci Fdf a Pdf - vbs

'

'

' vbs - unisce i valori contenuti in un file Fdf

' nel file Pdf editabile contenente i relativi campi.

'

Option explicit

'

Dim objA

Set objA = Wscript.Arguments

if objA.count = 0 Then

Wscript.Echo "Servono almeno due file: uno pdf e uno fdf"

Wscript.Quit

End If

'

Dim objFSO

Set objFSO = CreateObject("Scripting.FileSystemObject")

'

dim quantifile, contali, nomefile, filepdf, suffisso

quantifile = objA.count - 1

' ricerca il file pdf

for contali = 0 to quantifile

nomefile = trim(obja(contali))

suffisso = lcase(objFSO.GetExtensionName(nomefile))

if suffisso = "pdf" then

filepdf = nomefile

end if

next

'

' ricerca i fle fdf

for contali = 0 to quantifile

nomefile = trim(obja(contali))

suffisso = lcase(objFSO.GetExtensionName(nomefile))

if suffisso = "fdf" then

call stampapdf(nomefile) ' stampa i file unisce fdf a pdf

call muovifile(nomefile) ' il file pdf generato assume il nome del file fdf

end if

next

'

' ===

sub muovifile(pnomefile)

Dim objFSO, origine, destinazione

Set objFSO = CreateObject("Scripting.FileSystemObject")

'

origine = "C:\pdf\770ED.pdf" ' file Pdf con i campi da compilare

destinazione = "C:\pdf\" & objFSO.GetBaseName(pnomefile) & ".pdf" ' nome file Fdf senza suffisso

'

objFSO.MoveFile origine, destinazione



end sub

' =====

sub stampapdf(strPDFpath)

'

Dim objPrinter, stampantepredefinita

Set objPrinter = CreateObject("WScript.Network")

objPrinter.SetDefaultPrinter "PDFCreator" ' assegna la stampante pdf come predefinita

'

Dim wsh, esegui, attesa

Set wsh = CreateObject("WScript.Shell")

'

'esegui = "acrord32.exe /p /h """ & strPDFpath

esegui = "acrord32.exe /t /h """ & strPDFpath

'attesa = wsh.Run (esegui, 1, true) ' nel caso si voglia chiudere manualmente il file pdf

wsh.Run esegui

'

WScript.Sleep 15000 ' attende 15 secondi prima di terminare Adobe

'

objPrinter.SetDefaultPrinter "AMMINISTRA" ' ripristina la stampante predefinita

'

dim strComputer, objWMIService, colProcessList, objProcess

strComputer = "."

Set objWMIService = GetObject ("winmgmts:\\" & strComputer & "\root\cimv2")

Set colProcessList = objWMIService.ExecQuery ("Select * from Win32_Process Where Name = 'acrord32.exe'")

For Each objProcess in colProcessList

objProcess.Terminate()

Next

'

end sub

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

P

'

' vbs - Microsoft Outlook Exchange 2000

' elenca tutte le cartelle pubbliche

'

'

Option Explicit

'

dim NomeArchivio, cosascrivere

NomeArchivio="C:\elenco-cartelle-exchange.txt" '

'

call cancellazioneiniziale(NomeArchivio)

'

call ElencaCartellePubbliche

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

sub ElencaCartellePubbliche()

Dim objFolder, objNamespace, objOutlook

'

Const TipoCartella = 18 ' cartelle pubbliche ' 5 = Sent Items

'

Set objOutlook = CreateObject( "Outlook.Application" )

Set objNamespace = objOutlook.GetNamespace( "MAPI" )

'

objNamespace.Logon "Default Outlook Profile", , False, False

Set objFolder = objNamespace.GetDefaultFolder( TipoCartella )

'

Dim scartelle

'

for each scartelle in objFolder.folders

'msgbox scartelle.Name

cosascrivere = scartelle.Name

Call ScriviFileJollyAppend(NomeArchivio, cosascrivere)

next

'

Set objOutlook = Nothing

Set objNamespace = Nothing

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

' ===

sub cancellazioneiniziale(vNomeArchivio)

dim CFSO

Set CFSO = CreateObject("Scripting.FileSystemObject")

If CFSO.FileExists(vNomeArchivio) = true Then

CFSO.DeleteFile(vNomeArchivio)

else

end if

end sub

'=========