Want to win a PS4? Go Premium and enter to win our High-Tech Treats giveaway. Enter to Win

x
?
Solved

Word 2007 Automation - Adding Multiple Tables using VBA

Posted on 2010-09-01
5
Medium Priority
?
2,620 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 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 2000 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

[Webinar] Lessons on Recovering from Petya

Skyport is working hard to help customers recover from recent attacks, like the Petya worm. This work has brought to light some important lessons. New malware attacks like this can take down your entire environment. Learn from others mistakes on how to prevent Petya like worms.

Question has a verified solution.

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

The Selection object is designed for user interaction. It has a Range property, so it can be used in most places that a Range object can. Recorded macros must use the Selection because they are simply copying what the user is doing. A Range prope…
I would like to show you some basics you can do with Mailings in MS Word. It´s quite handy feature you can use for creating envelopes, labels, personalized letters etc. First question could be what is this feature good for? Mailing can really he…
This video walks the viewer through the process of creating Hyperlinks for the web and other documents. Select the "Insert" tab: Click "Hyperlink":  Type "http://" followed by a web address to reference a website or navigate to a document to ref…
In a previous video Micro Tutorial here at Experts Exchange (http://www.experts-exchange.com/videos/1358/How-to-get-a-free-trial-of-Office-365-with-the-Office-2016-desktop-applications.html), I explained how to get a free, one-month trial of Office …
Suggested Courses

609 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