venerdì 23 febbraio 2018

vbs tutte le informazioni su un file - caratteristiche avanzate

'

' vbs tutte le informazioni su un file - caratteristiche avanzate

option explicit

'

' di un file formato jpg si ottengono, di norma,  le seguenti informazioni:

'

'0         Nome: 07060002.JPG

'1         Dimensione: 583 KB

'2         Tipo: Immagine JPEG

'3         Data ultima modifica: 05/09/2007 15.11

'4         Data creazione: 22/01/2014 16.28

'5         Data ultimo accesso: 07/01/2016 15.54

'6         Attributi: A

'7         Stato: In linea

'8         Proprietario: ...

'13        Pagine: 1

'24        Modello fotocamera: ...                     ' se il file è stato generato da una fotocamera.

'25        Data immagine scattata: 06/07/2007 0.00     ' se il file è stato generato da una fotocamera.

'26        Formato: 2048 x 1376

'

'  utilizzando queste informazioni è possibile creare un programma

'  che evidenzi quali files sono duplicati.

'

dim FolderPath, objShell, objFolder, i, strFileName

dim s

'

dim qualecartella

qualecartella = "C:\lavori-info-file\"

'

FolderPath = qualecartella

 

 

Dim TitoliIntestazione(300)

Set objShell = CreateObject("Shell.Application")

Set objFolder = objShell.Namespace(FolderPath)

 

' crea elenco titoli informazioni

For i = 0 to 300

    TitoliIntestazione(i) = objFolder.GetDetailsOf(objFolder.Items, i)

Next

'

For Each strFileName in objFolder.Items

    s = ""

    call ScriviFileJollyAppend(qualecartella & "info.txt", s)

    For i = 0 to 300

       s =  i & vbtab & TitoliIntestazione(i) & ": " & objFolder.GetDetailsOf(strFileName, i)

       if len(trim(TitoliIntestazione(i))) > 0 and len(trim(objFolder.GetDetailsOf(strFileName, i))) > 0 then

          call ScriviFileJollyAppend("C:\lavori-info-file\info.txt", s)

       end if

    Next

Next

'

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

'

Sub ScriviFileJollyAppend(NomeArchivio, cosascrivere)

'

Dim fso, rifefile

Set fso = CreateObject("Scripting.FileSystemObject")

If (fso.FileExists(NomeArchivio)) Then

      'msg = NomeArchivio & " esiste!"

       Set rifefile = fso.OpenTextFile(NomeArchivio, 8)

   Else

      'msg = NomeArchivio & " NON esiste!!!"

       Set rifefile = fso.CreateTextFile(NomeArchivio, True)

   End If

rifefile.WriteLine (cosascrivere)

rifefile.Close

Set rifefile = Nothing

End Sub

'

' =========

'

vbs - trova il link di una immagine in una stringa html

'

Option Explicit

'

' vbs - trova il link di una immagine in una stringa html

'

dim stringa

stringa="<a href=""http://dominio/""><img src=""http://dominio/immagine.jpg""/></a><br>descrizione immanine."

'

msgbox getImgTagURL(stringa)

'

'

'

Function getImgTagURL(HTMLstring)

Dim RegEx, Matches, URL, Match

 

    Set RegEx = CreateObject("Scripting.FileSystemObject")

    With RegEx

        .Pattern = "src=[\""\']([^\""\']+)"

        .IgnoreCase = True

        .Global = True

    End With

 

    Set Matches = RegEx.Execute(HTMLstring)

    ' ricerca tutte le immagini

    URL = ""

    For Each Match in Matches

        ' estrae solo il primo risultato

        URL = Match.Value

        Exit For

    Next

    '

    Set Match = Nothing

    Set RegEx = Nothing

    '

    getImgTagURL = Replace(URL, "src=""", "")

End Function

'

'

'

giovedì 22 febbraio 2018

dal foglio excel con il dettaglio delle fatture crea foglio inventario

' vba -  dal foglio excel con il dettaglio delle fatture crea foglio inventario

