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

'

' ===

'

mercoledì 11 aprile 2018

vbs -verifica se il programma di posta outlook si trova in esecuzione

'

option explicit

'

' vbs -verifica se il programma di posta outlook si trova in esecuzione

'

dim sprocesso, presente, trovato

dim sComputerName, objWMIService, sQuery, objItems, objItem

trovato = 0

'

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" 

end if

 

martedì 27 marzo 2018

vba Excel Copia Righe con formula Non In Errore

Option Explicit

'

' vba Excel Copia Righe con formula Non In Errore

'

Sub CopiaRigheNonInErrore()

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

Dim sfoglio, sriga

Set foglio = Sheets(ActiveSheet.Name)

Dim colonnainerrore

colonnainerrore = ActiveCell.Column ' cella attiva

Sheets.Add

Set sfoglio = Sheets(ActiveSheet.Name)

foglio.Activate

'

'

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

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

contacolonne = 1

contarighe = 1

sriga = 0

'

While contarighe <= quanterighe

   If IsError(foglio.Cells(contarighe, colonnainerrore).Value) = False Then

      contacolonne = 1

      sriga = sriga + 1

      foglio.Cells(contarighe, colonnainerrore).Select

      While contacolonne <= quantecolonne

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

         sfoglio.Cells(sriga, contacolonne).Value = foglio.Cells(contarighe, contacolonne).Value

         contacolonne = contacolonne + 1

      Wend

   End If

   contarighe = contarighe + 1

Wend

'

End Sub

'

giovedì 22 marzo 2018

vba Excel verifica una partita iva di un operatore non Vies

'

‘ vba Excel verifica una partita iva di un operatore non Vies

‘ scrive l’esito della ricerca sia in formato Html che testo.

Option Explicit

'

Public Const cartellaarchivio = "C:\archivio-dati\"

Public risposta

'

Sub settaTastoF4CercaPartitaIvaAEchiudi()

Application.OnKey "{F4}", "tastoCercaPartitaIvaAEchiudi"

End Sub

'

Sub tastoCercaPartitaIvaAEchiudi()

Dim riga, piva, contarighe, maxrighe, sriga, contenuto

Dim colonnapartitaiva, colonnarisposta

colonnapartitaiva = "A"

colonnarisposta = "O"

riga = ActiveCell.Row

piva = ActiveSheet.Cells(riga, colonnapartitaiva).Value

Call CercaPartitaIvaAEchiudi(piva)

'

ActiveSheet.Cells(riga, colonnarisposta).Value = risposta

'

'

End Sub

'

Sub CercaPartitaIvaAEchiudi(passapiva)

    Dim i As Long

    Dim IE As Object

    Dim objElement As Object

    Dim objCollection As Object

 '

    Dim HTMLDOC, htmltesto, codicehtml, presente, presente1, presente2

 

   ' Create InternetExplorer Object

    Set IE = CreateObject("InternetExplorer.Application")

 

   ' applicazione non visibile

   IE.Visible = False

 

    ' url

    IE.Navigate "https://telematici.agenziaentrate.gov.it/VerificaPIVA/IVerificaPiva.jsp"

 

    ' messaggio di attesa

    Application.StatusBar = "in attesa di connessione. Please wait..."

 

    ' attende il caricamento della pagina.

    Do While IE.Busy

        Application.Wait DateAdd("s", 1, Now)

    Loop

 

    ' esempio di ricerca per input tags:

    '   1. Text field

    '   <input type="text" class="textfield" name="s" size="24" value="" />

    '

    '   2. Button

    '   <input type="submit" class="button" value="" />

    ' messaggio di attesa

    Application.StatusBar = "Caricamento in corso wait..."

 

    Set objCollection = IE.Document.getElementsByTagName("input")

 

    i = 0

    While i < objCollection.Length

        If objCollection(i).Name = "piva" Then

 

            ' inserisce il valore

            objCollection(i).Value = passapiva

 

        Else

           ' If objCollection(i).Type = "submit" And _

           '   objCollection(i).Name = "" Then

           '

           '   ' "Search" button trovato

           '    Set objElement = objCollection(i)

           '

           ' End If

        End If

        i = i + 1

    Wend

  '  objElement.Click    ' click sul button search

   

    ' attende il caricamento della pagina.

    Do While IE.Busy

        Application.Wait DateAdd("s", 1, Now)

    Loop

 

    ' oggetto IE visibile

    IE.Visible = True

'

    Set HTMLDOC = IE.Document

    htmltesto = HTMLDOC.body.innerText

    codicehtml = HTMLDOC.body.innerhtml

    presente = 0

    While presente = 0

       presente1 = InStr(htmltesto, "PARTITA IVA ATTIVA")

       presente2 = InStr(htmltesto, "PARTITA IVA CESSATA")

       If presente1 > 0 Then

          presente = presente1

          risposta = "trovato"

       End If

       If presente2 > 0 Then

          presente = presente2

          risposta = "cessato"

       End If

       If presente > 0 Then

          Call ScriviDatiToFile(cartellaarchivio & passapiva & ".txt", htmltesto)

          Call ScriviDatiToFile(cartellaarchivio & passapiva & ".html", codicehtml)

       End If

       Application.Wait DateAdd("s", 3, Now)

       Set HTMLDOC = IE.Document

       htmltesto = HTMLDOC.body.innerText

       codicehtml = HTMLDOC.body.innerhtml

       '

 

       '

    Wend

