Tipp 0369 Excel-Tabellen in HTML exportieren
Autor/Einsender:
Datum:
  Angie
07.12.2003
Entwicklungsumgebung:   Excel 97
Fügt man eine Excel-Tabelle per Zwischenablage in Frontpage ein, entsteht ein HTML-Code, der extrem viele Formatierungsanweisungen enthält, die unter Umständen zu unerwünschten Effekten führen können. Folgendes Beispiel zeigt, wie man den verwendeten Bereich der aktiven Tabelle als HTML-Code exportieren kann, hier werden auch ggf. verbundene Zellen berücksichtigt.
 
Option Explicit

Private Const mc_DOC_TITLE As String = _
          "Excel-Tabellen in HTML exportieren"
Private astrChars() As String

Public Sub CreateHTMLFile()
  Dim objWkb          As Workbook
  Dim objSheet        As Object

  Dim strHTMLFileName As String
  Dim strHTML         As String

  Dim nRows           As Long
  Dim nCols           As Integer
  Dim rngRange        As Range

  Set objWkb = ActiveWorkbook
  Set objSheet = ActiveSheet

  If Not UCase$(TypeName(objSheet)) = "WORKSHEET" Then
    MsgBox "In diesem Beispiel ist nur der Export eines " & _
          "Tabellenblatts möglich !", vbOKOnly + vbInformation, _
          Title:=mc_DOC_TITLE

    Set objSheet = Nothing
    Set objWkb = Nothing
    Exit Sub
  End If

  With objSheet
    If Application.WorksheetFunction.CountA(.Cells) > 0 Then
      nRows = .Cells.Find(What:="*", After:=.Cells(1, 1), _
                  SearchOrder:=xlByRows, _
                  SearchDirection:=xlPrevious).Row

      nCols = .Cells.Find(What:="*", After:=.Cells(1, 1), _
                  SearchOrder:=xlByColumns, _
                  SearchDirection:=xlPrevious).Column

      Set rngRange = .Cells(1, 1).Resize(nRows, nCols)

    Else
      MsgBox "In dem Tabellenblatt '" & objSheet.Name & _
            "' sind keine Daten vorhanden!", _
            vbOKOnly + vbInformation, Title:=mc_DOC_TITLE
    End If
  End With

  If Not rngRange Is Nothing Then
    strHTMLFileName = GetHTMLFileName(objWkb, objSheet)
    If Len(strHTMLFileName) = 0 Then
      MsgBox "Bitte zuerst die aktive Arbeitsmappe speichern!", _
            vbOKOnly + vbInformation, Title:=mc_DOC_TITLE
      Exit Sub
    End If

    ExportRangeToHTML rngRange, strHTMLFileName, "80%", 4, 4, 1
    Set rngRange = Nothing
  End If

  Set objSheet = Nothing
  Set objWkb = Nothing
End Sub

Private Function GetHTMLFileName(ByVal WKB As Workbook, _
      Optional ByVal WKS As Worksheet) As String

  Dim strPath     As String
  Dim strFilename As String
  Dim nPos        As Long

  strPath = WKB.Path

  If Len(strPath) <> 0 Then
    If Right$(strPath, 1) <> "\" Then strPath = strPath & "\"
    strFilename = WKB.Name
    #If VBA6 Then
      nPos = VBA.InStrRev(strFilename, ".")
    #Else
      nPos = InStrRev(strFilename, ".")
    #End If
    If nPos > 0 Then
      strFilename = Left$(strFilename, nPos - 1)
    End If

    If Not WKS Is Nothing Then
      strFilename = strFilename & "_" & WKS.Name
    End If

    GetHTMLFileName = strPath & strFilename & ".html"
  End If
End Function

