venerdì 15 giugno 2018

vbs - esegue programma in base ad un dizionario del numero dei mesi

'

option explicit

'

' vbs - esegue programma in base ad un dizionario del numero dei mesi

'

dim giornomese

giornomese = day(date)   ' dalla data odierna prende il giorno

'

'

dim programma ' programma da eseguire

programma = "C:\sell-in\report-sell-in.vbs"

'

Dim d, valore

Set d = CreateObject("Scripting.Dictionary")

' SI = esegue il programma

d.Add "1", "NO"

d.Add "2", "NO"

d.Add "3", "NO"

d.Add "4", "NO"

d.Add "5", "NO"

d.Add "6", "NO"

d.Add "7", "NO"

d.Add "8", "NO"

d.Add "9", "NO"

d.Add "10", "NO"

d.Add "11", "NO"

d.Add "12", "NO"

d.Add "13", "NO"

d.Add "14", "SI"

d.Add "15", "SI"

d.Add "16", "SI"

d.Add "17", "NO"

d.Add "18", "NO"

d.Add "19", "NO"

d.Add "20", "NO"

d.Add "21", "NO"

d.Add "22", "NO"

d.Add "23", "NO"

d.Add "24", "NO"

d.Add "25", "NO"

d.Add "26", "NO"

d.Add "27", "NO"

d.Add "28", "NO"

d.Add "29", "NO"

d.Add "30", "NO"

d.Add "31", "NO"

'

' recupera il valore abbinato a numero del mese

valore = d.Item(CSTR(giornomese))

'

Dim WshShell, esegui, attesa

Set WshShell = CreateObject("WScript.Shell")

'

if valore = "SI" then

   esegui = programma

   attesa = WshShell.Run (esegui, 1, true)

end if

'

'

 

mercoledì 30 maggio 2018

vba verifica esistenza file per un determinato giorno della settimana

Option Explicit

'

Public Const cartellafile = "C:\Users\Downloads\"

'

' vba verifica esistenza file per un determinato giorno della settimana

'

Sub VerificaEsistenzaFileDataGiorno()

Dim quanterighe, contarighe, foglio, contenuto, colonnadaleggere, giorno, sfile

Set foglio = Sheets(ActiveSheet.Name)

'

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

colonnadaleggere = "A"

'

contarighe = 2

While contarighe <= quanterighe

      contenuto = foglio.Cells(contarighe, colonnadaleggere).Value

      If IsDate(contenuto) = True Then

         giorno = settimanaNomeGiorno(contenuto)

         If giorno = "domenica" Then

            foglio.Cells(contarighe, "B").Value = "x"

            sfile = cartellafile & dataansi(contenuto) & ".txt"

            If esistefile(sfile) = "si" Then

                foglio.Cells(contarighe, "c").Value = "esiste"

            Else

                foglio.Cells(contarighe, "c").Value = "NON esiste"

            End If

         End If

      End If

      contarighe = contarighe + 1

Wend

'

'

End Sub

'

'

'

Function esistefile(parchivio)

Dim fs

Set fs = CreateObject("Scripting.FileSystemObject")

If fs.FileExists(parchivio) = True Then

   esistefile = "si"

Else

   esistefile = "no"

End If

Set fs = Nothing

End Function

'

'

'

Function dataansi(pdata)

Dim sdata

sdata = Year(pdata)

sdata = sdata & Month(pdata)

sdata = sdata & Day(pdata)

dataansi = sdata

'

End Function

'

'

'

Function settimanaNomeGiorno(dt)

Dim NomeGiorno 'As String

Select Case Weekday(dt, 1)

      Case 1: NomeGiorno = "domenica" ' "Sun"

      Case 2: NomeGiorno = "lunedi'" ' "Mon"

      Case 3: NomeGiorno = "martedi'" ' "Tue"

      Case 4: NomeGiorno = "mercoledi'" ' "Wed"

      Case 5: NomeGiorno = "giovedi'" ' "Thu"

      Case 6: NomeGiorno = "venerdi'" ' "Fri"

      Case 7: NomeGiorno = "sabato" ' "Sat"

End Select

 

settimanaNomeGiorno = NomeGiorno

 

End Function

'

 

 

'

martedì 29 maggio 2018

vbs - scrive dati foglio Excel in file csv per stampa mailmerge etichette in Word

'

' vbs - scrive dati foglio Excel in file csv per stampa mailmerge etichette in Word

