Thomas Risi Softwareentwicklung

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.


Quellcode für Beispiel-Verwendung ...

Option Explicit Dim rc As cRangeConverter Sub Test() Set rc = New cRangeConverter ' Einstellungen für HTML-Mode. rc.DisplayGrid = True rc.DisplayHeader = True rc.DisplayFormulas = True ' Konvertiert den Bereich in's HTML-Format, und kopiert ihn in die Zwischenablage. 'rc.StringToClipboard rc.RangeToHTML(Selection) ' Erstellt eine HTML-Datei mit dem Bereich. rc.WriteRangeToFile rc.RangeToHTML(Selection), FILETYPE_HTML ' Erstellt eine CSV-Datei mit dem Bereich. 'rc.WriteRangeToFile rc.RangeToCSV(Selection), FILETYPE_CSV ' Erstellt eine TXT-Datei mit dem Bereich. 'rc.WriteRangeToFile rc.RangeToText(Selection), FILETYPE_TXT Set rc = Nothing End Sub

Quellcode für Klassenmodul ...

' Klasse cRangeConverter ' ' Konvertiert Excelbereiche in Dateien (CSV, HTM und TXT), bzw. kopiert die Daten in die Zwischenablage. ' ' Autor(en) Risi Thomas ' ' Erstellt 05.06.2005 ' Überarbeitet 12.06.2005 ' ' Version 0.2 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) & ">" & "&nbsp;" _ & "</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) ' Standard-HTML 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 = "&nbsp;" 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: ' CSV Open m_FilePath & Application.PathSeparator & m_FileName & ".csv" For Binary As f Put f, , s Close Case 1: ' TXT Open m_FilePath & Application.PathSeparator & m_FileName & ".txt" For Binary As f Put f, , s Close Case 2: ' HTML 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 = "" 'Application.StandardFont m_StandardFontSize = TAB_TEXTSIZE m_BorderLine = TAB_CELLBORDER m_FileName = FIL_DEFAULTNAME m_FilePath = FIL_DEFAULTPATH End Sub

Bewerten Sie bitte dieses Programm.
1 2 3 4 5
Weniger nützlich Sehr nützlich
Bitte teilen Sie uns mit, warum Sie das Programm so bewertet haben. (optional)