Crea catalogo jpg to pdf

Attribute VB_Name = "m_crea_catalogo_jpg_to_pdf"

'

'

Option Explicit

'

' vba - crea file Pdf da un elenco di immagini jpg.

' utilizza la classe: "mjwPDF"

'

' riferimenti classe:

' Creating PDF files in Visual Basic

' "mjwPDF 1.0"

' classe scaricabile dal sito:

' http://www.vb6.us/tutorials/visual-basic-tutorial-pdf

'

Sub CatalogoImmaginiPdf()

'

Dim immagine

Dim foglio, quanterighe, conta, quantejpg, contajpg, filejpg As String, titolodocumento

Dim percorsodocumentodacreare, percorsopdffonts, percorsojpg, txtlink

Set foglio = Sheets("db")

quanterighe = foglio.UsedRange.Rows.Count

quantejpg = 10

'

titolodocumento = "documento di prova pdf"

txtlink = "http:// il vostro sito da dichiare"

percorsodocumentodacreare = "C:\catalogo-jpg.pdf"

percorsopdffonts = "C:\pdfFonts"

percorsojpg = "c:\jpg\"

' Create a simple PDF file using the mjwPDF class

Dim objPDF As New mjwPDF



' Set the PDF title and filename

objPDF.PDFTitle = titolodocumento

objPDF.PDFFileName = percorsodocumentodacreare



' We must tell the class where the PDF fonts are located

objPDF.PDFLoadAfm = percorsopdffonts



' Set the file properties

objPDF.PDFSetLayoutMode = LAYOUT_DEFAULT

objPDF.PDFFormatPage = FORMAT_A4

objPDF.PDFOrientation = ORIENT_PORTRAIT

objPDF.PDFSetUnit = UNIT_PT



' Lets us set see the bookmark pane when we view the PDF

objPDF.PDFUseOutlines = True

'

' Begin our PDF document

objPDF.PDFBeginDoc

' Lets add a heading

objPDF.PDFSetFont FONT_ARIAL, 12, FONT_BOLD

objPDF.PDFSetDrawColor = vbRed

objPDF.PDFSetTextColor = vbBlack

'objPDF.PDFSetAlignement = ALIGN_Right

objPDF.PDFSetAlignement = ALIGN_Left

objPDF.PDFSetBorder = BORDER_None

'objPDF.PDFSetFill = True

