VBA-Beispiel 040
mail schreiben
mail schreiben

von der aktiven Exceltabelle eine HTML-Datei erstellen
Diese Prozedur erstellt von der aktiven Tabelle eine HTML-Datei mit validem Quelltext.

Übernommen werden die Schriftformatierungen: fett, unterstrichen und kursiv
Textausrichtung: links, zentriert und rechtsbündig
Zellfarbe, Spaltenbreite sowie Hyperlinks.

Beispiel hier ansehen
Download:   vba040.zip
Dim Hex_Farbe As String

Sub HTML_Datei_anlegen()
Dim fsDatei As Object, Text As Object
Dim Pfad As String, Inhalt As String
Dim Zeile As Long, LZ As Long
Dim Spalte As Long, LS As Long
Dim Zellfarbe As Long, TabBreite As Long

On Error GoTo Hell

Pfad = ThisWorkbook.Path & "\" _
       & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) & "_" & ActiveSheet.Name & ".html"

'HTML-Datei erstellen
Set fsDatei = CreateObject("Scripting.FileSystemObject")
fsDatei.CreateTextFile Pfad

Set fsDatei = fsDatei.getfile(Pfad)
'öffnet die Datei zum reinschreiben
Set Text = fsDatei.OpenAsTextStream(2, -2)

'HTML-Grundgerüst erstellen
Text.write "<!DOCTYPE HTML PUBLIC ""-//W3C//DTD HTML 4.01 Transitional//EN"">" & vbLf
Text.write "<html>" & vbLf  '& vbLf erzeugt im html-Quelltext einen Zeilenumbruch
Text.write "<!-- diese Datei wurde über eine Excel-VBA-Prozedur erstellt-->" & vbLf
Text.write "<!-- " & ThisWorkbook.FullName & "-->" & vbLf

Text.write "<head>" & vbLf
Text.write "<meta http-equiv=""Content-Type"" content=""text/html; charset=iso-8859-1"">" & vbLf
Text.write "<title>Excel -- Html</title>" & vbLf

Text.write "</head>" & vbLf & vbLf
Text.write "<body bgcolor=""#ffffff"">" & vbLf & vbLf 'Hintergrundfarbe

'letzte Zeile mit Inhalt (Excel) ermitteln
LZ = Cells.Find(What:="*", After:=[a1], SearchOrder:=xlByRows, _
    SearchDirection:=xlPrevious).Row
'letzte Spalte mit Inhalt (Excel) ermitteln
LS = Cells.Find(What:="*", After:=[a1], SearchOrder:=xlByColumns, _
    SearchDirection:=xlPrevious).Column

'Tabellenbreite ermitteln
For Spalte = 1 To LS  
  TabBreite = TabBreite + Round(Cells(1, Spalte).Width * 1.5)
Next Spalte

'HTML-Tabelle einfügen
Text.write "<table border=""0"" bgcolor=""#C0C0C0"" align=""center""" _
         & "cellpadding=""3"" cellspacing=""1"" width=""" & TabBreite & """>" & vbLf
'######################################################

For Zeile = 1 To LZ

Text.write "<tr>" ' Zeile einfügen

    For Spalte = 1 To LS
        Zellfarbe = Cells(Zeile, Spalte).Interior.Color
        umwandeln (Zellfarbe) 'Funktion aufrufen

       'Spalte einfügen
        If Cells(Zeile, Spalte) = "" Then   'wenn Zelle leer
          Text.write "<td bgcolor=""#" & Hex_Farbe & """" _
           & "width=""" & Round(Cells(Zeile, Spalte).Width * 1.5) & """>&nbsp; "
       'rechtsbündig
        ElseIf Cells(Zeile, Spalte).HorizontalAlignment = xlRight Then
          Text.write "<td align=""right"" bgcolor=""#" & Hex_Farbe & """" _
           & "width=""" & Round(Cells(Zeile, Spalte).Width * 1.5) & """>"
       'zentriert
        ElseIf Cells(Zeile, Spalte).HorizontalAlignment = xlCenter Then
          Text.write "<td align=""center"" bgcolor=""#" & Hex_Farbe & """" _
           & "width=""" & Round(Cells(Zeile, Spalte).Width * 1.5) & """>"
       'linksbündig
        Else
          Text.write "<td bgcolor=""#" & Hex_Farbe & """" _
           & "width=""" & Round(Cells(Zeile, Spalte).Width * 1.5) & """>"
        End If  

       'Hyperlink
        If Cells(Zeile, Spalte).Hyperlinks.Count = 1 Then
          Inhalt = "<a href=""" & Cells(Zeile, Spalte).Hyperlinks(1).Address & """ >" _
                   & Cells(Zeile, Spalte).Value & "</a>"
        Else
          Inhalt = Cells(Zeile, Spalte).Value
        End If

       'fett
        If Cells(Zeile, Spalte).Font.Bold = True Then Inhalt = "<b>" & Inhalt & "</b>"
       'kursiv
        If Cells(Zeile, Spalte).Font.Italic = True Then Inhalt = "<i>" & Inhalt & "</i>"
       'unterstrichen
        If Cells(Zeile, Spalte).Font.Underline = xlUnderlineStyleSingle Then Inhalt = "<u>" & Inhalt & "</u>"

        Text.write Inhalt   &   "</td>"
    Next Spalte

Text.write "</tr>"  ' Zeile schließen
Text.write vbLf     'Zeilenumbruch im HTML-Quelltext

Next Zeile

'######################################################>
'alle HTNL-Tags wieder schließen
Text.write "</table>" & vbLf & vbLf
Text.write "</body>" & vbLf
Text.write "</html>"
Text.Close

'Info zu Speicherpfad + Frage wg Anzeige
If MsgBox("als Html-Datei gespeichert in:    " & Pfad _
    & vbNewLine & vbNewLine _
    & "Html-Datei anzeigen?", vbYesNo, "") = vbYes Then
   Shell "hh " & Pfad, vbMaximizedFocus
End If

'aufräumen
Set fsDatei = Nothing
Set Text = Nothing
Exit Sub

'Fehlerbehandlung
Hell:
Set fsDatei = Nothing
Set Text = Nothing
MsgBox "FehlerNr.: " & Err.Number & vbNewLine & vbNewLine _
        & "Beschreibung: " & Err.Description _
       , vbCritical, "da ist leider ein Fehler aufgetreten"

End Sub

Function umwandeln(Zellfarbe)
Dim Rot As Long, Gruen As Long, Blau As Long

Rot = Zellfarbe Mod 256
Zellfarbe = (Zellfarbe - Rot) / 256
Gruen = Zellfarbe Mod 256
Zellfarbe = (Zellfarbe - Gruen) / 256
Blau = Zellfarbe Mod 256

Hex_Farbe = Format(Hex(Rot), "00") & Format(Hex(Gruen), "00") & Format(Hex(Blau), "00")

End Function
Download:   vba040.zip
relevante Links:

top