'

Sub ScriviFoglioCsvSql()

Dim quanterighe, contarighe, foglio, contacolonne, quantecolonne, contenuto

'

Dim cartellafile, fs, a, archivio, stesto, nomefile

cartellafile = "C:\etichette-csv\"

nomefile = "etichette-" & Format(Now(), "yyyymmddmms") & ".txt" ' & ".csv"

archivio = cartellafile & nomefile

'

'

Set fs = CreateObject("Scripting.FileSystemObject")

Set a = fs.CreateTextFile(archivio, True)

'

Set foglio = Sheets(ActiveSheet.Name)

'

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

quantecolonne = Range(foglio.UsedRange.Cells(1, foglio.UsedRange.Columns.Count).Address).Column

'

quantecolonne = 6

'

contarighe = 1

While contarighe <= quanterighe

   contacolonne = 1

   stesto = ""

   While contacolonne <= quantecolonne

      contenuto = foglio.Cells(contarighe, contacolonne).Value

      contenuto = Replace(contenuto, ";", " ")

      contenuto = contenuto & ";"

      stesto = stesto & contenuto

      contacolonne = contacolonne + 1

   Wend

   '

   a.WriteLine (stesto)

   '

   contarighe = contarighe + 1

Wend

'

a.Close

'

Dim cartella, documento, nomedoc

cartella = "C:\etichette-csv\"

documento = cartella & "b-etichette-105x37 - Copia.doc"

'

Dim oApp, wdDoc

'

Set oApp = CreateObject("Word.Application")

oApp.Visible = True

'

Set wdDoc = oApp.Documents.Open(documento)

'

With oApp

    nomedoc = .ActiveDocument.Name

   .Activate

   .Documents(nomedoc).Activate  ' setta il riferimento al documento

End With

'

 wdDoc.MailMerge.OpenDataSource Name:= _

        archivio, ConfirmConversions:=False, _

        ReadOnly:=False, LinkToSource:=True, AddToRecentFiles:=False, _

        PasswordDocument:="", PasswordTemplate:="", WritePasswordDocument:="", _

        WritePasswordTemplate:="", Revert:=False, Format:=0, _

        Connection:="", SQLStatement:="", SQLStatement1:="", SubType:=0

 

  wdDoc.MailMerge.Execute

'

oApp.Documents(documento).Close SaveChanges:=wdDoNotSaveChanges

'

End Sub

'

'

venerdì 25 maggio 2018

salva allegati pdf dei messaggi di posta elettronica

'

option explicit

'

dim cartellaprg

cartellaprg = "C:\azioniprogrammate\allegati-posta-oggetto-fattura\"

dim prg1, prg2, prg3, prg4

prg1 = cartellaprg & "prg-010-salva-allegati-cartelle-pubbliche-oggetto-fattura.vbs"

prg2 = cartellaprg & "prg-020-converti-in-testo.vbs"

prg3 = cartellaprg & "prg-030-elenca-file-cartella.vbs"

prg4 = cartellaprg & "prg-040-cancella-file-messaggi.vbs"

'

dim prgemaildaarchiviodigitale, prgdominidaarchiviodigitale

prgemaildaarchiviodigitale = "C:\azioniprogrammate\archivio-digitale-fatture-2018\p02-cartelle-archivio-digitale.vbs"

prgdominidaarchiviodigitale  = "C:\azioniprogrammate\archivio-digitale-fatture-2018\p03-elenco-domini.vbs"

'

dim prgriferimentipartitaiva

prgriferimentipartitaiva = "C:\azioniprogrammate\salva-allegati-posta-piva\p02-cartelle-archivio-digitale.vbs"

'

' = verifica che outlook sia attivo

'

dim sprocesso, presente, trovato

dim sComputerName, objWMIService, sQuery, objItems, objItem

trovato = 0

'This function can report names from

'TaskManager -> Processes

    sComputerName = "."

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

    sQuery = "SELECT * FROM Win32_Process"

    Set objItems = objWMIService.ExecQuery(sQuery)

    'iterate all item(s)

    For Each objItem In objItems

        sprocesso = objItem.Name

        presente = instr(lcase(sprocesso), "outlook.exe")

        if presente > 0 then

           trovato = 1

           exit for

        else

           trovato = 0 

        end if

    Next

'

if trovato = 0 then

   'msgbox "outlook NON attivo"

