vba Cancella Righe Con Cella Vuota o Non Numerica

'
Option Explicit
'
' vba Cancella Righe Con Cella Vuota o Non Numerica
'
Sub CancellaRigheConCellaVuotaoNonNumerica()
On Error GoTo errore
Dim quanterighe, contarighe, foglio, contenuto, colonnainput
Set foglio = Sheets(ActiveSheet.Name)
'
quanterighe = Range(foglio.UsedRange.Cells(foglio.UsedRange.Rows.Count, 1).Address).Row
colonnainput = InputBox("colonna da pulire", "scelta", "C")
'
contarighe = quanterighe
While contarighe > 2
      contenuto = Trim(foglio.Cells(contarighe, colonnainput).Value)
      If Len(contenuto) = 0 Then
         Rows(contarighe).Delete Shift:=xlUp
      Else
         If IsNumeric(contenuto) = False Then
            Rows(contarighe).Delete Shift:=xlUp
         End If
       End If
       contarighe = contarighe - 1
Wend
'
terminato:
GoTo esci
errore:
foglio.Cells(contarighe, colonnainput).Select
esci:
'
End Sub

' vba Evidenzia Celle Per Contenuto

'
Option Explicit
'
' vba Evidenzia Celle Per Contenuto
'

Sub EvidenziaCellePerContenuto()
    Dim re, strPattern As String, r As Range
    Set re = CreateObject("VBScript.RegExp")
    strPattern = InputBox("cosa deve contenure la cella:", "scelta", "")
    With re
        .Pattern = strPattern
        .IgnoreCase = True
        .Global = True
        For Each r In ActiveSheet.UsedRange
            If .test(r.Value) Then r.Interior.ColorIndex = 3
        Next r
    End With
    Set re = Nothing
End Sub

'

vba - excel - cancella righe del foglio con il valore della cella corrente

'
Option Explicit
'
' vba - excel - cancella righe del foglio con il valore della cella corrente
'
Sub cancellarigheconvalorecorrente()
'
Dim colonnaattiva, corrente As String, quanterighe, contarighe
Dim valorecellaattiva As String, foglio
Set foglio = Sheets(ActiveSheet.Name)
colonnaattiva = ActiveCell.Column
valorecellaattiva = Trim(ActiveCell.Value) ' valore cella attiva
'
Application.Cursor = xlWait
Application.ScreenUpdating = False
'
quanterighe = Range(foglio.UsedRange.Cells(foglio.UsedRange.Rows.Count, 1).Address).Row
'
For contarighe = quanterighe To 1 Step -1                               ' conteggio righe usate
    corrente = Trim(foglio.Cells(contarighe, colonnaattiva).Value)
    If corrente = valorecellaattiva Then
       foglio.Rows(contarighe).Delete
    End If
Next contarighe
'
Application.ScreenUpdating = True
Application.Cursor = xlDefault
'
'
End Sub

visualizza foglio excel in una pagina html ricerca con ajax - vbs

script: visualizza foglio excel in una pagina html ricerca con ajax - vbs

'
option explicit
' vbs Excel html
'
dim dbmodellohtml, modellohtml, shtml
dbmodellohtml = "C:\azioniprogrammate\tabella-jquery\db-tabella-ajax.txt"
modellohtml = leggifiletutto(dbmodellohtml)
'
dim foglioexcel, foglio, nomefoglio
dim dblog, slog
' =====================================
dblog = "C:\cartella-report\temp-report.html" ' === nome pagina html da creare
foglioexcel = "C:\fogli-excel\magazzino_2018_per_codici.xlsx"  ' file excel da leggere
nomefoglio = "dati"                             ' foglio excel da leggere
' =============
'
shtml = ""
shtml = shtml & modellohtml
'
dim app
set app = createobject("Excel.Application")
app.Visible = true
'
dim oExcelBook
'
Set oExcelBook = app.Workbooks.open(foglioexcel)
set foglio = oExcelBook.sheets(nomefoglio)
'
Dim quanterighe, contarighe,  contacolonne, quantecolonne, contenuto
'
quanterighe = foglio.Range(foglio.UsedRange.Cells(foglio.UsedRange.Rows.Count, 1).Address).Row
quantecolonne = foglio.Range(foglio.UsedRange.Cells(1, foglio.UsedRange.Columns.Count).Address).Column
'
contacolonne = 1
contarighe = 1
' scrive riga di intestazione
shtml = shtml & "<thead>" & "<tr>"
'
While contacolonne <= quantecolonne
   contenuto = "<th>" & foglio.Cells(contarighe, contacolonne).Value & "</th>"
  shtml = shtml & contenuto
   contacolonne = contacolonne + 1
