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
Nessun commento:
Posta un commento