Solved

Word 2007 Automation - Adding Multiple Tables using VBA

Posted on 2010-09-01
5
2,290 Views
Last Modified: 2012-05-10
Hi all,

I'm trying to add multiple tables to a word document.  The first table works fine but I cannot get any further tables added properly... any help would be appreciated. Code is attached.  I assumed I would create a table then move to the end of the document then create another table etc.  


'*****EARLY BINDING

Dim objWord As Word.Application

Dim objDoc As Word.Document

Dim objTable As Word.Table

Dim objRange As Word.Range

'Create Word Instance

Set objWord = New Word.Application

'Create doc

Set objDoc = objWord.Documents.Add

objWord.Visible = True

objWord.Activate

'*****END EARLY BINDING -



'START TYPING

objWord.Selection.Font.Bold = True

objWord.Selection.TypeText "Projects"



objWord.Selection.TypeParagraph



'***Add Header



'***Add Projects*********************************************************************

rst.Open "SELECT Name, Start_Date FROM tblProject WHERE Plan_Year = 2010 AND FKEYProjectType=1 ORDER BY Name ASC", CurrentProject.Connection, adOpenKeyset, adLockOptimistic

i = rst.RecordCount



'Create Table

Set objRange = objWord.Selection.Range

Set objTable = objDoc.Tables.Add(objRange, i + 1, 3)

'Setup Table properties

With objTable

    .AllowAutoFit = True

    .AutoFitBehavior wdAutoFitContent

    .BottomPadding = 0

    .TopPadding = 0

    .Rows.SetHeight 13, wdRowHeightExactly

    .Range.Font.Bold = False

'    .Columns(3).SetWidth 0.2, wdAdjustNone

End With



'Load Values into the table

objTable.Cell(1, 1).Range.InsertAfter "PROJECT NAME"

objTable.Cell(1, 2).Range.InsertAfter "START DATE"

With objWord.Selection.Font

    .Bold = True

    .Size = 9

End With



While Not rst.EOF

For x = 1 To i



    objTable.Cell(x + 1, 1).Range.InsertAfter x & ") " & rst.Fields("Name")

    objTable.Cell(x + 1, 2).Range.InsertAfter Nz(rst.Fields("Start_Date"), "NO START")



    rst.MoveNext



Next x

Wend

'ADD NEXT TABLE - Move to the end of the document to add the next table

objWord.ActiveDocument.Characters.Last.Select

objWord.Selection.Collapse

    With objRange

        .Collapse Direction:=wdCollapseEnd

        .MoveEnd

        .InsertParagraphAfter

        .Collapse Direction:=wdCollapseEnd

    End With

'***Add Road Construction

rst.Close

rst.Open "SELECT Name FROM tblVendor WHERE IsRoadSide = 1 ORDER BY Name ASC", CurrentProject.Connection, adOpenKeyset, adLockOptimistic

i = rst.RecordCount



'Create Table

Set objTable = objDoc.Tables.Add(objRange, i + 1, 2)

'Setup Table properties

With objTable

    .AllowAutoFit = True

    .AutoFitBehavior wdAutoFitContent

    .BottomPadding = 0

    .TopPadding = 0

    .Rows.SetHeight 13, wdRowHeightExactly

    .Range.Font.Bold = False

'    .Columns(3).SetWidth 0.2, wdAdjustNone

End With



'Load Values into the table

objTable.Cell(1, 1).Range.InsertAfter "Road Side"

objTable.Cell(1, 2).Range.InsertAfter "Notes"

With objWord.Selection.Font

    .Bold = True

    .Size = 9

End With



While Not rst.EOF

For x = 1 To i



    objTable.Cell(x + 1, 1).Range.InsertAfter x & ") " & rst.Fields("Name")

    rst.MoveNext



Next x

Wend

Open in new window

0
Comment
Question by:CFrasnelly
  • 3
  • 2
5 Comments
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 33579080
Try:

objDoc.Application.Selection.TypeParagraph
Set objTable = objDoc.Tables.Add(objDoc.Application.Selection.Range, i + 1, 2)


Basically it does two things - adds a paragraph to disconnect from the previous table and replaces the ref to objrange which hasn't changed for the new table to be the end of the document where you placed the cursor.

Chris
'*****EARLY BINDING

Dim objWord As Word.Application

Dim objDoc As Word.Document

Dim objTable As Word.Table