Wend
'
shtml = shtml & "</tr>" &  "</thead>" & "<tbody id=""myTable"">"
'
' === scrive il dettaglio
contarighe = 2
While contarighe <= quanterighe
   contacolonne = 1
   shtml = shtml & "<tr>"
   While contacolonne <= quantecolonne
      contenuto = "<td>" & foglio.Cells(contarighe, contacolonne).Value & "</td>"
      shtml = shtml & contenuto
  
      contacolonne = contacolonne + 1
   Wend
   shtml = shtml & "</tr>"
   contarighe = contarighe + 1
   foglio.Cells(contarighe, "A").select
Wend
'
shtml = shtml & "</tbody>" & "</TABLE>"  & "</BODY>" & "</HTML>"
call SovraScriviFile(dblog, shtml)
'
'
oExcelBook.close
'
Set oExcelBook = Nothing
app.Quit
Set app = Nothing
'
' === 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 leggifiletutto(sFilePathAndName)
dim sFileContents, oFS, oTextStream
Set oFS = CreateObject("Scripting.FileSystemObject")
If oFS.FileExists(sFilePathAndName) = True Then
     Set oTextStream = oFS.OpenTextFile(sFilePathAndName,1)
     sFileContents = oTextStream.ReadAll
     oTextStream.Close
     Set oTextStream = nothing
End if
Set oFS = nothing
'
leggifiletutto = sFileContents
'
end function
'
' =================
'

--- file: db-tabella-ajax.txt

<!DOCTYPE html>
<html>
<head>
<meta http-equiv="X-UA-Compatible" content="IE=edge">
<meta name="viewport" content="width=device-width, initial-scale=1">
<script src="https://ajax.googleapis.com/ajax/libs/jquery/3.4.1/jquery.min.js"></script>
<script>
$(document).ready(function(){
  $("#myInput").on("keyup", function() {
    var value = $(this).val().toLowerCase();
    $("#myTable tr").filter(function() {
      $(this).toggle($(this).text().toLowerCase().indexOf(value) > -1)
    });
  });
});
</script>
<style>
table {
  font-family: arial, sans-serif;
  border-collapse: collapse;
  width: 100%;
}

td, th {
  border: 1px solid #dddddd;
  text-align: left;
  padding: 8px;
}

tr:nth-child(even) {
  background-color: #dddddd;
}
</style>
</head>
<body>

<h2>ricerca</h2> 
<input id="myInput" type="text" placeholder="ricerca...">
<br>

<table>

vba - ricerca partita iva se presente nel vies della commissione europea

'

Option Explicit
'
' vba -Excel - ricerca partita iva se presente nel vies della commissione europea
' legge le partite iva da un foglio excel.
' scrive se la parita iva è presente nel vies.
' la macro è settata per la ricerca della partite iva italiane.
'
Dim esitovies
Dim mcodicehtml
Public Const partitaivadelrichiedente = "00000000000" ' partita iva del richiedente
'
Sub VatNumberGiriAblocchi()
Dim quanterighe, contarighe, foglio, contenuto, colonnapartitaiva, stxt, contali, sverifica
Dim colonnaesito
Dim nblocco
Set foglio = Sheets(ActiveSheet.Name)
'
quanterighe = Range(foglio.UsedRange.Cells(foglio.UsedRange.Rows.Count, 1).Address).Row

colonnapartitaiva = "A"   ' colonna in cui è presente la partita iva del cliente
colonnaesito = "K"        ' colonna dove scrivere l'esito della ricerca.
'
contali = 1
nblocco = 10 ' 150    ' numero di partite iva da verificare.
'contarighe = 2
contarighe = ActiveCell.Row      ' inizia il controllo dalla cella attiva.
'
While contarighe <= quanterighe
      contenuto = Trim(foglio.Cells(contarighe, colonnapartitaiva).Value)
      sverifica = Trim(foglio.Cells(contarighe, colonnaesito).Value)
      If Len(contenuto) = 11 And Len(sverifica) = 0 Then
         foglio.Cells(contarighe, colonnapartitaiva).Activate
         '
         Call CercaPartitaVatNumber(contenuto)
'
         foglio.Cells(contarighe, colonnaesito).Value = esitovies
         '
        contali = contali + 1
         '
         Application.Wait DateAdd("s", 15, Now) ' attendi 15 secondi
         If contali >= nblocco Then
            Exit Sub                    ' esce dalla macro al raggiungimento del numero prefissato di ricerche.
         End If
      End If
      contarighe = contarighe + 1       ' incrementa il numnero delle righe
Wend
'
End Sub
'
'
'
Sub CercaPartitaVatNumber(passapiva)
    Dim i As Long
    Dim IE As Object
    Dim objElement As Object
    Dim objCollection As Object
    Dim HTMLDOC, htmlcodice, htmltesto, stxt
 
    'crea oggetto InternetExplorer
    Set IE = CreateObject("InternetExplorer.Application")
 
    '
    IE.Visible = False
 
    ' url della pagina in cui inserire i dati per la ricerca
    IE.Navigate "http://ec.europa.eu/taxation_customs/vies/vatRequest.html"
 
    ' Statusbar
    Application.StatusBar = "in attesa di connessione. Attendere..."
 
    ' attendi un secondo fino alla lettura completa di IE.
    Do While IE.Busy
        Application.Wait DateAdd("s", 1, Now)
    Loop
 '
 '
    ' cerca 2 tags input:
    '   1. Text field
    '   <input type="text" class="textfield" name="s" size="24" value="" />
    '
    '   2. Button
    '   <input type="submit" class="button" value="" />
   
    Application.StatusBar = "cerca casella di input dei valori. Attendere..."
 
    Set objCollection = IE.document.getElementsByTagName("input")
 
    i = 0
    While i < objCollection.Length
        If objCollection(i).ID = "requesterNumber" Then        ' partita iva del richiedente
           objCollection(i).Value = partitaivadelrichiedente
        End If
 '
      
        If objCollection(i).ID = "number" Then
        'If objCollection(i).Name = "piva" Then
            ' inserisce la partita iva da verificare.
            objCollection(i).Value = passapiva
 
        Else
            If objCollection(i).Type = "submit" And _
                objCollection(i).Value = "Verificare" Then
              ' objCollection(i).ID = "vies_formfcs" Then
              ' objCollection(i).Name = "" Then
 '
  '              ' memorizza il pulsante cerca
              Set objElement = objCollection(i)
 '
        End If
        End If
        i = i + 1
    Wend
   
    '
    Dim e, e2
    Set e = IE.document.getElementById("countryCombobox")
    e.SelectedIndex = 17        ' stato IT = italia
    Set e2 = IE.document.getElementById("requesterCountryCombobox")
    e2.SelectedIndex = 18       ' stato IT = italia
    '
    objElement.Click    ' click bottone avvio ricerca
    '
    ' attende aggiornamento di IE.
    Do While IE.Busy
        Application.Wait DateAdd("s", 1, Now)
    Loop
 
    ' IE visibile
    IE.Visible = True
 '
    Set HTMLDOC = IE.document
    'MsgBox HTMLDOC.body.innerText
    htmlcodice = HTMLDOC.body.innerhtml
    htmltesto = HTMLDOC.body.innerText
    mcodicehtml = HTMLDOC.body.innerhtml
    'stxt = WriteLineToFile(htmlcodice & vbCrLf & htmltesto)
    'stxt = WriteLineToFile(trovaesito(htmlcodice))
    Application.Wait DateAdd("s", 5, Now)
    IE.Quit
 
 '  numero di partita IVA verifica se trovato
    stxt = trovaesitovies(mcodicehtml)
 
 
    ' chiude
    Set IE = Nothing
    Set objElement = Nothing
    Set objCollection = Nothing