'

Sub creaInventario()

'

On Error Resume Next

'

 

Dim quanterighe, contarighe, foglioleggi, sigla, articolo, quantita, posizione, importo, codice

Dim dbquantita, dbimporto, colonnarticoloazienda, scolartazienda, articoloazienda

Dim prezzomedioacquisto

Dim fogliodb, righedb

Set foglioleggi = Sheets("fatture")

Set fogliodb = Sheets("inventario")

Dim scolArticolo, scolQta, scolImp, scolsigla, scolcodice, scolprm

'

'

Dim colonnaSigla, colonnaArticolo, ColonnaQuantita, colonnaImporto, ColonnaCodice

Dim colonnadtft, colonnanrft, colonnaultimoscarico, scoldtft, scolnrft, scolulsca

'

colonnaSigla = "A"

colonnaArticolo = "B"

ColonnaQuantita = "e"

colonnaImporto = "G"

colonnarticoloazienda = "O"

colonnadtft = "K"

colonnanrft = "J"

colonnaultimoscarico = "P"

'

'

'

scolcodice = "A"

scolsigla = "B"

scolArticolo = "C"

scolQta = "D"

scolImp = "E"

scolartazienda = "F"

scolprm = "G"

'

scoldtft = "H"

scolnrft = "I"

scolulsca = "J"

'

fogliodb.Cells(1, scolcodice).Value = "codice"

fogliodb.Cells(1, scolsigla).Value = "sigla"

fogliodb.Cells(1, scolArticolo).Value = "articolo"

fogliodb.Cells(1, scolQta).Value = "ddt_qta"

fogliodb.Cells(1, scolImp).Value = "ddt_valore"

fogliodb.Cells(1, scolprm).Value = "pr_medio_acq"

fogliodb.Cells(1, scolartazienda).Value = "articolo_azienda"

fogliodb.Cells(1, scoldtft).Value = "dt_ft"

fogliodb.Cells(1, scolnrft).Value = "nr_ft"

fogliodb.Cells(1, scolulsca).Value = "ultimo_scarico"

'

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

'

contarighe = 2

While contarighe <= quanterighe

      sigla = Trim(foglioleggi.Cells(contarighe, colonnaSigla).Value)

      articolo = Trim(foglioleggi.Cells(contarighe, colonnaArticolo).Value)

      quantita = foglioleggi.Cells(contarighe, ColonnaQuantita).Value

      importo = foglioleggi.Cells(contarighe, colonnaImporto).Value

      articoloazienda = foglioleggi.Cells(contarighe, colonnarticoloazienda).Value

      codice = sigla & articolo

      If Len(articolo) > 0 Then

         If Application.IsError(Application.Match(codice, fogliodb.Range("A:A"), 0)) Then

            'ActiveSheet.Cells(riga, "C").ClearContents

            righedb = Range(fogliodb.UsedRange.Cells(fogliodb.UsedRange.Rows.Count, 1).Address).Row

          righedb = righedb + 1

         fogliodb.Cells(righedb, scolcodice).Value = "'" & codice

         fogliodb.Cells(righedb, scolsigla).Value = "'" & sigla

         fogliodb.Cells(righedb, scolArticolo).Value = "'" & articolo

         fogliodb.Cells(righedb, scolartazienda).Value = "'" & articoloazienda

         '

         fogliodb.Cells(righedb, scoldtft).Value = "'" & foglioleggi.Cells(contarighe, colonnadtft).Value

         fogliodb.Cells(righedb, scolnrft).Value = "'" & foglioleggi.Cells(contarighe, colonnanrft).Value

         fogliodb.Cells(righedb, scolulsca).Value = "'" & foglioleggi.Cells(contarighe, colonnaultimoscarico).Value

        

         '

         posizione = righedb

         If IsNumeric(quantita) = True Then

            fogliodb.Cells(righedb, scolQta).Value = quantita

         Else

             fogliodb.Cells(righedb, scolQta).Value = 0

         End If

         If IsNumeric(importo) = True Then

            fogliodb.Cells(righedb, scolImp).Value = importo

         Else

            fogliodb.Cells(righedb, scolImp).Value = 0

         End If

      Else

         posizione = Application.Match(codice, fogliodb.Range("A:A"), 0)

'

         dbquantita = fogliodb.Cells(posizione, scolQta).Value

         dbimporto = fogliodb.Cells(posizione, scolImp).Value

         If IsNumeric(quantita) = True Then

            dbquantita = dbquantita + quantita

         End If

         If IsNumeric(importo) = True Then

            dbimporto = dbimporto + importo

         End If

         fogliodb.Cells(posizione, scolQta).Value = dbquantita

         fogliodb.Cells(posizione, scolImp).Value = dbimporto

         fogliodb.Cells(posizione, scoldtft).Value = "'" & foglioleggi.Cells(contarighe, colonnadtft).Value

         fogliodb.Cells(posizione, scolnrft).Value = "'" & foglioleggi.Cells(contarighe, colonnanrft).Value

         fogliodb.Cells(posizione, scolulsca).Value = "'" & foglioleggi.Cells(contarighe, colonnaultimoscarico).Value

         '

         End If

         '

         '

      End If

      contarighe = contarighe + 1

Wend

' calcola prezzo acquisto

contarighe = 2

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

While contarighe <= quanterighe

      dbquantita = fogliodb.Cells(contarighe, scolQta).Value

      dbimporto = fogliodb.Cells(contarighe, scolImp).Value

      If IsNumeric(dbimporto) = True And IsNumeric(dbquantita) = True Then

         If dbimporto > 0 And dbquantita > 0 Then

            prezzomedioacquisto = dbimporto / dbquantita

            fogliodb.Cells(contarighe, scolprm).Value = CCur(prezzomedioacquisto)

         End If

      End If

      contarighe = contarighe + 1

Wend

'

'

fogliodb.Activate

Columns("A:F").Select

    ActiveWorkbook.Names.Add Name:="dbinventario", RefersToR1C1:= _

        "=inventario!C1:C10"

'

End Sub

 

vba legge nominativi da un foglio excel e crea vcard per importazione rubrica telefono

'

Option Explicit

'

'  vba legge nominativi da un foglio excel e crea vcard per importazione rubrica telefono

'

Public Const cartella = "C:\telefoni\vcard\"

'

Public ragionesociale, cellulare

'

Public LASTNAME, FIRSTNAME, MOBILE

Public ADDRESS1, CITY, POSTALCODE, COUNTRY

'

Sub LeggiFoglioCreaVcard()

Dim quanterighe, contarighe, foglio, psContactID, esito

Set foglio = Sheets(ActiveSheet.Name)

'

Dim dblog, slog

dblog = cartella & "report-test-2008.vcf"

'

Dim colonnaragionesociale, colonnanumeromobile

colonnaragionesociale = "C"

colonnanumeromobile = "B"

'

Dim sFileName

sFileName = cartella & "rubrica-2008.vcf"

'

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

'

contarighe = 2

While contarighe <= quanterighe

      psContactID = foglio.Cells(contarighe, colonnaragionesociale).Value ' ragione sociale

      psContactID = Replace(psContactID, ".", "")

'

      LASTNAME = foglio.Cells(contarighe, colonnaragionesociale).Value    ' ragione sociale

      FIRSTNAME = foglio.Cells(contarighe, colonnaragionesociale).Value   ' ragione sociale

      MOBILE = foglio.Cells(contarighe, colonnanumeromobile).Value      ' numero di cellulare

'

'

      Call preparavcf(sFileName)

      '

      If contarighe = 2 Then

         Call preparavcf(dblog)

      End If

      '

'

      contarighe = contarighe + 1

Wend

'

End Sub

'

Sub preparavcf(pfile)

'

Dim fVCardFile

'

fVCardFile = ""

fVCardFile = fVCardFile & "BEGIN:VCARD" & vbCrLf

fVCardFile = fVCardFile & "VERSION:2.1" & vbCrLf

fVCardFile = fVCardFile & "N:" & LASTNAME & ";" & FIRSTNAME & vbCrLf

fVCardFile = fVCardFile & "FN:" & FIRSTNAME & " " & LASTNAME & vbCrLf

'  fVCardFile = fVCardFile & "ORG:" & "ACCOUNT") & vbCrLf

'  fVCardFile = fVCardFile & "TITLE:" & "TITLE") & vbCrLf

'  fVCardFile = fVCardFile & "TEL;WORK;VOICE:" & "WORKPHONE".Value) & vbCrLf

'  fVCardFile = fVCardFile & "TEL;WORK;FAX:" & "FAX") & vbCrLf

'  fVCardFile = fVCardFile & "TEL;HOME;VOICE:" & "HOMEPHONE") & vbCrLf

'  fVCardFile = fVCardFile & "TEL;CELL:" & MOBILE & vbCrLf

'

fVCardFile = fVCardFile & "TEL;TYPE=WORK,MSG:+39" & MOBILE & vbCrLf

'

'  fVCardFile = fVCardFile & "EMAIL;WORK:" & "EMAIL" & vbCrLf

fVCardFile = fVCardFile & "ADR;HOME:;;" & ADDRESS1 & ";" & CITY & ";;" & POSTALCODE & ";" & COUNTRY & vbCrLf

fVCardFile = fVCardFile & "END:VCARD" & vbCrLf

'

Call ScriviFileJollyAppend(pfile, fVCardFile)

'

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

'

' =========

'

mercoledì 21 febbraio 2018

vba excel Scrivi file Fdf Comunicazione Dati Iva

‘ vba excel  Scrivi file Fdf Comunicazione Dati Iva

Sub ScriviFdfComunicazioneDatiIva()

Dim foglio, nomefoglio

nomefoglio = "comunicazione-iva"

Set foglio = Sheets(nomefoglio)

'

Dim quanterighe, contarighe

'

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

contarighe = 2

'

Dim mese

mese = Trim(foglio.Range("C2").Value)

'

Dim colonnacampo, colonnavalore, valorecampo, nomecampo

colonnacampo = "D"

colonnavalore = "C"

Dim s

s = ""

s = s & "%FDF-1.2" & vbCrLf

s = s & "1 0 obj" & vbCrLf

s = s & "<<" & vbCrLf

s = s & "  /FDF" & vbCrLf

s = s & "  <<" & vbCrLf

's = s & "    /Fields [ << /V (valore campo)  /T (nome_campo)>> ]" & vbCrLf

'

s = s & "    /Fields [ " & vbCrLf

'

nomecampo = "azienda"

valorecampo = "nome azienda"

 

s = s & "    << /V (" & valorecampo & " )  /T (" & nomecampo & ")>> " & vbCrLf

'

While contarighe <= quanterighe

      nomecampo = Trim(foglio.Cells(contarighe, colonnacampo).Value)

      valorecampo = Trim(foglio.Cells(contarighe, colonnavalore).Value)

      If Len(nomecampo) > 0 Then

         If IsNumeric(valorecampo) = True Then

            valorecampo = Format(valorecampo, "#,###.00")

         End If

         s = s & "    << /V (" & valorecampo & " )  /T (" & nomecampo & ")>> " & vbCrLf

      End If

      contarighe = contarighe + 1

Wend

'

'

s = s & "     ]" & vbCrLf

'

s = s & "    /F (comunicazione-iva-2017_editabile.pdf)" & vbCrLf ' rifrimento al file pdf editabile contente i campi presenti nella colonna “colonna campo”

s = s & "    /ID [ ()()]" & vbCrLf

s = s & "  >>" & vbCrLf

s = s & ">>" & vbCrLf

s = s & "endobj" & vbCrLf

s = s & "trailer" & vbCrLf

s = s & "<<" & vbCrLf

s = s & "/Root 1 0 R" & vbCrLf

s = s & ">>" & vbCrLf

s = s & "%%EOF" & vbCrLf

'

Dim fs, a, archivio

If Len(mese) > 0 Then

   archivio = "C:\iva-comuniazioni-liquidazioni\comunicazione-iva" & mese & ".fdf"

Else

   archivio = "C:\iva-comuniazioni-liquidazioni\comunicazione-iva.fdf"

End If

'

Set fs = CreateObject("Scripting.FileSystemObject")

Set a = fs.CreateTextFile(archivio, True)

a.WriteLine (s)

a.Close

 

'

End Sub

 

vba Excel – allinea valori sulla colonna attiva

' vba Excel – allinea valori sulla colonna attiva

 

Option Explicit

'

'

Sub allineasuColonnaAttiva()

'

Dim rigaattiva, colonnaattiva, secondacolonna, contale, valoreAttivo, valoresx, contacolonne

Dim quanter, contar, foglio

Set foglio = Sheets(ActiveSheet.Name)

rigaattiva = ActiveCell.Row

colonnaattiva = ActiveCell.Column

secondacolonna = colonnaattiva - 1

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

 

For contale = colonnaattiva To secondacolonna Step -1

    contar = 1

    While contar <= quanter

          valoreAttivo = Trim(foglio.Cells(contar, contale).Value)

          If Len(valoreAttivo) = 0 Then

              For contacolonne = secondacolonna To 1 Step -1

                  valoresx = Trim(foglio.Cells(contar, contacolonne).Value)

                  If Len(valoresx) > 0 Then

                     If IsNumeric(valoresx) = True Then

                        foglio.Cells(contar, contale).Value = CDbl(valoresx)

                     Else

                        foglio.Cells(contar, contale).Value = valoresx

                     End If

                        foglio.Cells(contar, contacolonne).ClearContents

                     Exit For

                  End If

              Next contacolonne

          End If

          contar = contar + 1

    Wend

 

 

Next contale

'

'

End Sub

 

martedì 20 febbraio 2018

vbs estrae dal file righe con codici intrastat

option explicit

'

' vbs legge un file di testo

' ed estrare solo le righe contenti un numero lungo otto cifre.

' esempio: ricerca codici Intrastat.

'

dim spazi

spazi = "                                                              "

'

dim nomearchivio

nomearchivio = "C:\filepdfatesto.txt"

'

dim dblog,  slog

dblog = "C:\filepdfatesto-filtrato-a.txt"

call SovraScriviFile(dblog, "")

'

'

call leggielenco(nomearchivio)

'

call ScriviFileJollyAppend(dblog, "F")

'

' ====

sub leggielenco(filedaleggere)

 

dim objFSO, objFile, strLine, trovato,  trovato2, chiave

dim primaparte, secondaparte, srisultato

 

Set objFSO = CreateObject("Scripting.FileSystemObject")

Set objFile = objFSO.OpenTextFile(filedaleggere, 1)

'

Do While objFile.AtEndOfStream = False

   strLine = objFile.ReadLine

   if len(trim(strLine)) > 0 then

      trovato =  TrovaValore(strLine,"\s\d{8}\s")

      if len(trovato) > 0 then

         slog = strLine

         call ScriviFileJollyAppend(dblog, slog)

      end if

   end if

'

'

Loop

'

'

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

'

' === 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 TrovaValore(strVal, comecercare) 'As String

TrovaValore = ""

Dim sParts, sPart, rPart 'As Object

Set rPart = CreateObject("VBScript.RegExp")

rPart.Global = True

rPart.IgnoreCase = True

rPart.pattern = comecercare '

' test di ricerca

if rPart.Test(strVal) then

   Set sParts = rPart.Execute(strVal)

   ' restituisce il primo risultato

   For Each sPart In sParts

      TrovaValore = sParts(0)

      Exit For

   Next 'sPart

   else

   TrovaValore = ""

   end if

Set sParts = Nothing

End Function

'

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

'