''''

Dim jpgdasinistra As Double, jpgdallalto As Double, jpgaltezza As Double, jpglunghezza As Double

jpgdasinistra = 20

jpgdallalto = 15

jpgaltezza = 50

jpglunghezza = 50

'

contajpg = 0

For conta = 2 To quanterighe

immagine = foglio.Cells(conta, 2)

filejpg = percorsojpg & immagine

'

If Len(immagine) = 0 Then

immagine = "nd.jpg"

End If

'

'Lets add an image to page

objPDF.PDFImage filejpg, jpgdasinistra, jpgdallalto, jpglunghezza, jpgaltezza, CStr(txtlink)

jpgdallalto = jpgdallalto + jpgaltezza + 10

'

contajpg = contajpg + 1

If contajpg > quantejpg Then

contajpg = 0

jpgdallalto = 15

objPDF.PDFEndPage

'Start page

objPDF.PDFNewPage

End If

Next conta

'

' End our PDF document (this will save it to the filename)

objPDF.PDFEndDoc

'

MsgBox "catalogo creato in: " & percorsodocumentodacreare

'

End Sub

dividi articoli - vbs

' *****

' esempio file di origine:

'AAA418|PLAFON. CABL 4X18 W|NR|22|0|0|0|0|00|0|0|160|11/05/2011|1446|AAA|AAA|0000000000000

'BBB00050|SCATOLA CONICA D.65|NR|22|0|0|0|0|0|0|0|204|16/09/2013|00050|BBB|BBB|0000000000000

'************************************************

' vbs - divide un file di testo in più file.

' utilizza i primi tre caratteri di ogni riga per determinare il nome del file di output

'************************************************

option explicit

'

' ForAppending = 8 ForReading = 1, ForWriting = 2

Const ForAppending = 8

'

Dim fso, farticoli, datiletti, iniziali, contenuti

dim marchivio, s, archiviodef, archivioorigine, archiviolog, archivioelenco, cartelladiscrittura, log, elencof

' ==== path dei file utilizzati

' === archivio di default per le iniziali non dichiarate

archiviodef = "C:\listino-personalizzato\articolialtri.txt"

' === file contenente gli articoli da suddividere

archivioorigine = "C:\listino-personalizzato\articoli.txt"

' file di log - copia del file di origine

archiviolog = "C:\listino-personalizzato\log.txt"

' elenco dei file creati

archivioelenco = "C:\listino-personalizzato\da-bus\elencofile.txt"

'

cartelladiscrittura = "C:\listino-personalizzato\"

' ====

'

Set fso = CreateObject("Scripting.FileSystemObject")

'file contenente gli articoli da suddividere

Set farticoli = fso.OpenTextFile(archivioorigine) ' Apre file di testo.

' file di log - copia del file di origine

Set log = fso.OpenTextFile(archiviolog, 2, True)

' elenco dei file creati

Set elencof = fso.OpenTextFile(archivioelenco, 2, True)

'

Do While Not (farticoli.atEndOfStream)

datiletti = farticoli.ReadLine 'legge una riga

if len(datiletti) => 3 then

iniziali = left(datiletti,3)

log.writeline(datiletti)

call scrivifile(iniziali,datiletti)

else

log.writeline(datiletti)

call scrivifile("articolivari",datiletti)

end if

Loop

'

sub scrivifile(piniziali,pdatiletti)

dim afso, archivio, fscrivo, presente

Set afso = CreateObject("Scripting.FileSystemObject")

'

archivio = cartelladiscrittura & piniziali & ".txt"

presente = instr(piniziali,"|")

if presente > 0 then

archivio = archiviodef

end if

'

marchivio = archivio

Select Case piniziali

' per queste iniziali viene creato un file specifico

Case "ABB", "ARC", "ARE", "ALL"

CASE "BER", "BOC", "TIC", "L&L"

CASE "CAM", "COM", "AIR", "GUZ"

CASE "CEM", "COE", "CAV", "MRT"

CASE "SUR", "GEW", "MTT", "TIC", "NMZ"

CASE "PLE", "VIW", "PRI", "TAR", "PAL"

CASE "TRE", "NOX", "ETN", "SIL", "VIM"

CASE "LEO", "TEN", "FRA", "SIM", "MAR"

CASE "OMR", "ELV", "FAI", "LOM", "URM"

CASE "PRO", "OTY", "SID", "IVE", "LUM"

CASE "EGO", "LPU", "VIP", "TUT", "VAL"

CASE "PRA", "LT3", "CST", "MCI", "IDL", "NAT"

CASE "LUC", "FOS", "ZUC", "VOR", "OSR", "GMB"

CASE "OVA", "PHI", "MEG", "INT", "REG", "SIS"

'

Case Else

archivio = archiviodef

End Select

'

If afso.FileExists(archivio) = true Then

Set fscrivo = afso.OpenTextFile(archivio, ForAppending, True) ' Apre file di testo.

else

Set fscrivo = afso.OpenTextFile(archivio, 2, True)

fscrivo.WriteLine("SG|TX|AR_UNMIS|AR_CODIVA|PREZZO1|PREZZO2|listino|prezzo|sconto1|sconto2|sconto3|L_AV_CLASS|aggiornato|ar_codalt|siglacaem|siglametel|ean13")

'

s = " File """ & archivio & """"

elencof.WriteLine(s)

end if

'

fscrivo.WriteLine(pdatiletti)

fscrivo.Close

'

set afso = nothing

end sub

'

'

' ===

sconponi split pdf - vbs

'

' drag e drop

'

' estre e crea un file pdf per ogni pagina di un documento.

' utilizza Pdf Split and Merge

' scaricabile da: http://sourceforge.net/projects/pdfsam/

'

Option Explicit

'

dim objArgs, I

'

Set objArgs = WScript.Arguments 'Verifica esistenza presenza argomenti passati allo script

if objargs.count=0 then ' conteggio elementi

msgbox "Trascinare un file sul programma per visualizzarlo", vbinformation+vbokonly, Title

wscript.quit

end if

'

dim archivio, objFile, esegui, programma, attesa

Dim strTmp, objShell

'

set objShell = WScript.CreateObject("Wscript.Shell")

'

For I = 0 to objArgs.Count - 1

archivio = objArgs(I)

strTmp = "java -jar C:\Programmi\pdfsam\lib\pdfsam-console-0.5.2.jar -f " & archivio & " -p pdfsam_ -s BURST -o C:\provep\s2 split"

attesa = objShell.Run (strTmp, 1, True)

Next

'

Set objShell = Nothing '

' *****

Ghostscript pdf to jpg - vbs

'

' vbs - Ghostscript pdf to jpg

' converte tutti i file in formato pdf in immagini jpg.

' collocare il programmino nella directory interessata e cliccateci sopra.

' utilizza per la conversione Ghostscript.

' la risoluzione immagige è 600 px: azione = azione & " -r600 "

Option explicit

'

Dim file ' il file da convertire

Dim folder ' la directory corrente

Dim fso ' file system object

dim percorso, azione

dim archivio, archiviojpg, archiviopdf

dim tipo

dim esegui

Set Esegui = CreateObject("WScript.Shell")

'

' Creo il FileSystemObject

Set fso=CreateObject("Scripting.FileSystemObject")

'

' recupero la directory corrente

Set folder=fso.GetFolder(".")

'

' scorro tutti i file corrispondenti

For Each file in folder.Files

' msgbox file.Name

archivio = file.Name

if Len(archivio) > 5 then

tipo = Right(LCase(archivio),4)

if tipo = ".pdf" or tipo = ".PDF" then

percorso = folder & "\" & file.name

archiviopdf = file.name

' msgbox archiviopdf

archiviojpg = LEFT(archiviopdf,LEN(ARCHIVIOPDF)-3)

archiviojpg = archiviojpg & "jpg" ' 32

azione = ""

' path dipendente dalla versione di Ghoscript installata

' azione = azione & ""C:\Program Files (x86)\gs\gs9.07\bin\gswin32"" -dNOPAUSE -sDEVICE=jpeg "

azione = azione & "C:\Programmi\gs\gs8.64\bin\gswin32 -dNOPAUSE -sDEVICE=jpeg "

azione = azione & " -r600 "

azione = azione & " -sOutputFile=" & archiviojpg

azione = azione & " -dBATCH " & archiviopdf

'

Esegui.Run azione, 2, true

'

end if

end if

'

Next

'

'

'msgbox "finito"

'

'*********************************************************

legge un file listino Metel ed estrae in un file di testo solo articoli inseriti bel file trova

'

' vbs - legge un file Metel ed estrae, in un file di testo, solo

' gli articoli inseriti nel file trova.txt

' esempio struttura file trova.txt:

' 4878

' 4881

' 54776

' 50264

'

option explicit

'

Const ForReading = 1 'Apre un file in lettura.

dim filelistinometel, filerisultato, filericercati, dovescrivere, messaggio

Dim fso, ftrovati, fleggi, articolodatrovare, memorizzati(), contali, quanti, conta

Set fso = CreateObject("Scripting.FileSystemObject")

' === nome dei file da utilzzare

filelistinometel = "C:\LISTINOLSP.TXT" ' file listino metel

filericercati = "C:\trova.txt" ' file contenenti articoli da trovare

filerisultato = "C:\ttrovati.txt" ' file articoli corrispondenti

'

messaggio = ""

messaggio = messaggio & time & vbcrlf

'

'

Set dovescrivere = fso.CreateTextFile(filerisultato)

Set fleggi = fso.OpenTextFile(filericercati, ForReading, False)

'

' === carica in memoria il listino metel

quanti = 0

call Caricafile(filelistinometel)

'

' === per recuperare la testata del listino

call ricercadatato("METEL")

'

' === legge in memoria tutto il file

Do While fleggi.AtEndOfStream <> True

articolodatrovare = fleggi.ReadLine

call ricercadatato(articolodatrovare)

Loop

'

'

dovescrivere.close

fleggi.close

'

messaggio = messaggio & time & vbcrlf & "nr. articoli: " & quanti

msgbox messaggio

' ===

sub ricercadatato(articoloricercato)

Dim articolo, strdata, lunghezzaarticolo

lunghezzaarticolo = 19

for conta = 1 to quanti

strdata = memorizzati(conta)

articolo = left(strdata,lunghezzaarticolo)

if instr(articolo, articoloricercato) then

dovescrivere.WriteLine strdata

End If

next

'

end sub

' === memorizza in una array tutti gli articoli

Sub Caricafile(sFileName)

Dim fp, rigaletta

Set fp = fso.OpenTextFile( sFileName, ForReading, False)

Do While fp.AtEndOfStream <> True

rigaletta = fp.ReadLine

quanti = quanti + 1

redim preserve memorizzati(quanti)

memorizzati(quanti) = rigaletta

Loop

fp.Close

End Sub

'

'

vbs suddividi file - vbs

'

' vbs - suddivide un file Metel di grandi dimensioni

' in file da 60.000 righe

'

option explicit

'

dim filelistinometel

filelistinometel = "C:\LISTINOLSP.TXT"

'

Const ForReading = 1 'Apre un file in lettura.

Dim fso, fileinlettura, rigaletta, contarighe, testata, fileinscrittura, contafile

Set fso = CreateObject("Scripting.FileSystemObject")

Set fileinlettura = fso.OpenTextFile(filelistinometel, ForReading, False)

'

contarighe = 0

contafile = 0

Do While fileinlettura.AtEndOfStream <> True

rigaletta = fileinlettura.ReadLine

contarighe = contarighe + 1

if contarighe = 1 then

testata = rigaletta

contafile = contafile + 1

call creafiledascrivere(testata)

else

fileinscrittura.WriteLine rigaletta

end if

if contarighe > 60000 then

fileinscrittura.Close

contafile = contafile + 1

contarighe = 2

call creafiledascrivere(testata)

end if

Loop

fileinlettura.Close

fileinscrittura.Close

'

sub creafiledascrivere(contenuto)

dim nomefilescrittura

nomefilescrittura = "C:\list-" & contafile & ".txt"

Set fileinscrittura = fso.CreateTextFile(nomefilescrittura)

fileinscrittura.WriteLine contenuto

end sub

'

' ===

m ricostruzione articolo

Attribute VB_Name = "m_ricostruzione_articolo"

'

Option Explicit

'

'

Dim restituito

'

' vba === ricostruzione articolo originario

' per abbinamento

' articolo cliente: EA0115

' articolo fornitore: EA 011 5

'

Sub ScansionaArticoli()

Dim quanterighe, contarighe, foglio, colonnadaleggere, contenuto

Set foglio = Sheets(ActiveSheet.Name)

'

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

contarighe = 2

colonnadaleggere = "k"

'

While contarighe < quanterighe

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

If Len(contenuto) = 6 Then

Call aritcoloanalizza(contenuto, "(\S)", 6)

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

End If

contarighe = contarighe + 1

Wend

'

'

End Sub

'

Sub aritcoloanalizza(contenuto, cosatrovare, lunghezzarichiesta)

Dim oggRegEx, myMatches, myMatch

Set oggRegEx = CreateObject("VBScript.RegExp")

'

oggRegEx.Global = True

oggRegEx.Pattern = cosatrovare

Set myMatches = oggRegEx.Execute(contenuto)

'

If myMatches.Count = lunghezzarichiesta Then

restituito = ""

restituito = restituito & myMatches(0).Value

restituito = restituito & myMatches(1).Value

restituito = restituito & " "

restituito = restituito & myMatches(2).Value

restituito = restituito & myMatches(3).Value

restituito = restituito & myMatches(4).Value

restituito = restituito & " "

restituito = restituito & myMatches(5).Value

End If

'

'

End Sub

crea file cartella temporanea - vbs

'

' vbs.

' Crea nome di un file temporaneo.

' visualizza il percorsso della cartella temp.

' visualizza il percorso/path del file temporaneo.

'

Option Explicit

'

Dim strTempFile

Dim strTempFolder

Dim strTemp

dim tipofile

tipofile = ".fdf"



Dim fso

Set fso = CreateObject("Scripting.FileSystemObject")

Set strTempfolder = fso.GetSpecialFolder(2)

strTempFile = fso.GetTempName()

strTempFile = left(strTempFile, len(strTempFile)-4)

strTemp = strTempFolder & "\" & strTempFile & tipofile



dim s

s = ""



s = s & "Nome File Temporaneo: " & strTempFile & vbcrlf

s = s & "Nome Cartella Temporanea: " & strTempFolder & vbcrlf

s = s & "Percorso/Path file temporaneo: " & strTemp & vbcrlf



msgbox s

vbs inserisce in range excel usando sql

'

' vbs. Inserisce in range Excel usando istruzione sql

' il dato viene accodato ad un Range creato con inserisci nome.

' Se si selezionane tutte le colonne verrà generato l'errore di foglio pieno.

' Il foglio deve contenere le intestazioni, servono come nome campo.

'

'

option explicit

'

dim objConn, objRS, SQL, riferimentodb

riferimentodb = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=c:\articoli.xls" & ";Extended Properties=Excel 8.0;"

'

Set objConn = CreateObject("ADODB.Connection")

objConn.Open riferimentodb



Set objRS = CreateObject("ADODB.Recordset")



' stringa sql



SQL = "INSERT INTO articoli (articolo, descrizione) VALUES ('BVIM8000', 'INTERRUTTORE 1P 10AX')"



objRS.Open SQL, objConn

'

vbs crea excel tramite tabella html - vbs

'

' vbs

' crea un file Excel

' utilizzando il codice html per una tabella.

'

option explicit

'

dim fs, filetxt

dim testo, contarighe



Set fs = CreateObject("Scripting.FileSystemObject")

Set filetxt = fs.CreateTextFile("c:\excel-test.xls", True)

testo ="<TABLE>"

filetxt.WriteLine(testo)

'

for contarighe = 1 to 15 step 1

testo = ""

' inizio riga

testo = testo & "<TR>"

' prima colonna - colonna A

testo = testo & "<td>" & contarighe & "</td>"

' seconda colonna - colonna B

testo = testo & "<td>" & (contarighe*2) & "</td>"

' fine riga

testo = testo & "</TR>"

filetxt.WriteLine(testo)

next

'

testo = ""

'inserisce formula Somma

testo = testo & "<TR>" ' inizio riga

testo = testo & "<td width=40><b>=sum(A1:A15)</b></td>"

testo = testo & "<td width=40><b>=sum(B1:B15)</b></td>"

testo = testo & "</TR>"

testo = testo & "</table>"

filetxt.WriteLine(testo)



filetxt.Close

'

ricerca ed estrae righe da file testo - vbs

'

' vbs - ricerca ed estrae righe da un

' file di testo.

' le parole da ricercare sono contenute nel file trova.txt

'

Option explicit

'

dim filelistino, fileDaScrivere, fileRicercati, scrivitext

Const ForReading = 1 'Apre un file in lettura.

Dim fso, ftrovati, fleggi, stringaricercata, CercaNelFile

Set fso = CreateObject("Scripting.FileSystemObject")

'

filelistino = "C:\listino.txt" ' file listino

fileDaScrivere = "C:\trovati.txt" ' file con il risultato della ricerca

fileRicercati = "C:\trova.txt" ' file contente i valori da trovare

'

Set scrivitext = fso.CreateTextFile(fileDaScrivere)

Set fleggi = fso.OpenTextFile(fileRicercati, ForReading, False)

'

Call mCercaNelFile(filelistino, "xyJK") ' serve per creare una eventuale intestazione

'

Do While fleggi.AtEndOfStream <> True

stringaricercata = fleggi.ReadLine

Call mCercaNelFile(filelistino, stringaricercata)

Loop

'

scrivitext.close

fleggi.close

'---

' Cerca nel file sFileName

'---

Sub mCercaNelFile(filelistino, stringaricercata)

Dim fp, rigaletta

Set fp = fso.OpenTextFile(filelistino, ForReading, False)

'

Do While fp.AtEndOfStream <> True

rigaletta = fp.ReadLine

if instr(rigaletta, stringaricercata) then

scrivitext.WriteLine rigaletta

End If

Loop

fp.Close

'

End Sub

'---

crea foglio excel e html

'

' crea file Excel ed Html con intestazione

'

dim archivio

archivio = "articoli" & time

'

Const xlHTML = 44



Set objExcel = CreateObject("Excel.Application")

objExcel.Visible = True

Set objWorkbook = objExcel.Workbooks.Add()

Set objWorksheet = objWorkbook.Worksheets(1)



objExcel.DisplayAlerts = False



objExcel.Cells(1, 1).Value = "articolo"

objExcel.Cells(1, 2).Value = "descrizione"

objExcel.Cells(1, 3).Value = "prezzo"

objExcel.Cells(1, 4).Value = "um"



objWorkbook.SaveAs "C:\" & archivio & ".xls"

objWorkbook.SaveAs "C:\" & archivio & ".html", xlHTML

finesta a tempo

Attribute VB_Name = "finesta_a_tempo"

'

Option Explicit

'

' vba - Excel.

' Finetra Pop Up Temporanea.

' la durata è configurabile.

'

Sub FinestraPopUpTemporanea()

Dim txtmsg

Dim wshshell As Object, durata

durata = 3

'

txtmsg = ""

txtmsg = txtmsg & "il messaggio " & vbCrLf

txtmsg = txtmsg & "scomparità entro " & durata & " secondi " & vbCrLf

'

Set wshshell = CreateObject("Wscript.shell")

'

wshshell.popup txtmsg, durata, "intestazione messaggio"

'

End Sub

estrae informazione query

Attribute VB_Name = "estrae_informazione_query"

'

Option Explicit

'

' Vba - Excel

' Estrae da una query i riferimenti

' alla connessione e alla stringa sql.

'

'

Sub EstraeInformazioniDaQuery()

'

' riferiemto alla cartella attiva, al primo foglio e alla prima query.

' ThisWorkbook.Worksheets(1).QueryTables(1)

'

Dim contenuto As String

'

contenuto = ""

'

' riferimento al foglio attivo e alla prima Query

'

With ThisWorkbook.ActiveSheet.QueryTables(1)

contenuto = contenuto & "connessione: " & .Connection & vbCrLf

contenuto = contenuto & "stringa sql: " & .CommandText & vbCrLf

MsgBox contenuto

Sheets.Add

ActiveSheet.Range("B2") = "connessione:"

ActiveSheet.Range("B3") = "stringa sql:"

ActiveSheet.Range("C2") = .Connection

ActiveSheet.Range("C3") = .CommandText



End With

'

End Sub

sql cartella excel

Attribute VB_Name = "sql_cartella_excel"

'

Option Explicit

'

' vba - Excel

' carica, tramite istruzione Sql

' i dati contenuto in un altro foglio excel.

'

'

Sub CaricaDati()

Dim s As String, stringasql As String, questacartella

questacartella = "<percorso cartella excel>.xls"

'

' stringa sql

s = ""

s = s & ""

s = s & " SELECT <nome campi>,"

s = s & " FROM <nome range excel>"

s = s & " ORDER BY <nome campi>"



stringasql = s

'

Call ExcelSqlCopyrecordset(questacartella, CStr("?nomefoglio?"), stringasql)

'

End Sub

'

Sub ExcelSqlCopyrecordset(questacartella, nomefoglio As String, stringasql As String)

'

Dim ExcelConnessione, ExcelRS, s As String

Dim quanticampi, conta, nomecampo



Set ExcelConnessione = CreateObject("ADODB.Connection")

Set ExcelRS = CreateObject("ADODB.Recordset")

'

ExcelConnessione.Provider = "Microsoft.Jet.OLEDB.4.0"

ExcelConnessione.Properties("Extended Properties").Value = "Excel 8.0"

ExcelConnessione.Open questacartella

'

Set ExcelRS = ExcelConnessione.Execute(stringasql)

'

quanticampi = ExcelRS.Fields.Count - 1 ' conteggio numero campi

'

Sheets(nomefoglio).Activate

'ActiveSheet.Range("A2:Z65500").ClearContents

ActiveSheet.UsedRange.ClearContents ' pulisce tutta area utilizzata nel foglio.

'

' usa i nomi dei campi per intestazione colonne

For conta = 0 To quanticampi

nomecampo = ExcelRS(conta).Name

ActiveSheet.Cells(1, (conta + 1)) = nomecampo

Next conta

'

ActiveSheet.Range("A2").CopyFromRecordset ExcelRS

'

ExcelRS.Close

Set ExcelRS = Nothing

Set ExcelConnessione = Nothing

'

Rows("2:2").Select

ActiveWindow.FreezePanes = True

Cells.Select

Cells.EntireColumn.AutoFit

Range("A2").Select

'

End Sub

ricerca parole tag

Attribute VB_Name = "ricerca_parole_tag"

'

Option Explicit

'

' vba - Excel.

' trova parole/tag in una colonna di Excel.

' tramite espressione regolare crea

' elenco della parole presenti in una colonna.

' Evita i duplicati.

'

Sub TrovaParoleTag()

Dim quanterighe, contarighe, foglio, contenuto As String, colonnaDaLeggere, trovate As String, parole

Dim objRegEx, paroletrovate, parola

Set foglio = Sheets(ActiveSheet.Name)

Set objRegEx = CreateObject("VBScript.RegExp")

objRegEx.Global = True

'

' conteggio delle righe utilizzare

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

colonnaDaLeggere = "D" ' colonna contenete celle da leggere

'

contarighe = 1 ' parte dalla prima riga

contenuto = ""

trovate = ""

While contarighe <= quanterighe

' carica il contenuto della cella

contenuto = " " & foglio.Cells(contarighe, colonnaDaLeggere).Value & " "

'

objRegEx.Pattern = "\w+" ' ricerca parole

Set paroletrovate = objRegEx.Execute(contenuto)

'

If paroletrovate.Count > 0 Then ' conteggio delle parole trovate

For Each paroletrovate In paroletrovate

parola = paroletrovate.Value

'

objRegEx.Pattern = parola

' verifca che la parola sia memorizzata

If objRegEx.test(trovate) = False Then

trovate = trovate & " " & parola

End If

'

Next

End If

'

contarighe = contarighe + 1

foglio.Cells(contarighe, colonnaDaLeggere).Activate

Wend

'

' che nuovo foglio contenente le parole trovate

parole = Split(trovate, " ")

Dim quanteparole, contaparole

Sheets.Add

quanteparole = UBound(parole)

For contaparole = 0 To quanteparole

ActiveSheet.Cells((contaparole + 1), "A").Value = parole(contaparole)

Next contaparole

'

End Sub

'

estratto conto

Attribute VB_Name = "estratto_conto"

'

Option Explicit

'

' vba - excel

' riferimenti: Microsoft Word Object library

' estratto conto su tabella WOrd

' scorre il foglio di Excel, e anche in presenza di un cliente con pià righe concomitanti

' crea un unico documento word.

' Nel documento Word sono presenti due tabelle:

' 1 - dati clienti

' 2 - dettaglio documenti del cliente

'

Public Const modelloword = "C:\circolarizzazione_crediti\ClientiEstrattoConto.dot"

Public Const cartellasalvataggio = "C:\circolarizzazione_crediti\EC\"

'

Dim appWD As Word.Application

Dim nomedoc, tabtesta, tabdettaglio, docrighe

Dim docaperto

'

Sub vaiwordn(nomedocumento) ' crea nuovo documeto Word

Set appWD = CreateObject("Word.Application")

appWD.Visible = True

'

With appWD

.Documents.Add Template:=nomedocumento, NewTemplate:=False, DocumentType:=0

nomedoc = .ActiveDocument.Name

.Activate

End With

'

appWD.Documents(nomedoc).Activate

'

' setta il riferimento al documento

Set tabtesta = appWD.Documents(nomedoc).Tables(1) ' dati del cliente (ragione sociale, indirizzo etc.

Set tabdettaglio = appWD.Documents(nomedoc).Tables(2) ' tabella dettaglio del credito

'

docaperto = 1

'

End Sub

'

Sub salvadoc(salvaconnome) ' salva documento

'

appWD.ActiveDocument.SaveAs salvaconnome

' applicazione visibile

appWD.Visible = True

' a tutto shermo

appWD.WindowState = wdWindowStateMaximize

' attivato

appWD.Application.Activate

'

appWD.ActiveDocument.Close

appWD.Quit



Set appWD = Nothing

docaperto = 0 ' flag

End Sub

'

Sub PreparaEstrattoConto()

Dim quanterighe, contarighe, foglio, conto, contoprecedente, colonnai, docreati

Dim nomefoglio As String, riga, nomedocumento As String, salvaconnome As String, importo, totale

nomefoglio = ActiveSheet.Name

Set foglio = Sheets(ActiveSheet.Name)

'

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

nomedocumento = modelloword ' utilizza un modello di Word

colonnai = "C" ' colonna contenete il campo di controllo - tipo codice cliente/partita iva

'

contoprecedente = 0

docreati = 0

totale = 0 ' totale delle partite del cliente

importo = 0

'

contarighe = 2 ' parte dalla seconda riga del foglio

While contarighe <= quanterighe

conto = Trim(foglio.Cells(contarighe, colonnai).Value)

If Len(conto) > 0 Then ' verifica che la cella non sia vuota

If conto <> contoprecedente Then ' verifica il cambio del codice cliente/partita iva

If docreati > 0 Then ' salva il documento con il valore della cella chiave

salvaconnome = cartellasalvataggio & contoprecedente

Call salvadoc(salvaconnome)

End If

Call vaiwordn(nomedocumento)

docreati = docreati + 1

tabtesta.Cell(Row:=1, Column:=2).Range.InsertAfter Text:=foglio.Cells(contarighe, "D").Value ' ragione sociale

tabtesta.Cell(Row:=2, Column:=2).Range.InsertAfter Text:=foglio.Cells(contarighe, "R").Value ' indirizzo

tabtesta.Cell(Row:=3, Column:=2).Range.InsertAfter Text:=foglio.Cells(contarighe, "T").Value ' città

contoprecedente = conto

End If

docrighe = tabdettaglio.Rows.Count ' conteggio righe della tabella dettaglio

'

tabdettaglio.Cell(Row:=docrighe, Column:=1).Select

tabdettaglio.Rows.Add ' aggiunge righe alla tabella Word contente il dettaglio dei dati



tabdettaglio.Cell(Row:=docrighe, Column:=1).Range.InsertAfter Text:=foglio.Cells(contarighe, "B").Value ' data scadenza

tabdettaglio.Cell(Row:=docrighe, Column:=2).Range.InsertAfter Text:=foglio.Cells(contarighe, "F").Value ' causale scadenza

tabdettaglio.Cell(Row:=docrighe, Column:=3).Range.InsertAfter Text:=foglio.Cells(contarighe, "K").Value ' totale documento

tabdettaglio.Cell(Row:=docrighe, Column:=4).Range.InsertAfter Text:=foglio.Cells(contarighe, "L").Value ' importo scadenza

tabdettaglio.Cell(Row:=docrighe, Column:=5).Range.InsertAfter Text:=foglio.Cells(contarighe, "M").Value ' numero documento

tabdettaglio.Cell(Row:=docrighe, Column:=6).Range.InsertAfter Text:=foglio.Cells(contarighe, "G").Value ' serie documento

tabdettaglio.Cell(Row:=docrighe, Column:=7).Range.InsertAfter Text:=foglio.Cells(contarighe, "A").Value ' data documento

docrighe = docrighe + 1

'

End If

contarighe = contarighe + 1

Wend

'

'

If docaperto = 1 Then ' contatore di documento ancora aperto

salvaconnome = cartellasalvataggio & contoprecedente

Call salvadoc(salvaconnome)

End If

'

'Set appWD = Nothing

'appWD.ActiveDocument.Save

'appWD.Quit

'

End Sub

'

inserisci in word

Attribute VB_Name = "inserisci_in_word"

'

Option Explicit

'

' vba - Excel to Word.

' attivare strumenti/riferimenti Microsoft Word Office Library

' i nomi presenti nella prima riga del foglio servono come chiavi di ricerca in Word.

' es. A1 = "indirizzo" in Word viene ricercata la parola: "%%indirizzo%%".

' in Word la parola "%%indirizzo%%" viene sostituita con il valore contenuto nella cella attiva del foglio Excel.

' la procedura cerca di inserire i valori di tutte le colonne.

'

'

Sub usocambiainword()

Dim nomefoglio As String, riga, nomedocumento As String, salvaconnome As String

nomefoglio = CStr(ActiveSheet.Name)

riga = ActiveCell.Row

nomedocumento = CStr("C:\dato.doc")

salvaconnome = CStr("C:\datosalvato.doc")

Call cambiainword(nomefoglio, riga, nomedocumento, salvaconnome)

'

End Sub

'

Sub cambiainword(nomefoglio As String, riga, nomedocumento As String, salvaconnome As String)

'

Dim appwd As Object, colkey As Integer, coldato As Integer

Dim tipodocWord

'

Set appwd = CreateObject("Word.Application")

appwd.Visible = True

' applicazione invisibile

' appwd.Visible = False

' ingrandisco la finestra

' appwd.WindowState = wdWindowStateMaximize

'

tipodocWord = Right(nomedocumento, 4)

If tipodocWord = ".dot" Then

' documento da modello .dot

appwd.Documents.Add nomedocumento

End If

If tipodocWord = ".doc" Then

' apro il documento

appwd.Documents.Open (nomedocumento)

End If

'

Dim parolachiave As String, testo As String, foglio

Dim quantecolonne, contacolonne

'

Set foglio = Sheets(nomefoglio)

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

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

'

For contacolonne = 1 To quantecolonne

parolachiave = Trim(foglio.Cells(1, contacolonne))

testo = Trim(foglio.Cells(riga, contacolonne))

parolachiave = "%%" & parolachiave & "%%"



With appwd.ActiveDocument.Range.Find

.Text = parolachiave

.Replacement.Text = testo

.Forward = True

.Wrap = wdFindContinue

.Format = False

.MatchCase = False

.MatchWholeWord = False

.MatchByte = False

.MatchWildcards = False

.MatchSoundsLike = False

.MatchAllWordForms = False

.Execute Replace:=wdReplaceAll ' tutte le espressioni vengono sostituite.

End With

Next contacolonne

' stampo il documento

' appwd.ActiveDocument.PrintOut

' salvo il documento.

appwd.ActiveDocument.SaveAs salvaconnome

' visualizzo il documento

appwd.Visible = True

' finestra al massimo

appwd.WindowState = wdWindowStateMaximize

' attivo

appwd.Application.Activate

'

End Sub

query tabella html

Attribute VB_Name = "query_tabella_html"

'

Option Explicit

'

' vba - Excel

' crea query su tutte le tabelle di una pagina htlm di un sito.

' la query rimane collegata alla pagina. La query può essere aggiornata quando si vuole.

' uso: call QueryTabellaHtml("http://www.<sito>.<suffisso>/pag-115.html")

'

Sub QueryTabellaHtml(paginahtml)

'

'

Sheets.Add

Range("A1").Select

Application.left = 115.75

Application.top = 62.5

'With ActiveSheet.QueryTables.Add(Connection:="URL;C:\TEMP\GRIGLIA1.HTML", Destination:=Range("A1"))

With ActiveSheet.QueryTables.Add(Connection:="URL;" & paginahtml, Destination:=Range("A1"))

.Name = "GRIGLIA1"

.FieldNames = True

.RowNumbers = False

.FillAdjacentFormulas = False

.PreserveFormatting = True

.RefreshOnFileOpen = False

.BackgroundQuery = True

.RefreshStyle = xlInsertDeleteCells

.SavePassword = False

.SaveData = True

.AdjustColumnWidth = True

.RefreshPeriod = 0

.WebSelectionType = xlAllTables ' tutte le tabelle

.WebFormatting = xlWebFormattingNone

.WebPreFormattedTextToColumns = True

.WebConsecutiveDelimitersAsOne = True

.WebSingleBlockTextImport = False

.WebDisableDateRecognition = False

.Refresh BackgroundQuery:=False

End With

'

End Sub

'

leggi ecofee metel

Attribute VB_Name = "leggi_ecofee_metel"

'

Option Explicit

'

' vba - Excel

' Legge ed importa un file di testo con il tracciato record

' Ecofee RAEE Metel

'

'

Sub leggiEcoFeeMetel()

'

Dim percorso

'

ChDir ("\\Caem02\listini")

percorso = Application.GetOpenFilename("Tutti i file (*.*), *.*")

If percorso = False Then

Exit Sub

End If

'

Sheets.Add

'

With ActiveSheet.QueryTables.Add(Connection:= _

"TEXT;" & percorso, Destination:= _

Range("A1"))

.Name = "ECOFEEMETEL"

.FieldNames = True

.RowNumbers = False

.FillAdjacentFormulas = False

.PreserveFormatting = True

.RefreshOnFileOpen = False

.RefreshStyle = xlInsertDeleteCells

.SavePassword = False

.SaveData = True

.AdjustColumnWidth = True

.RefreshPeriod = 0

.TextFilePromptOnRefresh = False

.TextFilePlatform = xlWindows

.TextFileStartRow = 1

.TextFileParseType = xlFixedWidth

.TextFileTextQualifier = xlTextQualifierDoubleQuote

.TextFileConsecutiveDelimiter = False

.TextFileTabDelimiter = True

.TextFileSemicolonDelimiter = False

.TextFileCommaDelimiter = False

.TextFileSpaceDelimiter = False

.TextFileColumnDataTypes = Array(2, 2, 2, 1, 2, 2, 2, 1, 1, 1, 2, 2, 2, 2)

.TextFileFixedColumnWidths = Array(3, 16, 20, 9, 30, 30, 70, 5, 8, 7, 3, 70, 29)

.Refresh BackgroundQuery:=False

End With

' testata

Dim foglio

Set foglio = Sheets(ActiveSheet.Name)

foglio.Cells(1, 1) = "Marchio"

foglio.Cells(1, 2) = "Codice articolo"

foglio.Cells(1, 3) = "Tipo tassa"

foglio.Cells(1, 4) = "Peso netto"

foglio.Cells(1, 5) = "Consorzio"

foglio.Cells(1, 6) = "Codice Fee"

foglio.Cells(1, 7) = "Descrizione Fee"

foglio.Cells(1, 8) = "Quantità Fee"

foglio.Cells(1, 9) = "Importo singolo Fee"

foglio.Cells(1, 10) = "Percentuale Fee"

foglio.Cells(1, 11) = "Soggetto a IVA o esenzione"

foglio.Cells(1, 12) = "Categoria merceologica"

foglio.Cells(1, 13) = "Filler"

' ' dividi

Dim quanterighe, contarighe, prezzonetto, nprezzonetto, divisore, importofee, nimportofee

Dim percentualefee, npercentualefee

quanterighe = ActiveSheet.UsedRange.Rows.Count

For contarighe = 1 To quanterighe

prezzonetto = ActiveSheet.Cells(contarighe, 4)

importofee = ActiveSheet.Cells(contarighe, 9)

percentualefee = ActiveSheet.Cells(contarighe, 10)

'

divisore = 1000

If IsNull(prezzonetto) = False And IsNumeric(prezzonetto) = True Then

nprezzonetto = prezzonetto / divisore

ActiveSheet.Cells(contarighe, 4) = nprezzonetto

End If

'

divisore = 10000

If IsNull(importofee) = False And IsNumeric(importofee) = True Then

nimportofee = importofee / divisore

ActiveSheet.Cells(contarighe, 9) = nimportofee

End If

'

divisore = 10000

If IsNull(percentualefee) = False And IsNumeric(percentualefee) = True Then

npercentualefee = percentualefee / divisore

ActiveSheet.Cells(contarighe, 10) = npercentualefee

End If

'

Next

'

Columns("D:D").Select

Selection.NumberFormat = "#,##0.000"

Columns("I:I").Select

Selection.NumberFormat = "#,##0.0000"

Columns("J:J").Select

' Selection.NumberFormat = "0.0000%"

'

Cells.Select

Cells.EntireColumn.AutoFit

Range("A2").Select

Range("A2").Activate

'

End Sub

m accoda foglio riepilogo

Attribute VB_Name = "m_accoda_foglio_riepilogo"

'

Option Explicit



'

' vba - excel

' acconta il contenuto de foglio attivo

' ad un foglio denominato riepilogo

'

Sub AccodaFoglioRiepilogo()



Dim quanterighe, contarighe, foglio, contacolonne, quantecolonne

Dim nomefoglio, sfoglio, sriga

nomefoglio = ActiveSheet.Name

Set foglio = Sheets(nomefoglio)

Set sfoglio = Sheets("riepilogo")

'

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

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

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

sriga = sriga + 1

'

contarighe = 1

While contarighe <= quanterighe

sriga = sriga + 1

contacolonne = 1

While contacolonne <= quantecolonne

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

contacolonne = contacolonne + 1

Wend

contarighe = contarighe + 1

Wend

'

sfoglio.Activate

foglio.Delete

'

End Sub

m salva allegati email

Attribute VB_Name = "m_salva_allegati_email"

'

Option Explicit



'



' vba - Outlook 2002

' salva gli allegati delle email selezionate.

'

Public Sub SalvaAllegatiEmail()

'

Dim objOL As Outlook.Application

Dim objMsg As Object, archivio

Dim objAttachments As Outlook.Attachments

Dim objSelection As Outlook.Selection

Dim i As Long

Dim lngCount As Long, domanda As String

Dim strFile As String

Dim strFolder As String

Dim soggetto

'

Dim fs, esiste As Boolean, tentativi As Integer

Set fs = CreateObject("Scripting.FileSystemObject")

'

On Error Resume Next

' Crea oggetto Outlook Application.

Set objOL = CreateObject("Outlook.Application")

' riferimento messaggi selezionati.

Set objSelection = objOL.ActiveExplorer.Selection

' strFolder = Application.GetOpenFilename("Tutti i file (*.*), *.*")

' scelta della cartella dove salvare gli allegati

strFolder = InputBox("scelta cartella", "scelta cartella", "c:\allegati-posta")

If strFolder = "" Then

MsgBox "cartella non trovata!", vbOKOnly

GoTo ExitSub

End If

'

strFolder = strFolder & "\"

'

Dim style

style = vbYesNo + vbCritical + vbDefaultButton2 ' Definisce i pulsanti.

domanda = MsgBox("cancello allegati?", style, "scelta") ' scelta se cancellare gli allegati dopo il salvataggio

'

For Each objMsg In objSelection ' ciclo su tutti i messaggi

tentativi = 0

' serve per i messaggi nelle cartelle pubbliche o private

If objMsg.Class = 43 Or objMsg.Class = 45 Then

' riferimento agli allegati

Set objAttachments = objMsg.Attachments

'

'''MsgBox objMsg.HTMLBody