'
    Application.StatusBar = ""
'
End Sub
'
'
'
Function trovaesitovies(ptesto)
'<p class="vies_ok">CODICE IVA VALIDO</p>
Dim objre
Set objre = CreateObject("vbscript.regexp")

With objre
    .Pattern = "partita IVA valida"
    .IgnoreCase = True
    .Global = False
End With
' Test se partita iva trovata.
If objre.Test(ptesto) Then
    trovaesitovies = "vies_ok"
Else
    trovaesitovies = "non_trovato"
End If
'
esitovies = trovaesitovies
'
Set objre = Nothing
'
End Function
'
'
'

vbs gestione intervalli data per sql

'
option explicit
'
' vbs - gestire la data attuale, scrive data in formato ansi.
' riceve come input la cartella su cui scrivere i files con le date richieste.
'
dim objArgs, Title
Set objArgs = WScript.Arguments  'Controlla se esistono argomenti passati allo script
if objargs.count=0 then  'altrimenti visualizzo come si usa il programma
 msgbox "Trascinare un file sul programma per visualizzarlo", vbinformation+vbokonly, Title
 wscript.quit
end if
'
dim cartella
'
cartella = wscript.arguments(0)
'
dim dblog, slog, jarchivio
'
dim oggi
dim datasqlcorrente, datarichiesta, datasqlrichiesta

oggi = date
'
datasqlcorrente = fdatasql(oggi)
datarichiesta = fdatarichiesta(oggi)
'
datasqlrichiesta = fdatasql(datarichiesta)
'
dblog = cartella & "db-j-data-corrente.txt"
slog = oggi
call SovraScriviFile(dblog, slog)
'
dblog = cartella & "db-j-data-sql-corrente.txt"
slog = datasqlcorrente
call SovraScriviFile(dblog, slog)
'
dblog = cartella & "db-j-data-sql-richiesta.txt"
slog = datasqlrichiesta
call SovraScriviFile(dblog, slog)
'
'
' =========
'
function fdatarichiesta(pdata)
'
' legge di quanti giorni si vuole variare la data. per data passata inserire il numero in negativo. esempio -15
jarchivio = cartella & "db-j-data-varia-piu-o-meno-giorni.txt"
dim variadigioni

variadigioni = leggituttopulisci(jarchivio)
fdatarichiesta = dateadd("d", variadigioni, pdata)
end function
'
'
'
function fdatasql(pdata)
' genera la data nel formato: anno-mese-giorno. il 31/12/2099 diventa 2099-12-31
dim anno, mese, giorno, sdataj
anno = year(pdata)
sdataj = "00" & month(pdata)
mese = right(sdataj, 2)
sdataj = "00" & day(pdata)
giorno = right(sdataj, 2)
'
fdatasql = anno & "-" & mese & "-" & giorno
'
end function
'
' ============
'
function leggituttopulisci(pfiledaleggere)
'
dim contenutoletto
dim objFSO, objFile
Set objFSO = CreateObject("Scripting.FileSystemObject")
If objFSO.FileExists(pfiledaleggere) = true  Then
    'esistefile = "si"
    Set objFile = objFSO.OpenTextFile(pfiledaleggere, 1)
    contenutoletto = objFile.Readall
    objFile.Close
