CreateTableFromRecordset doesn't put data into table?

  • Thread starter Thread starter pietlinden
  • Start date Start date
P

pietlinden

I'm getting wise... I'm using CreateTableFromRecordset from ADH 2002
Desktop.

The only difference between what I am doing and what is done in the
book is that instead of sending a recordset to Word and converting it
to a table in a bookmark, I am sending it to a cell in an existing
table.

I can send it to the cell without a problem but then the
ConvertToTable command fails. I get a 2x2 nested table at the top of
each cell, and the delimited string never gets converted to a table.

Also, this only works *at all* if I comment out the code to include
field names.

Here's the code I am using:

Private Sub cmdCreateWordReport_Click()


Dim dtmStartTime As Date
Dim lngRetVal As Long ' for playsound api
'--Word variables
Dim boolWord As Boolean 'Quit Word?
Dim appWord As Word.Application
Dim docWord As Word.Document
Dim wrdRange As Word.Range
Dim rngAny As Word.Range
Dim aCell As Word.Cell
Dim aPara As Word.Paragraph

'--record start time (just for information...)
'--show the system is busy...
DoCmd.Hourglass True
dtmStartTime = Now

'--variables for processing the query objects
Dim cnn As ADODB.Connection
Dim cmd As ADODB.Command
Dim rsAny As ADODB.Recordset
Dim strObjectToOpen As String '---either the XTB table or a
select query

Dim aSelected() As Variant ' to put the selected items into the
array
Dim varItem As Variant ' to process the listbox items
Dim varFieldTypeList As Variant 'to format columns in the
table (store the field types, since they imply an alignment

' Show the "busy" label
Me.lblProcessing.Visible = True
Me.Repaint

Set appWord = New Word.Application
appWord.Documents.Add Application.CurrentProject.Path &
"\SummaryReport.dot"

Set docWord = appWord.ActiveDocument

With docWord.Bookmarks
.Item("StudyID").Range = GetCustomProperty("StudyID")
.Item("StudyID").Range.Bold = wdToggle
.Item("StudyManager").Range = GetCustomProperty
("StudyManager")
.Item("StudyTitle").Range = GetCustomProperty("StudyTitle")
.Item("StudyTitle").Range.Bold = wdToggle
End With

' Get details from database and create a table
' in the document
' Get an array filled with the selected items.
aSelected = mmp.SelectedItems

Set cnn = CurrentProject.Connection
Set rsAny = New ADODB.Recordset

For Each varItem In aSelected
'---the only queries that get into the collection are
dbQSelect and dbQCrosstab
If Left$(varItem, 2) = "--" Then
'it's a section, so put in the first column of the current
row
docWord.Tables(1).Cell(docWord.Tables(1).Rows.Count,
1).Range = Replace(varItem, "-", "")

Else
'--it's a normal query, so process as usual
If DBEngine(0)(0).QueryDefs(varItem).Type = dbQSelect Then
rsAny.Open varItem, cnn, adOpenStatic, adLockReadOnly,
adCmdStoredProc
Else
DBEngine(0)(0).Execute "DELETE * FROM
TEMP_XTB_RESULTS;", dbFailOnError
DBEngine(0)(0).Execute "qappXTB_to_TempTable",
dbFailOnError
rsAny.Open "TEMP_XTB_RESULTS", cnn, adOpenStatic,
adLockReadOnly, adCmdTable
End If

'-- Replace the underscores in query names with spaces
docWord.Tables(1).Cell(docWord.Tables(1).Rows.Count,
2).Range = Replace(varItem, "_", " ")

' this does not convert the delimited list in the cell to
a table.
' It does successfully write the delimited string into the
cell, though...

With CreateTableFromRecordset( _
docWord.Tables(1).Cell(docWord.Tables
(1).Rows.Count, 3).Range, _
rsAny, _
True)
End With
docWord.Tables(1).Rows.Add

If rsAny.State = adStateOpen Then
rsAny.Close
End If
End If

Next varItem

Set rsAny = Nothing

'--system is no longer busy!
DoCmd.Hourglass False
appWord.Visible = True


Set docWord = Nothing
Set appWord = Nothing

Me.SetFocus
Me.lblProcessing.Visible = False
Me.Repaint

lngRetVal = fPlayStuff("C:\WINDOWS\MEDIA\tada.wav")

MsgBox "Creating the report took " & DateDiff("s", dtmStartTime,
Now) & " seconds.", vbOKOnly + vbInformation

End Sub

For some odd reason, in the cells on which I use
CreateTableFromRecordset, I get a two-column nested table with nothing
in the cells and then a delimited list of the result of the GetString
command.

If I try to include the field names when I call the function, it
errors out in here...

For Each fldAny In rstAny.Fields
cField = cField + 1
.Cell(1, cField).Range.Text = fldAny.Name
Next

It throws "Error 5941: The requested member of the collection does not
exist." (Because rsAny is no longer open? But that doesn't make
sense, because the contents of the recordset get written to the
cell...)

Any clue what I am doing wrong?

Thanks!
Pieter
 
Pieter.

You need to reduce the range you're passing to the
CreateTableFromRecordset() function by one character.

Here's a demo you can paste into standard module in a word
document.
Create a 3-column table in the document.

Public Sub Demo()

' Examine the selected range after each
' Stop command.

Dim objTBL As Word.Table
Dim objRNG As Word.Range
Dim strData As String

strData = "R1C1,R1C2,R1C2" & vbNewLine & "R2C1,R2C2,R2C3"

Set objTBL = ActiveDocument.Tables(1)
Set objRNG = objTBL.Cell(objTBL.Rows.Count, 3).Range
objRNG.Select
Stop
objRNG.InsertAfter strData
objRNG.Select
Stop
objRNG.End = objRNG.End - 1
objRNG.Select
Stop
objRNG.ConvertToTable

Set objRNG = Nothing

End Sub


Regards
Geoff
 
Pieter.

You need to reduce the range you're passing to the
CreateTableFromRecordset() function by one character.

Here's a demo you can paste into standard module in a word
document.
Click to expand...

Geoff,

Great example! I figured the mess out... well, except for controlling
which table format is applied to the table, but I guess I should do
that in the Word template... Thanks for the excellent example!

Pieter
 
Okay, last question...

how do I set paragraph alignment inside a cell or for a range in a
table?

Here's my latest attempt...

Function CreateTableFromRecordset( _
rngQResult As Word.Range, _
rstAny As ADODB.Recordset, _
Optional fIncludeFieldNames As Boolean = False) _
As Word.Table

Dim objTable As Word.Table
Dim fldAny As ADODB.Field
Dim varData As Variant
Dim strBookmark As String
Dim cField As Long

' to align column data
Dim lngRow As Long, lngColumn As Long

' Get the data from the recordset
varData = rstAny.GetString()

' Create the table
With rngQResult
.End = .End - 1
'Stop
' Creating the basic table is easy,
' just insert the tab-delimted text
' add convert it to a table
.InsertAfter varData
.Select
'Stop
Set objTable = .ConvertToTable()

'seems to make sense to set the paragraph alignment here.
'rule:
' Left-align: Text
' Right-align: Currency, Numbers, Dates
'Stop
' Field names are more work since
' you must do them one at a time
If fIncludeFieldNames Then
With objTable
.AutoFormat ApplyBorders:=True, ApplyHeadingRows:=True
' Add a new row on top and make it a heading
.Rows.Add(.Rows(1)).HeadingFormat = True

' Iterate through the fields and add their
' names to the heading row
For Each fldAny In rstAny.Fields
cField = cField + 1
.Cell(1, cField).Range.Text = fldAny.Name
Next
End With
End If
End With

With objTable
For lngColumn = 1 To rstAny.Fields.Count

Select Case rstAny.Fields(lngColumn).Type
'Just process these as the default...
'Case adChar, adVarChar
' For lngRow = 1 To objTable.Rows.Count
' objTable.Cell(lngRow,
lngColumn).Range.Text.Alignment = wdAlignRowLeft
' Next lngRow
Case adNumeric, adDate, adCurrency
For lngRow = 2 To objTable.Rows.Count
objTable.Cell(lngRow,
lngColumn).Range.Text.Alignment = wdAlignRowRight
Next lngRow
Case Else
For lngRow = 2 To objTable.Rows.Count
objTable.Cell(lngRow,
lngColumn).Range.Text.Alignment = wdAlignRowLeft
Next lngRow
End Select

Next lngColumn
End With

Set CreateTableFromRecordset = objTable
End Function