'

'MsgBox objMsg.Subject

'MsgBox "allegati: " & objAttachments.Count

lngCount = objAttachments.Count ' conteggio del numero di allegati

If lngCount > 0 Then

' ciclo su tutti gli allegati del messaggio.

For i = lngCount To 1 Step -1

' strFile = objAttachments.Item(i).FileName

soggetto = objMsg.Subject ' oggetto del messaggio

' MsgBox soggetto

' sostituisce i caratteri no utilizzabili nel nome di un file

soggetto = Replace(soggetto, "/", "-")

soggetto = Replace(soggetto, ".", "_")

soggetto = Replace(soggetto, "I:", "")

soggetto = Replace(soggetto, "I:", "")

soggetto = Replace(soggetto, ":", "")

'strFile = objAttachments.Item(i).FileName

' crea il mome del file - concatena oggetto del messaggio con il nome del file

strFile = soggetto & "-" & objAttachments.Item(i).FileName

archivio = strFile

' MsgBox strFile

' crea il percorso di salvataggio allegato.

strFile = strFolder & strFile

' verifica se esiste un file con il medesimo nome

esiste = fs.FileExists(strFile)

' MsgBox esiste

'

While esiste = True ' nel caso esista lo stesso nome del file incrementa il contatore

tentativi = tentativi + 1