Else
    'esistefile = "no"
    contenutoletto = "0"
    call SovraScriviFile(pfiledaleggere, contenutoletto)
End If
'
contenutoletto = replace(contenutoletto, vbcrlf, "")
contenutoletto = replace(contenutoletto, vbcr, "")
contenutoletto = replace(contenutoletto, vblf, "")
'
leggituttopulisci = 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
'
' =======

controlla presenza nuovi dati - vbs

'
'
option explicit
'
dim cartellaprocedura, cartellalavoro, dbstringhesql, contenutostringhe, cartellaprg
'
dim daticorrenti, datiprima, nomereportcorrente, fileflag
dim prgreport, prgemail, prgcompara, prgcontatore, cazione
dim rsj, estratti
dim dizionario
Set dizionario = CreateObject("Scripting.Dictionary")
dizionario.CompareMode = vbTextCompare
'
' ===================
cartellaprocedura = "\\azioniprogrammate\dichiarazioni-intento\"
' ======================
cartellalavoro = cartellaprocedura
cartellaprg = cartellaprocedura
'
nomereportcorrente = "rep-dati-correnti.html"
daticorrenti = cartellalavoro & nomereportcorrente
datiprima = cartellalavoro & "rep-dati-prima.html"
fileflag = cartellalavoro  & "solo-nel-file-" & nomereportcorrente
'
dbstringhesql = cartellaprocedura & "db-stringhe-sql.txt"
'
'
prgreport = "\\azioniprogrammate\modelli\jolly-esegui-sql-scrivi-report.vbs"
prgcompara = "\\azioniprogrammate\modelli\comparazione-due-file.vbs"
prgemail = "\\azioniprogrammate\modelli\prg-report-email\prg-db-email-corpo-invia-email-html.vbs"
prgcontatore = "\\azioniprogrammate\modelli\gestione-contatore.vbs"
'
'
call verificasecrearefile(daticorrenti)
call verificasecrearefile(datiprima)
'
call elencafiledb(dbstringhesql, "cancella") ' cancella file precedenti
'
call leggistringhesql(dbstringhesql)
'
call elencafiledb(dbstringhesql, "carica")
'
call scrividizionario(daticorrenti)
'
cazione = ""
cazione = cazione & prgcompara & " "
cazione = cazione & daticorrenti & " "
cazione = cazione & datiprima & " "
'
call chiamaprogramma(cazione)
'
call uniscifile(daticorrenti, datiprima)
'
' decidi di inviare email
call decidiinvioemail(fileflag)
' cancella i dati precedenti
call cancellafile(datiprima)
' copia il report attuale come precedente
call copiaFile(daticorrenti, datiprima)
'
' =====
'
sub decidiinvioemail(pfile)
'
dim fs
set fs=CreateObject("Scripting.FileSystemObject")
if fs.FileExists(pfile) = true then
   ' esiste
   cazione = prgcontatore & " " & cartellaprg & " db-email-oggetto-modello.txt db-email-oggetto.txt "
   call chiamaprogramma(cazione)
   '
   cazione = prgemail & " " & cartellaprg
   call chiamaprogramma(cazione)
else
  ' non esiste
