Create new Word document from Access Query using VBA automation

Quick Jump

Download

Download zipped BAS file with module that you can import mod_aWordDocumentFromQuery_s4p__BAS.zip

Download sample Access database with test data aWordDocument_AccessQuery_s4p__ACCDB.zip

If you have trouble with the downloads, you may need to unblock the ZIP file, aka remove Mark of the Web, before extracting the file. Here are steps to do that: https://msaccessgurus.com/MOTW_Unblock.htm

VBA

Standard module: mod_aWordDocumentFromQuery_s4p

Option Compare Database  'Ignore Case
Option Explicit  'variables must be declared
'261014
'*************** Code Start ***************************************************
' module: mod_aWordDocumentFromQuery_s4p
' Purpose  : Automate Word: Create a new Word document from Access Query records
'              new Microsoft Word document with dynamic page header
'                 data shown in Word table with borders + Header Row (shading)
'                 Page header: query name, date/time code, page # and total pages
'              Specify query name
'              Optional:
'                 Description to be written to document before table
'                 Orientation is Portrait unless Landscape specified
'                 Margins can be Narrow
'            progress Status Bar: File, Options, Current Database, Display Status Bar
' Author   : crystal (strive4peace)
' this code: https://msaccessgurus.com/VBA/aWord_NewFromQuery.htm
' LICENSE  :
'   You may freely use and share this code, but not sell it.
'   Keep attribution. Mark your changes. Use at your own risk.
'------------------------
' PROCEDURE
'     aWordDocumentFromQuery
'--------------------------------------- TEST
'     test_aWordDocumentFromQuery_PrimeNumber
'     test_aWordDocumentFromQuery_SpecialChar
'     test_aWordDocumentFromQuery_Element
'     test_aWordDocumentFromQuery_BogusError
'     test_aWordDocumentFromQuery_NoRecordsError
'     test_aWordDocumentFromQuery_CantOpenError
'-------------------------------------------------------------------------------
'-------------------------------------------------------------------------------
'           aWordDocumentFromQuery
'-------------------------------------------------------------------------------
Public Sub aWordDocumentFromQuery( _ 
   psQueryName As String _ 
   ,Optional psDescription As String =  "" _ 
   ,Optional piOrientation As Integer = 0 _ 
   ,Optional pbNarrow As Boolean = False _ 
   ) 