'

    IE.Quit

'

'

    Set IE = Nothing

    Set objElement = Nothing

    Set objCollection = Nothing

 

    Application.StatusBar = ""

'

'

End Sub

'

Sub ScriviDatiToFile(parchivio, ptesto)

'

Const ForReading = 1, ForWriting = 2

Dim fso, f

Set fso = CreateObject("Scripting.FileSystemObject")

Set f = fso.OpenTextFile(parchivio, ForWriting, True)

f.WriteLine ptesto '

f.Close

'

End Sub

 

 

domenica 4 marzo 2018

vba Excel Archivia Fattura

'

Option Explicit

'

' vba Excel Archivia Fattura

Sub ArchiviaFattura()

Dim sigla, articolo

Dim campi, ritorno, quanti, valori

campi = Array("errore", "colonna sigla(0 se manca)", "articolo", "descrizione", "misura", "quantita", "prezzo", "importo", "nr. fattura fornitore", "nr protocollo azienda", "data fattura")

valori = Array("", "A", "B", "C", "D", "E", "F", "G", ".", "", ".", ".", ".")

ritorno = creamaskeraDef(campi, valori)

quanti = UBound(ritorno)

'

Dim colsigla, colart, coldescr, colum, colqta, colpre, colimp

colsigla = ritorno(1)

colart = ritorno(2)

coldescr = ritorno(3)

colum = ritorno(4)

colqta = ritorno(5)

colpre = ritorno(6)

colimp = ritorno(7)

'

If colsigla = 0 Then

sigla = InputBox("dammi la sigla aziendale del fornitore", "scelta", "")

End If

'MsgBox valori(8) & vbCrLf & valori(9) & vbCrLf & valori(10)

Dim quanter, contar, foglio, contenuto, colonnai, sfoglio, sriga

Set foglio = Sheets("fattura")

Set sfoglio = Sheets("fatture")

'

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

sriga = Range(sfoglio.UsedRange.Cells(sfoglio.UsedRange.Rows.Count, 1).Address).Row

sriga = sriga + 1

'

contar = 2

While contar <= quanter

      sriga = sriga + 1

      If colsigla <> 0 Then

         sfoglio.Cells(sriga, "A").Value = foglio.Cells(contar, colsigla).Value  ' sigla

      Else

         sfoglio.Cells(sriga, "A").Value = sigla ' sigla

      End If

      If colart <> 0 Then ' articolo

         articolo = Trim(foglio.Cells(contar, colart).Value)

         If IsNumeric(articolo) = True Then

            sfoglio.Cells(sriga, "B").Value = "'" & articolo

         Else

            sfoglio.Cells(sriga, "B").Value = articolo

         End If

      End If

      If coldescr <> 0 Then sfoglio.Cells(sriga, "c").Value = foglio.Cells(contar, coldescr).Value ' descr

      If colum <> 0 Then sfoglio.Cells(sriga, "d").Value = foglio.Cells(contar, colum).Value ' um

      If colqta <> 0 Then sfoglio.Cells(sriga, "e").Value = foglio.Cells(contar, colqta).Value ' qta

      If colpre <> 0 Then sfoglio.Cells(sriga, "f").Value = foglio.Cells(contar, colpre).Value ' prezzo

      If colimp <> 0 Then sfoglio.Cells(sriga, "G").Value = foglio.Cells(contar, colimp).Value ' importo

      sfoglio.Cells(sriga, "H").Value = ActiveWorkbook.Name ' fornitore

      sfoglio.Cells(sriga, "I").Value = ritorno(8) ' nr_fattura

      sfoglio.Cells(sriga, "J").Value = ritorno(9) ' protocollo

      sfoglio.Cells(sriga, "K").Value = ritorno(10) ' data ft

      contar = contar + 1

Wend

'

'

End Sub

'

 

'

Function creamaskeraDef(campi, valori)

On Error GoTo esci

Dim H, IE, objtag, quanti, conta

quanti = UBound(campi)

ReDim ritorno(quanti)

ritorno(0) = "errore"

'

Set IE = CreateObject("InternetExplorer.Application")

IE.navigate "about:blank" '

IE.Visible = True

IE.Height = 700

IE.Width = 550

IE.MenuBar = False

IE.Toolbar = False

IE.StatusBar = False

IE.resizable = True

'

IE.document.Title = "azienda - "

'

H = ""

H = H + "<html><body><center>"

H = H + " inserimento<br>"

H = H + "<FORM name=""mask"">"

For conta = 1 To quanti

   H = H + campi(conta) + ": <input name=""" & campi(conta) & """  type=""text"" value=""" + valori(conta) + """><br>"

Next conta

H = H + "</FORM></body></html>"

IE.document.body.innerHTML = H

'

' Do While IE.readyState = 4: DoEvents: Loop

'

 Do While IE.readyState = 4

 '

    conta = 0

    For Each objtag In IE.document.all.tags("INPUT")

        conta = conta + 1

        ritorno(conta) = objtag.Value

 

    Next

 

  '

  DoEvents

  Loop

'

ritorno(0) = "risposta"

Set IE = Nothing

'

esci:

'

creamaskeraDef = ritorno

'

 

'

End Function

'