end if
'
set fs=nothing
'
end sub
'
' ===========
'
sub uniscifile(parchivio1, parchivio2)
dim dbemailcorpo, contenuto1, contenuto2, shtml
dbemailcorpo = cartellaprg & "db-email-corpo.txt"
'
contenuto1 = leggifiletutto(parchivio1, "niente")
'
contenuto2 = leggifiletutto(parchivio2, "niente")
'
'
shtml = ""
shtml = shtml & "<TABLE>"
shtml = shtml & "<TR><TD>variazioni:  " & date & " - " & time & "</TD></TR>"
shtml = shtml & "<TR><TD>situazione attuale:</TD></TR>"
shtml = shtml & "<TR><TD>" & contenuto1 & "</TD></TR>"
shtml = shtml & "<TR><TD>situazione precedente:</TD></TR>"
shtml = shtml & "<TR><TD>" & contenuto2 & "</TD></TR>"
shtml = shtml & "</TABLE>"
'
'
call SovraScriviFile(dbemailcorpo, shtml)
'
end sub
'
' =========
'
sub elencafiledb(pfiledaleggere, pazione)
dim html, trovato, contali
html = leggifiletutto(pfiledaleggere, "togli")
'
dim righe, sriga, riga, valori, matches, match, tableText
'
dim sdata, svalore
'
Set righe=GetMatch(html,"<TR[^>]*>([\S\s]*?)</TR>")
'
contali = 0
For Each sriga In righe
    riga = Trim(sriga.value)
    set valori = GetMatch(riga,"<TD[^>]*>([\S\s]*?)</TD>")
    If valori.count <> 0 Then
       sdata = valori.Item(0).value
       svalore = trim(StripHTML(valori.Item(1).value))
       contali = contali +1
'
       if pazione = "cancella" then
          call cancellafile(svalore)
       end if
'
       if pazione = "carica"  then
          if contali = 1 then
             call CreaDizionarioBase(svalore, "no")
          else
             call leggiNelDizionario(svalore, "si")
          end if
       end if
'
    End If
'
'
Next
'
end sub
'
' =======
'
Sub chiamaprogramma(ppassato)
Dim objShell, attesa, azione
Set objShell = Wscript.CreateObject("WScript.Shell")
'
azione = ppassato
'
attesa = objShell.Run(azione, 1, true)
'
end sub
'
' =======================
'
sub verificasecrearefile(pfile)
dim fs
set fs=CreateObject("Scripting.FileSystemObject")
if fs.FileExists(pfile) = true then
   ' esiste
else
  ' non esiste
   call SovraScriviFile(pfile, " ")
end if
set fs=nothing
end sub
'
' ==============
'
sub scrividizionario(pfiledascrivere)
dim a, chiave, valore, stesto, i
'
stesto = ""
stesto = stesto & "<TABLE BORDER='1'>" & vbcrlf
stesto = stesto & "<TR>"
stesto = stesto & "<TD>codice</TD>"
stesto = stesto & "<TD>fatt.immediate da contabilizzare</TD>"
stesto = stesto & "<TD>ddt da fatturare</TD>"
stesto = stesto & "<TD>totale vendite</TD>"
stesto = stesto & "<TD>imporo acquistabile</TD>"
stesto = stesto & "<TD>cliente</TD>"
'
stesto = stesto & "<TR>" 
'
call SovraScriviFile(pfiledascrivere, stesto)
'
a=dizionario.Keys
for i=0 to dizionario.Count-1
   chiave = a(i)
   valore = dizionario.item(chiave)
   stesto = "<TR>" & chiave & valore & "</TR>"
   call ScriviFileJollyAppend(pfiledascrivere, stesto)
next
'
stesto =  "</TABLE>"
call ScriviFileJollyAppend(pfiledascrivere, stesto)
'
end sub
'
' =======
'
sub copiaFile(ifile, ofile)
Dim objFSO
Set objFSO = CreateObject("Scripting.FileSystemObject")

objFSO.CopyFile ifile,  ofile

Set objFSO = Nothing
end sub
'
' ========================
'
sub cancellafile(pfilepassato)
dim fs
Set fs=CreateObject("Scripting.FileSystemObject")
if fs.FileExists(pfilepassato) then
   fs.DeleteFile(pfilepassato)