'260930...1014
   'PARAMETERs
   '   psQueryName = name of query with data to show in a Word table
   'Optional
   '   psDescription - Text to write above the table
   '   piOrientation - Default = 0 = Portrait.
   '                   Landscape = 1 -- send any number except 0 (zero)
   '   pbNarrow - Default = False. True = set to narrow margins (0.5 inch)

   'object variables
   Dim db As DAO.Database 
   Dim rs As DAO.Recordset 
   
   '  Late Binding for Word
   '  For Early Binding: Microsoft Word #.# Object Library
   Dim oWord As Object   'Word.Application
   Dim oDoc As Object    'Word.Document
   Dim oTable As Object  'Word.Table
   Dim oRange As Object  'Word.Range
         
   'variables
   Dim sMsg As String          'message
   Dim sPath As String         'file path
   Dim sPathFile As String     'file path and file name
   Dim nRow As Long            'current row of table
   Dim nCol As Long            'current column of table
   Dim nRows As Long           'number of data rows
   Dim nColumns As Long        'number of columns
   Dim i As Integer            'integer for counting
   Dim bCloseWord As Boolean   'True to close Word Application
   
   'setup error handler
   On Error GoTo Proc_Err 
      
   '-------------------------------------------- Open Query
   'make sure we can open the query
   nRows = 0 
   '------------------- assign db database and rs recordset objects
   Set db = CurrentDb() 
   On Error Resume Next 
   'OpenRecordset using Snapshot: loads completely and is read-only
   Set rs = db.OpenRecordset(psQueryName,dbOpenSnapshot) 
   If Err.Number > 0 Then 
      sMsg =  "Can't open query: " _ 
         & vbCrLf & Space(5) & psQueryName 
      MsgBox sMsg,, "Can't write results to Word "
      GoTo Proc_Exit 
   End If 
   On Error GoTo Proc_Err 
   
   'Count the rows and columns if not at end
   'EOF stands for End Of File even though a recordset isn't a traditional file
   With rs 
      If Not .EOF Then 
         ' no need to move with Snapshot
         '.MoveLast 'dynaset must load all to get RecordCount
         '.MoveFirst 'go back to start
         nRows = .RecordCount 
         nColumns = .Fields.Count 
      End If 
   End With 
   
   'don't make Word document if there is no data
   If Not nRows > 0 Then 
      MsgBox  "No records in query: " & psQueryName _ 
         ,, "Can't write results to a Word document"
      GoTo Proc_Exit 
   End If 
   
   '-------------------------------------------- Status Bar
   sMsg =  "Creating Word document ..."
   Application.SysCmd acSysCmdSetStatus,sMsg 
   
   '-------------------------------------------- Document path
   '                                   CUSTOMIZE
   'Path: QUERY_WordDocuments folder under database path
   sPath = CurrentProject.Path &  "\QUERY_WordDocuments\"
   'create path if it doesn't exist
   If Dir(sPath,vbDirectory) =  "" Then 
      MkDir sPath 
      DoEvents 
   End If 
   
   '-------------------------------------------- Document name
   sPathFile = sPath &  "QUERY_" _ 
      & psQueryName _ 
      & Format(Now, "_yymmdd_hhnn") _ 
      &  ".DOCX"

   '-------------------------------------------- Word Application
   'if Word is already open, use that instance
   'ignore errors because if Word is NOT open, we will get one
   On Error Resume Next 
   'make assumption that Word is Open
   bCloseWord = False 
   Set oWord = GetObject(, "Word.Application") 
   On Error GoTo Proc_Err 
     
   'If oWord doesn't have a value then we need to open Word
   If oWord Is Nothing Then 
      'Word was not open -- create a new instance
      Set oWord = CreateObject( "Word.Application") 
      bCloseWord = True 
   End If 
   'make Word visible -- uncomment if you want to watch it.
   'Runs slower but more interesting
   'oWord.Visible = True
   
   '-------------------------------------------- New Word Document
   'make a new Word Document
   Set oDoc = oWord.Documents.Add 
   
   '-------------------------------------------- Setup Word
   With oDoc 
      'do page setup before writing data for better layout
      With .PageSetup 
         '0=Portait, 1=Landscape
         .Orientation = IIf(piOrientation = 0,0,1) 
         If pbNarrow <> False Then 
            'Narrow Margins
            'distance in points (1"=72 points)
            .LeftMargin = 36 
            .RightMargin = 36 
            .TopMargin = 36 
            .BottomMargin = 36 
         End If 
      End With  'PageSetup
      
      'redefine Styles for document
      With .Styles( "Normal") 
         With .ParagraphFormat 
            .SpaceBefore = 2  'points, 72 points/inch
            .SpaceAfter = 2 
            .KeepTogether = True  'keep whole paragraph on same page
            .LineSpacingRule = 0  'wdLineSpaceSingle
         End With  'ParagraphFormat
      End With  'Normal Style
      With .Styles( "Heading 1") 
         With .ParagraphFormat 
            .SpaceBefore = 0 
            .SpaceAfter = 4 
         End With  'ParagraphFormat
      End With  'Heading 1 Style
   
      '----------------------------------------- Content
      With .Content 
         'Title
         .InsertAfter psQueryName 
         'style as Heading 1, .Parent is oDoc
         .Paragraphs(1).Style _ 
               = .Parent.Styles( "Heading 1") 
         .InsertParagraphAfter  'paragraph mark
      
         'write description
         If psDescription <>  "" Then 
            .InsertAfter psDescription 
            'blank line
            .InsertParagraphAfter 
         End If 
         
         'write number of rows
         .InsertAfter Format(nRows, "#,##0") &  " Rows"
         'blank line
         .InsertParagraphAfter 
         
      End With 
         
      '----------------------------------------- Make table
      'range for table, put at end
      Set oRange = .Content 
      oRange.Collapse Direction:=0   'wdCollapseEnd
      
      'insert table +1 row for header row
      Set oTable = .Tables.Add( _ 
       Range:=oRange _ 
         ,NumRows:=nRows + 1 _ 
         ,NumColumns:=nColumns _ 
         ) 

   End With  'oDoc.Content
   
   '-------------------------------------------- Data
   With oTable 
      'column headings -- use query field names
      nRow = 1 
      For nCol = 1 To nColumns 
         .Cell(nRow,nCol).Range.Text = rs.Fields(nCol - 1).Name 
      Next nCol 
      
      'mark heading row
      .Rows(1).HeadingFormat = True 
      'dont allow rows to break
      .Rows.AllowBreakAcrossPages = False 
      
      '----------------------------------------- Rows
      Do While Not rs.EOF 
         sMsg =  "Writing Row " & nRow &  " of " & nRows 
         Application.SysCmd acSysCmdSetStatus,sMsg 
         
         nRow = nRow + 1 
         For nCol = 1 To nColumns 
            .Cell(nRow,nCol).Range.Text = rs.Fields(nCol - 1).Value &  ""
         Next nCol 
         rs.MoveNext 
      Loop    'rs
   
      'best-fit columns
      .Columns.AutoFit 

      '----------------------------------------- Border lines
      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 

      'change border lines to black for first row + add shading
      With .Rows(1) 
         For i = 1 To 4 
            With .Borders(-i) 
               .Color = 0        'wdColorBlack = 0
            End With 
         Next i 
         'Shading for header row, light-gray
         .Shading.BackgroundPatternColor = RGB(232,232,232) 
      End With   'first row

   End With 
   
   '-------------------------------------------- Header
   ' add after data and update page count
   Set oRange = oDoc.Sections(1).Headers(1).Range   '
   
   With oRange 
      'insert text of Heading 1 style
      'wdFieldEmpty = -1
      .Fields.Add Range:=.Characters.Last _ 
         ,Type:=-1 _ 
         ,Text:= "STYLEREF  ""Heading 1"" " _ 
         ,PreserveFormatting:=False 
      
      'then a TAB and text on right
      .InsertAfter Chr(9) _ 
         & Format(Now, "d-mmm-yy, ddd hh:nn") _ 
         &  ", page "

      'then PAGE/NUMPAGES
      '33=wdFieldPage
      'wdFieldEmpty = -1
      .Fields.Add Range:=.Characters.Last _ 
         ,Type:=-1 _ 
         ,Text:= "PAGE" '
      .InsertAfter Text:= "/"
      '26=wdFieldNumPages
      .Fields.Add Range:=.Characters.Last _ 
         ,Type:=-1 _ 
         ,Text:= "NUMPAGES"
   
      'add border line below
      With .Borders(-3)   'wdBorderBottom =-3
         .LineStyle = 1    'wdLineStyleSingle=1
         .LineWidth = 8   'wdLineWidth100pt=8
         .Color = RGB(75,75,75)  'dark gray
      End With 
      With .ParagraphFormat 
         'clear current tabstops
         .TabStops.ClearAll 
         'set right-aligned Tab Stop at 10 inches
         '72 points/inch
         'when Position > width, Word displays ok anyway
         '2=wdAlignTabRight
         '0=wdTabLeaderSpaces
         .TabStops.Add _ 
            Position:=10 * 72 _ 
            ,Alignment:=2 _ 
            ,Leader:=0 
         '0=Left, 1=Center, 2=Right
         .Alignment = 0   '0=wdAlignParagraphLeft
         'space after paragraph = 6 points
         .SpaceAfter = 6 
      End With 
      .Fields.Update 
   End With   'header
   
   '-------------------------------------------- Save File
   'delete the output file if it already exists
   'not likely as yymmdd_hhnn in filename
   If Dir(sPathFile) <>  "" Then 
      Kill sPathFile 
      DoEvents 
   End If 
   'save Word Document and Close
   With oDoc 
      .SaveAs sPathFile 
      .Close 
   End With 
       
   sMsg =  "Created " & sPathFile 
   Application.SysCmd acSysCmdSetStatus,sMsg 
   
   sMsg =  "Done creating a new Word document" _ 
      & vbCrLf &  "   " & sPathFile 
   
   Debug.Print Now(),sMsg 
   sMsg = sMsg & vbCrLf & vbCrLf &  "Open Path?"
   
   If MsgBox(sMsg,vbYesNo, "Done") <> vbNo Then 
      'open path
      Call Shell( "Explorer.exe " & sPath,vbNormalFocus) 
   End If 
   
   '-------------------------------------------- Exit
Proc_Exit: 
   'cleanup object variables
   On Error Resume Next 
   If Not rs Is Nothing Then 
      rs.Close 
      Set rs = Nothing 
   End If 
   Set db = Nothing 
   Set oRange = Nothing 
   Set oTable = Nothing 
   Set oDoc = Nothing 
   If bCloseWord <> False Then 
      oWord.Quit 
   End If 
   Set oWord = Nothing 
   'clear status bar
   Application.SysCmd acSysCmdClearStatus 
   'exit before the error handler!
   Exit Sub 
 
Proc_Err:  'error handler
   MsgBox Err.Description _ 
     ,, "ERROR " & Err.Number _ 
     &  "   aWordDocumentFromQuery"
   Resume Proc_Exit 
   Resume  'Break then set this to be the Next Statement to go to the bad line
End Sub 
'========================================================================== TEST
'-------------------------------------------------------------------------------
'           test_aWordDocumentFromQuery_PrimeNumber
'-------------------------------------------------------------------------------
Public Sub test_aWordDocumentFromQuery_PrimeNumber() 
'261012
   'CLICK HERE, press F5 to Run!
   'Create Word document from query
   Call aWordDocumentFromQuery( "qPrimeNumber") 
End Sub 

'-------------------------------------------------------------------------------
'           test_aWordDocumentFromQuery_SpecialChar
'-------------------------------------------------------------------------------
Public Sub test_aWordDocumentFromQuery_SpecialChar() 
'261007,14
   'CLICK HERE, press F5 to Run!
   Dim sQueryName As String _ 
      ,sDescription As String 
      
   sQueryName =  "qWdSpecialCharNotation"
   ' Chr(11) is a manual line break in Word
   sDescription =  "Notation for special characters you can use when you" _ 
      & Chr(11) &  " Find or Find/Replace in Word," _ 
      &  " including non-printing characters."
      
   'Create Word document from query, specify description
   Call aWordDocumentFromQuery(sQueryName,sDescription) 
