shieldsco
asked on
Access VBA add Column Widths to Word table
I using the code below and would like to set column widths. There are 7 columns in the table. Thoughts
Function Export2DOC(sQuery As String)
Dim oWord As Object
Dim oWordDoc As Object
Dim oWordTbl As Object
Dim bWordOpened As Boolean
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim iCols As Integer
Dim iRecCount As Integer
Dim iFldCount As Integer
Dim i As Integer
Dim j As Integer
Const wdPrintView = 3
Const wdWord9TableBehavior = 1
Const wdAutoFitFixed = 0
'Start Word
On Error Resume Next
Set oWord = GetObject("Word.Application") 'Bind to existing instance of Word
If Err.Number <> 0 Then 'Could not get instance of Word, so create a new one
Err.Clear
On Error GoTo Error_Handler
Set oWord = CreateObject("Word.application")
bWordOpened = False
Else 'Word was already running
bWordOpened = True
End If
On Error GoTo Error_Handler
oWord.Visible = False 'Keep Word hidden until we are done with our manipulation
Set oWordDoc = oWord.Documents.Add 'Start a new document
'Open our SQL Statement, Table, Query
Set db = CurrentDb
Set rs = db.OpenRecordset("tblSearch")
With rs
If .RecordCount <> 0 Then
.MoveLast 'Ensure proper count
iRecCount = .RecordCount + 1 'Number of records returned by the table/query
.MoveFirst
iFldCount = .Fields.Count 'Number of fields/columns returned by the table/query
oWord.ActiveWindow.View.Type = wdPrintView 'Switch to print preview mode (not req'd just a personal preference)
oWord.ActiveDocument.Tables.Add Range:=oWord.Selection.Range, NumRows:=iRecCount, NumColumns:= _
iFldCount, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
wdAutoFitFixed
'Build our Header Row
Set oWordTbl = oWordDoc.Tables(1)
oWordTbl.Rows(1).HeadingFormat = True 'Add column headings to each page
With oWord.ActiveDocument.Sections(1).Headers(1).Range 'Add header to each page
.Text = "Appendix of Appeals"
.Font.Italic = True
.Font.Bold = True
.Font.Size = 14
.Font.ColorIndex = 1
.Paragraphs.Alignment = 1 'Align Center
End With
With oWord.ActiveDocument.Sections(1)
.Footers(wdHeaderFooterPrimary).Range.Text = vbTab & "Page "
.Footers(wdHeaderFooterPrimary).PageNumbers.Add FirstPage:=True
End With
For i = 0 To iFldCount - 1
oWordTbl.Cell(1, i + 1) = rs.Fields(i).Name
Next i
i = 2 ' first row of data goes in 2nd row of table
'Build our data rows
Set oWordTbl = oWordDoc.Tables(1)
Do Until rs.EOF = True
For j = 0 To iFldCount - 1
oWordTbl.Cell(i, j + 1) = Nz(rs.Fields(j).Value, "")
Next j
.MoveNext
i = i + 1
Loop
Else
MsgBox "There are no records returned by the specified queries/SQL statement.", vbCritical + vbOKOnly, "No data to generate an Word spreadsheet with"
GoTo Error_Handler_Exit
End If
End With
' oWordDoc.Close True, sFileName 'Save and close
'Close Word if is wasn't originally running
' If bWordOpened = False Then
' oWord.Quit
' End If
Error_Handler_Exit:
On Error Resume Next
oWord.Visible = True 'Make Word visible to the user
rs.Close
Set rs = Nothing
Set db = Nothing
Set oWordTbl = Nothing
Set oWordDoc = Nothing
Set oWord = Nothing
Exit Function
Error_Handler:
MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: Export2DOC" & vbCrLf & _
"Error Description: " & Err.Description _
, vbOKOnly + vbCritical, "An Error has Occured!"
Resume Error_Handler_Exit
End Function
ASKER
It does set it auto but I need them to vary. Maybe the preferred method based on %
You can always record a macro in Word and then turn it to VBA and use this code to figure out how to do it.
Hi,
pls try something like this
pls try something like this
Set oCols = oWordTbl.Columns
For Each oCol In oCols
totalWidth = totalWidth + oCol.Width
Next
'arrColWidths must total to 1 (100%) and have the same count as the tbl.columns
arrColWidths = Array(0.3, 0.2, 0.2, 0.1, 0.1, 0.1)
For Idx = 0 To UBound(arrColWidths)
If oCols(Idx + 1).Width >= totalWidth * arrColWidths(Idx) Then
oCols(Idx + 1).Width = totalWidth * arrColWidths(Idx)
End If
Next
For Idx = 0 To UBound(arrColWidths)
If oCols(Idx + 1).Width < totalWidth * arrColWidths(Idx) Then
oCols(Idx + 1).Width = totalWidth * arrColWidths(Idx)
End If
Next
Regards
ASKER
Compile error on line:
totalWidth = totalWidth + oCols.Width
totalWidth = totalWidth + oCols.Width
Dim oCols As Table
Dim totalWidth As Integer
Set oCols = oWordTbl.Columns
For Each oCols In oCols
totalWidth = totalWidth + oCols.Width
Next
'arrColWidths must total to 1 (100%) and have the same count as the tbl.columns
arrColWidths = Array(0.2, 0.2, 0.2, 0.1, 0.1, 0.1, 0.1)
For Idx = 0 To UBound(arrColWidths)
If oCols(Idx + 1).Width >= totalWidth * arrColWidths(Idx) Then
oCols(Idx + 1).Width = totalWidth * arrColWidths(Idx)
End If
Next
For Idx = 0 To UBound(arrColWidths)
If oCols(Idx + 1).Width < totalWidth * arrColWidths(Idx) Then
oCols(Idx + 1).Width = totalWidth * arrColWidths(Idx)
End If
Next
corrected (2nd time)
Dim oCol As Column
Dim oCols As Columns
Dim totalWidth As Single
Set oCols = oWordTbl.Columns
For Each oCol In oCols
totalWidth = totalWidth + oCol.Width
Next
'arrColWidths must total to 1 (100%) and have the same count as the tbl.columns
arrColWidths = Array(0.2, 0.2, 0.2, 0.1, 0.1, 0.1, 0.1)
For Idx = 0 To UBound(arrColWidths)
If oCols(Idx + 1).Width >= totalWidth * arrColWidths(Idx) Then
oCols(Idx + 1).Width = totalWidth * arrColWidths(Idx)
End If
Next
For Idx = 0 To UBound(arrColWidths)
If oCols(Idx + 1).Width < totalWidth * arrColWidths(Idx) Then
oCols(Idx + 1).Width = totalWidth * arrColWidths(Idx)
End If
Next
ASKER
The code runs however the columns are not resized .... I believe it has to do with :
DefaultTableBehavior:=wdWo rd9TableBe havior, AutoFitBehavior:= _
wdAutoFitFixed
DefaultTableBehavior:=wdWo
wdAutoFitFixed
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
Thanks
Doesn't that code set the table to autofit?
If it does that should mean the column widths should change based on the content of the table.