end if
set fs=nothing
end sub
'
' =======================
'
sub CreaDizionarioBase(pfiledaleggere, xenumero)
dim html, trovato
html = leggifiletutto(pfiledaleggere, "togli")
'
dim righe, sriga, riga, valori, matches, match, tableText
'
dim sdata, svalore
'
Set righe=GetMatch(html,"<TR[^>]*>([\S\s]*?)</TR>")
'
For Each sriga In righe
    riga = Trim(sriga.value)
    set valori = GetMatch(riga,"<TD[^>]*>([\S\s]*?)</TD>")
    If valori.count <> 0 Then
       sdata = valori.Item(0).value
       svalore = valori.Item(1).value
'
       if xenumero = "si" then
          svalore = "<TD  align=""right"">" & formatnumber(StripHTML(svalore)) & "</TD>"
       end if
'
       if dizionario.Exists(sdata)= true then
          '   Response.Write("Key exists.")
       else
          ' Response.Write("Key does not exist.")
          dizionario.Add sdata, svalore
      end if
    End If
'
'
Next
'
'
end sub
'
' ==========
'
Sub leggiNelDizionario(pfiledaleggere, xenumero)
dim html, trovato
html = leggifiletutto(pfiledaleggere, "togli")
'
dim ldizionario
Set ldizionario = CreateObject("Scripting.Dictionary")
ldizionario.CompareMode = vbTextCompare

dim righe, sriga, riga, valori, matches, match, tableText
'
dim sdata, svalore
'
Set righe=GetMatch(html,"<TR[^>]*>([\S\s]*?)</TR>")
'
For Each sriga In righe
    riga = Trim(sriga.value)
    set valori = GetMatch(riga,"<TD[^>]*>([\S\s]*?)</TD>")
    If valori.count <> 0 Then
       sdata = valori.Item(0).value
       svalore = valori.Item(1).value
'
       if xenumero = "si" then
          svalore = "<TD align=""right"">" & formatnumber(StripHTML(svalore)) & "</TD>"
       end if
'
       'msgbox sdata & vbcrlf & svalore
       if ldizionario.Exists(sdata)= true then
          '   Response.Write("Key exists.")
       else
          ' Response.Write("Key does not exist.")
          ldizionario.Add sdata, svalore
      end if
   End If
'
Next
'
'
dim a, i, s, v, ev, nv, ve
'
a=dizionario.Keys
for i = 0 To dizionario.Count -1
    s = a(i)
    v = dizionario.item(s)
'
    if ldizionario.exists(s) = true then
       ve = ldizionario.item(s)
       nv = ve & v
       dizionario.item(s) = nv
    else
       dizionario.item(s) = "<TD align=""right"">0</TD>" & v
    end if
'
next
'
'
end sub
'
' =================================
'
sub leggistringhesql(pfiledaleggere)
dim html, trovato
html = leggifiletutto(pfiledaleggere, "togli")
'
dim righe, sriga, riga, valori, matches, match, tableText
'
dim lstringasql, lreport
'
Set righe=GetMatch(html,"<TR[^>]*>([\S\s]*?)</TR>")
'
For Each sriga In righe
    riga = Trim(sriga.value)
    set valori = GetMatch(riga,"<TD[^>]*>([\S\s]*?)</TD>")
    If valori.count <> 0 Then
       lstringasql = StripHTML(valori.Item(0).value)
       lreport = trim(StripHTML(valori.Item(1).value))
'
'
       call recuperadatiSQLSRL(lstringasql)
       call ElencaDatiEstratti(lreport)
'
    End If
'
'
Next
'
'
end sub
'
' === estrae dati dal database ==========
'
sub recuperadatiSQLSRL(pstringasql)
dim SQLConn, conn, adoCmd, strSQL
' stringa di conn
SQLConn =  "DSN=ODBC;DSN=wwww;UID=wwww;Database=wwww"
'
set conn = createobject("ADODB.Connection")
conn.open sqlconn
'  time out
Set adoCmd = CreateObject("ADODB.Command")
adoCmd.CommandTimeout = 45
adoCmd.ActiveConnection = conn
'
strSQL = pstringasql
'
set rsj=CreateObject("ADODB.recordset")
rsj.Open strSQL, conn, 3, 3
estratti = rsj.RecordCount
'
' msgbox "estratti: " & estratti
'
end sub
'
' ===== test Elenca Dati Estratti - sql ======
'
Sub ElencaDatiEstratti(pdovescrivere)
dim rs, intestazione, nrcampi,  i, stxt, xslog
set rs = rsj
nrcampi =  RS.Fields.Count - 1
stxt = ""
stxt = stxt & "<TABLE border=1><TR>"
For i = 0 to RS.Fields.Count - 1
      stxt = stxt & "<TH>" & rs(i).Name & "</TH>"
