'
' 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
'
giovedì 18 luglio 2013
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
'
' 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
'
mercoledì 17 luglio 2013
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
'---
' 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
' 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
martedì 16 luglio 2013
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
'
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
'
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
'
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
'
'
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
'
venerdì 12 luglio 2013
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
'
'
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
'
mercoledì 10 luglio 2013
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
'
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
'
'
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
'
martedì 9 luglio 2013
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
'
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
'
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
'
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
martedì 2 luglio 2013
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
'
'
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
'
Iscriviti a:
Post (Atom)