Vba access таблица word

04. Данный пример показывает как можно создать таблицу в Microsoft Word, используя vba в Word. При этом создается соединение внутри документа Word. Обратите внимание, что функция InsertDatabase отличается параметрами в разных версиях офиса.

Option Compare Database
Option Explicit
'#Const AccessVer = 2000
'#Const AccessVer = 2002
#Const AccessVer = 2003

'***************************************************************
'04.Пример. Как создать таблицу в документе Word ?
'***************************************************************

'==============================================================
'   Создание таблицы в документе Word
'   ---------------------------------
'   Для этого Вы должны создать в шаблоне la_automat.dot
'   закладку с имеенем Таблица. Например,
'   Вставка - Закладка ... - Имя закладки=Таблица
'   (Нажмите кнопку Добавить и сохраните шаблон)
'
Private Sub butNewWord_Click()
Dim app As Word.Application  'Приложение программы
Dim strDOC As String ' Имя документа
Dim strDOT As String ' Имя шаблона
Dim strMDB As String ' Имя базы данных
Dim rng As Word.Range ' Область данных
Dim tbl As Word.Table ' Таблица документа
Dim c As Word.Cell ' Ячейка таблицы
Dim i As Long ' Переменная

    On Error GoTo 999
    ' Определяем имена шаблона, документа и базы данных
    With Application.CurrentProject
        strDOT = .Path  ""  "la_automat.dot"
        strDOC = .Path  ""  "la_automat.doc"
        strMDB = .Path  ""  .Name
    End With
    
    ' Управление документом Word
    Set app = New Word.Application 'Новое приложение Word
    app.Visible = True 'Отображаем документ
    app.Documents.Add strDOT 'Добавляем шаблон
    
    ' Выбираем закладку (позицию) таблицы
    Set rng = app.ActiveDocument.Bookmarks("Таблица").Range
    With rng
        .Collapse wdCollapseEnd
        ' Вставляем таблицу, используя запрос из базы данных
        #If AccessVer = 2000 Then
            .InsertDatabase _
                Style:=191, _
                LinkToSource:=False, _
                Connection:="Query ЗапросПримера04", _
                DataSource:=strMDB
        #ElseIf AccessVer = 2002 Then
            .InsertDatabase Format:=0, Style:=0, LinkToSource:=False, _
            Connection:= _
            "Provider=Microsoft.Jet.OLEDB.4.0;Password="""";User ID=Admin;Data Source="  strMDB  ";Mode=Read;Extended Properties="""";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Database Password="""";Jet OLEDB:Engi" _
            , SQLStatement:="SELECT * FROM `ЗапросПримера04`"  "", PasswordDocument _
            :="", PasswordTemplate:="", WritePasswordDocument:="", _
            WritePasswordTemplate:="", DataSource:= _
            strMDB, From:=-1, To:=-1, _
            IncludeFields:=True
        #Else
            .InsertDatabase Format:=0, Style:=0, LinkToSource:=False, _
                Connection:= _
                "Provider=Microsoft.Jet.OLEDB.4.0;Password="""";User ID=Admin;Data Source="  strMDB  ";Mode=Read;Extended Properties="""";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Database Password="""";Jet OLE" _
                , SQLStatement:="SELECT * FROM `ЗапросПримера04`"  "", PasswordDocument _
                :="", PasswordTemplate:="", WritePasswordDocument:="", _
                WritePasswordTemplate:="", DataSource:= _
                strMDB, From:=-1, To _
                :=-1, IncludeFields:=True
        #End If
        
        i = .Tables.Count ' Всего таблиц в данной области
        Set tbl = .Tables(i) ' Созданная таблица
        ' Форматируем всю таблицу
        tbl.Range.Font.Size = 10 ' Выбираем шрифт
        tbl.AutoFormat wdTableFormatGrid8 ' Выбираем авто-формат
       
        ' Вставляем колонку в начало таблицы
        tbl.Columns.Add tbl.Columns(1) ' Добавляем колонку
        i = 0
        For Each c In tbl.Range.Columns(1).Cells
            If i Then
                ' Изменяем данные
                c.Range.InsertAfter Format(i, "000") ' Вставить данные
                c.Range.ParagraphFormat.Alignment = wdAlignParagraphRight  'Правый формат
            Else
                ' Изменяем заголовок ячейки
                tbl.Range.Columns(1).Cells(1).Range.Text = "Пункт"
            End If
            i = i + 1
        Next c
        ' Форматируем заголовок, т.е. всю строку
        tbl.Rows(1).Select ' Выбираем заголовок
        With app.Selection
            .ParagraphFormat.Alignment = wdAlignParagraphCenter
            .Font.Name = "Arial" ' Имя шрифта
            .Font.Size = 10 ' Размер шрифта
        End With
        
        ' Добавляем новую строку
        tbl.Rows.Add ' Добавляем строку в конец таблицы
        With tbl.Cell(tbl.Rows.Count, 1) ' Выбираем 1 ячейку строки
          .Formula "=SUM(ABOVE)" ' Устанавливаем формулу
          .Shading.BackgroundPatternColorIndex = wdDarkRed ' Назначаем цвет фона
          .Range.Font.Bold = True ' Толщина (вес) текста
        End With
   End With
    
    app.ActiveDocument.SaveAs strDOC  ' Сохраняем файл
    ' app.Quit 'Закрываем приложение
    Exit Sub