Dim objRange As Word.Range

'Create Word Instance

Set objWord = New Word.Application

'Create doc

Set objDoc = objWord.Documents.Add

objWord.Visible = True

objWord.Activate

'*****END EARLY BINDING -



'START TYPING

objWord.Selection.Font.Bold = True

objWord.Selection.TypeText "Projects"



objWord.Selection.TypeParagraph



'***Add Header



'***Add Projects*********************************************************************

rst.Open "SELECT Name, Start_Date FROM tblProject WHERE Plan_Year = 2010 AND FKEYProjectType=1 ORDER BY Name ASC", CurrentProject.Connection, adOpenKeyset, adLockOptimistic

i = rst.RecordCount



'Create Table

Set objRange = objWord.Selection.Range

Set objTable = objDoc.Tables.Add(objRange, i + 1, 3)

'Setup Table properties

With objTable

    .AllowAutoFit = True

    .AutoFitBehavior wdAutoFitContent

    .BottomPadding = 0

    .TopPadding = 0

    .Rows.SetHeight 13, wdRowHeightExactly

    .Range.Font.Bold = False

'    .Columns(3).SetWidth 0.2, wdAdjustNone

End With



'Load Values into the table

objTable.Cell(1, 1).Range.InsertAfter "PROJECT NAME"

objTable.Cell(1, 2).Range.InsertAfter "START DATE"

With objWord.Selection.Font

    .Bold = True

    .Size = 9

End With



While Not rst.EOF

For x = 1 To i



    objTable.Cell(x + 1, 1).Range.InsertAfter x & ") " & rst.Fields("Name")

    objTable.Cell(x + 1, 2).Range.InsertAfter Nz(rst.Fields("Start_Date"), "NO START")



    rst.MoveNext



Next x

Wend

'ADD NEXT TABLE - Move to the end of the document to add the next table

objWord.ActiveDocument.Characters.Last.Select

objWord.Selection.Collapse

    With objRange

        .Collapse Direction:=wdCollapseEnd

        .MoveEnd

        .InsertParagraphAfter

        .Collapse Direction:=wdCollapseEnd

    End With

'***Add Road Construction

rst.Close

rst.Open "SELECT Name FROM tblVendor WHERE IsRoadSide = 1 ORDER BY Name ASC", CurrentProject.Connection, adOpenKeyset, adLockOptimistic

i = rst.RecordCount



'Create Table

objDoc.Application.Selection.TypeParagraph

Set objTable = objDoc.Tables.Add(objDoc.Application.Selection.Range, i + 1, 2)

'Set objTable = objDoc.Tables.Add(objRange, i + 1, 2)

'Setup Table properties

With objTable

    .AllowAutoFit = True

    .AutoFitBehavior wdAutoFitContent

    .BottomPadding = 0

    .TopPadding = 0

    .Rows.SetHeight 13, wdRowHeightExactly

    .Range.Font.Bold = False

'    .Columns(3).SetWidth 0.2, wdAdjustNone

End With



'Load Values into the table

objTable.Cell(1, 1).Range.InsertAfter "Road Side"

objTable.Cell(1, 2).Range.InsertAfter "Notes"

With objWord.Selection.Font

    .Bold = True

    .Size = 9

End With



While Not rst.EOF

For x = 1 To i



    objTable.Cell(x + 1, 1).Range.InsertAfter x & ") " & rst.Fields("Name")

    rst.MoveNext



Next x

Wend

Open in new window

0
 

Author Comment

by:CFrasnelly
ID: 33579145
That didn't work... although it did extend the first table?????
0
 
LVL 59

Accepted Solution

by:
Chris Bottomley earned 500 total points
ID: 33579409
I had to remove references to the database to test it so hopefully I have re-instated it okay.  It works for me now in a practical test ... so see if this is different?

Chris
'*****EARLY BINDING

Dim objWord As Word.Application

Dim objDoc As Word.Document

Dim objTable As Word.Table

Dim objRange As Word.Range

'Create Word Instance

Set objWord = New Word.Application

'Create doc

Set objDoc = objWord.Documents.Add

objWord.Visible = True

objWord.Activate

'*****END EARLY BINDING -



'START TYPING

objWord.Selection.Font.Bold = True

objWord.Selection.TypeText "Projects"



objWord.Selection.TypeParagraph



'***Add Header



