Access 2007 merge form + subform to Word

Private Sub cmdCreateInvoice_Click()
'Written by Helen Feddema 19-Aug-1999
'Last modified 22-Feb-2009
'Needs references to the DAO, Office, Word and Scripting Runtime libraries
 
   Dim appWord As Object
   Dim blnSaveNameFail As Boolean
   Dim curFreight As Currency
   Dim curSubtotal As Currency
   Dim curTotal As Currency
   Dim dblQuantity As Double
   Dim dbs As DAO.Database
   Dim doc As Word.Document
   Dim docs As Object
   Dim dteOrderDate As Date
   Dim dteRequiredDate As Date
   Dim dteShippedDate As Date
   Dim dteTodayDate As Date
   Dim fil As Scripting.File
   Dim fso As New Scripting.FileSystemObject
   Dim intCount As Integer
   Dim intReturn As Integer
   Dim lngOrderID As Long
   Dim lngProductID As Long
   Dim prps As Object
   Dim rst As DAO.Recordset
   Dim strBillToAddress As String
   Dim strBillToCityStateZip As String
   Dim strBillToCountry As String
   Dim strCompanyName As String
   Dim strCustomerID As String
   Dim strDefaultDocsPath As String
   Dim strDefaultTemplatesPath As String
   Dim strDiscount As String
   Dim strDoc As String
   Dim strDocsPath As String
   Dim strExtendedPrice As String
   Dim strMessage As String
   Dim strMessageTitle As String
   Dim strProductName As String
   Dim strPrompt As String
   Dim strSalesperson As String
   Dim strSaveName As String
   Dim strSaveNamePath As String
   Dim strShipAddress As String
   Dim strShipCityStateZip As String
   Dim strShipCountry As String
   Dim strShipName As String
   Dim strShipper As String
   Dim strShortDate As String
   Dim strTemplateName As String
   Dim strTemplateNameAndPath As String
   Dim strTemplatesPath As String
   Dim strTest As String
   Dim strTestFile As String
   Dim strTitle As String
   Dim strUnitPrice As String
   
On Error GoTo ErrorHandler
   
   'Create a Word instance to use for the invoice; uses the existing Word
   'instance if there is one, otherwise creates a new instance
    Set appWord = GetObject(, "Word.Application")
   
   'Keep Word invisible until the document is finished
   appWord.Visible = False
   
   'Run make-table queries to create tables to use for export;
   'I use make-table queries instead of select queries, because the
   'queries have a criterion limiting the Order ID to the one selected
   'on the form, and such parameter queries can't be used in a recordset.
   'Instead, the make-table queries are run to create tables which will
   'be used in the recordsets later in the code.
   DoCmd.SetWarnings False
   DoCmd.OpenQuery "qmakInvoice"
   DoCmd.OpenQuery "qmakInvoiceDetails"
   
   'Check that there is at least one detail item before creating invoice
   intCount = DCount("*", "tmakInvoiceDetails")
   Debug.Print "Number of Detail items: " & intCount
   
   If intCount < 1 Then
      strTitle = "Nothing to invoice"
      strPrompt = "No detail items for invoice; canceling"
      MsgBox prompt:=strPrompt, _
         buttons:=vbExclamation + vbOKOnly, _
         Title:=strTitle
      GoTo ErrorHandlerExit
   End If
   
   'Create recordset and get needed doc properties for this invoice
   Set dbs = CurrentDb
   Set rst = dbs.OpenRecordset("tmakInvoice", dbOpenDynaset)
   With rst
      'The Nz function is used to convert any Nulls to zeros or
      'zero-length strings, to prevent problems with exporting
      'to Word
      lngOrderID = Nz(![OrderID])
      Debug.Print "Order ID: " & lngOrderID
      strShipName = Nz(![ShipName])
      strShipAddress = Nz(![ShipAddress])
      strShipCityStateZip = Nz(![ShipCityStateZip])
      strShipCountry = Nz(![ShipCountry])
      strCompanyName = Nz(![CompanyName])
      strCustomerID = Nz(![CustomerID])
      strCompanyName = Nz(![CompanyName])
      strBillToAddress = Nz(![BillToAddress])
      strBillToCityStateZip = Nz(![BillToCityStateZip])
      strBillToCountry = Nz(![BillToCountry])
      strSalesperson = Nz(![Salesperson])
      dteOrderDate = Nz(![OrderDate])
      dteRequiredDate = Nz(![RequiredDate])
      dteShippedDate = Nz(![ShippedDate])
      strShipper = Nz(![Shipper])
      curSubtotal = Nz(![Subtotal])
      curFreight = Nz(![Freight])
      curTotal = Nz(![Total])
   End With
   rst.Close
   
   'Get selected Docs and Templates paths from database properties
   '(saved from controls on main menu)
   strDefaultDocsPath = appWord.Options.DefaultFilePath(wdDocumentsPath) & "\"
   strDocsPath = GetProperty("DocsPath", strDefaultDocsPath)
   Debug.Print "Docs path: " & strDocsPath
   strDefaultTemplatesPath = appWord.Options.DefaultFilePath(wdUserTemplatesPath) & "\"
   strTemplatesPath = GetProperty("TemplatesPath", strDefaultTemplatesPath)
   strTemplateName = "Northwind Invoice.dot"
   strTemplateNameAndPath = strTemplatesPath & strTemplateName
   
   'This date string is used in creating the invoice's save name
   strShortDate = Format(Date, "m-d-yyyy")
   'This date variable is used to print today's date on the invoice
   '(unlike a Word date code, it remains stable when the invoice is
   'reopened later)
   dteTodayDate = Date
   
   'Check for existence of template in templates folder,
   'and exit if not found