strFile = strFolder & objMsg.Subject & "-allegato-" & tentativi & archivio

esiste = fs.FileExists(strFile)

Wend

' salva allegato.

objAttachments.Item(i).SaveAsFile strFile

'

If domanda = vbYes Then ' nel caso si sia scelto di cancellare gli allegati.

' cancella allegato.

objAttachments.Item(i).Delete

End If

'



Next i

End If

objMsg.Save

End If

Next

'

ExitSub:

Set objAttachments = Nothing

Set objMsg = Nothing

Set objSelection = Nothing

Set objOL = Nothing

'

End Sub

m leggi intestazione internet

Attribute VB_Name = "m_leggi_intestazione_internet"

'

Option Explicit

'

' vba per Outlook

' visualizza intesazioni internet

' di un messaggio di posta elettronica.

' cartelle pubbliche.

' Outlook 2002

'

Sub LeggiIntestazioneInterneteMail()

'

Const PR_SENDER_EMAIL_ADDRESS = &HC1F001E

Const PR_TRANSPORT_MESSAGE_HEADERS = &H7D001E

'

Dim oMsgColl, quantimessaggi, testo

Dim mittente, emailmittente, oggettomsg, intestazionemsg

Dim MAPIobj As MAPI.Session, MAPIfold As MAPI.Folder