'***Add Projects*********************************************************************

rst.Open "SELECT Name, Start_Date FROM tblProject WHERE Plan_Year = 2010 AND FKEYProjectType=1 ORDER BY Name ASC", CurrentProject.Connection, adOpenKeyset, adLockOptimistic

i = rst.RecordCount



'Create Table

Set objRange = objWord.Selection.Range

Set objTable = objDoc.Tables.Add(objRange, i + 1, 3)

'Setup Table properties

With objTable

    .AllowAutoFit = True

    .AutoFitBehavior wdAutoFitContent

    .BottomPadding = 0

    .TopPadding = 0

    .Rows.SetHeight 13, wdRowHeightExactly

    .Range.Font.Bold = False

'    .Columns(3).SetWidth 0.2, wdAdjustNone

End With



'Load Values into the table

objTable.Cell(1, 1).Range.InsertAfter "PROJECT NAME"

objTable.Cell(1, 2).Range.InsertAfter "START DATE"

With objWord.Selection.Font

    .Bold = True

    .Size = 9

End With



While Not rst.EOF

For x = 1 To i



    objTable.Cell(x + 1, 1).Range.InsertAfter i

    'objTable.Cell(x + 1, 2).Range.InsertAfter Nz(rst.Fields("Start_Date"), "NO START")



    rst.MoveNext



Next x

Wend

'ADD NEXT TABLE - Move to the end of the document to add the next table

objWord.ActiveDocument.Characters.Last.Select

objWord.Selection.Collapse

    With objRange

        .Collapse Direction:=wdCollapseEnd

        .MoveEnd

        .InsertParagraphAfter

        .Collapse Direction:=wdCollapseEnd

    End With

''***Add Road Construction

rst.Close

rst.Open "SELECT Name FROM tblVendor WHERE IsRoadSide = 1 ORDER BY Name ASC", CurrentProject.Connection, adOpenKeyset, adLockOptimistic

i = rst.RecordCount



'Create Table

objDoc.Application.Selection.TypeParagraph

Set objTable = objDoc.Tables.Add(objDoc.Application.Selection.Range, i + 1, 2)

'Setup Table properties

With objTable

    .AllowAutoFit = True

    .AutoFitBehavior wdAutoFitContent

    .BottomPadding = 0

    .TopPadding = 0

    .Rows.SetHeight 13, wdRowHeightExactly

    .Range.Font.Bold = False

'    .Columns(3).SetWidth 0.2, wdAdjustNone

End With



'Load Values into the table

objTable.Cell(1, 1).Range.InsertAfter "Road Side"

objTable.Cell(1, 2).Range.InsertAfter "Notes"

With objWord.Selection.Font

    .Bold = True

    .Size = 9

End With



While Not rst.EOF

For x = 1 To i



    objTable.Cell(x + 1, 1).Range.InsertAfter x & ") " & rst.Fields("Name")

    rst.MoveNext



Next x

Wend

Open in new window

0
 

Author Comment

by:CFrasnelly
ID: 33579635
It works!!! With one strange bug (there's always something isn't there) ... It goes back and deletes almost the entire contents of the first cell in the first table....

Just figured it out... I needed to remove the below code... the .InsertParagraphAfter command was destroying it.  Thanks for your help on this Chris!!!

'objWord.Selection.Collapse
'    With objRange
'        .Collapse Direction:=wdCollapseEnd
'        .MoveEnd
'        .InsertParagraphAfter
'        .Collapse Direction:=wdCollapseEnd
'    End With
0
 

Author Closing Comment

by:CFrasnelly
ID: 33579637
Very helpful!!!!
0

Featured Post

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

I'm writing to share my clumsy experience in using this elegant tool so you can avoid every stupid mistake I made. (I leave it to the authorities to decide if this deserves a place in the Knowledge archives.)  Now that I am on the other side of my l…
Preface: When I started this series, I used the term CommandBars because that is the Office Object class that it discusses. Unfortunately, when Microsoft introduced Office 2007, they replaced the standard Commandbar menus with "The Ribbon" and rem…
This video shows and describes the main difference between both orientations in Microsoft Word. Viewers will understand when to use each orientation and how to get the most out of them.
The viewer will learn how to make their project stand out over others by learning how to change colors and shapes, add spaces, change directions, and add bullets to their charts.

911 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

25 Experts available now in Live!

Get 1:1 Help Now