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