Question : Exporting Access Form query into MS Word

I have the following code and the following tables.
I found the code from internet and modified the beginning just a little bit for my purposes. The code is on an access form button. I would like user to be able to export the contents of the form to MS Word template.

So basically, i would like to have
FundName
Contact Name
Phone
Contact Email

(these come from the Tbale fund Info with the query)
to be displayed in the header.

Then,
I would like
User
Contact Type
DateTime1
to come from Comcon with the query
then I would like
Comments (again from ComCon with the query)

to appear on the MS Microsoft word template.
How can I do this with the code I have

thanks

         
           
             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:

           
           
          Private Sub Command6_Click()

'Written by Helen Feddema 5-9-98
'Last modified 8-2-2000

On Error GoTo ErrorHandler

   Dim dbs As dao.Database
   Dim rst As dao.Recordset
   
   Dim strTemplateDir As String
   Dim appWord As Object
'   dim appword as Word.
   Dim docs As Object
   Dim doc As Object
   Dim strLetter As String
   Dim strFullName As String
   Dim strAddress As String
   Dim lngCount As Long
   Dim intAddressType As Integer
   Dim strEmpty As String
   Dim FundName As String
   Dim strsql As String
   Dim strwhere As String
   Dim strword As String
   
'     strsql = "SELECT * FROM FundInfo "
'    strsql2 = "SELECT * FROM ComCon "
'    strWhere = "1=1"
'    strWhere2 = "1=1"
'
'    If Not IsNull(Me.fundselection) Then
'        strWhere = strWhere & " AND fundname = '" & Me.fundselection.Column(1) & "'"
'    End If
'If Not IsNull(Me.fundselection) Then
'        strWhere2 = strWhere2 & " AND fundname = '" & Me.fundselection.Column(1) & "'"
'    End If

strword = "C:\Program Files\Microsoft Office\Office11\WinWord.Exe"
    

    Shell """" & strword & """ /a", vbMinimizedFocus

strEmpty = Chr$(34) & Chr$(34)
   strsql = "Select * from Comcon"
   If Not IsNull(Me.FundName) Then
        strwhere = strwhere & " fundname = '" & Me.FundName & "'"
        strwhere = strwhere & " AND ID = " & CLng(Me.ID) & ""
    End If
    
    
   strsql = strsql & " where " & strwhere
'   MsgBox strsql
   
   
   'Get reference to data table
   Set dbs = CurrentDb()
   Set rst = dbs.OpenRecordset(strsql)
   
'   Set rst = dbs![Query4].OpenRecordset(dbOpenDynaset)
   
   lngCount = rst.RecordCount
   If lngCount = 0 Then
      MsgBox "No records to export"
      Exit Sub
   Else
'      MsgBox lngCount & " records to transfer to Word"
   End If
   
   'Determine what kind of address to export to labels
   'from user selection in option group
'   intAddressType = Me![fraAddressType]
   
   'Open Word invisibly
   
   Set appWord = GetObject(, "Word.Application")
'   Set appWord = CreateObject("Word.Application")
   strLetter = "asilk.dot"
   appWord.Visible = True
   'Pick up Word user templates folder from Registry
   
   
   
   strTemplateDir = "U:\ss\siena\Niang"
   strLetter = strTemplateDir & "\" & strLetter
'   Debug.Print "Opening document based on template: " & strLetter
appWord.Visible = True
   Set docs = appWord.Documents
   docs.Add strLetter
   Set doc = appWord.ActiveDocument
   'Loop through table, exporting each record to a cell in the Word table
   Do Until rst.EOF
      With rst
         FundName = !FundName
         
         Debug.Print strFullName
        
         Debug.Print strAddress
         
         'Insert data into labels
         With appWord.Selection
            .TypeText Text:=strFullName
            .TypeParagraph
            .TypeText Text:=strAddress
            .TypeParagraph
            .MoveRight Unit:=wdCell
            .MoveRight Unit:=wdCell
         End With
'
'         Me![txtLastContact] = strFullName
         DoCmd.RunCommand acCmdSaveRecord
      End With
   rst.MoveNext
   Loop
   
   'Make font size smaller for business addresses
   If intAddressType = 1 Then
      appWord.Selection.WholeStory
      With appWord.Selection.Font
         .Name = "Calibri"
         .Size = 9
      End With
   End If
   
   appWord.Selection.HomeKey Unit:=wdStory
   MsgBox "All Contacts exported!"

ErrorHandlerExit:
   Exit Sub

ErrorHandler:
    If Err = 429 Then
      'Word is not running; open Word with CreateObject
      Set appWord = CreateObject("Word.Application")
      Resume Next
   Else
      MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description
      Resume ErrorHandlerExit
   End If
   
End Sub

           
         

Attachments:

gg.bmp (1.7 MB) (File Type Details)

database pic

Answer : Exporting Access Form query into MS Word

You can export the current data from the form's datasource with some code like this.

                       
         
           
             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:

           
           
             Sub ExportToWord()
    Dim rs As Recordset
    Dim fld As Field
    Dim wrdApp As Word.Application
    Dim wrdDoc As Word.Document
    Dim strBookmarkName As String
    
    On Error Resume Next
    Set wrdApp = GetObject(, "Word.Application")
    On Error GoTo 0
    If wrdApp Is Nothing Then 'word wasn't already running, so create a new instance
        Set wrdApp = CreateObject("Word.Application")
    End If
    wrdApp.Visible = True
    
    Set wrdDoc = wrdApp.Documents.Add("C:MyTemplates\MyTemplate.dot")
     
    Set rs = Form1.Recordset
    For Each fld In rs.Fields
        strBookmarkName = Replace(fld.Name, " ", "_") 'bookmark names must not contain spaces
        wrdDoc.Bookmarks(strBookmarkName).Range.Text = fld.Value
    Next fld
          
    
End Sub
           
         