Advertisement
Guest User

Untitled

a guest
Aug 3rd, 2012
104
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. ;; -*-scheme-*-
  2. ;; fancy-invoice.scm -- a Fancy Invoice Report, used to print a GncInvoice
  3. ;;
  4. ;; Created by: Derek Atkins <warlord@MIT.EDU>
  5. ;; Copyright (c) 2003 Derek Atkins <warlord@MIT.EDU>
  6. ;;
  7. ;; This program is free software; you can redistribute it and/or
  8. ;; modify it under the terms of the GNU General Public License as
  9. ;; published by the Free Software Foundation; either version 2 of
  10. ;; the License, or (at your option) any later version.
  11. ;;
  12. ;; This program is distributed in the hope that it will be useful,
  13. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  15. ;; GNU General Public License for more details.
  16. ;;
  17. ;; You should have received a copy of the GNU General Public License
  18. ;; along with this program; if not, contact:
  19. ;;
  20. ;; Free Software Foundation Voice: +1-617-542-5942
  21. ;; 51 Franklin Street, Fifth Floor Fax: +1-617-542-2652
  22. ;; Boston, MA 02110-1301, USA gnu@gnu.org
  23.  
  24.  
  25. ;; Fancy Invoice customized from "invoice.scm"
  26. ;; Customized by: Oliver Jones <gnucash at oliverstech dot com>
  27. ;;
  28. ;; WARNING: customizations are hard-coded, some translations might be
  29. ;; broken and it won't work for bills/expense vouchers
  30. ;;
  31. ;; Customizations are marked with "oli-custom".
  32. ;;
  33. ;; Hint: you may set your default options here until a way to save report
  34. ;; options will be implemented.
  35. ;;
  36. ;; You will need to upgrade to gtkhtml-1.1 for the latest features or
  37. ;; it won't look right. gtkhtml doesn't have support for table
  38. ;; colgroup, tbody, thead and rules tags yet. When it will, the
  39. ;; invoice will look even better.
  40. ;;
  41. ;; This is a quick and dirty hack. The proper way to do this (when I
  42. ;; or someone else will have time) is to have the user supply an HTML
  43. ;; template. The most common used templates will be distributed with
  44. ;; gnucash.
  45.  
  46. ;; Modifed to use settable options instead of the hard coded ones.
  47. ;; modified by Brian Dolbec <dol-sen at telus dot net> Feb. 6, 2006
  48.  
  49. (define-module (gnucash report standard-reports terra-invoice))
  50.  
  51. (use-modules (srfi srfi-1))
  52. (use-modules (gnucash printf))
  53. (use-modules (gnucash gnc-module))
  54.  
  55. (gnc:module-load "gnucash/report/report-system" 0)
  56. (gnc:module-load "gnucash/business-utils" 0)
  57.  
  58. (use-modules (gnucash report standard-reports))
  59. (use-modules (gnucash report business-reports))
  60.  
  61. (define invoice-page gnc:pagename-general)
  62. (define invoice-name (N_ "Invoice Number"))
  63.  
  64. (define-macro (addto! alist element)
  65. `(set! ,alist (cons ,element ,alist)))
  66.  
  67. (define (set-last-row-style! table tag . rest)
  68. (let ((arg-list
  69. (cons table
  70. (cons (- (gnc:html-table-num-rows table) 1)
  71. (cons tag rest)))))
  72. (apply gnc:html-table-set-row-style! arg-list)))
  73.  
  74. (define (date-col columns-used)
  75. (vector-ref columns-used 0))
  76. (define (description-col columns-used)
  77. (vector-ref columns-used 1))
  78. (define (action-col columns-used)
  79. (vector-ref columns-used 2))
  80. (define (quantity-col columns-used)
  81. (vector-ref columns-used 3))
  82. (define (price-col columns-used)
  83. (vector-ref columns-used 4))
  84. (define (discount-col columns-used)
  85. (vector-ref columns-used 5))
  86. (define (tax-col columns-used)
  87. (vector-ref columns-used 6))
  88. (define (taxvalue-col columns-used)
  89. (vector-ref columns-used 7))
  90. (define (value-col columns-used)
  91. (vector-ref columns-used 8))
  92.  
  93. (define columns-used-size 9)
  94.  
  95. (define (num-columns-required columns-used)
  96. (do ((i 0 (+ i 1))
  97. (col-req 0 col-req))
  98. ((>= i columns-used-size) col-req)
  99. (if (vector-ref columns-used i)
  100. (set! col-req (+ col-req 1)))))
  101.  
  102. (define (build-column-used options)
  103. (define (opt-val section name)
  104. (gnc:option-value
  105. (gnc:lookup-option options section name)))
  106. (define (make-set-col col-vector)
  107. (let ((col 0))
  108. (lambda (used? index)
  109. (if used?
  110. (begin
  111. (vector-set! col-vector index col)
  112. (set! col (+ col 1)))
  113. (vector-set! col-vector index #f)))))
  114.  
  115. (let* ((col-vector (make-vector columns-used-size #f))
  116. (set-col (make-set-col col-vector)))
  117. (set-col (opt-val "Display Columns" "Date") 0)
  118. (set-col (opt-val "Display Columns" "Description") 1)
  119. (set-col (opt-val "Display Columns" "Action") 2)
  120. (set-col (opt-val "Display Columns" "Quantity") 3)
  121. (set-col (opt-val "Display Columns" "Price") 4)
  122. (set-col (opt-val "Display Columns" "Discount") 5)
  123. (set-col (opt-val "Display Columns" "Taxable") 6)
  124. (set-col (opt-val "Display Columns" "Tax Amount") 7)
  125. (set-col (opt-val "Display Columns" "Total") 8)
  126. col-vector))
  127.  
  128. (define (make-heading-list column-vector)
  129.  
  130. (let ((heading-list '()))
  131. (if (date-col column-vector)
  132. (addto! heading-list (_ "Date")))
  133. (if (description-col column-vector)
  134. (addto! heading-list (_ "Description")))
  135. (if (action-col column-vector)
  136. (addto! heading-list (_ "Charge Type")))
  137. (if (quantity-col column-vector)
  138. (addto! heading-list (_ "Quantity")))
  139. (if (price-col column-vector)
  140. (addto! heading-list (string-expand (_ "Unit Price") #\space "&nbsp;")))
  141. (if (discount-col column-vector)
  142. (addto! heading-list (_ "Discount")))
  143. (if (tax-col column-vector)
  144. (addto! heading-list (_ "Taxable")))
  145. (if (taxvalue-col column-vector)
  146. (addto! heading-list (_ "Tax Amount")))
  147. (if (value-col column-vector)
  148. (addto! heading-list (_ "Total")))
  149. (reverse heading-list)))
  150.  
  151. (define (make-account-hash) (make-hash-table 23))
  152.  
  153. (define (update-account-hash hash values)
  154. (for-each
  155. (lambda (item)
  156. (let* ((acct (car item))
  157. (val (cdr item))
  158. (ref (hash-ref hash acct)))
  159.  
  160. (hash-set! hash acct (if ref (gnc-numeric-add-fixed ref val) val))))
  161. values))
  162.  
  163.  
  164. (define (monetary-or-percent numeric currency entry-type)
  165. (if (gnc:entry-type-percent-p entry-type)
  166. ;; oli-custom - make a string instead of a table
  167. (string-append (gnc:default-html-gnc-numeric-renderer numeric #f) " " (_ "%"))
  168. (gnc:make-gnc-monetary currency numeric)))
  169.  
  170. (define (add-entry-row table currency entry column-vector row-style invoice?)
  171. (let* ((row-contents '())
  172. (entry-value (gnc:make-gnc-monetary
  173. currency
  174. (gncEntryReturnValue entry invoice?)))
  175. (entry-tax-value (gnc:make-gnc-monetary
  176. currency
  177. (gncEntryReturnTaxValue entry invoice?))))
  178.  
  179. (if (date-col column-vector)
  180. (addto! row-contents
  181. (gnc-print-date (gncEntryGetDate entry))))
  182.  
  183. (if (description-col column-vector)
  184. (addto! row-contents
  185. (gncEntryGetDescription entry)))
  186.  
  187. (if (action-col column-vector)
  188. (addto! row-contents
  189. (gncEntryGetAction entry)))
  190.  
  191. (if (quantity-col column-vector)
  192. (addto! row-contents
  193. (gnc:make-html-table-cell/markup
  194. "number-cell"
  195. (gncEntryGetQuantity entry))))
  196.  
  197. (if (price-col column-vector)
  198. (addto! row-contents
  199. (gnc:make-html-table-cell/markup
  200. "number-cell"
  201. (gnc:make-gnc-monetary
  202. currency (if invoice? (gncEntryGetInvPrice entry)
  203. (gncEntryGetBillPrice entry))))))
  204.  
  205. (if (discount-col column-vector)
  206. (addto! row-contents
  207. (if invoice?
  208. (gnc:make-html-table-cell/markup
  209. "number-cell"
  210. (monetary-or-percent (gncEntryGetInvDiscount entry)
  211. currency
  212. (gncEntryGetInvDiscountType entry)))
  213. "")))
  214.  
  215. (if (tax-col column-vector)
  216. (addto! row-contents
  217. (if (if invoice?
  218. (and (gncEntryGetInvTaxable entry)
  219. (gncEntryGetInvTaxTable entry))
  220. (and (gncEntryGetBillTaxable entry)
  221. (gncEntryGetBillTaxTable entry)))
  222. ;; Translators: This "T" is displayed in the taxable column, if this entry contains tax
  223. ;;Jeremy-Custom: Show taxes that are being applied in table
  224. (_ (gncTaxTableGetName (gncEntryGetInvTaxTable entry))) "")))
  225. ;; (_ "T") "")))
  226.  
  227. (if (taxvalue-col column-vector)
  228. (addto! row-contents
  229. (gnc:make-html-table-cell/markup
  230. "number-cell"
  231. entry-tax-value)))
  232.  
  233. (if (value-col column-vector)
  234. (addto! row-contents
  235. (gnc:make-html-table-cell/markup
  236. "number-cell"
  237. entry-value)))
  238.  
  239. (gnc:html-table-append-row/markup! table row-style
  240. (reverse row-contents))
  241.  
  242. (cons entry-value entry-tax-value)))
  243.  
  244. ;; oli-custom - here you can set your default options
  245.  
  246. (define (options-generator)
  247.  
  248. (define gnc:*report-options* (gnc:new-options))
  249.  
  250. (define (gnc:register-inv-option new-option)
  251. (gnc:register-option gnc:*report-options* new-option))
  252.  
  253. (gnc:register-inv-option
  254. (gnc:make-invoice-option invoice-page invoice-name "x" ""
  255. (lambda () '()) #f))
  256.  
  257. (gnc:register-inv-option
  258. (gnc:make-string-option
  259. invoice-page (N_ "Custom Title")
  260. "z" (N_ "A custom string to replace Invoice, Bill or Expense Voucher")
  261. ""))
  262.  
  263. (gnc:register-inv-option
  264. (gnc:make-simple-boolean-option
  265. (N_ "Display Columns") (N_ "Date")
  266. "b" (N_ "Display the date?") #f))
  267.  
  268. (gnc:register-inv-option
  269. (gnc:make-simple-boolean-option
  270. (N_ "Display Columns") (N_ "Description")
  271. "d" (N_ "Display the description?") #t))
  272.  
  273. (gnc:register-inv-option
  274. (gnc:make-simple-boolean-option
  275. (N_ "Display Columns") (N_ "Action")
  276. "g" (N_ "Display the action?") #f))
  277.  
  278. (gnc:register-inv-option
  279. (gnc:make-simple-boolean-option
  280. (N_ "Display Columns") (N_ "Quantity")
  281. "ha" (N_ "Display the quantity of items?") #t))
  282.  
  283. (gnc:register-inv-option
  284. (gnc:make-simple-boolean-option
  285. (N_ "Display Columns") (N_ "Price")
  286. "hb" (N_ "Display the price per item?") #t))
  287.  
  288. (gnc:register-inv-option
  289. (gnc:make-simple-boolean-option
  290. (N_ "Display Columns") (N_ "Discount")
  291. "k" (N_ "Display the entry's discount") #f))
  292.  
  293. (gnc:register-inv-option
  294. (gnc:make-simple-boolean-option
  295. (N_ "Display Columns") (N_ "Taxable")
  296. "l" (N_ "Display the entry's taxable status") #t))
  297.  
  298. (gnc:register-inv-option
  299. (gnc:make-simple-boolean-option
  300. (N_ "Display Columns") (N_ "Tax Amount")
  301. "m" (N_ "Display each entry's total total tax") #f))
  302.  
  303. (gnc:register-inv-option
  304. (gnc:make-simple-boolean-option
  305. (N_ "Display Columns") (N_ "Total")
  306. "n" (N_ "Display the entry's value") #t))
  307.  
  308. (gnc:register-inv-option
  309. (gnc:make-simple-boolean-option
  310. (N_ "Display") (N_ "Individual Taxes")
  311. "o" (N_ "Display all the individual taxes?") #t))
  312.  
  313. (gnc:register-inv-option
  314. (gnc:make-simple-boolean-option
  315. (N_ "Display") (N_ "Totals")
  316. "p" (N_ "Display the totals?") #t))
  317.  
  318. (gnc:register-inv-option
  319. (gnc:make-simple-boolean-option
  320. (N_ "Display") (N_ "References")
  321. "s" (N_ "Display the invoice references?") #t))
  322.  
  323. (gnc:register-inv-option
  324. (gnc:make-simple-boolean-option
  325. (N_ "Display") (N_ "Billing Terms")
  326. "t" (N_ "Display the invoice billing terms?") #t))
  327.  
  328. (gnc:register-inv-option
  329. (gnc:make-simple-boolean-option
  330. (N_ "Display") (N_ "Billing ID")
  331. "ta" (N_ "Display the billing id?") #t))
  332.  
  333. (gnc:register-inv-option
  334. (gnc:make-simple-boolean-option
  335. (N_ "Display") (N_ "Invoice Notes")
  336. "tb" (N_ "Display the invoice notes?") #f))
  337.  
  338. (gnc:register-inv-option
  339. (gnc:make-simple-boolean-option
  340. (N_ "Display") (N_ "Payments")
  341. "tc" (N_ "Display the payments applied to this invoice?") #f))
  342.  
  343. (gnc:register-inv-option
  344. (gnc:make-number-range-option
  345. (N_ "Display") (N_ "Minimum # of entries")
  346. "u" (N_ "The minimum number of invoice entries to display. (-1)") 5
  347. 4 23 0 1))
  348.  
  349. (gnc:register-inv-option
  350. (gnc:make-text-option
  351. (N_ "Display") (N_ "Extra Notes")
  352. "u" (N_ "Extra notes to put on the invoice")
  353. (_ "Thank you for your patronage")))
  354.  
  355. (gnc:register-inv-option
  356. (gnc:make-complex-boolean-option
  357. (N_ "Display") (N_ "Payable to")
  358. "ua1" (N_ "Display the Payable to: information") #t #f
  359. (lambda (x) (gnc-option-db-set-option-selectable-by-name
  360. gnc:*report-options* "Display" "Payable to string" x))))
  361.  
  362. (gnc:register-inv-option
  363. (gnc:make-text-option
  364. (N_ "Display") (N_ "Payable to string")
  365. "ua2" (N_ "The phrase for specifying to whom payments should be made")
  366. (_ "Make all cheques Payable to")))
  367.  
  368. (gnc:register-inv-option
  369. (gnc:make-complex-boolean-option
  370. (N_ "Display") (N_ "Company contact")
  371. "ub1" (N_ "Display the Company contact information") #t #f
  372. (lambda (x) (gnc-option-db-set-option-selectable-by-name
  373. gnc:*report-options* "Display" "Company contact string" x))))
  374.  
  375. (gnc:register-inv-option
  376. (gnc:make-text-option
  377. (N_ "Display") (N_ "Company contact string")
  378. "ub2" (N_ "The phrase used to introduce the company contact")
  379. (_ "Direct all inquiries to")))
  380.  
  381. ; not used
  382. ; (gnc:register-inv-option
  383. ; (gnc:make-string-option
  384. ; (N_ "Display") (N_ "Today Date Format")
  385. ; "v" (N_ "The format for the date->string conversion for today's date.")
  386. ; (gnc-default-strftime-date-format)))
  387.  
  388. (gnc:options-set-default-section gnc:*report-options* "General")
  389.  
  390. gnc:*report-options*)
  391.  
  392.  
  393. (define (make-entry-table invoice options add-order invoice?)
  394. (define (opt-val section name)
  395. (gnc:option-value
  396. (gnc:lookup-option options section name)))
  397.  
  398. (let ((show-payments (opt-val "Display" "Payments"))
  399. (display-all-taxes (opt-val "Display" "Individual Taxes"))
  400. (lot (gncInvoiceGetPostedLot invoice))
  401. (txn (gncInvoiceGetPostedTxn invoice))
  402. (currency (gncInvoiceGetCurrency invoice))
  403. (entries-added 0))
  404.  
  405. (define (colspan monetary used-columns)
  406. (cond
  407. ((value-col used-columns) (value-col used-columns))
  408. ((taxvalue-col used-columns) (taxvalue-col used-columns))
  409. (else (price-col used-columns))))
  410.  
  411. (define (display-subtotal monetary used-columns)
  412. (if (value-col used-columns)
  413. monetary
  414. (let ((amt (gnc:gnc-monetary-amount monetary)))
  415. (if amt
  416. (if (gnc-numeric-negative-p amt)
  417. (gnc:monetary-neg monetary)
  418. monetary)
  419. monetary))))
  420.  
  421. (define (get-empty-row colcount)
  422. (define row-contents '())
  423. (do ((i 1 (+ i 1)))
  424. ((> i colcount))
  425. (addto! row-contents (gnc:make-html-table-cell)) ;;do stuff here
  426. )
  427. row-contents
  428. )
  429.  
  430. (define (add-subtotal-row table used-columns
  431. subtotal-collector subtotal-style subtotal-label)
  432. (let ((currency-totals (subtotal-collector
  433. 'format gnc:make-gnc-monetary #f)))
  434.  
  435. (for-each (lambda (currency)
  436. (gnc:html-table-append-row/markup!
  437. table
  438. subtotal-style
  439. ;; oli-custom modified to colspan the subtotal labels
  440. ;; instead of the data fields
  441. (append (cons (gnc:make-html-table-cell/size/markup
  442. 1 (colspan currency used-columns)
  443. "total-label-cell" subtotal-label)
  444. '())
  445. (list (gnc:make-html-table-cell/markup
  446. ;; 1 (colspan currency used-columns)
  447. "total-number-cell"
  448. (display-subtotal currency used-columns))))))
  449. currency-totals)))
  450.  
  451. (define (add-payment-row table used-columns split total-collector)
  452. (let* ((t (xaccSplitGetParent split))
  453. (currency (xaccTransGetCurrency t))
  454. (invoice (opt-val invoice-page invoice-name))
  455. (owner '())
  456. ;; XXX Need to know when to reverse the value
  457. (amt (gnc:make-gnc-monetary currency (xaccSplitGetValue split)))
  458. (payment-style "grand-total")
  459. (row '()))
  460.  
  461. ; Update to fix bug 564380, payment on bill doubles bill. Mike Evans <mikee@saxicola.co.uk>
  462. ;; Reverse the value when needed
  463. (if (not (null? invoice))
  464. (begin
  465. (set! owner (gncInvoiceGetOwner invoice))
  466. (let ((type (gncOwnerGetType
  467. (gncOwnerGetEndOwner owner))))
  468. (cond
  469. ((eqv? type GNC-OWNER-CUSTOMER)
  470. (total-collector 'add
  471. (gnc:gnc-monetary-commodity amt)
  472. (gnc:gnc-monetary-amount amt)))
  473. ((eqv? type GNC-OWNER-VENDOR)
  474. (total-collector 'add
  475. (gnc:gnc-monetary-commodity amt)
  476. (gnc:gnc-monetary-amount (gnc:monetary-neg amt))))
  477. ))))
  478.  
  479.  
  480. (if (date-col used-columns)
  481. (addto! row
  482. (gnc-print-date (gnc-transaction-get-date-posted t))))
  483.  
  484. (if (description-col used-columns)
  485. (addto! row (_ "Payment, thank you")))
  486.  
  487. (gnc:html-table-append-row/markup!
  488. table
  489. payment-style
  490. (append (reverse row)
  491. (list (gnc:make-html-table-cell/size/markup
  492. 1 (colspan currency used-columns)
  493. "total-number-cell"
  494. (display-subtotal amt used-columns)))))))
  495.  
  496. (define (do-rows-with-subtotals entries
  497. table
  498. used-columns
  499. width
  500. odd-row?
  501. value-collector
  502. tax-collector
  503. total-collector
  504. acct-hash)
  505. (if (null? entries)
  506. (begin
  507. ;; oli-custom - modified to have a minimum of entries per table,
  508. ;; currently defaults to 24
  509. ;; also, doesn't count payment rows and stuff
  510. (do ((entries-added entries-added (+ entries-added 1))
  511. (odd-row? odd-row? (not odd-row?)))
  512. ((> entries-added (opt-val "Display" "Minimum # of entries" )))
  513. (gnc:html-table-append-row/markup!
  514. table (if odd-row? "normal-row" "alternate-row")
  515. (get-empty-row (num-columns-required used-columns)))
  516. )
  517. (add-subtotal-row table used-columns value-collector
  518. "grand-total" (_ "Net Price"))
  519.  
  520. (if display-all-taxes
  521. (hash-for-each
  522. (lambda (acct value)
  523. (let ((collector (gnc:make-commodity-collector))
  524. (commodity (xaccAccountGetCommodity acct))
  525. (name (xaccAccountGetName acct)))
  526. (collector 'add commodity value)
  527. (add-subtotal-row table used-columns collector
  528. "grand-total" (string-expand
  529. name #\space "&nbsp;"))))
  530. acct-hash)
  531.  
  532. ; nope, just show the total tax.
  533. (add-subtotal-row table used-columns tax-collector
  534. "grand-total" (_ "Tax")))
  535.  
  536. (add-subtotal-row table used-columns total-collector
  537. "grand-total" (string-expand (_ "Total Price")
  538. #\space "&nbsp;"))
  539.  
  540. (if (and show-payments (not (null? lot)))
  541. (let ((splits (sort-list!
  542. (gnc-lot-get-split-list lot)
  543. (lambda (s1 s2)
  544. (let ((t1 (xaccSplitGetParent s1))
  545. (t2 (xaccSplitGetParent s2)))
  546. (< (xaccTransOrder t1 t2) 0))))))
  547. (for-each
  548. (lambda (split)
  549. (if (not (equal? (xaccSplitGetParent split) txn))
  550. (add-payment-row table used-columns
  551. split total-collector)))
  552. splits)))
  553.  
  554. (add-subtotal-row table used-columns total-collector
  555. "grand-total" (string-expand (_ "Amount Due")
  556. #\space "&nbsp;")))
  557.  
  558. ;;
  559. ;; End of BEGIN -- now here's the code to handle all the entries!
  560. ;;
  561. (let* ((current (car entries))
  562. (current-row-style (if odd-row? "normal-row" "alternate-row"))
  563. (rest (cdr entries))
  564. (next (if (null? rest) #f
  565. (car rest)))
  566. (entry-values (add-entry-row table
  567. currency
  568. current
  569. used-columns
  570. current-row-style
  571. invoice?)))
  572.  
  573. (if display-all-taxes
  574. (let ((tax-list (gncEntryReturnTaxValues current invoice?)))
  575. (update-account-hash acct-hash tax-list))
  576. (tax-collector 'add
  577. (gnc:gnc-monetary-commodity (cdr entry-values))
  578. (gnc:gnc-monetary-amount (cdr entry-values))))
  579.  
  580. (value-collector 'add
  581. (gnc:gnc-monetary-commodity (car entry-values))
  582. (gnc:gnc-monetary-amount (car entry-values)))
  583.  
  584. (total-collector 'add
  585. (gnc:gnc-monetary-commodity (car entry-values))
  586. (gnc:gnc-monetary-amount (car entry-values)))
  587. (total-collector 'add
  588. (gnc:gnc-monetary-commodity (cdr entry-values))
  589. (gnc:gnc-monetary-amount (cdr entry-values)))
  590.  
  591. (let ((order (gncEntryGetOrder current)))
  592. (if (not (null? order)) (add-order order)))
  593.  
  594. (set! entries-added (+ entries-added 1))
  595.  
  596. (do-rows-with-subtotals rest
  597. table
  598. used-columns
  599. width
  600. (not odd-row?)
  601. value-collector
  602. tax-collector
  603. total-collector
  604. acct-hash))))
  605.  
  606. (let* ((table (gnc:make-html-table))
  607. (used-columns (build-column-used options))
  608. (width (num-columns-required used-columns))
  609. (entries (gncInvoiceGetEntries invoice))
  610. (totals (gnc:make-commodity-collector)))
  611.  
  612. (gnc:html-table-set-col-headers!
  613. table
  614. (make-heading-list used-columns))
  615.  
  616. (do-rows-with-subtotals entries
  617. table
  618. used-columns
  619. width
  620. #t
  621. (gnc:make-commodity-collector)
  622. (gnc:make-commodity-collector)
  623. totals
  624. (make-account-hash))
  625. table)))
  626.  
  627. (define (string-expand string character replace-string)
  628. (define (car-line chars)
  629. (take-while (lambda (c) (not (eqv? c character))) chars))
  630. (define (cdr-line chars)
  631. (let ((rest (drop-while (lambda (c) (not (eqv? c character))) chars)))
  632. (if (null? rest)
  633. '()
  634. (cdr rest))))
  635. (define (line-helper chars)
  636. (if (null? chars)
  637. ""
  638. (let ((first (car-line chars))
  639. (rest (cdr-line chars)))
  640. (string-append (list->string first)
  641. (if (null? rest) "" replace-string)
  642. (line-helper rest)))))
  643. (line-helper (string->list string)))
  644.  
  645. (define (make-client-table owner orders)
  646. (let ((table (gnc:make-html-table))
  647. (name-cell (gnc:make-html-table-cell)))
  648. (gnc:html-table-set-style!
  649. table "table"
  650. 'attribute (list "border" 0)
  651. 'attribute (list "cellspacing" 0)
  652. 'attribute (list "cellpadding" 0))
  653. (gnc:html-table-cell-append-objects!
  654. name-cell (gnc:owner-get-name-dep owner))
  655. (gnc:html-table-cell-set-style!
  656. name-cell "td"
  657. 'font-size "+2")
  658. (gnc:html-table-append-row! table (list name-cell "" "")) ;;Bert: had a newline and a "<br>"
  659. (gnc:html-table-append-row!
  660. table
  661. (list
  662. (string-expand (gnc:owner-get-address-dep owner) #\newline "<br>")))
  663. (gnc:html-table-append-row!
  664. table
  665. (list "<br>"))
  666. (for-each
  667. (lambda (order)
  668. (let* ((reference (gncOrderGetReference order)))
  669. (if (and reference (> (string-length reference) 0))
  670. (gnc:html-table-append-row!
  671. table
  672. (list
  673. (string-append (_ "REF") ":&nbsp;" reference))))))
  674. orders)
  675. (set-last-row-style!
  676. table "td"
  677. 'attribute (list "valign" "top"))
  678. table))
  679.  
  680. (define (make-date-row! table label date)
  681. (gnc:html-table-append-row!
  682. table
  683. (list
  684. (string-append label ":&nbsp;")
  685. ;; oli-custom - modified to display a custom format
  686. ;; for the invoice date/due date fields
  687. ;; I could have taken the format from the report options, but... ;)
  688. (string-expand (strftime (gnc-default-strftime-date-format)
  689. (localtime (car date)))
  690. #\space "&nbsp;")
  691. ;;(string-expand (gnc-print-date date) #\space "&nbsp;")
  692. )))
  693.  
  694. (define (make-date-table)
  695. (let ((table (gnc:make-html-table)))
  696. (gnc:html-table-set-style!
  697. table "table"
  698. 'attribute (list "border" 0)
  699. 'attribute (list "cellpadding" 0))
  700. (set-last-row-style!
  701. table "td"
  702. 'attribute (list "valign" "top"))
  703. table))
  704.  
  705. (define (make-myname-table book date-format title)
  706. (let* ((table (gnc:make-html-table))
  707. (slots (qof-book-get-slots book))
  708. (name (kvp-frame-get-slot-path-gslist
  709. slots (append gnc:*kvp-option-path*
  710. (list gnc:*business-label* gnc:*company-name*))))
  711. ;; (contact (kvp-frame-get-slot-path-gslist
  712. ;; slots (append gnc:*kvp-option-path*
  713. ;; (list gnc:*business-label* gnc:*company-contact*))))
  714. (addy (kvp-frame-get-slot-path-gslist
  715. slots (append gnc:*kvp-option-path*
  716. (list gnc:*business-label* gnc:*company-addy*))))
  717. (id (kvp-frame-get-slot-path-gslist
  718. slots (append gnc:*kvp-option-path*
  719. (list gnc:*business-label* gnc:*company-id*))))
  720. (phone (kvp-frame-get-slot-path-gslist
  721. slots (append gnc:*kvp-option-path*
  722. (list gnc:*business-label* gnc:*company-phone*))))
  723. (fax (kvp-frame-get-slot-path-gslist
  724. slots (append gnc:*kvp-option-path*
  725. (list gnc:*business-label* gnc:*company-fax*))))
  726. (url (kvp-frame-get-slot-path-gslist
  727. slots (append gnc:*kvp-option-path*
  728. (list gnc:*business-label* gnc:*company-url*))))
  729. (invoice-cell (gnc:make-html-table-cell))
  730. (name-cell (gnc:make-html-table-cell))
  731.  
  732. )
  733. ;; oli-custom - modified the name table to increase the
  734. ;; font size of the company name
  735. ;; and add an "INVOICE" title to the upper right, also,
  736. ;; put some contact information in the middle
  737. ;; FIXME: "INVOICE" should be translated and support bills/expense vouchers
  738. (gnc:html-table-set-style!
  739. table "table"
  740. 'attribute (list "border" 0)
  741. 'attribute (list "cellspacing" 0)
  742. 'attribute (list "cellpadding" 0)
  743. 'attribute (list "width" "100%"))
  744. (gnc:html-table-cell-append-objects!
  745. invoice-cell title)
  746. (gnc:html-table-cell-set-style!
  747. invoice-cell "td"
  748. 'font-size "+2")
  749. (gnc:html-table-cell-append-objects!
  750. name-cell (if name name ""))
  751. (gnc:html-table-cell-set-style!
  752. name-cell "td"
  753. 'font-size "+2")
  754. (gnc:html-table-append-row! table (list name-cell (gnc:make-html-table-cell) invoice-cell)) ;;(gnc:make-html-table-cell) was ""
  755. (gnc:html-table-set-col-style!
  756. table 1 "td"
  757. 'attribute (list "align" "center")
  758. 'attribute (list "width" "33%"))
  759. (gnc:html-table-set-col-style!
  760. table 2 "td"
  761. 'attribute (list "align" "right")
  762. 'attribute (list "width" "33%"))
  763. (gnc:html-table-append-row!
  764. table (list (string-expand (string-append (if addy addy "") (if id (string-append "\n" id) "")) #\newline "<br>")
  765. (string-expand
  766. (string-append (if phone
  767. (string-append (_ "Phone:") " " phone)
  768. "")
  769. (if fax (string-append (if phone "\n" "")
  770. (_ "Fax:") " " fax)
  771. ""))
  772. #\newline "<br>" )
  773. (if url (string-append (_ "Web:") " " url) "")))
  774.  
  775. ;; oli-custom - I didn't want today's date on the invoice.
  776. ;; The invoice already has a date.
  777. ;; Today's date can be in the email, fax or letter accompanying the invoice.
  778. ;; (gnc:html-table-append-row! table (list
  779. ;; (strftime
  780. ;; date-format
  781. ;; (localtime (car (gnc:get-today))))))
  782. table))
  783.  
  784. (define (make-break! document)
  785. (gnc:html-document-add-object!
  786. document
  787. (gnc:make-html-text
  788. (gnc:html-markup-br))))
  789.  
  790. (define (reg-renderer report-obj)
  791. (define (opt-val section name)
  792. (gnc:option-value
  793. (gnc:lookup-option (gnc:report-options report-obj) section name)))
  794.  
  795. (define (title-string title custom-title)
  796. (if (not (equal? "" custom-title))
  797. (string-expand custom-title
  798. #\space "&nbsp;")
  799. title))
  800.  
  801. (let* ((document (gnc:make-html-document))
  802. (table '())
  803. (orders '())
  804. (invoice (opt-val invoice-page invoice-name))
  805. (owner '())
  806. (references? (opt-val "Display" "References"))
  807. (default-title (_ "Invoice"))
  808. (custom-title (opt-val invoice-page "Custom Title"))
  809. (invoice? #f))
  810.  
  811.  
  812. (define (add-order o)
  813. (if (and references? (not (member o orders)))
  814. (addto! orders o)))
  815.  
  816. (if (not (null? invoice))
  817. (begin
  818. (set! owner (gncInvoiceGetOwner invoice))
  819. (let ((type (gncOwnerGetType
  820. (gncOwnerGetEndOwner owner))))
  821. (cond
  822. ((eqv? type GNC-OWNER-CUSTOMER)
  823. (set! invoice? #t))
  824. ((eqv? type GNC-OWNER-VENDOR)
  825. (set! default-title (_ "Bill")))
  826. ((eqv? type GNC-OWNER-EMPLOYEE)
  827. (set! default-title (_ "Expense Voucher")))))
  828. ))
  829.  
  830. ;; oli-custom - title redundant, "Invoice" moved to myname-table,
  831. ;; invoice number moved below
  832. ;;(gnc:html-document-set-title! document title)
  833.  
  834.  
  835. (if (not (null? invoice))
  836. (let* ((book (gncInvoiceGetBook invoice))
  837. (slots (qof-book-get-slots book))
  838. (date-object #f)
  839. (helper-table (gnc:make-html-table))
  840. (title (title-string default-title custom-title)))
  841. (set! table (make-entry-table invoice
  842. (gnc:report-options report-obj)
  843. add-order invoice?))
  844.  
  845. (gnc:html-table-set-style!
  846. table "table"
  847. 'attribute (list "border" 1)
  848. 'attribute (list "cellspacing" 0)
  849. 'attribute (list "cellpadding" 4)
  850. ;; oli-custom - make table as wide as possible
  851. ;; works fine with simple style sheet templates,
  852. ;; doesn't work quite right with fancy ones
  853. ;; probably supplying the style sheet with a wide image
  854. ;; for the header (even if transparent/white) would fix it
  855. 'attribute (list "width" "100%"))
  856.  
  857. ;; oli-custom - make the description column big
  858. ;; 50% or 60%, depending on whether the first column is
  859. ;; displayed or not
  860. ;; should actually be something more complicated,
  861. ;; it's a really ugly hack right now :)
  862. (gnc:html-table-set-col-style!
  863. table (if (opt-val "Display Columns" "Date") 1 0) "td"
  864. 'attribute (list "width" (if (opt-val "Display Columns" "Date")
  865. "50%" "60%")))
  866.  
  867. (gnc:html-document-add-object!
  868. document (make-myname-table
  869. book ;;(opt-val "Display" "Today Date Format")))
  870. "" title))
  871.  
  872. (make-break! document)
  873. (make-break! document)
  874. (make-break! document)
  875.  
  876. ;; oli-custom - client table and table with invoice
  877. ;; number/date/due date both inserted into a table
  878. (gnc:html-table-set-style!
  879. helper-table "table"
  880. 'attribute (list "border" 0)
  881. 'attribute (list "cellspacing" 0)
  882. 'attribute (list "cellpadding" 0)
  883. 'attribute (list "width" "100%"))
  884.  
  885. (set! date-object (let ((date-table #f)
  886. (post-date (gncInvoiceGetDatePosted invoice))
  887. (due-date (gncInvoiceGetDateDue invoice)))
  888.  
  889. (if (not (equal? post-date (cons 0 0)))
  890. (begin
  891. (set! date-table (make-date-table))
  892. ;; oli-custom - moved invoice number here
  893. (gnc:html-table-append-row!
  894. date-table (list (sprintf #f (_ "%s&nbsp;#") title) (gncInvoiceGetID invoice)))
  895. ;; Translators: The first %s below is "Invoice" or
  896. ;; "Bill" or even the custom title from the
  897. ;; options. This string sucks for i18n, but I don't
  898. ;; have a better solution right now without breaking
  899. ;; other people's invoices.
  900. (make-date-row! date-table (sprintf #f (_ "%s&nbsp;Date") title) post-date)
  901. (make-date-row! date-table (_ "Due Date") due-date)
  902. date-table)
  903. (gnc:make-html-text
  904. ;; oli-custom - FIXME: I have a feeling I broke a
  905. ;; translation by not using string-expand for &nbsp;
  906. (string-append title "<br>" (_ "Invoice in progress..."))))))
  907.  
  908. (gnc:html-table-append-row!
  909. helper-table
  910. (list (make-client-table owner orders) date-object))
  911.  
  912. (gnc:html-table-set-col-style!
  913. helper-table 0 "td"
  914. 'attribute (list "valign" "top"))
  915.  
  916. (gnc:html-table-set-col-style!
  917. helper-table 1 "td"
  918. 'attribute (list "valign" "top")
  919. 'attribute (list "align" "right")
  920. ;; oli-custom - "squeeze" the date table,
  921. ;; or else it's spaced out
  922. 'attribute (list "width" "1%"))
  923.  
  924. (gnc:html-document-add-object!
  925. document
  926. helper-table)
  927.  
  928. (make-break! document)
  929.  
  930. (if (opt-val "Display" "Billing ID")
  931. (let ((billing-id (gncInvoiceGetBillingID invoice)))
  932. (if (and billing-id (> (string-length billing-id) 0))
  933. (begin
  934. (gnc:html-document-add-object!
  935. document
  936. (gnc:make-html-text
  937. (string-append
  938. (_ "Reference") ":&nbsp;"
  939. (string-expand billing-id #\newline "<br>"))))
  940. (make-break! document)))))
  941.  
  942. (if (opt-val "Display" "Billing Terms")
  943. (let* ((term (gncInvoiceGetTerms invoice))
  944. (terms (gncBillTermGetDescription term)))
  945. (if (and terms (> (string-length terms) 0))
  946. (gnc:html-document-add-object!
  947. document
  948. (gnc:make-html-text
  949. (string-append
  950. (_ "Terms") ":&nbsp;"
  951. (string-expand terms #\newline "<br>")))))))
  952.  
  953. (make-break! document)
  954.  
  955. (gnc:html-document-add-object! document table)
  956.  
  957. (make-break! document)
  958. (make-break! document)
  959.  
  960. (if (opt-val "Display" "Invoice Notes")
  961. (let ((notes (gncInvoiceGetNotes invoice)))
  962. (gnc:html-document-add-object!
  963. document
  964. (gnc:make-html-text
  965. (string-expand notes #\newline "<br>")))))
  966.  
  967. (make-break! document)
  968.  
  969. (if (opt-val "Display" "Payable to")
  970. (let* ((name (kvp-frame-get-slot-path-gslist
  971. slots (append gnc:*kvp-option-path*
  972. (list gnc:*business-label*
  973. gnc:*company-name*))))
  974. (name-str (opt-val "Display" "Payable to string")))
  975. (if (and name (> (string-length name) 0))
  976. (gnc:html-document-add-object!
  977. document
  978. (gnc:make-html-text
  979. (string-append name-str ":&nbsp;"
  980. (string-expand name #\newline "<br>")))))))
  981.  
  982. (make-break! document)
  983.  
  984. (if (opt-val "Display" "Company contact")
  985. (let* ((contact (kvp-frame-get-slot-path-gslist
  986. slots (append gnc:*kvp-option-path*
  987. (list gnc:*business-label*
  988. gnc:*company-contact*))))
  989. (contact-str (opt-val "Display" "Company contact string")))
  990. (if (and contact (> (string-length contact) 0))
  991. (gnc:html-document-add-object!
  992. document
  993. (gnc:make-html-text
  994. (string-append contact-str ":&nbsp;"
  995. (string-expand contact #\newline "<br>")))))))
  996.  
  997. (gnc:html-document-add-object!
  998. document
  999. (gnc:make-html-text
  1000. (gnc:html-markup-br)
  1001. (string-expand (opt-val "Display" "Extra Notes") #\newline "<br>")
  1002. (gnc:html-markup-br))))
  1003.  
  1004. ; else
  1005. (gnc:html-document-add-object!
  1006. document
  1007. (gnc:make-html-text
  1008. (_ "No valid invoice selected. Click on the Options button and select the invoice to use."))))
  1009.  
  1010. document))
  1011.  
  1012. (define terra-invoice-guid "3ce293441e894423a2425d7a22dd1ac8")
  1013.  
  1014. (gnc:define-report
  1015. 'version 1
  1016. 'name (N_ "Terra Invoice")
  1017. 'report-guid terra-invoice-guid
  1018. ;; 'menu-path (list gnc:menuname-business-reports)
  1019. ;; 'menu-path (list gnc:menuname-utility)
  1020. 'menu-path (list "Terra")
  1021. 'options-generator options-generator
  1022. 'renderer reg-renderer
  1023. 'in-menu? #t)
  1024.  
  1025. (define (gnc:fancy-invoice-report-create-internal invoice)
  1026. (let* ((options (gnc:make-report-options fancy-invoice-guid))
  1027. (invoice-op (gnc:lookup-option options invoice-page invoice-name)))
  1028.  
  1029. (gnc:option-set-value invoice-op invoice)
  1030. (gnc:make-report fancy-invoice-guid options)))
  1031.  
  1032. (export gnc:fancy-invoice-report-create-internal)
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement