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