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