Next
stxt = stxt & "</TR>" '& vbcrlf
xslog = stxt
call ScriviFileJollyAppend(pdovescrivere, xslog)
'
Do until rs.Eof
   '
      stxt = ""
      stxt = stxt & "<TR>" ' & vbcrlf
      For i = 0 to RS.Fields.Count - 1
         stxt = stxt &  "<TD>" &  rs(i).Value  & "</TD>"
      Next
      stxt = stxt & "</TR>" '& vbcrlf 
      xslog = stxt
      call ScriviFileJollyAppend(pdovescrivere, xslog)

'
   rs.MoveNext
Loop
'
xslog = "</TABLE>" & vbcrlf 
call ScriviFileJollyAppend(pdovescrivere, xslog)
'
End Sub
'
' =================
'
Function StripHTML(cell)  
Dim RegEx 'As Object 
Set RegEx = CreateObject("vbscript.regexp") 
Dim sInput 'As String 
Dim sOut 'As String 
sInput = cell 
'  
With RegEx 
   .Global = True 
   .IgnoreCase = True 
   .MultiLine = True 
   .Pattern = "<[^>]+>" 'Regular Expression for HTML Tags. 
End With 
 
sOut = RegEx.Replace(sInput, "") 
StripHTML = sOut 
Set RegEx = Nothing 
'
End Function 
'
' === leggi stringa sql ===================
'
function leggifiletutto(sFilePathAndName, pazione)
dim contenutoletto
dim sFileContents, oFS, oTextStream
Set oFS = CreateObject("Scripting.FileSystemObject")
If oFS.FileExists(sFilePathAndName) = True Then
     Set oTextStream = oFS.OpenTextFile(sFilePathAndName,1)
     sFileContents = oTextStream.ReadAll
     oTextStream.Close
     Set oTextStream = nothing
else
    ' msgbox "non trovato: " & sFilePathAndName
End if
Set oFS = nothing
contenutoletto = sFileContents
if pazione = "togli" then
   contenutoletto = replace(contenutoletto, vbcrlf, " ")
   contenutoletto = replace(contenutoletto, vbcr, " ")
   contenutoletto = replace(contenutoletto, vblf, " ")
end if
'
leggifiletutto = contenutoletto
'
end function
'
' ====
'
Function GetMatch(strString,strPattern)
    Dim RegEx, arrMatches, colMatches
    Set RegEx = CreateObject("VBScript.RegExp")          
    RegEx.IgnoreCase = True            
    RegEx.Global=True                  
    RegEx.Pattern=strPattern
    Set colMatches=RegEx.Execute(strString)
    Set GetMatch=colMatches
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
'
' ===== Scrivi file Jolly Append ==========
'
Sub ScriviFileJollyAppend(NomeArchivio, cosascrivere)
'
'
dim fso,  rifefile
Set fso=CreateObject("Scripting.FileSystemObject")
If (fso.FileExists(NomeArchivio)) Then
      'msg = filespec & " exists."
       Set rifefile = fso.OpenTextFile(NomeArchivio, 8)
   Else
      'msg = filespec & " doesn't exist."
       Set rifefile = fso.CreateTextFile(NomeArchivio, TRUE)
   End If
rifefile.WriteLine(cosascrivere)
rifefile.Close
set rifefile = Nothing
End Sub
'
' ====================
'