999:
    MsgBox Err.Description  'Ошибка
    Err.Clear
    app.Quit
End Sub

What you need to do is to first open a new instance of Word from Access. This is done by the following command:

Set wrdApp = CreateObject("Word.Application")

Then to make it visible and to add a document, you use this object from that point on:

wrdApp.Visible = True
Set myDoc = wrdApp.Documents.Add   'Here you should also keep the new document as an object so you can directly refer to it

Or if you use a template you need to open it instead:

wrdApp.Visible = True
Set myDoc = wrdApp.Documents.Open ("C:databasetemplate.docx")

And then comes your code that you need to modify accordingly to the above:

For iCount = 0 To numberOfTables - 1

    myDoc.Tables.Add Range:=Selection.Range, NumRows:=2, NumColumns:= _
        3, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
        wdAutoFitFixed
    With myDoc.ActiveWindow.Selection.Tables(1)  
'Note here that for the Selection object you need to refer to the active window
        If .Style <> "Table Grid" Then
            .Style = "Table Grid"
        End If
        .ApplyStyleHeadingRows = True
        .ApplyStyleLastRow = False
        .ApplyStyleFirstColumn = True
        .ApplyStyleLastColumn = False
        '.ApplyStyleRowBands = True 'Office 2010
        '.ApplyStyleColumnBands = False 'Office 2007
    End With

    myDoc.ActiveWindow.Selection.EndKey Unit:=wdStory
    myDoc.ActiveWindow.Selection.TypeParagraph

Next iCount

This should get you started.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
Public Sub WordA(SelectOrderID)
' Передача данных в Microsoft Word
' Описание рабочих переменных
Dim B, C, F, D, E
Dim a As Variant
Dim s$, i%
a = Date
' Объект Word
Dim oWord As Object
 
Dim DSset As ADODB.Recordset  ' Набор данных
Set DSset = New ADODB.Recordset
' Процедура находится в модуле ModuleSlave
' SelectDateTreaty - Дата
' DayMonthYear - Дата прописью
' Создание объекта MS Word
Set oWord = CreateObject("Word.Application")
' Сделать окно MS Word видимым
oWord.Visible = True
' Заголовок окна MS Word
oWord.Caption = "Заказ-наряд на проведение проверки качества "
oWord.Documents.Add
' Ориентация книжная бумага А4
' Поля (1 см = 28 пунктов)
With oWord.ActiveDocument.PageSetup
 .LineNumbering.Active = False
     .Orientation = wdOrientPortrait
     .LeftMargin = 48
     .RightMargin = 40
     .TopMargin = 56
     .BottomMargin = 56
End With
With oWord.ActiveDocument
     .AutoHyphenation = True
     .HyphenateCaps = True
     .ConsecutiveHyphensLimit = 0
End With
 
 
    With oWord.Selection
         .Font.Bold = True
         .Font.Name = "Times New Roman"
         .Font.Size = 11
         .ParagraphFormat.Alignment = wdAlignParagraphJustify
         .TypeText ("Заказ-наряд от " & a)
         .TypeParagraph
         .TypeText ("ООО Сервисный центр тел. +7 800 7707 888")
         .TypeParagraph
         .Font.Bold = False
         .Font.Size = 9
         .ParagraphFormat.Alignment = wdAlignParagraphJustify
         .TypeText ("Юридический адрес 143909, Московская область, г.Балашика, ул.Звездная, д.76, пом 418")
         .TypeParagraph
         .TypeText ("Адрес филиала: инд 195220 г. Санкт-Петербург пр. Науки 21 к.1")
         .TypeParagraph
         .Font.Underline = True
         .TypeText ("Основание: Расходная накладная от 29.05.2015")
         .TypeParagraph
         .Font.Bold = True
         .Font.Size = 11
         With DSset
            .Source = "SELECT OrderID, FamilyName, FirstName, SecondName, Object, Dates, DueDate, Cost, Phone " & _
            "FROM tblOrder " & _
            "WHERE OrderID = " & SelectOrderID
            .ActiveConnection = CurrentProject.Connection
            .CursorType = adOpenKeyset
            .Open
         
            D = !OrderID
            F = !FamilyName
            B = !FirstName
            C = !Phone
            E = "Покупатель: " & F & (" " + B)
         End With
    
    .TypeText (E)
    .TypeParagraph
    .Font.Bold = False
    .Font.Size = 9
    .Font.Underline = False
    .TypeText ("Сот. :" & C)
    DSset.Close
    End With
    
'======================================================================
'Пошла табличка:.
    oWord.Selection.TypeParagraph
 
    oWord.ActiveDocument.Tables.Add oWord.Selection.Range, 2, 4, 1, 0
    'oWord.ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=2, NumColumns:= _
        4, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
        wdAutoFitFixed
        
        With oWord.Selection.Tables(1)
            If .Style <> "Table Grid" Then
                .Style = "Table Grid"
            End If
            .ApplyStyleHeadingRows = True
            .ApplyStyleLastRow = False
            .ApplyStyleFirstColumn = True
            .ApplyStyleLastColumn = False
            .ApplyStyleRowBands = True
            .ApplyStyleColumnBands = False
        End With
          
        oWord.Selection.Tables(1).Columns(1).SetWidth ColumnWidth:=28.1, RulerStyle:= _
            wdAdjustFirstColumn
    
        oWord.Selection.Tables(1).Columns(2).SetWidth ColumnWidth:=63.8, RulerStyle:= _
            wdAdjustFirstColumn
    
        oWord.Selection.Tables(1).Columns(3).SetWidth ColumnWidth:=255.15, RulerStyle:= _
            wdAdjustFirstColumn
            
        
        oWord.Selection.TypeText Text:="№"
        oWord.Selection.MoveRight Unit:=wdCell
        oWord.Selection.MoveRight Unit:=wdCharacter, Count:=2, Extend:=wdExtend
        oWord.Selection.Cells.Merge
        
        oWord.Selection.TypeText Text:="Наименование Товара"
        oWord.Selection.MoveRight Unit:=wdCell
        oWord.Selection.TypeText Text:="Серийный Номер"
 
        s = "SELECT * FROM Item WHERE OrderID=" & SelectOrderID
    
    
        With DSset
            .Source = s
            .ActiveConnection = CurrentProject.Connection
            .CursorType = adOpenKeyset
            .Open
             Do While Not .EOF '
                i = i + 1
                With oWord.Selection
                    .MoveRight 12 ' Unit:=wdCell
                    .TypeText CStr(i)
                    .MoveRight 12 ' Unit:=wdCell
                    .TypeText "123456789" '???? !!!!
                    .MoveRight 12 ' Unit:=wdCell
                    'Debug.Print DSset!ItemName
                    .TypeText CStr(DSset!ItemName)
                    .MoveRight 12 ' Unit:=wdCell
                    .TypeText "1234567890серийный" '???? !!!!
                End With
            .MoveNext
            Loop
            .Close
        End With
 
 
        oWord.Selection.MoveDown Unit:=wdLine, Count:=1
 
