|
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 = " "
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) = "&"
astrChars(1, 0) = "<": astrChars(1, 1) = "<"
astrChars(2, 0) = ">": astrChars(2, 1) = ">"
astrChars(3, 0) = Chr$(34): astrChars(3, 1) = """
astrChars(4, 0) = "'": astrChars(4, 1) = "'"
astrChars(5, 0) = "~": astrChars(5, 1) = "~"
astrChars(6, 0) = "Ä": astrChars(6, 1) = "Ä"
astrChars(7, 0) = "ä": astrChars(7, 1) = "ä"
astrChars(8, 0) = "Ö": astrChars(8, 1) = "Ö"
astrChars(9, 0) = "ö": astrChars(9, 1) = "ö"
astrChars(10, 0) = "Ü": astrChars(10, 1) = "Ü"
astrChars(11, 0) = "ü": astrChars(11, 1) = "ü"
astrChars(12, 0) = "ß": astrChars(12, 1) = "ß"
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
|
|