Private Sub ExportRangeToHTML(ByVal vrngData As Range, _
      ByVal vsFileName As String, _
      Optional ByVal vsTableWidth As String, _
      Optional ByVal viTableBorder As Integer, _
      Optional ByVal viCellPadding As Integer, _
      Optional ByVal viCellSpacing As Integer)

  Const HTML_BLANK    As String = "&nbsp;"
  Const DQUOTES       As String = """quot;

  Dim FN              As Integer

  Dim strHTML         As String
  Dim strAttributes   As String

  Dim nRows           As Long
  Dim nCols           As Integer
  Dim lngRow          As Long
  Dim intCol          As Integer

  Dim rngCell         As Range
  Dim nRowsMerged     As Integer
  Dim nColsMerged     As Integer
  Dim blnCellMerged   As Boolean

  Dim strCellText     As String
  Dim blnFontBold     As Boolean
  Dim blnFontItalic   As Boolean
  Dim lngCellHAlign   As Long

  On Error GoTo err_ExportRangeToHTML
  FN = FreeFile
  Open vsFileName For Output As #FN
  On Error GoTo 0

  strAttributes = "Von Excel per VBA exportiert: " & _
        vrngData.Address(External:=True)
  Print #FN, "<!--" & strAttributes & "-->"

  Print #FN, "<html>"
  Print #FN, "<head>"
  Print #FN, "<title>" & mc_DOC_TITLE & "</title>"
  Print #FN, "</head>"
  Print #FN,

  Print #FN, "<body>"
  Print #FN, "<h1><center>" & mc_DOC_TITLE & "</center></h1>"

  Print #FN, "<hr>"
  Print #FN,

  Print #FN, "<!--##TableBegin##-->"
  Print #FN, "<center>"

  strHTML = "<table"
  If Len(vsTableWidth) > 0 Then
    strHTML = strHTML & " width=" & _
          DQUOTES & vsTableWidth & DQUOTES
  End If

  strHTML = strHTML & " border=" & DQUOTES & _
        CStr(viTableBorder) & DQUOTES

  strHTML = strHTML & " cellpadding=" & DQUOTES & _
        CStr(viCellPadding) & DQUOTES

  strHTML = strHTML & " cellspacing=" & DQUOTES & _
        CStr(viCellSpacing) & DQUOTES

  strHTML = strHTML & ">"
  Print #FN, strHTML

  With vrngData
    nRows = .Rows.Count
    nCols = .Columns.Count
  End With

  InitReplaceCharsHTML

  For lngRow = 1 To nRows
    Print #FN, Space(2) & "<tr>"

    For intCol = 1 To nCols
      strHTML = Space(4)

      Set rngCell = vrngData.Cells(lngRow, intCol)
      On Error Resume Next
      lngCellHAlign = 0
      With rngCell
        strCellText = Trim(.Text)
        blnFontBold = .Font.Bold
        blnFontItalic = .Font.Italic
        lngCellHAlign = .HorizontalAlignment
      End With
      On Error GoTo 0

      strAttributes = ""
      blnCellMerged = False

      If Not rngCell.MergeArea.Address = rngCell.Address Then
        If rngCell.Address = _
                rngCell.MergeArea.Cells(1).Address Then

          nColsMerged = rngCell.MergeArea.Columns.Count
          If nColsMerged > 1 Then
            strAttributes = " colspan=" & CStr(nColsMerged)
          End If

          nRowsMerged = rngCell.MergeArea.Rows.Count
          If nRowsMerged > 1 Then
            strAttributes = strAttributes & _
                " rowspan=" & CStr(nRowsMerged)
          End If
        Else
          blnCellMerged = True
        End If
      End If

      If Not blnCellMerged Then
        If lngCellHAlign = xlHAlignGeneral Then
          If Len(strCellText) > 0 Then
            Select Case Asc(strCellText)
                Case 45, 48 To 57
                    lngCellHAlign = xlHAlignRight
            End Select
          End If
        End If

        If lngCellHAlign = xlHAlignCenter Then
            strAttributes = strAttributes & " align=""center"""
        End If

        If lngCellHAlign = xlHAlignRight Then
            strAttributes = strAttributes & " align=""right"""
        End If

        strHTML = strHTML & "<td" & strAttributes & ">"

        If Len(strCellText) = 0 Then
            strCellText = HTML_BLANK
        End If

        If blnFontBold Then strHTML = strHTML & "<b>"
        If blnFontItalic Then strHTML = strHTML & "<i>"

        strHTML = strHTML & ReplaceCharsHTML(strCellText, True)

        If blnFontItalic Then strHTML = strHTML & "</i>"
        If blnFontBold Then strHTML = strHTML & "</b>"

        strHTML = strHTML & "</td>"
        Print #FN, strHTML
      End If
    Next

    Print #FN, Space(2) & "</tr>"
  Next

  Print #FN, "</table>"
  Print #FN, "</center>"
  Print #FN, "<!--##TableEnd##-->"
  Print #FN,

  Print #FN, "<hr>"
  Print #FN,

  Print #FN, "<font size=-1><i>"
  Print #FN, "<br>Letzte Aktualisierung am " & CStr(Date)
  Print #FN, "<br>durch " & Application.UserName
  Print #FN, "<font size=+0></i>"
  Print #FN,

  Print #FN, "</body>"

  strAttributes = "ENDE - Von Excel per VBA exportiert: " & _
        vrngData.Address(External:=True)
  Print #FN, "<!--" & strAttributes & "-->"

  Print #FN, "</html>"
  Close #FN

  Exit Sub

