VBA
Standard module
Option Compare Text
Option Explicit
'*************** Code Start *****************************************************
' module name: bas_Word_QueryToTableBookmark_s4p
' 240820
' NEEDS REFERENCE for early binding
' Microsoft Word #.# Object Library
'-------------------------------------------------------------------------------
' Purpose : VBA to create a table in Word with results from an Access query
' optionally add Caption
' optionally add borders and shading to first row
' optionally add special formatting, such as cells in a column
' Author : crystal (strive4peace)
' This code: https://msaccessgurus.com/VBA/aWord_QueryToBookmark.htm
' LICENSE :
' You may freely use and share this code, but not sell it.
' Keep attribution. Use at your own risk.
'-------------------------------------------------------------------------------
' write a specified query to a new table in Word and then do some additional formatting.
' put the table after a bookmark so it doesn't replace it.
' After writing the table, it can do additional formatting for particular columns
' TO TEST EXAMPLE, as written:*
' 1. create a query in a database that has relationships
' query name: zq_MyExampleQuery
' uncomment only SQL block, copy, comment SQL block again,
' paste into SQL view of new query,
' switch to datasheet view to make sure you get data,
' save as zq_MyExampleQuery
' SQL:
'SELECT [szReferencedObject] & "." & [szReferencedColumn] AS Master
', [szObject] & "." & [szColumn] AS Child
', m.icolumn AS ColNbr, m.[ccolumn] AS ColCount
'FROM MSysRelationships AS m
'WHERE ((([szReferencedObject] & "." & [szReferencedColumn]) Not Like "MSys*"))
'ORDER BY IIf([ccolumn]>1,[szRelationship],[szReferencedObject] & [szReferencedColumn] & [szObject] & [szColumn])
', m.szRelationship, m.icolumn;
' 2. In Word, make a bookmark in your active Word document named:
' MyTable
' from ribbon: Insert, Bookmark (Links group), [enter Bookmark name] and click Add
'
' 3. REFERENCE Microsoft Word #.# Object Library (for early binding) -- Tools, References
' 4. Debug, Compile, Save
' 5. modify CUSTOMIZE stuff in Word_QueryToTableBookmark_s4p
' 6. then, compile, fix if necessary, save, and run Word_QueryToTableBookmark_s4p
'
' after the code successfully runs, look at the document that was just modified
'
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Word_QueryToTableBookmark_s4p
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Public Sub Word_QueryToTableBookmark_s4p()
'240811 strive4peace ... 240818, 240820
'
'CLICK HERE
'Press F5 to run
' --- CUSTOMIZE sQueryname, sBookmark. Caption, special formatting ---
' make a table in the active Word Document
' after the specified bookmark, make new paragraph,
' then create table with data
' with or without caption,
' with or without borders and shading
' with or without special formatting
' data is result from a query
' customize this logic to send information from. for instance:
' a table with Bookmark and Query names
' and maybe also:
' Caption, or first part of
' custom logic for special formatting
' CALLs
' GetWordTableNew_s4p
' WordTableBorders_s4p
'
' Word_CustomFormatColumn_s4p ' for additional formatting if desired
'
' GetWordActiveDocument_s4p
' for the example code
' not needed if you set document object another way
On Error GoTo Proc_Err
'early binding
Dim oDoc As Word.Document
Dim oRange As Word.Range
Dim oTable As Word.Table
Dim db As DAO.Database _
,rs As DAO.Recordset
Dim nRows As Long _
,nRow As Long _
,nCols As Long _
,nCol As Long _
,i As Integer _
,sQueryname As String _
,sBookmark As String _
,sCaption As String _
,sText As String
'------------------------- CUSTOMIZE
'whatever query or table name you want
' could also be an SQL statement
sQueryname = "zq_MyExampleQuery"
'your bookmark name
sBookmark = "MyTable" 'or whatever
'-------------------------
Set db = CurrentDb
'dbOpenSnapshot loads all the records
' since we have to count them
Set rs = db.OpenRecordset(sQueryname,dbOpenSnapshot)
With rs
nRows = .RecordCount
nCols = .Fields.Count
End With
If Not nRows > 0 Then
MsgBox sQueryname & " doesn't have data" _
,, "Error"
GoTo Proc_Exit
End If
'===================================== remove if you pass the document object
'get Word ActiveDocument
Set oDoc = GetWordActiveDocument_s4p()
If oDoc Is Nothing Then
'Word isn't open or no active document - already got message
GoTo Proc_Exit
End If
'=====================================
' --------------- mark spot for table
'set range to bookmark range
Set oRange = oDoc.Bookmarks(sBookmark).Range
'add blank row before table
oRange.InsertParagraphAfter
oRange.Collapse 0 'collapse to end
'------------------------- CUSTOMIZE
sCaption = sQueryname & " (" _
& nRows & " rows, " & nCols & " columns)"
'-------------------------
'this example has a heading row
nRows = nRows + 1 'add 1 for column headings
' --------------- Make table
'make table with specified number of rows and columns
' and caption, borders, shading for header row
Set oTable = GetWordTableNew_s4p( _
oRange _
,nRows _
,nCols _
,sCaption _
,True _
,True)
' --------------- Write data
With oTable
'column headings -- use query field names
nRow = 1
For nCol = 1 To nCols
.Cell(nRow,nCol).Range.Text = rs.Fields(nCol - 1).Name
Next nCol
'data
Do While Not rs.EOF
nRow = nRow + 1
For nCol = 1 To nCols
.Cell(nRow,nCol).Range.Text = rs.Fields(nCol - 1).Value
Next nCol
rs.MoveNext
Loop 'rs
End With
'================================== CUSTOMIZE - special formatting
' comment if not desired
' add Bold and Italics to cells in column 1 starting with row 2
' data is delimited with .
Call Word_CustomFormatColumn_s4p(oDoc,oTable, "BoldItalic",1,2, ".")
'==================================
'best-fit columns
oTable.Columns.AutoFit
MsgBox "Done making table in Word",, "Done"
Proc_Exit:
On Error Resume Next
'release object variables
Set oTable = Nothing
Set oRange = Nothing
Set oDoc = Nothing
If Not rs Is Nothing Then
rs.Close
Set rs = Nothing
End If
Set db = Nothing
On Error GoTo 0
Exit Sub
Proc_Err:
Select Case Err.Number
Case 5941
MsgBox "Bad bookmark name: " & sBookmark
Case Else
MsgBox Err.Description,, _
"ERROR " & Err.Number _
& " Word_QueryToTableBookmark_s4p "
End Select
Resume Proc_Exit
'if you break on error, set Resume to be Next Statement
'then single-step (F8) to see what caused the problem
Resume
End Sub
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' GetWordTableNew_s4p
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Public Function GetWordTableNew_s4p(oRange As Word.Range _
,ByVal pnRows As Long _
,ByVal pnCols As Long _
,Optional ByVal psCaption As String = "" _
,Optional pbDoBorders As Boolean = True _
,Optional pbHeaderRow As Boolean = True _
,Optional psCaptionPrefix As String = ". " _
,Optional ByVal paHeadArray As Variant _
) As Word.Table
'strive4peace 240811, 14, 18 pbHeaderRow, psCaptionPrefix
' modified from code posted here:
' https://msaccessgurus.com/VBA/Word_MakeTable.htm
'create a table in Word and return the table object
' PARAMETERS
' oRange is a range object where to insert table
' pnRows is a long integer number of rows
' pnCols is a long integer number of columns
' OPTIONAL
' psCaption is a caption
' pbDoBorders = True to add borders
' pbHeaderRow = True to mark and header row and add shading
' psCaptionPrefix = characters to write before caption, if specified
' paHeadArray is a Variant array with column headings
Dim i As Integer _
,iCol As Integer
'insert table
With oRange.Document
Set GetWordTableNew_s4p = .Tables.Add( _
Range:=oRange _
,NumRows:=pnRows _
,NumColumns:=pnCols _
)
End With
If (psCaption <> "") Then
'insert caption
' Position: WdCaptionPosition
' 0 = wdCaptionPositionAbove, 1=below
GetWordTableNew_s4p.Range.InsertCaption _
Label:= "Table" _
,Title:=psCaptionPrefix & psCaption _
,Position:=0 _
,ExcludeLabel:=0
End If
With GetWordTableNew_s4p
' .ApplyStyleHeadingRows = True 'doesn't work in 2007
.TopPadding = 0
.BottomPadding = 0
.LeftPadding = 2 'points
.RightPadding = 2
.Spacing = 0 'Auto
.AllowPageBreaks = True
.AllowAutoFit = False
'dont allow rows to break
.Rows.AllowBreakAcrossPages = False
'2 points above and below paragraphs
.Range.Paragraphs.SpaceBefore = 2
.Range.Paragraphs.SpaceAfter = 2
'Vertical Alignment
' 0=wdCellAlignVerticalTop
' 1=wdCellAlignVerticalCenter
.Range.Cells.VerticalAlignment = 0
'write labels if passed, which they usually won't be
If Not IsMissing(paHeadArray) Then
iCol = 1
For i = LBound(paHeadArray) To UBound(paHeadArray)
.Cell(1,iCol).Range.Text = paHeadArray(i)
iCol = iCol + 1
Next i 'array element
End If
' borders if pbDoBorders, shading if pbHeaderRow
If pbDoBorders Then
Call WordTableBorders_s4p(GetWordTableNew_s4p,pbHeaderRow)
End If
'240811 AutoFit columns if paHeadArray was passed
If Not IsMissing(paHeadArray) Then
'best-fit columns for column headings
' and/or do after data written
.Columns.AutoFit
End If
End With
End Function
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' WordTableBorders_s4p
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'Object is Word.Table
Public Sub WordTableBorders_s4p(oTable As Object _
,Optional pbHeaderRow As Boolean = True _
)
's4p 170811, 240818 pbHeaderRow
Dim i As Integer
With oTable
For i = 1 To 6
'wdBorderTop =-1
'wdBorderLeft = -2
'wdBorderBottom =-3
'wdBorderRight= -4
'wdBorderHorizontal = -5
'wdBorderVertical = -6
With .Borders(-i)
.LineStyle = 1 'wdLineStyleSingle=1
.LineWidth = 8 'wdLineWidth100pt=8. wdLineWidth150pt=12
.Color = RGB(200,200,200) 'medium-light gray
End With
Next i
End With
'mark heading row
If pbHeaderRow <> False Then 'True
With oTable.Rows(1)
'Heading Row
.HeadingFormat = True
'Shading for header row
.Shading.BackgroundPatternColor = RGB(232,232,232)
'change main borders to black for first row
For i = 1 To 4
With .Borders(-i)
.Color = 0 'wdColorBlack = 0
End With
Next i
End With 'first row
End If
'Not used:
' 'wdLineStyleNone = 0
' .Borders(-7).LineStyle = 0 'wdBorderDiagonalDown =-7
' .Borders(-8).LineStyle = 0 'wdBorderDiagonalUp =-8
End Sub
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Word_CustomFormatColumn_s4p
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Sub Word_CustomFormatColumn_s4p(poDoc As Word.Document _
,poTable As Word.Table _
,psMyCustom As String _
,Optional pnColumnNumber As Long = 1 _
,Optional pnRowStart As Long = 2 _
,Optional psDelimiter As String = "." _
)
'additional formatting for each cell in a column of a Word table
'PARAMETERs
' poDoc = Word document object
' poTable = Word table object
' psMyCustom = your custom code to send so this procedure knows what to do
' pnColumnNumber = column number for formatting
' pnRowStart = row to start formatting. Default=2 assuming header row
' psDelimiter = string to look for to separate special formatting, Default is period .
'================================== OPTIONAL FORMATTING
' customized to add Bold and Italics to cells in specified column when done
' for psMyCustom = BoldItalic
' although this example applies different formatting to parts of text in a cell,
' you could choose the same formatting for the whole cell
Dim nRow As Long _
,iPosition As Integer _
,sMsg As String _
,sText As String
With poTable
For nRow = pnRowStart To .Rows.Count ' nRows
'Custom
Select Case psMyCustom
Case "BoldItalic" '----------------- CUSTOMIZE for your needs
'Bold 1st part and Italicize 2nd part if delimiter found
With .Cell(nRow,pnColumnNumber)
sText = .Range.Text
'look for delimiter
iPosition = InStr(sText,psDelimiter)
If iPosition > 0 Then
'Bold first part
poDoc.Range(.Range.Start,.Range.Start + iPosition - 1).Font.Bold = True
'Italics second part
poDoc.Range(.Range.Start + iPosition,.Range.End).Font.Italic = True
End If
End With 'cell
Case Else
sMsg = "code for " & psMyCustom & " not found"
Debug.Print "Error Word_CustomFormatColumn_s4p: " & sMsg
MsgBox sMsg _
,, "Error Word_CustomFormatColumn_s4p"
Exit Sub
End Select 'Custom
Next nRow
End With 'poTable
End Sub
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' GetWordActiveDocument_s4p
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Private Function GetWordActiveDocument_s4p() As Word.Document
'240811 strive4peace
'return ActiveDocument in Word
'this isn't necessary when you already have a Document object
Dim oWord As Word.Application
'Initialize Word
On Error Resume Next
Set oWord = GetObject(, "Word.Application")
On Error GoTo Proc_Err
If oWord Is Nothing Then
MsgBox "Word isn't open",, "Can't get Word Object"
Exit Function
End If
'still here -- see if any docs open
With oWord
If Not .Documents.Count > 0 Then
MsgBox "No ActiveDocument in Word" _
,, "Can't get Word ActiveDocument"
Exit Function
End If
Set GetWordActiveDocument_s4p = .ActiveDocument
End With
Proc_Exit:
On Error Resume Next
Set oWord = Nothing
On Error GoTo 0
Exit Function
Proc_Err:
MsgBox Err.Description _
,, "ERROR " & Err.Number _
& " Word_Set _ActiveDocument"
Resume Proc_Exit
Resume
End Function
'*************** Code End ******************************************************
' Code was generated with colors using the free
Color Code add-in for Access