On Error Resume Next
 
   Set fil = fso.GetFile(strTemplateNameAndPath)
   If fil Is Nothing Then
      strTitle = "Template not found"
      strPrompt = "Can't find " & strTemplateName & " in " _
         & strTemplatesPath & "; canceling"
      MsgBox prompt:=strPrompt, _
         buttons:=vbInformation + vbOKOnly, _
         Title:=strTitle
      GoTo ErrorHandlerExit
   End If
   
On Error GoTo ErrorHandler
   
   Set docs = appWord.Documents
   Set doc = docs.Add(strTemplateNameAndPath)
   
   'Write information to Word custom document properties from
   'previously created variables
   Set prps = doc.CustomDocumentProperties
   prps.Item("TodayDate").Value = dteTodayDate
   prps.Item("OrderID").Value = lngOrderID
   prps.Item("ShipName").Value = strShipName
   prps.Item("ShipAddress").Value = strShipAddress
   prps.Item("ShipCityStateZip").Value = strShipCityStateZip
   prps.Item("ShipCountry").Value = strShipCountry
   prps.Item("CompanyName").Value = strCompanyName
   prps.Item("CustomerID").Value = strCustomerID
   prps.Item("CompanyName").Value = strCompanyName
   prps.Item("BillToAddress").Value = strBillToAddress
   prps.Item("BillToCityStateZip").Value = strBillToCityStateZip
   prps.Item("BillToCountry").Value = strBillToCountry
   prps.Item("Salesperson").Value = strSalesperson
   prps.Item("OrderDate").Value = dteOrderDate
   prps.Item("RequiredDate").Value = dteRequiredDate
   prps.Item("ShippedDate").Value = dteShippedDate
   prps.Item("Shipper").Value = strShipper
   prps.Item("Subtotal").Value = curSubtotal
   prps.Item("Freight").Value = curFreight
   prps.Item("Total").Value = curTotal
   
   'Highlight the entire Word document and update fields, so the data
   'written to the custom doc props is displayed in the DocProperty fields
   With appWord
      .Selection.WholeStory
      .Selection.Fields.Update
      .Selection.HomeKey Unit:=6
   End With
   
   'Go to table to fill with Details data
   With appWord.Selection
      .GoTo What:=wdGoToTable, Which:=wdGoToFirst, Count:=3, Name:=""
      .MoveDown Unit:=wdLine, Count:=1
   End With
   
   'Set up recordset of linked Details data to put in table on
   'Word invoice
   Set rst = dbs.OpenRecordset("tmakInvoiceDetails", dbOpenDynaset)
   
   'Save Details information to variables
   'Use Format function to apply appropriate formatting to
   'Currency and Percent fields
   With rst
      .MoveFirst
      Do While Not .EOF
         lngProductID = Nz(![ProductID])
         Debug.Print "Product ID: " & lngProductID
         strProductName = Nz(![ProductName])
         Debug.Print "Product Name: " & strProductName
         dblQuantity = Nz(![Quantity])
         Debug.Print "Quantity: " & dblQuantity
         strUnitPrice = Format(Nz(![UnitPrice]), "$##.00")
         Debug.Print "Unit price: " & strUnitPrice
         strDiscount = Format(Nz(![Discount]), "0%")
         Debug.Print "Discount: " & strDiscount
         strExtendedPrice = Format(Nz(![ExtendedPrice]), "$#,###.00")
         Debug.Print "Extended price: " & strExtendedPrice
         
         'Move through the table, writing values from the variables
         'to cells in the Word table
         With appWord.Selection
            .TypeText Text:=CStr(lngProductID)
            .MoveRight Unit:=wdCell
            .TypeText Text:=strProductName
            .MoveRight Unit:=wdCell
            .TypeText Text:=CStr(dblQuantity)
            .MoveRight Unit:=wdCell
            .TypeText Text:=strUnitPrice
            .MoveRight Unit:=wdCell
            .TypeText Text:=strDiscount
            .MoveRight Unit:=wdCell
            .TypeText Text:=strExtendedPrice
            .MoveRight Unit:=wdCell
         End With
         .MoveNext
      Loop
      .Close
   End With
   dbs.Close
   
   'Delete last, empty row
   Selection.SelectRow
   Selection.Rows.Delete
   
   'Check for existence of previously saved letter in documents folder,
   'and append an incremented number to save name if found
   strSaveName = "Invoice to " & strCompanyName & " for Order " _
      & lngOrderID & " on " & strShortDate & ".doc"
    
   intCount = 2
   blnSaveNameFail = True
   Do While blnSaveNameFail
      strSaveNamePath = strDocsPath & strSaveName
      Debug.Print "Proposed save name and path: " _
         & vbCrLf & strSaveNamePath
      strTestFile = Nz(Dir(strSaveNamePath))
      If strTestFile = strSaveName Then
         
         'Create new save name with incremented number
         blnSaveNameFail = True
       strSaveName = "Invoice " & CStr(intCount) & " to " & strCompanyName _
       & " for Order " & lngOrderID & " on " & strShortDate & ".doc"
 
         strSaveNamePath = strDocsPath & strSaveName
         intCount = intCount + 1
      Else
         blnSaveNameFail = False
      End If
   Loop
   
   'Ask whether user wants to save the document
   'If you prefer, you could eliminate the prompt and just
   'save the document with the save name automatically.
   strMessageTitle = "Save document?"
   strMessage = "Save invoice as '" & strSaveName & "'?"
   intReturn = MsgBox(strMessage, vbYesNoCancel + _
      vbQuestion + vbDefaultButton1, strMessageTitle)
   
   If intReturn = vbNo Then
      doc.Close savechanges:=wdDoNotSaveChanges
      GoTo ErrorHandlerExit
   ElseIf intReturn = vbYes Then
      doc.SaveAs strSaveNamePath
      appWord.Visible = True
   ElseIf intReturn = vbCancel Then
      GoTo ErrorHandlerExit
   End If
   
ErrorHandlerExit:
   Set appWord = Nothing
   'Close any open recordset or database, in case code stops because
   'of an error
   On Error Resume Next
   rst.Close
   On Error Resume Next
   dbs.Close
   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
                                              

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:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219:
220:
221:
222:
223:
224:
225:
226:
227:
228:
229:
230:
231:
232:
233:
234:
235:
236:
237:
238:
239:
240:
241:
242:
243:
244:
245:
246:
247:
248:
249:
250:
251:
252:
253:
254:
255:
256:
257:
258:
259:
260:
261:
262:
263:
264:
265:
266:
267:
268:
269:
270:
271:
272:
273:
274:
275:
276:
277:
278:
279:
280:
281:
282:
283:
284:
285:
286:
287:
288:
289:
290:
291:
292:
293:
294:
295:
296:
297:
298:
299:
300:
301:
302:
303:
304:
305:
306:
307:
308:
309:
310: