Justifying columns in Word Table after export from Access

[Creosote65]

Hi all,

I've looked extensively for an answer to this in the forums, but I can't seem to find the solution. In the following macro, I have created a loop that populates a Word table from an Access record set that ends after I reach the last record. Everything works find.

However, something is missing. I would like to justify certain columns to the right (1st, 5th, 6th). I have tried several object properties to do this, but nothing seems to work.

I would like the justification to happen before the records are populated.

Thanks,
Creo!

Private Sub cmbQuote_AfterUpdate()
Dim appWord As Word.Application
Dim docWord As Word.Document
Dim rngInsertionPoint As Word.Range
Dim rstContractHeader As New ADODB.Recordset
Dim rstContractDetails As New ADODB.Recordset
Dim strContractNo As String
Dim strCATNo As String
Dim lngProjVol As Long
Dim strItemCode As String
Dim strDescription As String
Dim strSellingUOM As String
Dim lngConversion As Long
Dim curPropSel As Currency

1 'Open the header recordset
2 DoCmd.SetWarnings False
3 DoCmd.OpenQuery "qryExportContrNoEng", acViewNormal, acReadOnly
4 rstContractHeader.Open "tblExportContrNoEng", _
5 CurrentProject.Connection, adOpenStatic

6 'Set current contract and CAT numbers as strings
7 With rstContractHeader
8 If IsNull(.Fields("ContrNo")) Then 'End if the value is null.
9 MsgBox "The quote contains no contract number. Please enter this information and retry."
10 DoCmd.OpenForm "frmMenuContrEng"
11 DoCmd.Close
12 acForm, "frmChooseQuoteExpArchContrEng", acSaveNo
13 Exit Sub
14 Else
15 strContractNo = .Fields("ContrNo")
16 End If
17 strCATNo = .Fields("ReqNo")
18 End With

19 'Open Word and create a new document
20 Set appWord = New Word.Application
21 appWord.Documents.Add
22 Set docWord = appWord.Documents(1)
23 docWord.Application.Visible = True

24 'Add a 3 column table to the tables collection
25 Set rngInsertionPoint = docWord.Paragraphs(1).Range
26 With rngInsertionPoint
27 .Collapse Direction:=wdCollapseEnd
28 .Tables.Add rngInsertionPoint, 1, 3
29 End With

30 'Add Column titles
With rngInsertionPoint.Tables(1).Rows(1)
.Cells(1).Range.Text = "PRODUCT PRICING"
.Cells(2).Range.Text = "EXHIBIT C"
.Cells(3).Range.Text = "CONTRACT " & strContractNo
.Range.Bold = True
.Range.Font.Name = "Times New Roman"
.Range.Font.Size = 8
End With

'Add a line for CAT id
rngInsertionPoint.Tables(1).Rows.Add
With rngInsertionPoint.Tables(1).Rows.Last
.Cells(3).Range.Text = "CAT" & strCATNo
End With
Set rngInsertionPoint = Nothing
DoCmd.Close acTable, "tblExportContrNoEng", acSaveNo

'Add a 6 column table to the tables collection (Item details output)
Set rngInsertionPoint = docWord.Paragraphs(7).Range
docWord.Paragraphs.Add
Set rngInsertionPoint = Nothing
Set rngInsertionPoint = docWord.Paragraphs(8).Range
With rngInsertionPoint
.Collapse Direction:=wdCollapseEnd
.Tables.Add rngInsertionPoint, 1, 6
End With
Set rngInsertionPoint = Nothing

'Add column Titles
Set rngInsertionPoint = docWord.Paragraphs(2).Range
With rngInsertionPoint.Tables(1).Rows(3)
.Cells(1).Range.Text = "Estimated Annual Usage"
.Cells(2).Range.Text = "Product Code"
.Cells(3).Range.Text = "Description"
.Cells(4).Range.Text = "UOM"
.Cells(5).Range.Text = "Quantity per UOM"
.Cells(6).Range.Text = "Price/UOM"
.Range.Font.Name = "Times New Roman"
.Range.Font.Size = 8
.Cells(1).Width = appWord.InchesToPoints(0.8)
.Cells(2).Width = appWord.InchesToPoints(0.8)
.Cells(3).Width = appWord.InchesToPoints(2.6)
.Cells(4).Width = appWord.InchesToPoints(0.5)
.Cells(5).Width = appWord.InchesToPoints(0.7)
.Cells(6).Width = appWord.InchesToPoints(0.75)
End With
rngInsertionPoint.Tables(1).Rows.Last.Borders.Enable = True

'Open the detail recordset
DoCmd.OpenQuery "qryExportDetailEng", acViewNormal, acReadOnly
rstContractDetails.Open "tblExportDetailEng", _
CurrentProject.Connection, adOpenStatic

'Place values in the table
With rstContractDetails
Do While .EOF = False
lngProjVol = .Fields("ProjVol")
strItemCode = .Fields("Item Code")
If IsNull(.Fields("Description")) Then 'End if the item description is null
appWord.Quit False

'Set appWord = Nothing
AppActivate "Microsoft Access"
MsgBox "Item code " & strItemCode & " is invalid. Please correct this information and retry."
DoCmd.OpenForm "frmMenuContrEng"
DoCmd.Close acForm, "frmChooseQuoteExpArchContrEng", acSaveNo
Exit Sub
End If
strDescription = .Fields("Description")
strSellingUOM = .Fields("Selling UOM")
lngConversion = .Fields("Smallest to Selling")
If IsNull(.Fields("PropSel")) Then 'End if the Proposed Selling Price is null
appWord.Quit False
AppActivate "Microsoft Access"
MsgBox "Item code " & strItemCode & " has no proposed pricing. Please correct this information and retry."
DoCmd.OpenForm "frmMenuContrEng"
DoCmd.Close acForm, "frmChooseQuoteExpArchContrEng", acSaveNo
Exit Sub
End If
curPropSel = .Fields("PropSel")

'Add a row to the table
rngInsertionPoint.Tables(1).Rows.Add
'Place values in the table
With rngInsertionPoint.Tables(1).Rows.Last
.Cells(1).Range.Text = lngProjVol
.Cells(2).Range.Text = strItemCode
.Cells(3).Range.Text = strDescription
.Cells(4).Range.Text = strSellingUOM
.Cells(5).Range.Text = lngConversion
.Cells(6).Range.Text = Format(curPropSel, "Currency")
End With
.MoveNext
Loop
rngInsertionPoint.Tables(1).Rows(3).Range.Bold = True
End With

'Close Word
appWord.Quit
Set appWord = Nothing

'Run the Archive and delete queries
DoCmd.OpenQuery "qryArchiveHeaderEng", acViewNormal, acReadOnly
DoCmd.OpenQuery "qryArchiveItemDetailEng", acViewNormal, acReadOnly
DoCmd.OpenQuery "qryDeleteInputEng"
MsgBox "Your quote has been successfully archived.", vbInformation, "Export and Archive Complete!!!"
DoCmd.OpenForm "frmMenuContrEng"
DoCmd.Close acForm, "frmChooseQuoteExpArchContrEng"

End Sub