End Sub

Всем привет, сегодня мы поговорим о том, как можно выгрузить данные из Access в такие приложения как Word и Excel. Но не о стандартном способе, который есть в  Access (связь с Office), а о способе, который позволяет выгружать данные в заданный шаблон как в Word, так и в Excel.

Другими словами, это нужно тогда, когда создать отчет в Access по шаблону, который уже существует, например, в Word, невозможно или слишком трудоемко. Как Вы знаете, отчет в Access может выводиться просто коряво или, самый распространенный вариант, это когда много текста, который в отчете Access не так хорошо форматируется как в Word, а данных не так много, но отчет необходимо автоматизировать, например это какие-то договора, заявления и так далее.

Использование слияния из самого Word-а не очень удобно, поэтому сегодня я расскажу, как можно заполнять такие шаблоны напрямую из Access, путем нажатия на одну кнопку.

Кроме выгрузки в шаблон Word, иногда возникает и необходимость выгрузки в шаблон Excel, и этот способ мы тоже сегодня рассмотрим.

Содержание

  1. Экспорт данных из Access в шаблон Word
  2. Код VBA для выгрузки данных в шаблон Word
  3. Экспорт данных из Access в шаблон Excel
  4. Код VBA для выгрузки данных в шаблон Excel

Вся разработка делится на две части, это:

  • Настройка шаблона Word;
  • Настройка выгрузки данных в шаблон.

Суть настройки шаблона заключается в том, чтобы проставить необходимые поля в тех местах шаблона, где нужно выводить те или иные данные. Это делается с помощью полей формы.

Примечание! Я использую Microsoft Word 2003.

Открываем шаблон Word, для начала добавим необходимую панель инструментов, для этого нажимаем «Вид -> Панель инструментов» и ставим галочку «Формы». Теперь у Вас отобразилась панель инструментом «Формы». Все, что осталось сделать — это вставить в местах, в которых необходимо выводить данные, элементы «Текстовое поле», которые доступны на только что добавленной панели инструментов.

После добавления поля, у Вас появится серая область, которая свидетельствует о том, что поле добавлено. Теперь необходимо задать имя этого поля, для того чтобы потом из access вставлять в него значения (стандартное названия не очень удобное). Для этого щелкните правой кнопкой мыши по полю и нажмите «Свойства». В поле закладка напишите желаемое имя этого поля, я в примере назвал его MyTestPole.

Скриншот 1

Курс по SQL для начинающих

Создайте столько полей, сколько Вам нужно.

На этом настройка шаблона закончена, рекомендую сделать этот шаблон только для чтения, а то пользователь возьмет, сформирует документ и сохранит его, и шаблон тем самым потеряется, а если сделать его только для чтения, то у него такой возможности не будет, только сохранять через «Сохранить как».

Переходим к более интересной задачи, это к реализации самой выгрузки из Access в этот шаблон на VBA.

Примечание! Я использую Access в связке с MS SQL 2008, поэтому и данные буду брать от туда.

Код VBA для выгрузки данных в шаблон Word