Dim oMessage As MAPI.Message

Set MAPIobj = New MAPI.Session

MAPIobj.Logon , , False, False



Set MAPIfold = MAPIobj.InfoStores("Cartelle pubbliche").RootFolder.Folders("Tutte le cartelle pubbliche")

Set MAPIfold = MAPIfold.Folders("Amministrazione")

'

Set oMsgColl = MAPIfold.Messages

quantimessaggi = oMsgColl.Count

'

For Each oMessage In oMsgColl

testo = ""

With oMessage

mittente = .Sender

oggettomsg = .Subject

emailmittente = .Fields(PR_SENDER_EMAIL_ADDRESS)

intestazionemsg = .Fields(PR_TRANSPORT_MESSAGE_HEADERS)

'

testo = testo & "mittente: " & mittente & vbCrLf

testo = testo & "email mittente: " & emailmittente & vbCrLf

testo = testo & "oggetto msg: " & oggettomsg & vbCrLf

testo = testo & "intestazione msg: " & intestazionemsg & vbCrLf

End With

MsgBox testo

Next

'

'

End Sub

'

crea rubrica css html

Attribute VB_Name = "crea_rubrica_css_html"

'

Option Explicit

'

' vba - excel

' converte il foglio attivo in una pagina html

' scansiona tutte le righe del foglio

' alla tabella html viene viene formatta con css style

'

Sub CreaRubricaHtmlcss()

'

Dim txtcella, contarighe, quanterighe, riga, testo, fs, a, testotd

Dim quantecolonne, contacolonne, cartellap, nomefoglio, cartella, messaggio, foglio, tiporiga

nomefoglio = ActiveSheet.Name

Set foglio = Sheets(nomefoglio)

cartellap = "C:\"

cartella = cartellap & nomefoglio & ".html"

messaggio = ""

messaggio = "il nome della rubrica e': " & nomefoglio & vbCrLf

messaggio = messaggio & "(il mome del foglio attivo)" & vbCrLf

messaggio = messaggio & "cartella in cui sara' salvata la rubrica: " & vbCrLf

messaggio = messaggio & cartellap

MsgBox messaggio

'

Set fs = CreateObject("Scripting.FileSystemObject")

'

Set a = fs.CreateTextFile(cartella, True)

'

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

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

'

testotd = "<TD>"

' intestazione

a.WriteLine ("<HTML><HEAD>")

a.WriteLine ("<TITLE>")

a.WriteLine (nomefoglio)

a.WriteLine ("</TITLE>")

' recupero codice html style

testo = memocodicecssstyle

a.WriteLine (testo)

'

a.WriteLine ("</HEAD>")

testo = "<BODY>"

a.WriteLine (testo)

a.WriteLine ("<CENTER><HR><BR> ")

a.WriteLine (nomefoglio)

a.WriteLine ("<HR> <Table id=""tabelladati"">")

' intestazione - utilizza la prima riga del foglio come intestazione

a.WriteLine ("<TR>")

For contacolonne = 1 To quantecolonne

txtcella = foglio.Cells(1, contacolonne).Value

testo = "<TH>" & txtcella & "</TH>"

a.WriteLine (testo)

Next contacolonne

a.WriteLine ("</TR>")

' scrive tutte le righe e colonne del foglio

For contarighe = 2 To quanterighe ' parte dalla seconda riga

tiporiga = contarighe Mod 2 ' determina quale style applicare

If tiporiga = 0 Then

testo = "<TR>"

Else

testo = "<TR class=""alt"">"

End If

a.WriteLine (testo)

For contacolonne = 1 To quantecolonne

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

testo = testotd & txtcella & "</TD>"

a.WriteLine (testo)

Next contacolonne

a.WriteLine ("</TR>")

Next contarighe

'

a.WriteLine ("</Table><BR><HR></FONT></CENTER></BODY><HTML>")

a.Close

'

End Sub

'

' codice css style

Function memocodicecssstyle()



Dim codicecss

codicecss = codicecss & "<style>" & vbCrLf

codicecss = codicecss & "#tabelladati" & vbCrLf

codicecss = codicecss & "{" & vbCrLf

codicecss = codicecss & "font-family:""Trebuchet MS"", Arial, Helvetica, sans-serif;" & vbCrLf

codicecss = codicecss & "width:100%;" & vbCrLf

codicecss = codicecss & "border-collapse:collapse;" & vbCrLf

codicecss = codicecss & "}" & vbCrLf

codicecss = codicecss & "#tabelladati td, #tabelladati th" & vbCrLf

codicecss = codicecss & "{" & vbCrLf

codicecss = codicecss & "font-size:1em;" & vbCrLf

codicecss = codicecss & "border:1px solid #98bf21;" & vbCrLf

codicecss = codicecss & "padding:3px 7px 2px 7px;" & vbCrLf