Tried that, but it balks at the Alignment statements. Any idea what
the right syntax is? (Maybe I should buy a good book on Word
programming?!) Since I would really be formatting columns at a time,
can I just do something like setting the range to all the cells in
R2C2 to R10C2 (say) and then set the alignment that way? Or do you
*have* to process by rows?

Thanks!
Pieter
 
Pieter,

Here is a demo for formatting a Word table using VBA:

Public Sub Demo2()

' Paste this into a standard module
' in a blank Word document.

Dim objDOC As Word.Document
Dim objTBL As Word.Table
Dim objCOL As Word.Column
Dim objROW As Word.Row
Dim objRNG As Word.Range
Dim objCELL As Word.Cell
Dim objCELLRNG As Word.Range
Dim sngTabPos As Single
Dim strData As String

' Initialise data:
strData = "Name,Date of Birth,Amount (£)" & vbNewLine _
& "Marilyn Monroe,1/6/1926,10.00" & vbNewLine _
& "Don Murray,31/7/1929,100.00" & vbNewLine _
& "Guy Madison, 19/1/1922,1000.00"

' Initialise currency tab stop position
' for cells in currency column:
sngTabPos = CentimetersToPoints(1)

' Create a Word table at beginning of document:
Set objDOC = Word.ActiveDocument
Set objRNG = objDOC.Range
With objRNG
.Collapse wdCollapseStart
.Text = strData
Set objTBL = .ConvertToTable
End With

' Set basic table font:
With objTBL.Range.Font
.Name = "Verdana"
.Size = 8
.Bold = False
End With

' For column 1:
' Set horizontal alignment to left:
Set objCOL = objTBL.Columns(1)
For Each objCELL In objCOL.Cells
objCELL.Range.Paragraphs.Alignment = wdAlignParagraphLeft
Next

' For column 2, set horizontal alignment to right:
Set objCOL = objTBL.Columns(2)
For Each objCELL In objCOL.Cells
objCELL.Range.Paragraphs.Alignment =
wdAlignParagraphRight
Next

' For each cell in column 3 (currency),
' add a decimal tab stop, except in cell
' on first (heading) row:
Set objCOL = objTBL.Columns(3)
For Each objCELL In objCOL.Cells
' Skip row 1:
If objCELL.RowIndex <> 1 Then
Set objCELLRNG = objCELL.Range
With objCELLRNG
.ParagraphFormat.TabStops.Add sngTabPos, _
wdAlignTabDecimal
' Surprisingly, the next two code lines
' are not needed:
'.Collapse wdCollapseStart
'.Text = vbTab
End With
End If
Next

' For row 1, supersede above formatting:
' Set horizontal alignment to left;
' Set font to Arial, Bold, 9 point:
' Set vertical alignment to center;
Set objROW = objTBL.Rows(1)
For Each objCELL In objROW.Cells
With objCELL
With .Range
.Paragraphs.Alignment = wdAlignParagraphLeft
With .Font
.Name = "Arial"
.Bold = True
.Size = 9
End With
End With
.VerticalAlignment = wdCellAlignVerticalCenter
End With
Next

' Make table fit contents:
objTBL.AutoFitBehavior wdAutoFitContent

' Clean up:
Set objCELLRNG = Nothing
Set objCELL = Nothing
Set objRNG = Nothing
Set objROW = Nothing
Set objCOL = Nothing
Set objTBL = Nothing
Set objDOC = Nothing

End Sub


The best book on Microsoft Word programming that I've come across
is:

"Writing Word Macros"
Published by O'Reilly
ISBN 1-56592-725-7
The author is a furniture-maker by the name of Steven Roman.
And, by the way, he happens to be a professor of mathematics in
his spare time!

Regards
Geoff
(e-mail address removed)
 
Pieter,

By the way, the CentimetersToPoints() function is a function
built-in to Microsoft Word.

As you're running your code in Access, you might want to decide
on a single value and hard code it.

Using the Immediate window in Microsoft Word, these examples will
give you values:

?CentimetersToPoints(1)
28.34646
?InchesToPoints(1)
72
?InchesToPoints(0.5)
36

Regards
Geoff
 
Pieter,

To put borders around each cell in the table, add this code:

' Add table borders:
objTBL.Borders.Enable = True

Regards,
Geoff
 
Back
Top