Допустим, у Вас есть форма, сделайте на ней кнопку (я назвал ее testbutton) и в событие нажатие кнопки вставьте следующий код VBA:

   
   Private Sub testbutton_Click()
   
   'Объявляем переменные
   Dim FileDialog As FileDialog
   Dim rsd As ADODB.Recordset
   Dim strSQL As String
   Dim WordApOb As Object
   Dim WordOb As Object
   Dim path As String
   Set rsd = New ADODB.Recordset
   
   'запрос к базе данных для получения необходимых данных
   strSQL = "select * from dbo.table where KOD = " & Me.kod & ""
   rsd.open strSQL, CurrentProject.Connection
  
  'Выбираем шаблон
   Set FileDialog = Application.FileDialog(msoFileDialogOpen)
   
   'убираем множественный выбор, он нам не нужен
   FileDialog.AllowMultiSelect = False
  
  'очистим и установим фильтры
   FileDialog.Filters.Clear
   FileDialog.Filters.add "Word", "*.doc"
   
   'установим фильтр по умолчанию
   FileDialog.FilterIndex = 1
   
   'проверяем, что сделал user, если выбрал шаблон, то начинаем работу
   If FileDialog.Show = False Then
     'Если нет, то выходим
     Set dlgFile = Nothing
     Exit Sub
   End If
   
   'получаем путь к файлу
   path = Trim(FileDialog.SelectedItems(1))
   
   'Очистим переменную
   Set FileDialog = Nothing
   If path <> "" Then
   
   'Будем отслеживать ошибки
   On Error GoTo Err_testbutton_Click
   
   'Создаем объект Word
   Set WordOb = CreateObject("Word.document")
   
   'Задаем нашему документу значение из шаблона
   Set WordOb = GetObject(path)
   
   'Задаем значение объекту word.Application
   Set WordApOb = WordOb.Parent
   
   'делаем приложение word видимым
   WordApOb.Visible = True
   
   'ищем наше поле в шаблоне
   WordOb.Bookmarks("mytestpole").Select
   
   'задаем ему новое значение из нашего Recordset
   WordApOb.Selection.TypeText Text:=Nz(rsd.Fields("field").Value, " ")
   'и так далее по всем полям
   
   'в конце перейдем на начало нашего документа
   WordApOb.Selection.Goto wdGoToFirst
   'и активируем его
   WordApOb.Activate
   
   'Очистим переменные
   Set WordOb = Nothing
   Set WordApOb = Nothing
   
   Exit_testbutton_Click:
     Exit Sub
   
   Err_testbutton_Click:
     MsgBox Err.Description
     'в случае ошибки будем делать следующие
     'закроем word без сохранения
     WordOb.Close (wddonotsavechanges)
     WordApOb.Quit
    'и также очистим переменные
     Set WordOb = Nothing
     Set WordApOb = Nothing
     Resume Exit_testbutton_Click
    End If
   
   End Sub

Код прокомментирован, поэтому сложностей возникнуть не должно. Здесь весь смысл сводится к созданию объекта word.document и word.application. А после мы уже работаем с нашими объектами, т.е. заполняем их.

Экспорт данных из Access в шаблон Excel

В шаблоне Excel уже не нужно создавать поля как в Word, так как здесь мы уже будем ориентироваться по адресам ячеек.

Существует несколько способов, как заполнять Excel шаблон, я опишу два, первый — это тогда, когда Вам просто необходимо проставить несколько полей, т.е. в источнике данных будет всего одна строка с несколькими столбцами. Второй — это когда строк будет уже несколько, причем Вы не знаете, сколько именно (в зависимости от каких то условий). В шаблоне по умолчанию отведено для этого все пару строк, поэтому мы будем нужные нам строки добавлять, для того чтобы наши данные не накладывалась на строки ниже (допустим там примечание, подпись руководителя и т.д.). И совет, я здесь, для примера, использую всего один источник данных, а Вы, если Вам необходимо заполнить шапку, примечание и некое количество строк (т.е. область данных), можете использовать несколько источников (Recordset).

Код VBA для выгрузки данных в шаблон Excel