codicecss = codicecss & "}" & vbCrLf

codicecss = codicecss & "#tabelladati th" & vbCrLf

codicecss = codicecss & "{" & vbCrLf

codicecss = codicecss & "font-size:1.1em;" & vbCrLf

codicecss = codicecss & "text-align:left;" & vbCrLf

codicecss = codicecss & "padding-top:5px;" & vbCrLf

codicecss = codicecss & "padding-bottom:4px;" & vbCrLf

codicecss = codicecss & "background-color:#A7C942;" & vbCrLf

codicecss = codicecss & "color:#ffffff;" & vbCrLf

codicecss = codicecss & "}" & vbCrLf

codicecss = codicecss & "#tabelladati tr.alt td" & vbCrLf

codicecss = codicecss & "{" & vbCrLf

codicecss = codicecss & "color:#000000;" & vbCrLf

codicecss = codicecss & "background-color:#EAF2D3;" & vbCrLf

codicecss = codicecss & "}" & vbCrLf

codicecss = codicecss & "</style>" & vbCrLf

'

memocodicecssstyle = codicecss

'

End Function

crea rubrica html

Attribute VB_Name = "crea_rubrica_html"

'

Option Explicit

'

' vba - excel

' converte il foglio attivo in una pagina html

'

Sub CreaRubricaHtml()

'

Dim txtcella, contarighe, quanterighe, riga, testo, fs, a, testotd

Dim quantecolonne, contacolonne, cartellap, nomefoglio, cartella, messaggio, foglio

nomefoglio = ActiveSheet.Name

Set foglio = Sheets(nomefoglio)

cartellap = "C:\"

cartella = cartellap & nomefoglio & ".html"

messaggio = "il nome della rubrica e': " & nomefoglio & vbCrLf

messaggio = messaggio & "(il mome del foglio attivo)" & vbCrLf

messaggio = messaggio & "cartella in cui sara' salvata la rubrica: " & vbCrLf

messaggio = messaggio & cartellap

MsgBox messaggio

'

Set fs = CreateObject("Scripting.FileSystemObject")

'

Set a = fs.CreateTextFile(cartella, True)

'

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

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

'

testotd = "<TD ALIGN=" & Chr(34) & "left" & Chr(34) & " >"

' intestazione

a.WriteLine ("<HTML><HEAD><TITLE>")

a.WriteLine (nomefoglio)

a.WriteLine ("</TITLE></HEAD>")

testo = "<BODY bgcolor = " & Chr(34) & "#ccffff" & Chr(34) & ">"

a.WriteLine (testo)

a.WriteLine ("<CENTER><BR><HR><BR> ")

a.WriteLine (nomefoglio)

a.WriteLine ("<HR> <Table border>")





testo = "<FONT FACE=" & Chr(34) & "Arial" & Chr(34) & "SIZE=+1>"

a.WriteLine (testo)

' scrive tutte le righe e colonne

For contarighe = 1 To quanterighe

testo = "<TR VALIGN=" & Chr(34) & "bottom" & Chr(34) & ">"

a.WriteLine (testo)

For contacolonne = 1 To quantecolonne

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

testo = testotd & txtcella & "</TD>"

a.WriteLine (testo)

Next contacolonne

a.WriteLine ("</TR>")

Next contarighe



a.WriteLine ("</Table><BR><HR></FONT></CENTER></BODY><HTML>")

a.Close

'

End Sub

m estrai primo spazio dx

Attribute VB_Name = "m_estrai_primo_spazio_dx"

'

Option Explicit

'

'vba - excel

' Estrae Stringa Dopo il primo spazio a destra

'

'

Sub EstraeStringaDopoilPrimoSpazioDestra()

Dim quanterighe, contarighe, foglio, contenuto1, contenuto2, colonnadascansionare, scrivicolonna, presente

Set foglio = Sheets(ActiveSheet.Name)

'

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

colonnadascansionare = ActiveCell.Column ' prende la colonna della cella attiva

scrivicolonna = colonnadascansionare + 1 ' colonna dove scrivere il valore trovato

'

contarighe = 1

While contarighe <= quanterighe

contenuto1 = Trim(foglio.Cells(contarighe, colonnadascansionare).Value)

contenuto2 = Trim(foglio.Cells(contarighe, scrivicolonna).Value)

presente = InStr(contenuto1, " ")

If presente > 0 Then

If Len(contenuto2) > 0 Then

ActiveSheet.Cells(contarighe, colonnadascansionare).Value = "'" & Trim(Left(contenuto1, presente))

ActiveSheet.Cells(contarighe, scrivicolonna).Value = "'" & contenuto2 & Trim(Mid(contenuto1, (presente + 1), (Len(contenuto1) - presente)))

Else

ActiveSheet.Cells(contarighe, colonnadascansionare).Value = "'" & Trim(Left(contenuto1, presente))

ActiveSheet.Cells(contarighe, scrivicolonna).Value = "'" & Trim(Mid(contenuto1, (presente + 1), (Len(contenuto1) - presente)))

End If

End If

contarighe = contarighe + 1

Wend

'

End Sub

'









'

m cancella su valore riga

Attribute VB_Name = "m_cancella_su_valore_riga"

'

Option Explicit

'

' vba - excel

' cancella righe che contegono il valore della cella attiva

'

Sub CancellaRigheConValoreCorrente()

'

Dim ColonnaAttiva, corrente As String, quanterighe, contarighe

Dim valore As String, foglio

Set foglio = Sheets(ActiveSheet.Name)

ColonnaAttiva = ActiveCell.Column

valore = Trim(CStr(ActiveCell.Value))

'

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(CStr(foglio.Cells(contarighe, ColonnaAttiva).Value))

If corrente = valore Then

foglio.Rows(contarighe).Delete

End If

Next contarighe

'

Application.ScreenUpdating = True

Application.Cursor = xlDefault

'



End Sub

m scrivi ps pdf campi

Attribute VB_Name = "m_scrivi_ps_pdf_campi"

'

Option Explicit

'

' crea griglia editabile per file pdf

' genera un file in formato PS-postscript

' tramite Ghostscript si crea il file in formato PDF

'

Sub ScriviFilePsPdfCampiEditabili()

Dim orizzontale, verticale, altezzacampo, lunghezzacampo

Dim contaaltezza, contacampi

Dim marginesinistro, partida, s As String

Dim lunghezzacampi, nomecampi, destinatarioemail

destinatarioemail = InputBox("destinatario email", "scelta", "")

Dim x, spostati

altezzacampo = 20

'lunghezzacampo = 30

orizzontale = 595 ' formato pagina a4

verticale = 842 ' formato pagina a4

marginesinistro = 21

partida = verticale - altezzacampo - altezzacampo - altezzacampo

contacampi = 0

'

nomecampi = Array("", "qta", "articolo", "descrizione", "nota", "note")

'

lunghezzacampi = Array(0, 35, 150, 250, 45, 70)

'

s = ""

s = s & "%!PS-Adobe-3.0 EPSF-3.0" & vbCrLf

s = s & "%%BoundingBox: 0 0 72 72" & vbCrLf

s = s & "%%EndComments" & vbCrLf

s = s & "%%BeginProlog /pdfmark where {pop} {userdict /pdfmark /cleartomark load put} ifelse " & "[ {ThisPage} << /Trans << /S /Dissolve >> >> /PUT pdfmark" & vbCrLf

s = s & "%%EndProlog" & vbCrLf

s = s & " " & vbCrLf

s = s & "%%BeginSetup" & vbCrLf

s = s & "%%EndSetup" & vbCrLf

s = s & " " & vbCrLf

s = s & "%%BeginPage:" & vbCrLf

s = s & " " & vbCrLf

'

spostati = marginesinistro

' intestazione della griglia

For x = 1 To UBound(lunghezzacampi)

lunghezzacampo = lunghezzacampi(x)

s = s & "/Times-Roman findfont 10 scalefont setfont" & vbCrLf

s = s & spostati & " 810 moveto" & vbCrLf

s = s & "(" & nomecampi(x) & ") show" & vbCrLf

spostati = spostati + lunghezzacampo + 2

Next x

' crea griglia

' campi editabili

For x = 1 To UBound(lunghezzacampi)

lunghezzacampo = lunghezzacampi(x)

For contaaltezza = partida To 61 Step -21

s = s & " " & vbCrLf

s = s & "[ /T (field" & nomecampi(x) & contacampi & x & ") % title" & vbCrLf

s = s & "/Subtype /Widget" & vbCrLf

s = s & "/FT /Tx % field type text box" & vbCrLf

s = s & "/V () % default value" & vbCrLf

's = s & "/Rect [ 25 619 116 639]" & vbCrLf

s = s & "/Rect [ " & marginesinistro & " " & contaaltezza & " " & (marginesinistro + lunghezzacampo) & " " & (contaaltezza + altezzacampo) & " ]" & vbCrLf

s = s & "/F 4 % field is printable" & vbCrLf

s = s & "/BS << /S /S /W 1 >> % border style solid, width = 1" & vbCrLf

s = s & "/MK <<" & vbCrLf

s = s & "/BC [ 1 0 0 ] % border color red" & vbCrLf

s = s & "/BG [ 1 1 1 ] >> % background color white" & vbCrLf

s = s & "/ANN pdfmark" & vbCrLf

s = s & " " & vbCrLf

contacampi = contacampi + 1

Next contaaltezza

'

marginesinistro = marginesinistro + lunghezzacampo + 1

'

Next x

'

' pulsante invio modulo tramite email

'

s = s & "[ /Rect [ 50 50 220 60 ]" & vbCrLf

s = s & "/Action << /Subtype /SubmitForm" & vbCrLf

s = s & "/F (mailto:" & destinatarioemail & ") >>" & vbCrLf

s = s & "/Flags 0" & vbCrLf

s = s & "/Subtype /Link" & vbCrLf

s = s & "/Border [ 1 1 1 ]" & vbCrLf

s = s & "/ANN pdfmark" & vbCrLf

'

s = s & "/Times-Roman findfont 10 scalefont setfont" & vbCrLf

s = s & "52 52 moveto" & vbCrLf

s = s & "(invia tramite e-mail) show" & vbCrLf