End Sub 

'-------------------------------------------------------------------------------
'           test_aWordDocumentFromQuery_Element
'-------------------------------------------------------------------------------
Public Sub test_aWordDocumentFromQuery_Element() 
'261007,14
   'CLICK HERE, press F5 to Run!
   Dim sQueryName As String _ 
      ,sDescription As String 
      
   sQueryName =  "qElement"
   
   'vbCrLf is Carriage Return + Line Feed and creates a paragraph mark
   sDescription =  "Elements that all matter is composed of with" _ 
      &  " Element name, Symbol, Z (#Protons), relative atomic Mass," _ 
      &  " Abundance (% in Body, Galaxy, and Air)," _ 
      &  " Essential (subjective)?, Pronounciation, common Charges, " _ 
      &  " Group and Period on Periodic Chart." _ 
      & vbCrLf _ 
      &  "Sorted by Atomic Number (Z)," _ 
      &  " which is the number of protons in the nucleus of an atom." _ 
      & vbCrLf 
      
   'Create Word document, specify query, description, Landscape, Narrow margins
   '1=Landscape (wide), True=Narrow margins
   Call aWordDocumentFromQuery(sQueryName _ 
      ,sDescription _ 
      ,1,True) 
End Sub 

'-------------------------------------------------------------------------------
'           test_aWordDocumentFromQuery_BogusError
'-------------------------------------------------------------------------------
Public Sub test_aWordDocumentFromQuery_BogusError() 
'260930
   'CLICK HERE, press F5 to Run!
   Dim sQueryName As String _ 
      ,sDescription As String 
      
   sQueryName =  "Bogus Query name"
   
   'Create Word document -- error since query doesn't exist
   Call aWordDocumentFromQuery(sQueryName,sDescription) 
End Sub 
'-------------------------------------------------------------------------------
'           test_aWordDocumentFromQuery_NoRecordsError
'-------------------------------------------------------------------------------
Public Sub test_aWordDocumentFromQuery_NoRecordsError() 
'260930
   'CLICK HERE, press F5 to Run!
   Dim sQueryName As String _ 
      ,sDescription As String 
      
   sQueryName =  "qNoRecords" 'Query doesn't have records
   
   'Create Word document -- error since query doesn't have records
   Call aWordDocumentFromQuery(sQueryName,sDescription) 
End Sub 

'-------------------------------------------------------------------------------
'           test_aWordDocumentFromQuery_CantOpenError
'-------------------------------------------------------------------------------
Public Sub test_aWordDocumentFromQuery_CantOpenError() 
'261010
   'CLICK HERE, press F5 to Run!
   Dim sQueryName As String _ 
      ,sDescription As String 
      
   sQueryName =  "qTempBadName" 'Query has a bad field name
   
   'Create Word document -- error since query can't open
   Call aWordDocumentFromQuery(sQueryName,sDescription) 
End Sub 

'*************** Code End *******************************************************

Reference

Microsoft Learn

CreateObject function

Documents.Add method (Word)

Range.InsertAfter method (Word)

Range.InsertParagraphAfter method (Word)

Range object (Word)

Tables.Add method (Word)

Table object (Word)

Table.Cell method (Word)

Row.HeadingFormat property (Word)

Row.AllowBreakAcrossPages property (Word)

Table.Borders property (Word)

Columns object (Word)

PageSetup object (Word)

Fields.Add method (Word)

Range.ParagraphFormat property (Word)

Database.OpenRecordset method (DAO)

RecordsetTypeEnum enumeration (DAO)

TableDef.Fields property (DAO)

AcSysCmdAction enumeration (Access)

MkDir statement

RGB function

Shell function

Backstory

This is a good example of creating a Word document from data in Access. In this case, the data is the results of a query. Instead of calling routines as I usually do to make a new Word document, create a Word table with borders and shading, add a header, change orientation to Landscape and set narrow page margins, all the VBA code is in one procedure.

~ crystal

the simplest way is best, but usually the hardest to see

Share with others

Here's the link for this page in case you want to copy it or share it with someone:

https://msaccessgurus.com/VBA/aWord_NewFromQuery.htm

or in old browsers:
http://www.msaccessgurus.com/VBA/aWord_NewFromQuery.htm