err_ExportRangeToHTML:
  MsgBox "Fehlernummer " & Err.Number & Chr$(13) & Error$(Err), _
            vbCritical, "Fehler"
End Sub

Private Sub InitReplaceCharsHTML()
  ReDim astrChars(0 To 12, 0 To 1)

  astrChars(0, 0) = "&":        astrChars(0, 1) = "&amp;"
  astrChars(1, 0) = "<":        astrChars(1, 1) = "&lt;"
  astrChars(2, 0) = ">":        astrChars(2, 1) = "&gt;"
  astrChars(3, 0) = Chr$(34):   astrChars(3, 1) = "&quot;"
  astrChars(4, 0) = "'":        astrChars(4, 1) = "&#39;"
  astrChars(5, 0) = "~":        astrChars(5, 1) = "&#126;"
  astrChars(6, 0) = "Ä":        astrChars(6, 1) = "&Auml;"
  astrChars(7, 0) = "ä":        astrChars(7, 1) = "&auml;"
  astrChars(8, 0) = "Ö":        astrChars(8, 1) = "&Ouml;"
  astrChars(9, 0) = "ö":        astrChars(9, 1) = "&ouml;"
  astrChars(10, 0) = "Ü":       astrChars(10, 1) = "&Uuml;"
  astrChars(11, 0) = "ü":       astrChars(11, 1) = "&uuml;"
  astrChars(12, 0) = "ß":       astrChars(12, 1) = "&szlig;"
End Sub

Private Function ReplaceCharsHTML(ByVal vsTextIn As String, _
      ByVal vTextToHTML As Boolean) As String

  Dim strFind     As String
  Dim strReplace  As String

  Dim i           As Integer
  Dim nPos        As Integer
  Dim nStart      As Integer

  For i = 0 To UBound(astrChars)
    If vTextToHTML Then
      strFind = astrChars(i, 0)
      strReplace = astrChars(i, 1)
    Else
      strFind = astrChars(i, 1)
      strReplace = astrChars(i, 0)
    End If

    If (Len(strFind) <> 0) And (strFind <> strReplace) Then
      nPos = InStr(1, vsTextIn, strFind, vbBinaryCompare)
      Do While nPos > 0
        vsTextIn = Left$(vsTextIn, nPos - 1) & strReplace & _
              Mid$(vsTextIn, nPos + Len(strFind))

        nStart = nPos + Len(strReplace)
        nPos = InStr(nStart, vsTextIn, strFind, vbBinaryCompare)
      Loop
    End If
  Next
  ReplaceCharsHTML = vsTextIn
End Function
 

Windows-Version
95
98/SE
ME
NT
2000
XP
Vista
Win 7
Excel-Version
95
97
2000
2002 (XP)
2003
2007
2010


Download  (40,2 kB) Downloads bisher: [ 993 ]

Vorheriger Tipp Zum Seitenanfang Nächster Tipp

Startseite | Projekte | Tutorials | API-Referenz | VB-/VBA-Tipps | Komponenten | Bücherecke | VB/VBA-Forum | VB.Net-Forum | DirectX-Forum | Foren-Archiv | DirectX | VB.Net-Tipps | Chat | Spielplatz | Links | Suchen | Stichwortverzeichnis | Feedback | Impressum

Seite empfehlen Bug-Report
Letzte Aktualisierung: Montag, 29. August 2011