s = s & "showpage" & vbCrLf

'

s = s & "%%EndPage:" & vbCrLf

s = s & "%%EOF" & vbCrLf

'

' scrive il file ps

Dim fs, a

Set fs = CreateObject("Scripting.FileSystemObject")

Set a = fs.CreateTextFile("c:\file-per-creazione-pdf.ps", True)

a.WriteLine (s)

a.Close

'

End Sub

m scrivi fdf

Attribute VB_Name = "m_scrivi_fdf"

'

Option Explicit

'

' un unico file PDF per visualizzare i dati del foglio Excel

' i nomi dei campi del file Pdf debbono essere gli stessi

' presenti una prima riga del foglio excel.

' per ogni riga del foglio excel viene generato un file fdf.

'

' esempio file fdf:

'%FDF-1.2

'1 0 obj

'<<

' /FDF

' <<

' /Fields [

' << /V (1) /T (an_conto)>>

' << /V (nominativo) /T (an_descr1)>>

' << /V (indirizzo) /T (an_indir)>>

' << /V (cap) /T (an_cap)>>

' << /V (città) /T (an_citta)>>

' << /V (prov) /T (an_prov)>>

' ]

' /F (C:\\schedefdf\\scheda-dati.pdf)

' /ID [ ()()]

' >>

'>>

'endobj

'trailer

'<<

'/Root 1 0 R

'>>

'%%EOF

'

'



Sub ScriviFileFdf()

Dim quanterighe, contarighe, foglio, quantecolonne, contacolonne, risposta

Dim cartellascrittura

Dim intestazioni(), contenuti(), filepdf, filefdf

Set foglio = Sheets(ActiveSheet.Name)

'

' il nome del file pdf su cui visualizzare i dati del foglio

' i momi dei campi debbono essere gli stessi di quelli presenti sulla

cartellascrittura = "C:\schedefdf\"

risposta = VerificaEsistenzaCartella(cartellascrittura)

'

'cartellascrittura = InputBox("cartella dove scrivere file fdf:", "scelta", "c:\temp\")

' prima riga del foglio

filepdf = "C:\\lschedefdf\\scheda-dati.pdf"

'

' conteggio righe e colonne

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

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

'

ReDim intestazioni(quantecolonne)

ReDim contenuti(quantecolonne)

'

contacolonne = 1

' utilizza i nomi inseriti nella prima riga come nome dei campi

'

While contacolonne <= quantecolonne

intestazioni(contacolonne) = foglio.Cells(1, contacolonne).Value

contacolonne = contacolonne + 1

Wend

'

contarighe = 1

'

While contarighe <= quanterighe

contacolonne = 1

While contacolonne <= quantecolonne

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

contacolonne = contacolonne + 1

Wend

' il file fdf prende il nome dal numero riga

filefdf = cartellascrittura & contarighe & ".fdf"

' in alternativa ii contenuto di una cella diventa il nome del file fdf.

' filefdf = cartellascrittura & trim(foglio.Cells(contarighe, "A").Value) & ".fdf"

Call funscrivifdf(intestazioni, contenuti, filepdf, filefdf)

contarighe = contarighe + 1

Wend

'

End Sub

'

Sub funscrivifdf(campi, valori, filepdf, filefdf)

Dim quanti, conta, nomecampo, valore

Dim s

quanti = UBound(campi)

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 [ " & vbCrLf

For conta = 1 To quanti

nomecampo = campi(conta)

valore = valori(conta)

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

Next conta

'

s = s & " ]" & vbCrLf

'

s = s & " /F (" & filepdf & ")" & vbCrLf

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

archivio = filefdf

Set fs = CreateObject("Scripting.FileSystemObject")

Set a = fs.CreateTextFile(archivio, True)

a.WriteLine (s)

a.Close

'

End Sub

'

Function VerificaEsistenzaCartella(cartella)

Dim fso, msg, crea

Set fso = CreateObject("Scripting.FileSystemObject")

If (fso.FolderExists(cartella)) Then

' esiste

Else

' non esiste e cre la cartella

Set crea = fso.CreateFolder(cartella)

End If

'

End Function

'

unisci fogli tramite sql

Attribute VB_Name = "unisci_fogli_tramite_sql"

'

Option Explicit

'

' tramite istruzione sql

' raggruppa in nuovo foglio i dati di due fogli

' contenenti la medesima intestazione di colonna.

' esempio:

' Foglio1, cella a1 = articolo

' Foglio2, cella a1 = articolo

'

Sub componiStringaSql()

'

Dim stringasql As String, fogliodestinazione

Dim foglio1, foglio2

foglio1 = "Foglio1"

foglio2 = "Foglio2"

'

stringasql = ""

stringasql = stringasql & " Select * from [" & foglio1 & "$]"

stringasql = stringasql & " UNION "

stringasql = stringasql & " Select * from [" & foglio2 & "$]"

'

Sheets.Add

fogliodestinazione = ActiveSheet.Name

Call EseguiSqlExcel(stringasql, fogliodestinazione)

'

End Sub

'

Sub EseguiSqlExcel(stringasql As String, fogliodestinazione)

'On Error Resume Next

Dim oggConnection, oggRecordset, rifcartella, i

rifcartella = ThisWorkbook.FullName

Const adOpenStatic = 3

Const adLockOptimistic = 3

Const adCmdText = &H1



Set oggConnection = CreateObject("ADODB.Connection")

Set oggRecordset = CreateObject("ADODB.Recordset")



oggConnection.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _

"Data Source=" & rifcartella & ";" & _

"Extended Properties=""Excel 8.0;HDR=Yes;"";"

'

oggRecordset.Open stringasql, oggConnection, adOpenStatic, adLockOptimistic, adCmdText

'

' intestazione - nome campi

'

For i = 0 To oggRecordset.Fields.Count - 1

Sheets(fogliodestinazione).Cells(1, (i + 1)) = oggRecordset.Fields(i).Name

Next

'

' scrive il recordset

Sheets(fogliodestinazione).Range("A2").CopyFromRecordset oggRecordset

'

End Sub

'

riconciliazione cg banca

Attribute VB_Name = "riconciliazione_cg_banca"

'

Option Explicit

'

' vba - Excel

' Riconciliazione movimenti Banca - Prima Nota

' ricerca ed evidenzia (in giallo) cella in base al contenuto utilizzando una espressione regolare

' le celle evidenziate non vengono più utilizzate per la ricerca

'

Dim rigatrovato

'

Sub RiconciliazionePrimaNotaBanca()

'

Dim nomefoglioprimanota, nomefogliobanca, colonnaprimanota, colonnabanca, datoricercato

Dim campi, ritorno

'

' input nome fogli e colonne per la ricerca

campi = Array("", "nome foglio prima nota", "colonna importi prima nota", "nome foglio banca", "colonna importi banca")

ritorno = creaMaskeraHtml(campi)

'

nomefoglioprimanota = ritorno(1)

colonnaprimanota = ritorno(2) ' colonna valori

nomefogliobanca = ritorno(3)

colonnabanca = ritorno(4) ' colonna valori

'

Dim quanterighe, contarighe, foglio

Set foglio = Sheets(nomefoglioprimanota)

'

' conteggio righe utilizzate

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

'

contarighe = 1

While contarighe <= quanterighe

datoricercato = foglio.Cells(contarighe, colonnaprimanota).Value

If IsNumeric(datoricercato) = True Then

If datoricercato > 0 Then

Call EvidenziaValoriColonnaPerContenuto(nomefogliobanca, colonnabanca, datoricercato)

If rigatrovato > 0 Then

foglio.Cells(contarighe, colonnaprimanota).Interior.ColorIndex = 6

End If

End If

End If

contarighe = contarighe + 1

Wend

'

'

End Sub

'

Function EvidenziaValoriColonnaPerContenuto(nomefoglio, colonnaricerca, datoricercato)

rigatrovato = 0

Dim procedura, cella As Range, foglio, zonaricerca, quanterighe, colorecella

Set foglio = Sheets(nomefoglio)

' conteggio righe utilizzate

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

'

Set zonaricerca = foglio.Range(Cells(1, colonnaricerca).Address, Cells(quanterighe, colonnaricerca).Address)

Set procedura = CreateObject("VBScript.RegExp")

'

With procedura

.Pattern = datoricercato

.IgnoreCase = True

.Global = True

For Each cella In zonaricerca

If .test(cella.Value) Then

colorecella = cella.Interior.ColorIndex ' verifica il colore cella

If colorecella = 6 Then ' nel caso il valore sia evidenziato

Else

cella.Interior.ColorIndex = 6 ' evidenzia la cella

rigatrovato = cella.row ' memorizza il numero riga

Exit Function

End If

End If

Next cella

End With

'

Set procedura = Nothing

'

End Function

'

Function creaMaskeraHtml(campi)

'

On Error GoTo esci

'

Dim txtHtml, IE, valoriinput, quanticampi, contacampi

quanticampi = UBound(campi)

ReDim ritorno(quanticampi)

ritorno(0) = "errore"

'

Set IE = CreateObject("InternetExplorer.Application")

IE.navigate "about:blank"

IE.Top = 150

IE.Visible = True

IE.Height = 300

IE.Width = 550

IE.MenuBar = False

IE.Toolbar = False

IE.StatusBar = False

IE.resizable = True

'

IE.document.Title = " - ricerca - "

' crea codice HTML della pagina per input dei valori.

' utilizzando una form e una tabella

txtHtml = ""

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

txtHtml = txtHtml + " inserimento<br>"

txtHtml = txtHtml + "<FORM name=""mask""><table>"

For contacampi = 1 To quanticampi

txtHtml = txtHtml + "<TR>" ' crea nuova riga

txtHtml = txtHtml + "<TD>" ' crea colonna della descrizione

txtHtml = txtHtml + campi(contacampi) ' testo visualizzato

txtHtml = txtHtml + ":</TD><TD>" ' nuova colonna

txtHtml = txtHtml + "<input name=""" & campi(contacampi) & """ type=""text"" value="""">" ' box input

txtHtml = txtHtml + "</TD></TR>"

Next contacampi

txtHtml = txtHtml + "</table></FORM></body></html>"

IE.document.body.innerHTML = txtHtml

'

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

'

Do While IE.readystate = 4

'

contacampi = 0

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

contacampi = contacampi + 1

ritorno(contacampi) = valoriinput.Value

Next

'

DoEvents

Loop

'

ritorno(0) = "risposta"

Set IE = Nothing

'

esci:

'

creaMaskeraHtml = ritorno

'

End Function

'

'

evidenzia ricerca valori

Attribute VB_Name = "evidenzia_ricerca_valori"

'

Option Explicit

'

' vba - Excel

' Evidenzia Valori Colonna Per Contenuto

' ricerca ed evidenzia cella in base al contenuto utilizzando una espressione regolare

' alternativa leggera alla formattazione condizionale

'

Sub uso_EvidenziaValoriColonnaPerContenuto()

'

Dim nomefoglio, colonnaricerca, datoricercato

Dim campi, ritorno

campi = Array("", "nome foglio", "colonna ricerca", "dato ricercato")

ritorno = creaMaskeraHtml(campi)

'

nomefoglio = ritorno(1)

colonnaricerca = ritorno(2)

datoricercato = ritorno(3)

'

Call EvidenziaValoriColonnaPerContenuto(nomefoglio, colonnaricerca, datoricercato)

'

End Sub

'

Sub EvidenziaValoriColonnaPerContenuto(nomefoglio, colonnaricerca, datoricercato)

Dim procedura, cella As Range, foglio, zonaricerca, quanterighe

Set foglio = Sheets(nomefoglio)

' conteggio righe utilizzate

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

'

Set zonaricerca = foglio.Range(Cells(1, colonnaricerca), Cells(quanterighe, colonnaricerca))

Set procedura = CreateObject("VBScript.RegExp")

'

With procedura

.Pattern = datoricercato

.IgnoreCase = True

.Global = True

For Each cella In zonaricerca

If .test(cella.Value) Then

cella.Interior.ColorIndex = 6

End If

Next cella

End With

'

Set procedura = Nothing

'

End Sub

'

Function creaMaskeraHtml(campi)

'

On Error GoTo esci

'

Dim txtHtml, IE, valoriinput, quanticampi, contacampi

quanticampi = UBound(campi)

ReDim ritorno(quanticampi)

ritorno(0) = "errore"

'

Set IE = CreateObject("InternetExplorer.Application")

IE.navigate "about:blank"

IE.Top = 150

IE.Visible = True

IE.Height = 300

IE.Width = 550

IE.MenuBar = False

IE.Toolbar = False

IE.StatusBar = False

IE.resizable = True

'

IE.document.Title = " - ricerca - "

' crea codice HTML della pagina per input dei valori.

' utilizzando una form e una tabella

txtHtml = ""

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

txtHtml = txtHtml + " inserimento<br>"

txtHtml = txtHtml + "<FORM name=""mask""><table>"

For contacampi = 1 To quanticampi

txtHtml = txtHtml + "<TR>" ' crea nuova riga

txtHtml = txtHtml + "<TD>" ' crea colonna della descrizione

txtHtml = txtHtml + campi(contacampi) ' testo visualizzato

txtHtml = txtHtml + ":</TD><TD>" ' nuova colonna

txtHtml = txtHtml + "<input name=""" & campi(contacampi) & """ type=""text"" value="""">" ' box input

txtHtml = txtHtml + "</TD></TR>"

Next contacampi

txtHtml = txtHtml + "</table></FORM></body></html>"

IE.document.body.innerHTML = txtHtml

'

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

'

Do While IE.readystate = 4

'

contacampi = 0

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

contacampi = contacampi + 1

ritorno(contacampi) = valoriinput.Value

Next

'

DoEvents

Loop

'

ritorno(0) = "risposta"

Set IE = Nothing

'

esci:

'

creaMaskeraHtml = ritorno

'

End Function

'

'

importazione listino metel

Attribute VB_Name = "importazione_listino_metel"

'

Option Explicit

'

' vba - procedura completa per importazione listino Metel

' inserisce intestazione campi/colonne

' dividi i prezzi per ottenere i due decimali

' inserisce in un foglio a parte la testata del listino

'

Sub ImportaListinoMetel()

'

' scelta file

Dim archivio

archivio = Application.GetOpenFilename("Tutti i file (*.*), *.*")

If archivio = False Then

Exit Sub

End If

'

Sheets.Add

Dim rigaletta, fso, f, sriga

' assegna il formato celle testo

Columns("A:D").Select

Selection.NumberFormat = "@"

Rows("2:2").Select

ActiveWindow.FreezePanes = True

sriga = 0

' legge il file di testo

Set fso = CreateObject("Scripting.FileSystemObject")

Set f = fso.OpenTextFile(archivio, 1, False)

Do While f.AtEndOfStream <> True

rigaletta = f.ReadLine

sriga = sriga + 1

ActiveSheet.Cells(sriga, 1) = rigaletta

Loop

f.Close

' analizza testo in colonne

ActiveSheet.Columns("A:A").Select

' tracciato record del listino metel

Selection.TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _

FieldInfo:=Array(Array(0, 1), _

Array(3, 2), Array(19, 2), Array(32, 1), Array(75, 1), Array(80, 1), Array(85, 1), Array _

(90, 1), Array(96, 1), Array(97, 1), Array(108, 1), Array(119, 1), Array(125, 1), Array(128 _

, 1), Array(131, 1), Array(132, 1), Array(133, 5), Array(141, 2), Array(159, 2))

' divide i prezzi per inserire i due decimali

Dim quanterighe, contarighe, prezzogg, nprezzogg, prezzorr, nprezzorr, divisore, foglio

Set foglio = Sheets(ActiveSheet.Name)

divisore = 100 ' per i due decimali del prezzo grossista e al pubblico

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

'

For contarighe = 1 To quanterighe

prezzogg = ActiveSheet.Cells(contarighe, "J").Value ' prezzo grossista

prezzorr = ActiveSheet.Cells(contarighe, "K").Value ' prezzo al pubblico

If IsNull(prezzogg) = False And IsNumeric(prezzogg) = True Then

nprezzogg = prezzogg / divisore

ActiveSheet.Cells(contarighe, "J").Value = nprezzogg

End If

If IsNull(prezzorr) = False And IsNumeric(prezzorr) = True Then

nprezzorr = prezzorr / divisore

ActiveSheet.Cells(contarighe, "k").Value = nprezzorr

End If

Next

Sheets(ActiveSheet.Name).Name = "listino"

' inserisce i nomi dei campi

Call testatalistinometel("listino")

'

Columns("A:S").Select

Selection.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess, _

OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

Range("B2").Select

'

End Sub

'

Sub testatalistinometel(nomefoglio)

'

Sheets(nomefoglio).Cells(1, 1) = "Sigla Marchio"

Sheets(nomefoglio).Cells(1, 2) = "Codice Prodotto Produttore"

Sheets(nomefoglio).Cells(1, 3) = "Codice EAN"

Sheets(nomefoglio).Cells(1, 4) = "Descrizione prodotto"

Sheets(nomefoglio).Cells(1, 5) = "Quantità cartone"

Sheets(nomefoglio).Cells(1, 6) = "Quantità multipla ordinazione"

Sheets(nomefoglio).Cells(1, 7) = "Quantità minima ordinazione"

Sheets(nomefoglio).Cells(1, 8) = "Quantità massima ordinazione"

Sheets(nomefoglio).Cells(1, 9) = "Lead Time"

Sheets(nomefoglio).Cells(1, 10) = "Prezzo al grossista"

Sheets(nomefoglio).Cells(1, 11) = "Prezzo al Pubblico"

Sheets(nomefoglio).Cells(1, 12) = "Moltiplicatore prezzo"

Sheets(nomefoglio).Cells(1, 13) = "Codice Valuta"

Sheets(nomefoglio).Cells(1, 14) = "Unità di misura"

Sheets(nomefoglio).Cells(1, 15) = "Prodotto Composto"

Sheets(nomefoglio).Cells(1, 16) = "Stato del prodotto"

Sheets(nomefoglio).Cells(1, 17) = "Data ultima variazione"

Sheets(nomefoglio).Cells(1, 18) = "Famiglia di sconto"

Sheets(nomefoglio).Cells(1, 19) = "Famiglia statistica"

End Sub

'

Sub leggitesta(archivio)

Sheets.Add

Sheets(ActiveSheet.Name).Name = "testatalistino"

Const ForReading = 1, ForWriting = 2, ForAppending = 3

Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0

Dim fs, f, ts, s, campo, conta

Set fs = CreateObject("Scripting.FileSystemObject")

Set f = fs.GetFile(archivio)

Set ts = f.OpenAsTextStream(ForReading, TristateFalse)

s = ts.ReadLine

ts.Close

Dim posizioni, lunghezze, sriga

Dim posizione, lungo

posizioni = Array(1, 21, 24, 35, 41, 49, 57, 87, 126, 129)

lunghezze = Array(20, 3, 11, 6, 8, 8, 30, 39, 3, 49)

Dim nomicampi(10)

nomicampi(0) = "Identificazione tracciato"

nomicampi(1) = "sigla produttore"

nomicampi(2) = "Partita IVA"

nomicampi(3) = "Numero listino prezzi"

nomicampi(4) = "Decorrenza listino prezzi"

nomicampi(5) = "Data ultima variazione/immissione"

nomicampi(6) = "Descrizione listino prezzi"

nomicampi(7) = "spazio1"

nomicampi(8) = "Versione tracciato listino prezzi"

nomicampi(9) = "spazio2"

'

For conta = 0 To 9

posizione = posizioni(conta)

lungo = lunghezze(conta)

sriga = conta + 1

campo = "'" & Mid(s, posizione, lungo)

Sheets("testatalistino").Cells(sriga, 2) = nomicampi(conta)

Sheets("testatalistino").Cells(sriga, 3) = campo

Next conta

'

End Sub

'

Sub vedifoglio(nomefoglio)

On Error GoTo crea

Sheets(nomefoglio).Activate

Sheets(nomefoglio).Delete

crea:

Sheets.Add

Sheets(ActiveSheet.Name).Name = nomefoglio

'

End Sub

'

'

'