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&#39;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

Open in new window

shieldscoAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

NorieAnalyst Assistant Commented:
Set them to what?

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.
0
shieldscoAuthor Commented:
It does set it auto but I need them to vary. Maybe the preferred method based on %
0
John TsioumprisSoftware & Systems EngineerCommented:
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.
0
The Five Tenets of the Most Secure Backup

Data loss can hit a business in any number of ways. In reality, companies should expect to lose data at some point. The challenge is having a plan to recover from such an event.

Rgonzo1971Commented:
Hi,

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

Open in new window

Regards
0
shieldscoAuthor Commented:
Error.JPGCompile error on line:

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

Open in new window

0
Rgonzo1971Commented:
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

Open in new window

0
shieldscoAuthor Commented:
The code runs however the columns are not resized .... I believe it has to do with :
DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
                                            wdAutoFitFixed
0
Rgonzo1971Commented:
then try
            oWord.ActiveDocument.Tables.Add Range:=oWord.Selection.Range, NumRows:=iRecCount, NumColumns:= _
                                            iFldCount, DefaultTableBehavior:=wdWord8TableBehavior

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
shieldscoAuthor Commented:
Thanks
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Access

From novice to tech pro — start learning today.