else

  ' msgbox "outlook attivo"

  call prgrammasalvaallegati 

end if

'

'   =====

'

sub prgrammasalvaallegati()

Dim WshShell, esegui, attesa

Set WshShell = CreateObject("WScript.Shell")

'

' - salva allegati da exchange - stampa, in pdf, i messaggi

'

esegui = prg1

attesa = WshShell.Run (esegui, 1, true)

'

esegui = prgemaildaarchiviodigitale

attesa = WshShell.Run (esegui, 1, true)

'

esegui = prgdominidaarchiviodigitale

attesa = WshShell.Run (esegui, 1, true)

'

esegui = prgriferimentipartitaiva

attesa = WshShell.Run (esegui, 1, true)

'

' - converte in testo allegati pdf e i messaggi di posta

'

esegui = prg2

attesa = WshShell.Run (esegui, 1, true)

'

' cerca la partita, e poi cerca con indirizzo email

'

esegui = prg3

attesa = WshShell.Run (esegui, 1, true)

'

' cancella file temporanei

'

esegui = prg4

attesa = WshShell.Run (esegui, 1, true)

end sub

'

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

'

venerdì 18 maggio 2018

vbscript - filtra un file di testo utilizzando espressioni regolari

'

option explicit

'

' vbs - filtra un file di testo utilizzando espressioni regolari

'

dim objArgs, Filename, cartellalavori, Title

'

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)

'

cartellalavori = fcartellalavori(Filename)

'

dim dblog, slog

dblog = cartellalavori & "esito-1.txt"

call cancellafile(dblog)

'

dim criterioricerca

 criterioricerca = "[ ]{3,}"   ' solo righe con tre spazi consecutivi

' criterioricerca = "^\w{3}\s+\w*"

' criterioricerca = "^\w+\s\w+"

 

'

call leggifile(FileName)

'

FileName = dblog

dblog = cartellalavori & "esito-2.txt"

call cancellafile(dblog)

criterioricerca = "^\w+\s\w+"

call leggifile(FileName)

'

 

'

' ===

'

sub leggifile(pFileName)

dim  objFSO, objFile, text, txtStream

'

Set objFSO = CreateObject("Scripting.FileSystemObject")

'

If objFSO.FileExists(pFilename) = true Then   

   Set txtStream = objFSO.OpenTextFile(pFilename) ' Apre file di testo.

   Do While Not (txtStream.atEndOfStream)      

       Text = txtStream.ReadLine 'legge una riga  

'

       call TestRegExp(criterioricerca, text)

'

  Loop

End If

'

'

end sub

'

'  =====

'

function fcartellalavori(pfile) ' determina la cartella di origine del file

dim  objFSO, objFile

'

Set objFSO = CreateObject("Scripting.FileSystemObject")

Set objFile = objFSO.GetFile(pfile)

'

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

'

'

end function

'

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

'

Sub TestRegExp(sPattern, ptesto)

'

dim sSearch

sSearch = ptesto

'

Dim oRE, oMatches, oMatch

Set oRE = CreateObject("VBScript.RegExp")

oRE.Global = True

oRE.IgnoreCase = True

oRE.Pattern = sPattern

if oRe.Test(sSearch) = true then

   Set oMatches = oRE.Execute(sSearch)

   For Each oMatch In oMatches

       ' msgbox oMatch.value

       ' stesto = stesto & oMatch.FirstIndex & " : " &  oMatch.Length  & " : " & oMatch.value & vbcrlf

       slog = ptesto

       '

       call ScriviFileJollyAppend(dblog, ptesto)

   Next

end if

'

'

End Sub

'

' =======

'

sub cancellafile(pfile)

dim fs

Set fs=CreateObject("Scripting.FileSystemObject")

if fs.FileExists(pfile) then

   fs.DeleteFile(pfile)

end if

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

'

' =========

'

martedì 15 maggio 2018

vbs - elenca file per data modifica

'

option explicit

'

' vbs - elenca file con data di modifica

' diversa dall'ultima scansione della cartella

'

'

dim cartella

cartella = "C:\archivio-listini\"

'

dim adesso, dbdataultimalettura, dataultimalettura

adesso = now

'

dbdataultimalettura = cartella & "db-data-ultima-lettura.txt"

dataultimalettura = leggituttoverifica(dbdataultimalettura, adesso)

'

'

Dim a, f, b, i

'

Set f  = FilesModificati(cartella, dataultimalettura)

