Thomas Risi Softwareentwicklung
Addins - Datenbanklösungen - Komponenten - RTDServer - WebServices
cRangeConverter
Eine Klasse, die Ihnen einiges bietet ...
Man kann damit Bereiche aus Excel-Arbeitsmappen als Dateien (CSV, HTM und TXT) abspeichern. Oder
den Bereich in einer HTML-Tabelle darstellen, zur Verwendung mit HTML-Dokumenten (u.v.m.).
Fügen Sie in Ihr VBA-Projekt ein neues Klassenmodul hinzu, und bennenen Sie es mit cRangeConverter. Dann den
Quellcode für die Klassen einfügen. Verwendet wird die Klasse, wie im Beispiel gezeigt.
Wenn Sie eine nützliche Erweiterung/Verbesserung haben, schreiben Sie mir und ich füge es an. Sie werden dann
unter den AUTOREN der Klasse verewiglicht.
Quellcode für Beispiel-Verwendung ...
Option Explicit
Dim rc As cRangeConverter
Sub Test()
Set rc = New cRangeConverter
rc.DisplayGrid = True
rc.DisplayHeader = True
rc.DisplayFormulas = True
rc.WriteRangeToFile rc.RangeToHTML(Selection), FILETYPE_HTML
Set rc = Nothing
End Sub
Quellcode für Klassenmodul ...
Option Explicit
Private Declare Function OpenClipboard Lib "user32" ( _
ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function SetClipboardData Lib "user32" ( _
ByVal wFormat As Long, _
ByVal hMem As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32" ( _
ByVal wFlags As Long, _
ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" ( _
ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" ( _
ByVal hMem As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" ( _
ByVal hMem As Long) As Long
Private Declare Function lstrcpy Lib "kernel32" ( _
ByVal lpStr1 As Any, _
ByVal lpStr2 As Any) As Long
Private Const CF_TEXT As Long = 1&
Private Const GMEM_MOVEABLE As Long = 2&
Private Const MAX_CHARS = 20
Private Const TAB_CHARS = 4
Private Const TAB_CELLBORDER = 1
Private Const TAB_CELLSPACING = 0
Private Const TAB_HEADERALIGNEMENT = "center"
Private Const TAB_HEADERVALIGNEMENT = "bottom"
Private Const TAB_HEADERCOLOR = "#EBEBEB"
Private Const TAB_HEADERFONT = "Arial"
Private Const TAB_HEADERHEIGHT = 11
Private Const TAB_TEXTDISTANCE = 0
Private Const TAB_TEXTSIZE = 12
Private Const LST_FONT = "Arial"
Private Const FIL_DEFAULTNAME = "Excelbereich"
Private Const FIL_DEFAULTPATH = "C:"
Public Enum FILETYPE_RC
FILETYPE_CSV = 0
FILETYPE_TXT
FILETYPE_HTML
End Enum
Private m_StandardFont As String
Private m_StandardFontSize As String
Private m_DisplayFormulas As Boolean
Private m_DisplayGrid As Boolean
Private m_DisplayHeader As Boolean
Private m_BorderLine As Integer
Private m_FileName As String
Private m_FilePath As String
Public Property Let FileName(Val As String)
m_FileName = Val
End Property
Public Property Get FileName() As String
FileName = m_FileName
End Property
Public Property Let FilePath(Val As String)
m_FilePath = Val
End Property
Public Property Get FilePath() As String
FilePath = m_FilePath
End Property
Public Property Let DisplayFormulas(Val As Boolean)
m_DisplayFormulas = Val
End Property
Public Property Get DisplayFormulas() As Boolean
DisplayFormulas = m_DisplayFormulas
End Property
Public Property Let DisplayGrid(Val As Boolean)
m_DisplayGrid = Val
If Val Then
m_BorderLine = TAB_CELLBORDER
Else
m_BorderLine = 0
End If
End Property
Public Property Get DisplayGrid() As Boolean
DisplayGrid = m_DisplayGrid
End Property
Public Property Let DisplayHeader(Val As Boolean)
m_DisplayHeader = Val
End Property
Public Property Get DisplayHeader() As Boolean
DisplayHeader = m_DisplayHeader
End Property
Public Function RangeToText(rng As Excel.Range, Optional Delimiter As String = vbTab) As String
Dim chars As String * MAX_CHARS
Dim result As String
Dim i&, j&
For i = 1 To rng.Rows.Count
For j = 1 To rng.Columns.Count
chars = rng(i, j)
result = result & chars & Delimiter
Next
result = Trim$(result) & vbCrLf
Next
RangeToText = result
End Function
Public Function RangeToCSV(rng As Excel.Range, Optional Delimiter = ";") As String
Dim result As String
Dim i&, j&
For i = 1 To rng.Rows.Count
For j = 1 To rng.Columns.Count
result = result & rng(i, j) & Delimiter
Next
result = result & vbCrLf
Next
RangeToCSV = result
End Function
Public Function RangeToHTML(rng As Excel.Range) As String
Dim tabchars As String: tabchars = Space(TAB_CHARS)
Dim result As String
Dim i&, j&
result = "<table border=" & Chr$(34) & m_BorderLine & Chr$(34) & " cellspacing=" & Chr$(34) & TAB_CELLSPACING & Chr$(34) & ">" & vbCrLf
If m_DisplayHeader Then
result = result & tabchars & "<tr>" & vbCrLf
For i = 0 To rng.Columns.Count
If i = 0 Then
result = result & tabchars & tabchars & "<td" _
& " width=" & Chr$(34) & "20" & Chr$(34) _
& " height="& Chr$(34) & TAB_HEADERHEIGHT & Chr$(34) _
& " bgcolor=" & Chr$(34) & TAB_HEADERCOLOR & Chr$(34) & ">" & " " _
& "</td>" & vbCrLf
Else
result = result & tabchars & tabchars & "<td" _
& GetCellWidth(rng(1, i)) _
& " height=" & Chr$(34) & TAB_HEADERHEIGHT & Chr$(34) _
& " bgcolor=" & Chr$(34) & TAB_HEADERCOLOR & Chr$(34) _
& " align=" & Chr$(34) & TAB_HEADERALIGNEMENT & Chr$(34) & ">" _
& "<font size=" & Chr$(34) & "2" & Chr$(34) & " face=" & Chr$(34) & TAB_HEADERFONT & Chr$(34) & "><b>" _
& GetCellColumn(rng(1, i)) & "</b></font>" _
& "</td>" & vbCrLf
End If
Next
result = result & tabchars & "</tr>" & vbCrLf
End If
For i = 1 To rng.Rows.Count
result = result & tabchars & "<tr>" & vbCrLf
If m_DisplayHeader Then
result = result & tabchars & tabchars & "<td" _
& " width=" & Chr$(34) & "20" & Chr$(34) _
& " height=" & Chr$(34) & TAB_HEADERHEIGHT & Chr$(34) _
& " bgcolor=" & Chr$(34) & TAB_HEADERCOLOR & Chr$(34) _
& " align=" & Chr$(34) & TAB_HEADERALIGNEMENT & Chr$(34) _
& " valign=" & Chr$(34) & TAB_HEADERVALIGNEMENT & Chr$(34) & ">" _
& "<font size=" & Chr$(34) & "2" & Chr$(34) & " face=" & Chr$(34) & TAB_HEADERFONT & Chr$(34) & "><b>" _
& GetCellRow(rng(i, 1)) & "</b></font>" _
& "</td>" & vbCrLf
End If
For j = 1 To rng.Columns.Count
result = result & tabchars & tabchars & "<td" _
& GetCellWidth(rng(i, j)) _
& GetCellHeight(rng(i, j)) _
& GetCellColor(rng(i, j)) _
& GetCellHorizontalAlignment(rng(i, j)) _
& GetCellVerticalAlignment(rng(i, j)) _
& ">" _
& GetCellFormat(rng(i, j)) _
& "</td>" & vbCrLf
Next
result = result & tabchars & "</tr>" & vbCrLf
Next
result = result & "</table>" & vbCrLf & vbCrLf
If m_DisplayFormulas Then
result = result & "<ul>" & vbCrLf
For i = 1 To rng.Columns.Count
For j = 1 To rng.Rows.Count
If rng(i, j).HasFormula Then
result = result & tabchars _
& "<li><b><font face=" & Chr$(34) & LST_FONT & Chr$(34) & ">" _
& rng(i, j).Address(False, False) & " " & rng(i, j).FormulaLocal _
& "</b></font></li>" & vbCrLf
End If
Next
Next
result = result & "</ul>" & vbCrLf
End If
RangeToHTML = result
End Function
Private Function VBColor2HTML(ByVal Color As Long) As String
Dim r%, g%, b%
r = Color And &HFF&
g = Color \ &H100& And &HFF&
b = Color \ &H10000 And &HFF&
VBColor2HTML = RGB2HTML(r, g, b)
End Function
Private Function RGB2HTML(ByVal r As Integer, ByVal g As Integer, ByVal b As Integer) As String
RGB2HTML = CHex(r, 2) + CHex(g, 2) + CHex(b, 2)
End Function
Private Function CHex(ByVal nValue As Long, Optional ByVal n As Integer = 0) As String
Dim sHex As String
sHex = Hex$(nValue)
If n > 0 And Len(sHex) < n Then
sHex = String(n - Len(sHex), "0") + sHex
End If
CHex = sHex
End Function
Private Function GetCellColor(rng As Excel.Range) As String
If Not rng.Interior.ColorIndex = Excel.xlNone Then _
GetCellColor = " bgcolor=" & Chr$(34) & "#" & VBColor2HTML(rng.Interior.Color) & Chr$(34)
End Function
Private Function GetCellFontColor(rng As Excel.Range) As String
If Not rng.Font.ColorIndex = Excel.xlAutomatic Then _
GetCellFontColor = " color=" & Chr$(34) & "#" & VBColor2HTML(rng.Font.Color) & Chr$(34)
End Function
Private Function GetCellFontFace(rng As Excel.Range) As String
GetCellFontFace = " face=" & Chr$(34) & rng.Font.Name & Chr$(34)
End Function
Private Function GetCellFontSize(rng As Excel.Range) As String
If Not rng.Font.Size = m_StandardFontSize Then
Select Case CInt(rng.Font.Size)
Case 1 To 8: GetCellFontSize = " size=" & Chr$(34) & "1" & Chr$(34)
Case 9 To 10: GetCellFontSize = " size=" & Chr$(34) & "2" & Chr$(34)
Case 11 To 12: GetCellFontSize = " size=" & Chr$(34) & "3" & Chr$(34)
Case 13 To 14: GetCellFontSize = " size=" & Chr$(34) & "4" & Chr$(34)
Case 15 To 18: GetCellFontSize = " size=" & Chr$(34) & "5" & Chr$(34)
End Select
End If
End Function
Private Function GetCellHorizontalAlignment(rng As Excel.Range) As String
If Not rng.HorizontalAlignment = Excel.xlLeft Then
If rng.HorizontalAlignment = Excel.xlRight Then
GetCellHorizontalAlignment = " align=" & Chr$(34) & "right" & Chr$(34)
ElseIf rng.HorizontalAlignment = Excel.xlCenter Then
GetCellHorizontalAlignment = " align=" & Chr$(34) & "center" & Chr$(34)
End If
End If
End Function
Private Function GetCellVerticalAlignment(rng As Excel.Range) As String
If Not rng.VerticalAlignment = Excel.xlCenter Then
If rng.VerticalAlignment = Excel.xlBottom Then
GetCellVerticalAlignment = " valign=" & Chr$(34) & "bottom" & Chr$(34)
ElseIf rng.VerticalAlignment = Excel.xlTop Then
GetCellVerticalAlignment = " valign=" & Chr$(34) & "top" & Chr$(34)
End If
End If
End Function
Private Function GetCellFormat(rng As Excel.Range) As String
Dim result As String
If Not rng.Value = "" Then
result = rng.Value
Else
result = " "
End If
If Not rng.Font.Underline = Excel.xlNone Then _
result = "<u>" & result & "</u>"
If rng.Font.Bold Then _
result = "<b>" & result & "</b>"
If rng.Font.Italic Then _
result = "<i>" & result & "</i>"
If Not rng.Font.Name = m_StandardFont Or _
Not rng.Font.ColorIndex = -4105 Or _
Not rng.Font.Size = m_StandardFontSize Then _
result = "<font" & GetCellFontFace(rng) _
& GetCellFontColor(rng) _
& GetCellFontSize(rng) _
& ">" & result & "</font>"
GetCellFormat = result
End Function
Private Function GetCellColumn(rng As Excel.Range) As String
Dim a: a = Split(rng.Address(True, False), "$")
GetCellColumn = a(0)
End Function
Private Function GetCellRow(rng As Excel.Range) As String
Dim a: a = Split(rng.Address(True, False), "$")
GetCellRow = a(1)
End Function
Private Function GetCellWidth(rng As Excel.Range) As String
GetCellWidth = " width=" & Chr$(34) & rng.Width & Chr$(34)
End Function
Private Function GetCellHeight(rng As Excel.Range) As String
GetCellHeight = " height=" & Chr$(34) & rng.Height & Chr$(34)
End Function
Public Sub StringToClipboard(s As String)
Dim hMem As Long
Dim hPtr As Long
hMem = GlobalAlloc(GMEM_MOVEABLE, Len(s) + 1)
hPtr = GlobalLock(hMem)
lstrcpy hPtr, s
GlobalUnlock hMem
OpenClipboard 0&
EmptyClipboard
SetClipboardData CF_TEXT, hMem
CloseClipboard
GlobalFree hMem
End Sub
Public Sub WriteRangeToFile(s As String, t As FILETYPE_RC)
Dim f&: f = FreeFile
Select Case t
Case 0:
Open m_FilePath & Application.PathSeparator & m_FileName & ".csv" For Binary As f
Put f, , s
Close
Case 1:
Open m_FilePath & Application.PathSeparator & m_FileName & ".txt" For Binary As f
Put f, , s
Close
Case 2:
Open m_FilePath & Application.PathSeparator & m_FileName & ".htm" For Binary As f
Put f, , MakeHTML(s)
Close
End Select
End Sub
Private Function MakeHTML(s As String) As String
Dim result As String
result = "<!doctype html public " & Chr$(34) & "-//W3C//DTD HTML 4.0 Transitional//EN" & Chr$(34) & ">" & vbCrLf
result = result & vbCrLf
result = result & "<html>" & vbCrLf & vbCrLf
result = result & "<head>" & vbCrLf
result = result & "</head>" & vbCrLf & vbCrLf
result = result & "<body>" & vbCrLf & vbCrLf
result = result & s & vbCrLf & vbCrLf
result = result & "</body>" & vbCrLf & vbCrLf
result = result & "</html>"
MakeHTML = result
End Function
Private Sub Class_Initialize()
m_DisplayFormulas = False
m_DisplayGrid = True
m_DisplayHeader = False
m_StandardFont = ""
m_StandardFontSize = TAB_TEXTSIZE
m_BorderLine = TAB_CELLBORDER
m_FileName = FIL_DEFAULTNAME
m_FilePath = FIL_DEFAULTPATH
End Sub
© 2001 -
by Thomas Risi