banner for Ms Access Gurus
Home Articles Code Tools

Create new Word document from Access Query using VBA automation

Create a new Word document using automation from Access using VBA. Write an optional description and then make a table with the results of an Access query. Add borders and shading to the table. Optionally specify Landscape orientation instead of Portrait (default). Create a page header with the query name, page number, and page count.

use VBA to Create Word document with results of an Access Query

Quick Jump

Download VBA Reference Backstory Share

Goto the Very Top  

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

Goto Top  

VBA

Standard module: mod_aWordDocumentFromQuery_s4p 

Option Compare Database  'Ignore Case
Option Explicit  'variables must be declared
'261010
'*************** Code Start ***************************************************
' module: mod_aWordDocumentFromQuery_s4p
' Purpose  : Automate Word: Create a new Word document from data in Access Query
'              Specify query name: results to Word table with borders + shading
'              Page header with page number and more
'              show information on StatusBar as code runs
'                 (File, Options, Current Database, check: Display Status Bar)
'              Optionally:
'                 Description to be written to document before table
'                 Orientation is Portrait unless Landscape specified
'                 Margins can be Narrow
' 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.
'------------------------
' PROCEDURES
'     aWordDocumentFromQuery
'------------------------ test procedures
'     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,1004,5,6,7,8
   'PARAMETERs
   '   psQueryName = name of query to show in a Word table
   'Optional
   '   psDescription - Text to write above the table
   '   piOrientation - Default = 0 = Portrait.
   '        Landscape = 1
   '   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 
      
   'make sure we can open the query
   nRows = 0 
   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 its not 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 
   
   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 under database folder
   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 

   '-------------------------------------------- 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 = piOrientation 
         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") 
         'only change in this document, not template
         .AutomaticallyUpdate = False 
         With .ParagraphFormat 
            .SpaceBefore = 2  'points, 72 points/inch
            .SpaceAfter = 2 
            .KeepTogether = True 
            .LineSpacingRule = 0  'wdLineSpaceSingle
         End With  'ParagraphFormat
      End With  'Normal Style
      With .Styles( "Heading 1") 
         .AutomaticallyUpdate = False 
         With .ParagraphFormat 
            .SpaceBefore = 0 
            .SpaceAfter = 4 
         End With  'ParagraphFormat
      End With  'Heading 1 Style
   
      '----------------------------------------- Content
      With .Content 
         'Title
         .InsertAfter psQueryName &  ", " _ 
            & Format(Now(), "yymmdd hh:nn ") 
         'style as Heading 1, .Parent is oDoc
         .Paragraphs(1).Style _ 
               = .Parent.Styles( "Heading 1") 
         .InsertParagraphAfter  'paragraph mark
      
         'write description paragraph
         If psDescription <>  "" Then 
            .InsertAfter psDescription 
            'blank line
            .InsertParagraphAfter 
         End If 
      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(Date, "d-mmm-yy, ddd") _ 
         &  ", 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: 
   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 
   Application.SysCmd acSysCmdClearStatus 

   Exit Sub 
 
Proc_Err: 
   MsgBox Err.Description _ 
     ,, "ERROR " & Err.Number _ 
     &  "   aWordDocumentFromQuery"
 
   Resume Proc_Exit 
   Resume 
End Sub 
'========================================================================== TEST
'-------------------------------------------------------------------------------
'           test_aWordDocumentFromQuery_SpecialChar
'-------------------------------------------------------------------------------
Public Sub test_aWordDocumentFromQuery_SpecialChar() 
'261007
   'CLICK HERE, press F5 to Run!
   Dim sQueryName As String _ 
      ,sDescription As String 
      
   sQueryName =  "qWdSpecialCharNotation"
   sDescription =  "Notation for special characters that you can use when you" _ 
      & vbCr &  " Find or Find/Replace in Word," _ 
      & vbLf &  " including non-printing characters." _ 
      & vbCrLf 
      
   'Create Word document
   Call aWordDocumentFromQuery(sQueryName,sDescription) 
End Sub 

'-------------------------------------------------------------------------------
'           test_aWordDocumentFromQuery_Element
'-------------------------------------------------------------------------------
Public Sub test_aWordDocumentFromQuery_Element() 
'261007
   'CLICK HERE, press F5 to Run!
   Dim sQueryName As String _ 
      ,sDescription As String 
      
   sQueryName =  "qElement"
   
   sDescription =  "Elements that all matter is composed of with" _ 
      &  " Element name, Symbol, Z, relative atomic Mass," _ 
      &  " Abundance (% in Body, Galaxy, and Air)," _ 
      &  " Essential? (subjective), Pronounciation, common Charges, " _ 
      &  " Group, and Period." _ 
      & vbCrLf _ 
      &  "Sorted by Atomic Number (Z)," _ 
      &  " which is the number of protons in the nucleus of an atom." _ 
      & vbCrLf 
      
   'Create Word document
   'Landscape (wide), 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 *******************************************************
Code was generated with colors using the free Color Code add-in, runs in Access

Goto Top  

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)

RGB function

Shell function

Goto Top  

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

Goto Top  

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

Goto Top