'

a = f.keys

b = f.items

 

For i = 0 To f.count - 1

  WScript.Echo "nuovo file: " &  a(i) & " : " & b(i)

Next

'

call SovraScriviFile(dbdataultimalettura, adesso)

'

Set f = Nothing

WScript.Quit(0)

'

' =====

'

Function FilesModificati (FolderSpec, pdataultimalettura)

  Dim fso, fc, f, d, numerogiorni

  Set fso = CreateObject("Scripting.FileSystemObject")

  Set fc = fso.GetFolder(FolderSpec).Files

  Set d = CreateObject("Scripting.Dictionary")

 

  For Each f in fc

      numerogiorni =  DateDiff("d", pdataultimalettura, f.DateLastModified)

      if numerogiorni > 0 then

         d.Add f, f.DateLastModified & " :nr: " & numerogiorni

      end if

  Next

  Set fso = Nothing

  Set fc = Nothing

  Set FilesModificati = d

End function

'

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

'

function leggituttoverifica(pfiledaleggere, pvaloredefault)

'

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

Else

    'esistefile = "no"

    contenutoletto = pvaloredefault

    Set objFile = objFSO.CreateTextFile(pfiledaleggere, TRUE)

    objFile.WriteLine(pvaloredefault)

End If

'

objFile.Close

'

leggituttoverifica = contenutoletto

'

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

'

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

'

giovedì 19 aprile 2018

vbscript - sposta di un cartella in base al tipo e al contenuto

'

option explicit

'

' vbscript

' nella cartella dove è collocato lo script scorre tutti i file.

' se il tipo file è diverso da .txt

' sposta i file in una sottocartella.

' Legge la prima riga del file .txt e se in questa non è presente

' una determinata parola li sposta in una sottocartella

'

dim archivio, archivioaltro

'

dim dovesono, sifile, nofile, testata

' legge il percorso di dove è collocato lo script.

dovesono = CreateObject("Scripting.FileSystemObject").GetParentFolderName(WScript.ScriptFullName) & "\"

archivio = dovesono & "archivio\"   

archivioaltro = dovesono & "altro\"

'

dim parolachiave

parolachiave = "LISTINO"

'

call verificacartella(archivio)

call verificacartella(archivioaltro)

'

sifile = ""

nofile = ""

'

call elencafilecartella(dovesono, "txt")

'

'call ScriviFileJolly(dovesono & "file-corrispondenti.txt", sifile)

'call ScriviFileJolly(dovesono & "file-non-corrispondenti.txt", nofile)

'

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

'

sub verificacartella(pcartella)

dim fso, shl, exists

Set fso = CreateObject("Scripting.FileSystemObject")

Set shl = CreateObject("WScript.Shell")

'  

exists = fso.FolderExists(pcartella)

 

if (exists)  = false then

   fso.CreateFolder pcartella

end if

'

'

end sub

'

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

'

sub elencafilecartella(cartellainlettura, tipofile)

'

Dim file        ' il file

Dim folder     ' la directory corrente

Dim fso        ' file system object

dim suffisso

' Creo il FileSystemObject

Set fso=CreateObject("Scripting.FileSystemObject")

Set folder=fso.GetFolder(cartellainlettura)

'

' scorro tutti i file

For Each file in folder.Files

    suffisso = fso.GetExtensionName(file.Path)

    if ucase(suffisso) = ucase(tipofile) then

       sifile = sifile & file.name & vbcrlf

       call leggitestata(file.Path)

       if testata = parolachiave then

       else

          call MoveAFile(file.Path, archivioaltro)

       end if

    else

       if suffisso <> "vbs" then 

         'nofile = nofile & file.name & vbcrlf

          nofile = nofile & file.Path & vbcrlf

          call MoveAFile(file.Path, archivio)

       end if

    end if

Next

'

set fso = Nothing

'

end sub

'

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

'

sub leggitestata(pfile)

dim fso, f, myline

Set fso = CreateObject("Scripting.FileSystemObject")

Set f = fso.OpenTextFile(pfile, 1)

myLine = f.ReadLine

testata = left(myline, 7)

f.close

end sub

'

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

'

Sub MoveAFile(pfile, pcartella)

'msgbox pfile & vbcrlf &  pcartella

Dim fso

Set fso = CreateObject("Scripting.FileSystemObject")

fso.MoveFile pfile, pcartella

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

'

' ===

'