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

'