Сначала добавьте кнопку на форму (я ее назвал testexcel) и вставьте следующий код в событие «Нажатие кнопки».

   
   Private Sub testexcel_Click()
   
   'Объявляем переменные
   Dim XL As Object
   Dim XLT As Object
   Dim newrow As Object
   Dim rsd As ADODB.Recordset
   Dim strSQL As String
   Set rsd = New ADODB.Recordset
   
   'Запрос к базе данных
   strSQL = "select * from dbo.table where kod = " & Me.kod & ""
   rsd.open strSQL, CurrentProject.Connection
   
   'Создаем необходимые объекты
   Set XL = CreateObject("Excel.Application")
   'для примера показываю, как можно сразу загружать шаблон без выбора
   Set XLT = XL.Workbooks.open("C:testfile.xls")
   
   '1 способ - если в источнике данных всего одна строка
   With XLT.Worksheets("Лист1")
              .[a1] = rsd.Fields("field1")
              .[b1] = rsd.Fields("field2")
              .[c1] = rsd.Fields("field3")
              .[d1] = rsd.Fields("field4")
            End With
   
   '2 способ - если строк в источнике несколько
   'причем мы учтем то, что у нас есть шапка и примечание в Excel
   'и мы не знаем, сколько строк у нас вставится 
   'и поэтому строки будем добавлять в случае необходимости
   'зададим, с какой строки будем начинать вставлять данные
   Rowss = 10
   'для нумерации
   numrow = 1
   'запускаем цикл, он будет работать до тех пор, пока не закончатся строки в нашем источнике
   While Not (rsd.EOF)
      'смотрим, если строк больше чем мы задали в шаблоне
      If Rowss >= 12 Then
          'то добавляем строку
         XLT.Worksheets("Лист1").Rows(Rowss).Insert
          'Запомним нашу строку
         Set newrow = XLT.Worksheets("Лист1").Rows(Rowss)
          'и вставим туда копию предыдущей строки
          'для того если вдруг у вас там есть объединенные ячейки или какие-то нужные данные
          'так как новая строка создастся без всяких объединений и значений
         XLT.Worksheets("Лист1").Rows(Rowss - 1).Copy newrow
          'это просто для примера как можно очистить некий диапазон внутри документа
       'XLT.Worksheets("Лист1").Range("A10:F10").ClearContents
       'динамически формируем адрес нужной ячейки
          cell = "a" & Rowss
          'и задаем ей значение
         XLT.Worksheets("Лист1").Range(cell) = numrow
         cell = "b" & Rowss
         XLT.Worksheets("Лист1").Range(cell) = rsd.Fields("field5").Value
         'переходим на следующую строку
          Rowss = Rowss + 1
          'переходим на следующую строку в источнике данных
         rsd.MoveNext
      Else
          'а это выполняется до тех пор, пока не закончатся заданные строки в шаблоне
          'т.е. если строк в источнике всего 1, то в код, который выше мы даже не попадем
         cell = "a" & Rowss
         XLT.Worksheets("Лист1").Range(cell) = numrow
         cell = "b" & Rowss
         XLT.Worksheets("Лист1").Range(cell) = rsd.Fields("field5").Value
         Rowss = Rowss + 1
         rsd.MoveNext
      End If
         
        'для нумерации
        numrow = numrow + 1
   'конец цикла
   Wend
   
   'это просто пример как можно удалить строку целиком
   'XLT.Worksheets("Лист1").Rows(20).Delete
   
   'делаем Excel видимым
   XL.Visible = True
   
   'Очищаем переменные
   Set XL = Nothing
   Set XLT = Nothing
   Set newrow = Nothing
   
   End Sub

Здесь я также все подробно прокомментировал, но если есть вопросы, то задавайте их в комментариях к данной статье.

Для сведения, я здесь при создании объекта и Word.Application и Excel.Application использовал позднее связывание, для того чтобы не добавлять необходимые библиотеки и обеспечить совместимость.

Надеюсь, мои примеры Вам помогут!

Similarily to my post regarding exporting records to MS Excel, below is some sample code that illustrates how one can export data into a new Word document (in a table structure). The code determines the necessary rows and columns based on the table or query passed to it and then does the rest. You can easily from this simple example get into formatting fonts, etc…

