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

'

 

venerdì 2 marzo 2018

vba Excel evidenzia Prezzi Diversi Preventivi Ddt

‘ vba Excel evidenzia Prezzi Diversi Preventivi Ddt

 

Sub evidenziaPrezziDiversiPreventiviDdt()

Dim quanterighe, contarighe, foglio

Dim prezzopreve, prezzoddt, mesepreve, meseddt

Set foglio = Sheets("DDT-preventivi")

'

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

 

'

contarighe = 2

While contarighe <= quanterighe

      prezzopreve = foglio.Cells(contarighe, "j").Value

      prezzoddt = foglio.Cells(contarighe, "F").Value

      mesepreve = Month(foglio.Cells(contarighe, "r").Value)

      meseddt = Month(foglio.Cells(contarighe, "u").Value)

      If prezzopreve = prezzoddt Then   ' se il prezzo è uguale toglie la formattazione della cella

         foglio.Rows(contarighe).Interior.ColorIndex = xlNone

      Else

         If prezzoddt > prezzopreve Then ' se il prezzo del ddt è maggiore del preventivo

            If meseddt = mesepreve Then  ' verifica il mese del ddt e il mese preventivo corrispondano

               foglio.Rows(contarighe).Interior.ColorIndex = 46  ' evidenza la cella

            Else

                foglio.Rows(contarighe).Interior.ColorIndex = 8

            End If

         Else

            foglio.Rows(contarighe).Interior.ColorIndex = 6

         End If

      End If

      contarighe = contarighe + 1

Wend

'

End Sub

'

mercoledì 28 febbraio 2018

vba Excel inserisce Hyperlinks

‘ vba  Excel inserisce Hyperlinks

Sub InserisciLinkSupportif(colonnadocumento)

'

On Error Resume Next

'

Dim fs, archivio, percorso, h

Set fs = CreateObject("Scripting.FileSystemObject")

percorso = "\\Caem02\cosanostra\supporti\" ' cartella in cui sono presenti i files

'

Dim quanterighe, contarighe, foglio, contenuto

Set foglio = Sheets(ActiveSheet.Name)

' conteggio delle righe utilizzate

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

'

' cancella link presenti

Range("C2:C65536").Hyperlinks.Delete

'

contarighe = 2

While contarighe <= quanterighe

      contenuto = Trim(foglio.Cells(contarighe, colonnadocumento).Value)

      If Len(contenuto) > 0 Then

         archivio = percorso & contenuto & ".pdf"

         If fs.FileExists(archivio) = True Then

            foglio.Cells(contarighe, colonnadocumento).Select

            foglio.Hyperlinks.Add Anchor:=Selection, Address:=archivio

         End If

      End If

      contarighe = contarighe + 1

Wend

'

End Sub

'