Escribir consulta de acceso al marcador de Word usando VBA

Vba

Módulo estándar

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: 
' 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:
'          
'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 ******************************************************

‘ El código se generó con colores usando el complemento gratuito Color Code para Access