'---------------------------------------------------------------------------------------
' Procedure : Export2DOC
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Export a recordset to a MS Word table in a new document
' Note      : Overwrites file if it already exists without any warning, so you may wish
'               to add a check prior to calling this function
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
'             (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Uses Late Binding, none required
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sQuery        : Name of the Table or Query to Export the data from
' sFileName     : Path and Filename to save the Word Document as
' bOpenDocument : Leave the document open to the users or not (close after generating)
'
' Usage:
' ~~~~~~
' Export2DOC "Contacts", "C:Temptesting01.docx"
' Export2DOC "IncomingOrders", "C:Temporders.docx", True
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2012-Apr-23             Initial Release
' 2         2020-04-08              Updated proc header
'                                   Added sFileName and bOpenDocument arguments
'                                   Added PageSetup.Orientation to proc
'                                   Fixed a bug in the table row count
'                                   Updated and expanded the error handler
'---------------------------------------------------------------------------------------
Function Export2DOC(sQuery As String, _
                    sFileName As String, _
                    Optional bOpenDocument As Boolean = False)
    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
    '    Const wdOrientPortrait = 0
    Const wdOrientLandscape = 1

    '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
    'Not strictly necessary, but for larger tables switching to Landscape can be very beneficial!
    '   so the next line demonstrates how that can easily be done
    oWordDoc.PageSetup.Orientation = wdOrientLandscape

    'Open our SQL Statement, Table, Query
    Set db = CurrentDb
    Set rs = db.OpenRecordset(sQuery, dbOpenSnapshot)
    With rs
        If .RecordCount <> 0 Then
            .MoveLast   'Ensure proper count
            iRecCount = .RecordCount    'Number of records returned by the table/query
            .MoveFirst
            iFldCount = .Fields.Count   'Number of fields/columns returned by the table/query

            'Switch to print preview mode (not req'd just a personal preference)
            oWord.ActiveWindow.View.Type = wdPrintView
            'Create the basic table
            oWord.ActiveDocument.Tables.Add oWord.selection.Range, _
                                            iRecCount + 1, _
                                            iFldCount, _
                                            wdWord9TableBehavior, _
                                            wdAutoFitFixed

            Set oWordTbl = oWordDoc.Tables(1)
            'Build our Header Row
            For i = 0 To iFldCount - 1
                oWordTbl.Cell(1, i + 1) = rs.Fields(i).Name
            Next i
            'Build our data rows
            For i = 1 To iRecCount
                For j = 0 To iFldCount - 1
                    oWordTbl.Cell(i + 1, j + 1) = Nz(rs.Fields(j).Value, "")
                Next j
                .MoveNext
            Next i
        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.SaveAs (sFileName)   'Save and close
    If bOpenDocument = False Then
        oWordDoc.Close

        '    Close Word if is wasn't originally running
        If bWordOpened = False Then
            oWord.Quit
        End If
    End If

Error_Handler_Exit:
    On Error Resume Next
    rs.Close
    Set rs = Nothing
    Set db = Nothing
    oWord.Visible = True   'Make Word visible to the user
    Set oWordTbl = Nothing
    Set oWordDoc = Nothing
    Set oWord = Nothing
    Exit Function

Error_Handler:
    If Err.Number = 5148 Then
        MsgBox "Your Table/Query contains a total of " & iFldCount & " fields/columns, but Word tables can only support a maximum of 63.  " & _
               "Please change your Table/Query to only supply a maximum of 63 fields/columns and try again.", _
               vbCritical Or vbOKOnly, "Operation Aborted"
    Else
        MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
               "Error Number: " & Err.Number & vbCrLf & _
               "Error Source: Export2DOC" & vbCrLf & _
               "Error Description: " & Err.Description & _
               Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
               , vbOKOnly + vbCritical, "An Error has Occurred!"
    End If
    Resume Error_Handler_Exit
End Function

You may also wish to review my MS Access Sample- Export Data to Excel and/or Word.

Понравилась статья? Поделить с друзьями:
  • Vba excel 2010 пример
  • Vba access создать excel
  • Vba excel 2007 что это
  • Vba access как вставить в excel
  • Vba excel 2007 учебник