Dynamically create a RTF table with user defined rows, columns, column width, font, size, center, italic and/or
bold text attributes
Dynamically create a RTF table with user defined rows, columns, column width, font, size, center, italic and/or
bold text attributes
After creating the table and import it into a richtext field, you should probably delete the file from the users harddrive.
150 rows, 50 columns
Fonts: Times New Roman, Arial, MS Sans Serif, MS Kanji
Text attributes: bold, Italic, center
================================================= Object definition: ================================================= Properties: filename DefaultFontType DefaultFontSize DefaultColumnWidth DefaultTextBold DefaultTextItalic DefaultTextCenter Methods: New (rows as Integer, columns as Integer) SetColWidth(col As Integer, value As Integer) SetCellValue(row As Integer, column As Integer, value As String) SetCellValueCustom(row As Integer, col As Integer, value As String, fontsize As Integer, font As String, bold As Boolean, italic As Boolean, center as Boolean ) CreateTable ==================================== Example Code ==================================== Dim t As TableObject Set t = New TableObject(10,3) t.DefaultFontType = "MS Sans Serif" t.DefaultFontSize = 10 t.DefaultColumnWidth = 1000 t.DefaultTextBold = True t.DefaultTextItalic = False t.DefaultTextCenter = True t.SetColWidth 1, 5000 t.FileName = "c:\table.rtf" t.SetCellValueCustom 1,1,"Item", 25,"MS Sans Serif", True, False, False t.SetCellValueCustom 1,2,"Yes", 12,"Times New Roman", True, False, False t.SetCellValueCustom 2,1,"Some text", 20,"MS Kanji", True, False, False t.SetCellValueCustom 3,1,"Some more text", 15,"Arial", True, True, True t.SetCellValue 1,3,"No" t.CreateTable ===================================== Table Object class ===================================== Class TableObject Public fileName As String 'The output filename Public DefaultFontType As String Public DefaultFontSize As Integer Public DefaultColumnWidth As Integer Public DefaultTextBold As Integer Public DefaultTextItalic As Integer Public DefaultTextCenter As Integer numRows As Integer 'the number of rows numCols As Integer ' the num of cols colWidth(1 To 50) As Integer ' the colwidth rtfTable As String ColLoop As Integer RowLoop As Integer fileNum As Integer tablevalue(1 To 150,1 To 50) As String rowvalue As String 'Constructor sub Sub New (r As Integer, c As Integer) numRows = r numCols = c fileNum% = Freefile() defaultfonttype = "Times New Roman" defaultfontsize = 10 DefaultColumnWidth = 1000 DefaultTextBold = False DefaultTextItalic = False DefaultTextCenter = False filename = "c:\table.rtf" End Sub 'Destructor sub. Sub Delete Print "Deleting table object." Erase tablevalue Erase colWidth End Sub 'Set the value of each cell using default values Sub SetCellValue(r As Integer, c As Integer, v As String) Dim temp As String Dim fType As String If DefaultFontType = "Times New Roman" Then fType = "\f4" Elseif DefaultFontType = "Arial" Then ftype = "\f5" Elseif DefaultFontType = "MS Kanji" Then ftype = "\f6" Elseif font = "MS Sans Serif" Then ftype = "\f7" Else ftype = "\f4" End If temp = ftype & "\fs" & Cstr(defaultfontsize * 2) & " " If DefaultTextBold = True Then temp = temp + "\b " If DefaultTextItalic = True Then temp = temp + "\i " If DefaultTextCenter = True Then temp = temp + "\qc " temp = temp & v & " \plain " & ftype & "\fs" & Cstr(defaultFontSize * 2) tablevalue(r,c) = temp End Sub 'Set the value of each cell using custom values Sub SetCellValueCustom(r As Integer, c As Integer, v As String, size As Integer, font As String, bold As Integer, italic As Integer, center As Integer ) Dim temp As String Dim fType As String If font = "Times New Roman" Then fType = "\f4" Elseif font = "Arial" Then ftype = "\f5" Elseif font = "MS Kanji" Then ftype = "\f6" Elseif font = "MS Sans Serif" Then ftype = "\f7" Else ftype = "\f4" End If temp = ftype & "\fs" & Cstr(size * 2) & " " If bold = True Then temp = temp + "\b " If italic = True Then temp = temp + "\i " If center = True Then temp = temp + "\qc " temp = temp & v & "\plain " & ftype & "\fs" & Cstr(defaultFontSize * 2) tablevalue(r,c) = temp End Sub 'Set the width of column Sub SetColWidth(c As Integer, v As Integer) colWidth(c) = v End Sub 'Create the RTF table Sub CreateTable Dim ColWidthSum As Long Dim ColWidthValue As Long For ColLoop = 1 To NumCols If colWidth(ColLoop) = 0 Then ColWidthValue = DefaultColumnWidth Else ColWidthValue = colWidth(ColLoop) End If ColWidthSum = ColWidthSum + ColWidthValue cols = cols & "\cellx" & Cstr(ColWidthSum) Next header = "{\rtf1\ansi \deff4\deflang1033{\fonttbl{\f4\froman\fcharset0\fprq2 Times New " _ & "Roman;}{\f5\fswiss\fcharset0\fprq2 Arial;}{\f6\froman\fcharset128\fprq1 \'82\'6c\'82\'72 \'96\'be\'92\'a9;}{\f7\fswiss \fcharset128 MS Sans Serif;}}" _ & "{\colortbl;\red0\green0\blue0;\red0\green0\blue255;\red0\green255\blue255;\red0\green255\blue0;\red255\green0\blue2" _ & "55;\red255\green0\blue0;\red255\green255\blue0;\red255\green255\blue255;\red0\green0\blue128;\red0\green128\blue128;\red0\" _ & "green128\blue0;\red128\green0\blue128;\red128\green0\blue0;\red128\green128\blue0;\red128\green128\blue128;\red192\green" _ & "192\blue192;}{\stylesheet{\widctlpar \f4\fs20 \snext0 Normal;}{\*\cs10 \additive Default Paragraph " _ & "Font;}}\paperw11906\paperh16838 \widowctrl\ftnbj\aenddoc\formshade \fet0\sectd " _ & "\linex0\headery709\footery709\colsx709\endnhere {\*\pnseclvl1\pnucrm\pnstart1\pnindent720\pnhang{\pntxta .}}{\*\pnseclvl2 " _ & "\pnucltr\pnstart1\pnindent720\pnhang{\pntxta .}}{\*\pnseclvl3\pndec\pnstart1\pnindent720\pnhang{\pntxta " _ & ".}}{\*\pnseclvl4\pnlcltr\pnstart1\pnindent720\pnhang{\pntxta )}}{\*\pnseclvl5\pndec\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta " _ & ")}}{\*\pnseclvl6 \pnlcltr\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta " _ & ")}}{\*\pnseclvl7\pnlcrm\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta " _ & ")}}{\*\pnseclvl8\pnlcltr\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta )}}{\*\pnseclvl9\pnlcrm\pnstart1\pnindent720\pnhang " _ & "{\pntxtb (}{\pntxta )}} " For RowLoop = 1 To NumRows rowValue = "" For ColLoop = 1 To NumCols rowValue = rowValue & " " & tableValue(RowLoop,ColLoop) & "\cell " Next If RowLoop = 1 Then tbl = cols & "\trowd \trgaph108\trleft-108 \plain \widctlpar\intbl \f4\fs20" & rowValue & "\pard \widctlpar\intbl " Else tbl = tbl & "\row \trowd \trgaph108\trleft-108 " & cols & " \pard \widctlpar\intbl" & rowValue & "\pard \widctlpar\intbl " End If If RowLoop = NumRows Then tbl = tbl & "\row \pard \widctlpar \par }" Next rtfTable = header & tbl Open fileName$ For Output As fileNum% Print #fileNum%, rtfTable Close fileNum% End Sub End Class |