IntenseFinance/gnucash
3
0
Fork 0
mirror of https://github.com/Gnucash/gnucash.git synced 2025-02-25 18:55:30 -06:00
Code Issues Packages Projects Releases Wiki Activity

Merge branch 'maint'

Browse Source
This commit is contained in:
Christopher Lam 2019-10-27 22:03:55 +08:00
commit 02e86a4c6a
13 changed files with 1486 additions and 301 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

84
gnucash/report/report-utilities.scm
View File

@ -852,6 +852,68 @@
(total 'merge (cadr account-balance) #f))
account-balances)
total))
;; ***************************************************************************
;; Business Functions
;; create a stepped list, then add a date in the infinite future for
;; the "current" bucket
(define (make-extended-interval-list to-date num-buckets)
(let lp ((begindate to-date) (num-buckets num-buckets))
(if (zero? num-buckets)
(append (gnc:make-date-list begindate to-date ThirtyDayDelta) (list +inf.0))
(lp (decdate begindate ThirtyDayDelta) (1- num-buckets)))))
;; Outputs: aging list of numbers
(define-public (gnc:owner-splits->aging-list splits num-buckets
to-date date-type receivable?)
(gnc:pk 'processing: (qof-print-date to-date) date-type 'receivable? receivable?)
(let ((bucket-dates (make-extended-interval-list to-date (- num-buckets 2)))
(buckets (make-vector num-buckets 0)))
(define (addbucket! idx amt)
(vector-set! buckets idx (+ amt (vector-ref buckets idx))))
(let lp ((splits splits))
(cond
((null? splits)
(vector->list buckets))
;; next split is an invoice posting split. note we don't need
;; to handle invoice payments because these payments will
;; reduce the lot balance automatically.
((eqv? (xaccTransGetTxnType (xaccSplitGetParent (car splits)))
TXN-TYPE-INVOICE)
(let* ((lot (gncInvoiceGetPostedLot
(gncInvoiceGetInvoiceFromTxn
(xaccSplitGetParent (car splits)))))
(invoice (gncInvoiceGetInvoiceFromLot lot))
(bal (gnc-lot-get-balance lot))
(bal (if receivable? bal (- bal)))
(date (if (eq? date-type 'postdate)
(gncInvoiceGetDatePosted invoice)
(gncInvoiceGetDateDue invoice))))
(gnc:pk 'next=invoice (car splits) invoice bal)
(let loop ((idx 0) (bucket-dates bucket-dates))
(if (< date (car bucket-dates))
(addbucket! idx bal)
(loop (1+ idx) (cdr bucket-dates)))))
(lp (cdr splits)))
;; next split is a prepayment
((and (eqv? (xaccTransGetTxnType (xaccSplitGetParent (car splits)))
TXN-TYPE-PAYMENT)
(null? (gncInvoiceGetInvoiceFromLot (xaccSplitGetLot (car splits)))))
(let* ((prepay (xaccSplitGetAmount (car splits)))
(prepay (if receivable? prepay (- prepay))))
(gnc:pk 'next=prepay (car splits) prepay)
(addbucket! (1- num-buckets) prepay))
(lp (cdr splits)))
;; not invoice/prepayment. regular or payment split.
(else
(gnc:pk 'next=skipped (car splits))
(lp (cdr splits)))))))
;; ***************************************************************************
;; Adds "file:///" to the beginning of a URL if it doesn't already exist
@ -896,6 +958,26 @@
(define (monetary->string mon)
(format #f "[~a]"
(gnc:monetary->string mon)))
(define (owner->str owner)
(define owner-alist
(list (cons GNC-OWNER-NONE "None")
(cons GNC-OWNER-UNDEFINED "Undefined")
(cons GNC-OWNER-JOB "Job")
(cons GNC-OWNER-CUSTOMER "Cust")
(cons GNC-OWNER-VENDOR "Vend")
(cons GNC-OWNER-EMPLOYEE "Emp")))
(format #f "[~a:~a]"
(or (assv-ref owner-alist (gncOwnerGetType owner)) "Owner")
(gncOwnerGetName owner)))
(define (invoice->str inv)
(format #f "~a<Post:~a,Owner:~a,Notes:~a,Total:~a>"
(gncInvoiceGetTypeString inv)
(qof-print-date (gncInvoiceGetDatePosted inv))
(gncOwnerGetName (gncInvoiceGetOwner inv))
(gncInvoiceGetNotes inv)
(monetary->string (gnc:make-gnc-monetary
(gncInvoiceGetCurrency inv)
(gncInvoiceGetTotal inv)))))
(define (try proc)
;; Try proc with d as a parameter, catching exceptions to return
;; #f to the (or) evaluator below.
@ -924,6 +1006,8 @@
(try trans->str)
(try monetary->string)
(try gnc-budget-get-name)
(try owner->str)
(try invoice->str)
(object->string d)))
(define (pair->num pair)

2
gnucash/report/reports/CMakeLists.txt
View File

@ -28,6 +28,7 @@ set (reports_standard_SCHEME
standard/income-gst-statement.scm
standard/income-statement.scm
standard/net-charts.scm
standard/new-owner-report.scm
standard/portfolio.scm
standard/price-scatter.scm
standard/reconcile-report.scm
@ -47,6 +48,7 @@ set (reports_standard_SCHEME
set (reports_standard_SCHEME_2
standard/customer-summary.scm # Depends on owner-report
standard/new-aging.scm # ditto
)
set(reports_example_SCHEME

315
gnucash/report/reports/standard/new-aging.scm Normal file
View File

@ -0,0 +1,315 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; new-aging.scm : accounts payable/receivable aging report
;;
;; By Christopher Lam, rewrite and debug
;; By Derek Atkins <warlord@MIT.EDU> taken from the original...
;; By Robert Merkel (rgmerk@mira.net)
;; Copyright (c) 2002, 2003 Derek Atkins <warlord@MIT.EDU>
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2 of
;; the License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, contact:
;;
;; Free Software Foundation Voice: +1-617-542-5942
;; 51 Franklin Street, Fifth Floor Fax: +1-617-542-2652
;; Boston, MA 02110-1301, USA gnu@gnu.org
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-module (gnucash reports standard new-aging))
(use-modules (srfi srfi-1))
(use-modules (srfi srfi-11)) ;let-values
(use-modules (gnucash utilities))
(use-modules (gnucash gnc-module))
(use-modules (gnucash gettext))
(gnc:module-load "gnucash/report" 0)
(use-modules (gnucash reports))
(define optname-to-date (N_ "To"))
(define optname-sort-order (N_ "Sort Order"))
(define optname-report-currency (N_ "Report's currency"))
(define optname-price-source (N_ "Price Source"))
(define optname-show-zeros (N_ "Show zero balance items"))
(define optname-date-driver (N_ "Due or Post Date"))
(define no-APAR-account (_ "No valid A/Payable or A/Receivable \
account found. Please ensure valid AP/AR account exists."))
(define empty-APAR-accounts (_ "A/Payable or A/Receivable accounts \
exist but have no suitable transactions."))
(define num-buckets 6)
(define (setup-query query accounts date)
(qof-query-set-book query (gnc-get-current-book))
(gnc:query-set-match-non-voids-only! query (gnc-get-current-book))
(xaccQueryAddAccountMatch query accounts QOF-GUID-MATCH-ANY QOF-QUERY-AND)
(xaccQueryAddDateMatchTT query #f 0 #t date QOF-QUERY-AND)
(qof-query-set-sort-order query (list SPLIT-TRANS TRANS-DATE-POSTED) '() '())
(qof-query-set-sort-increasing query #t #t #t))
(define (aging-options-generator options)
(let* ((add-option
(lambda (new-option)
(gnc:register-option options new-option))))
(gnc:options-add-report-date!
options gnc:pagename-general optname-to-date "a")
;; Use a default report date of 'today'
(gnc:option-set-default-value
(gnc:lookup-option options gnc:pagename-general optname-to-date)
(cons 'relative 'today))
(add-option
(gnc:make-multichoice-option
gnc:pagename-general optname-sort-order "ia" (N_ "Sort order.") 'increasing
(list
(vector 'increasing (N_ "Increasing") (N_ "Alphabetical order"))
(vector 'decreasing (N_ "Decreasing") (N_ "Reverse alphabetical order")))))
(add-option
(gnc:make-simple-boolean-option
gnc:pagename-general optname-show-zeros "j"
(N_ "Show all vendors/customers even if they have a zero balance.")
#f))
(add-option
(gnc:make-multichoice-option
gnc:pagename-general optname-date-driver "k" (N_ "Leading date.") 'duedate
(list
;; Should be using standard label for due date?
(vector 'duedate
(N_ "Due Date")
(N_ "Due date is leading."))
;; Should be using standard label for post date?
(vector 'postdate
(N_ "Post Date")
(N_ "Post date is leading.")))))
(gnc:options-set-default-section options "General")
options))
(define (txn-is-invoice? txn)
(eqv? (xaccTransGetTxnType txn) TXN-TYPE-INVOICE))
(define (txn-is-payment? txn)
(eqv? (xaccTransGetTxnType txn) TXN-TYPE-PAYMENT))
(define (gnc-owner-equal? a b)
(string=? (gncOwnerReturnGUID a) (gncOwnerReturnGUID b)))
(define (split-has-owner? split owner)
(let* ((split-owner (split->owner split))
(retval (gnc-owner-equal? split-owner owner)))
(gncOwnerFree split-owner)
retval))
(define (split-from-acct? split acct)
(equal? acct (xaccSplitGetAccount split)))
(define (list-split lst fn cmp)
(let-values (((list-yes list-no) (partition (lambda (elt) (fn elt cmp)) lst)))
(cons list-yes list-no)))
;; simpler version of gnc:owner-from-split. must be gncOwnerFree after
;; use! see split-has-owner? above...
(define (split->owner split)
(let* ((lot (xaccSplitGetLot (gnc-lot-get-earliest-split (xaccSplitGetLot split))))
(owner (gncOwnerNew))
(use-lot-owner? (gncOwnerGetOwnerFromLot lot owner)))
(unless use-lot-owner?
(gncOwnerCopy (gncOwnerGetEndOwner
(gncInvoiceGetOwner (gncInvoiceGetInvoiceFromLot lot)))
owner))
owner))
(define (aging-renderer report-obj receivable)
(define (op-value section name)
(gnc:option-value
(gnc:lookup-option (gnc:report-options report-obj) section name)))
(define make-heading-list
(list ""
(_ "Company")
(_ "Prepayments")
(_ "Current")
(_ "0-30 days")
(_ "31-60 days")
(_ "61-90 days")
(_ "91+ days")
(_ "Total")))
(let* ((type (if receivable ACCT-TYPE-RECEIVABLE ACCT-TYPE-PAYABLE))
(accounts (filter (lambda (acc) (eqv? (xaccAccountGetType acc) type))
(gnc-account-get-descendants-sorted
(gnc-get-current-root-account))))
(report-title (op-value gnc:pagename-general gnc:optname-reportname))
(report-date (gnc:time64-end-day-time
(gnc:date-option-absolute-time
(op-value gnc:pagename-general optname-to-date))))
(sort-order (op-value gnc:pagename-general optname-sort-order))
(show-zeros (op-value gnc:pagename-general optname-show-zeros))
(date-type (op-value gnc:pagename-general optname-date-driver))
(query (qof-query-create-for-splits))
(document (gnc:make-html-document)))
;; for sorting and delete-duplicates. compare GUIDs
(define (ownerGUID<? a b)
(string<? (gncOwnerGetGUID a) (gncOwnerGetGUID b)))
;; for presentation. compare names.
(define (owner<? a b)
((if (eq? sort-order 'increasing) string<? string>?)
(gncOwnerGetName a) (gncOwnerGetName b)))
;; set default title
(gnc:html-document-set-title! document report-title)
(cond
((null? accounts)
(gnc:html-document-add-object!
document (gnc:make-html-text no-APAR-account)))
(else
(setup-query query accounts report-date)
(let* ((splits (qof-query-run query))
(accounts (sort-and-delete-duplicates (map xaccSplitGetAccount splits)
gnc:account-path-less-p equal?))
(table (gnc:make-html-table)))
(qof-query-destroy query)
;; loop into each APAR account
(let loop ((accounts accounts)
(splits (filter
(lambda (split)
(or (txn-is-invoice? (xaccSplitGetParent split))
(txn-is-payment? (xaccSplitGetParent split))))
splits)))
(cond
((null? accounts)
(gnc:html-table-set-col-headers! table make-heading-list)
(gnc:html-document-add-object!
document (if (null? (gnc:html-table-data table))
(gnc:make-html-text empty-APAR-accounts)
table)))
(else
(let* ((account (car accounts))
(comm (xaccAccountGetCommodity account))
(splits-acc-others (list-split splits split-from-acct? account))
(acc-splits (car splits-acc-others))
(other-acc-splits (cdr splits-acc-others)))
(gnc:debug 'account account)
(gnc:html-table-append-row!
table (list (gnc:make-html-table-cell/size
1 (+ 2 num-buckets) (xaccAccountGetName account))))
(let* ((split-owners (map split->owner acc-splits))
(acc-owners (sort (sort-and-delete-duplicates
split-owners ownerGUID<? gnc-owner-equal?)
owner<?)))
(gnc:debug 'owners acc-owners)
;; loop into each APAR account split
(let lp ((acc-owners acc-owners)
(acc-splits acc-splits)
(acc-totals (make-list (1+ num-buckets) 0)))
(cond
((null? acc-owners)
(for-each gncOwnerFree split-owners)
(gnc:html-table-append-row!
table
(cons* #f
(gnc:make-html-table-cell/markup
"total-label-cell" (_ "Total"))
(map
(lambda (amt)
(gnc:make-html-table-cell/markup
"total-number-cell" (gnc:make-gnc-monetary comm amt)))
acc-totals)))
(loop (cdr accounts)
other-acc-splits))
(else
(let* ((owner (car acc-owners))
(splits-own-others (list-split acc-splits split-has-owner?
owner))
(owner-splits (car splits-own-others))
(other-owner-splits (cdr splits-own-others))
(aging (gnc:owner-splits->aging-list
owner-splits num-buckets report-date
date-type receivable))
(aging-total (apply + aging)))
(when (or show-zeros (not (every zero? aging)))
(gnc:html-table-append-row!
table
(append
(list #f)
(cons
(gnc:make-html-text
(gnc:html-markup-anchor
(gnc:owner-anchor-text owner)
(gncOwnerGetName owner)))
(map
(lambda (amt)
(gnc:make-html-table-cell/markup
"number-cell" (gnc:make-gnc-monetary comm amt)))
(reverse aging)))
(list
(gnc:make-html-table-cell/markup
"number-cell"
(gnc:make-html-text
(gnc:html-markup-anchor
(gnc:owner-report-text owner account)
(gnc:make-gnc-monetary comm aging-total))))))))
(lp (cdr acc-owners)
other-owner-splits
(map + acc-totals
(reverse (cons aging-total aging))))))))))))))))
(gnc:report-finished)
document))
(define (payable-options-generator)
(aging-options-generator (gnc:new-options)))
(define (receivable-options-generator)
(aging-options-generator (gnc:new-options)))
(define (payables-renderer report-obj)
(aging-renderer report-obj #f))
(define (receivables-renderer report-obj)
(aging-renderer report-obj #t))
(gnc:define-report
'version 1
'name (N_ "Payable Aging (beta)")
'report-guid "e57770f2dbca46619d6dac4ac5469b50-new"
'menu-path (list gnc:menuname-experimental)
'options-generator payable-options-generator
'renderer payables-renderer
'in-menu? #t)
(gnc:define-report
'version 1
'name (N_ "Receivable Aging (beta)")
'report-guid "9cf76bed17f14401b8e3e22d0079cb98-new"
'menu-path (list gnc:menuname-experimental)
'options-generator receivable-options-generator
'renderer receivables-renderer
'in-menu? #t)

889
gnucash/report/reports/standard/new-owner-report.scm Normal file
View File

@ -0,0 +1,889 @@
;; -*-scheme-*-
;; owner-report.scm -- Print out a detailed owner report, which is a
;; summary of invoices and payments for a particular
;; company (the owner) applied to an account.
;;
;; Created by: Derek Atkins <warlord@MIT.EDU>
;; Copyright (c) 2002, 2003 Derek Atkins <warlord@MIT.EDU>
;; Modified by AMM to show tax figures of invoice.
;; Modified by Christopher Lam to combine job/owner-report
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2 of
;; the License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, contact:
;;
;; Free Software Foundation Voice: +1-617-542-5942
;; 51 Franklin Street, Fifth Floor Fax: +1-617-542-2652
;; Boston, MA 02110-1301, USA gnu@gnu.org
(define-module (gnucash reports standard new-owner-report))
(use-modules (srfi srfi-1))
(use-modules (srfi srfi-8))
(use-modules (srfi srfi-11)) ;for let-values
(use-modules (gnucash gnc-module))
(use-modules (gnucash utilities)) ; for gnc:debug
(use-modules (gnucash gettext))
(gnc:module-load "gnucash/report" 0)
(use-modules (gnucash reports))
;; Option names
(define optname-from-date (N_ "From"))
(define optname-to-date (N_ "To"))
(define optname-date-driver (N_ "Due or Post Date"))
(define owner-page gnc:pagename-general)
(define date-header (N_ "Date"))
(define due-date-header (N_ "Due Date"))
(define reference-header (N_ "Reference"))
(define type-header (N_ "Type"))
(define desc-header (N_ "Description"))
(define sale-header (N_ "Sale"))
(define tax-header (N_ "Tax"))
(define credit-header (N_ "Credits"))
(define debit-header (N_ "Debits"))
(define amount-header (N_ "Balance"))
(define linked-txns-header (N_ "Links"))
;; Depending on the report type we want to set up some lists/cases
;; with strings to ease overview and translation
(define owner-string-alist
(list
(list GNC-OWNER-CUSTOMER
(N_ "Customer")
(_ "No valid customer selected.")
(_ "This report requires a customer to be selected."))
(list GNC-OWNER-EMPLOYEE
(N_ "Employee")
(_ "No valid employee selected.")
(_ "This report requires a employee to be selected."))
(list GNC-OWNER-JOB
(N_ "Job")
(_ "No valid job selected.")
(_ "This report requires a job to be selected."))
(list GNC-OWNER-VENDOR
(N_ "Vendor")
(_ "No valid vendor selected.")
(_ "This report requires a vendor to be selected."))))
(define (get-info key)
(assv-ref owner-string-alist key))
;; Names in Option panel (Untranslated! Because it is used for option
;; naming and lookup only, and the display of the option name will be
;; translated somewhere else.)
(define (owner-string owner-type)
(car (get-info owner-type)))
(define (date-col columns-used)
(vector-ref columns-used 0))
(define (date-due-col columns-used)
(vector-ref columns-used 1))
(define (num-col columns-used)
(vector-ref columns-used 2))
(define (type-col columns-used)
(vector-ref columns-used 3))
(define (memo-col columns-used)
(vector-ref columns-used 4))
(define (sale-col columns-used)
(vector-ref columns-used 5))
(define (tax-col columns-used)
(vector-ref columns-used 6))
(define (credit-col columns-used)
(vector-ref columns-used 7))
(define (debit-col columns-used)
(vector-ref columns-used 8))
(define (value-col columns-used)
(vector-ref columns-used 9))
(define columns-used-size 10)
(define (build-column-used options)
(define (opt-val section name)
(gnc:option-value
(gnc:lookup-option options section name)))
(define (make-set-col col-vector)
(let ((col 0))
(lambda (used? index)
(if used?
(begin
(vector-set! col-vector index col)
(set! col (+ col 1)))
(vector-set! col-vector index #f)))))
(let* ((col-vector (make-vector columns-used-size #f))
(set-col (make-set-col col-vector)))
(set-col (opt-val "Display Columns" date-header) 0)
(set-col (opt-val "Display Columns" due-date-header) 1)
(set-col (opt-val "Display Columns" reference-header) 2)
(set-col (opt-val "Display Columns" type-header) 3)
(set-col (opt-val "Display Columns" desc-header) 4)
(set-col (opt-val "Display Columns" sale-header) 5)
(set-col (opt-val "Display Columns" tax-header) 6)
(set-col (opt-val "Display Columns" credit-header) 7)
(set-col (opt-val "Display Columns" debit-header) 8)
(set-col (opt-val "Display Columns" amount-header) 9)
col-vector))
(define (make-heading-list column-vector link-option)
(let ((heading-list '()))
(if (date-col column-vector)
(addto! heading-list (_ date-header)))
(if (date-due-col column-vector)
(addto! heading-list (_ due-date-header)))
(if (num-col column-vector)
(addto! heading-list (_ reference-header)))
(if (type-col column-vector)
(addto! heading-list (_ type-header)))
(if (memo-col column-vector)
(addto! heading-list (_ desc-header)))
(if (sale-col column-vector)
(addto! heading-list (_ sale-header)))
(if (tax-col column-vector)
(addto! heading-list (_ tax-header)))
(if (credit-col column-vector)
(addto! heading-list (_ credit-header)))
(if (debit-col column-vector)
(addto! heading-list (_ debit-header)))
(if (value-col column-vector)
(addto! heading-list (_ amount-header)))
(case link-option
((simple)
(addto! heading-list (_ linked-txns-header)))
((detailed)
(addto! heading-list (_ "Date"))
(addto! heading-list (_ "Details"))
(addto! heading-list (_ "Amount"))))
(reverse heading-list)))
(define num-buckets 6)
(define (new-bucket-vector)
(make-vector num-buckets 0))
(define (txn-is-invoice? txn)
(eqv? (xaccTransGetTxnType txn) TXN-TYPE-INVOICE))
(define (txn-is-payment? txn)
(eqv? (xaccTransGetTxnType txn) TXN-TYPE-PAYMENT))
(define (make-aging-table splits to-date reverse? date-type currency)
(let ((table (gnc:make-html-table))
(aging-list (gnc:owner-splits->aging-list
splits num-buckets to-date date-type reverse?)))
(gnc:html-table-set-col-headers!
table (list (_ "Prepayments")
(_ "Current")
(_ "0-30 days")
(_ "31-60 days")
(_ "61-90 days")
(_ "91+ days")
(_ "Total")))
(gnc:html-table-append-row!
table (map (lambda (entry) (gnc:make-gnc-monetary currency entry))
(reverse (cons (apply + aging-list) aging-list))))
table))
;; addif is a macro; a simple procedure will always evaluate the
;; arguments pred? and elt which is not desirable; a macro will ensure
;; elt is only evaluated if pred? is not #f
(define-syntax-rule (addif pred? elt)
(if pred? (list elt) '()))
(define (make-cell elt) (gnc:make-html-table-cell/markup "number-cell" elt))
;;
;; Make a row list based on the visible columns
;;
(define (add-row table odd-row? column-vector date due-date num type-str
memo currency amt credit debit sale tax link-rows)
(define empty-cols
(count identity
(map (lambda (f) (f column-vector))
(list date-col date-due-col num-col type-col
memo-col sale-col tax-col credit-col
debit-col value-col))))
(define (cell amt)
(and amt (make-cell (gnc:make-gnc-monetary currency amt))))
(let lp ((link-rows link-rows)
(first-row? #t))
(unless (null? link-rows)
(if first-row?
(gnc:html-table-append-row/markup!
table (if odd-row? "normal-row" "alternate-row")
(append
(addif (date-col column-vector) (qof-print-date date))
(addif (date-due-col column-vector)
(and due-date (qof-print-date due-date)))
(addif (num-col column-vector) (gnc:html-string-sanitize num))
(addif (type-col column-vector) type-str)
(addif (memo-col column-vector) (gnc:html-string-sanitize memo))
(addif (sale-col column-vector) (cell sale))
(addif (tax-col column-vector) (cell tax))
(addif (credit-col column-vector) (cell credit))
(addif (debit-col column-vector) (cell (and debit (- debit))))
(addif (value-col column-vector) (cell amt))
(car link-rows)))
(gnc:html-table-append-row/markup!
table (if odd-row? "normal-row" "alternate-row")
(cons
(gnc:make-html-table-cell/size 1 empty-cols #f)
(car link-rows))))
(lp (cdr link-rows) #f))))
(define (add-owner-table table splits acc start-date end-date date-type
used-columns reverse? link-option)
(define currency (xaccAccountGetCommodity acc))
(define link-cols (assq-ref '((none . 0) (simple . 1) (detailed . 3)) link-option))
(define (print-totals total debit credit tax sale)
(define (total-cell cell)
(gnc:make-html-table-cell/markup "total-number-cell" cell))
(define (make-cell amt)
(total-cell (gnc:make-gnc-monetary currency amt)))
(define span
(count identity (map (lambda (f) (f used-columns))
(list memo-col type-col num-col date-due-col date-col))))
;; print period totals
(if (or (sale-col used-columns) (tax-col used-columns)
(credit-col used-columns) (debit-col used-columns))
(gnc:html-table-append-row/markup!
table "grand-total"
(append
(list (total-cell (_ "Period Totals")))
(addif (>= span 2) (gnc:make-html-table-cell/size 1 (1- span) ""))
(addif (sale-col used-columns) (make-cell sale))
(addif (tax-col used-columns) (make-cell tax))
(addif (credit-col used-columns) (make-cell credit))
(addif (debit-col used-columns) (make-cell (- debit)))
(addif (value-col used-columns) (make-cell (+ credit debit)))
(addif (> link-cols 0) (gnc:make-html-table-cell/size 1 link-cols #f)))))
;; print grand total
(if (value-col used-columns)
(gnc:html-table-append-row/markup!
table "grand-total"
(append
(list (total-cell
(if (negative? total)
(_ "Total Credit")
(_ "Total Due")))
(gnc:make-html-table-cell/size/markup
1 (value-col used-columns)
"total-number-cell"
(gnc:make-gnc-monetary currency total)))
(addif (> link-cols 0)
(gnc:make-html-table-cell/size 1 link-cols #f)))))
;; print aging table
(gnc:html-table-append-row/markup!
table "grand-total"
(list (gnc:make-html-table-cell/size
1 (+ columns-used-size link-cols)
(make-aging-table splits
end-date
reverse? date-type currency)))))
(define (add-balance-row odd-row? total)
(add-row table odd-row? used-columns start-date #f "" (_ "Balance") ""
currency total #f #f #f #f (list (make-list link-cols #f))))
(define (make-invoice->payments-table invoice invoice-splits currency txn)
(append
(map
(lambda (pmt-split)
(list
(qof-print-date
(xaccTransGetDate
(xaccSplitGetParent pmt-split)))
(let ((text (gnc-get-num-action
(xaccSplitGetParent pmt-split)
pmt-split)))
(if (string-null? text)
(_ "Payment")
text))
(make-cell
(gnc:make-html-text
(gnc:html-markup-anchor
(gnc:split-anchor-text pmt-split)
(gnc:make-gnc-monetary
currency (- (xaccSplitGetAmount pmt-split))))))))
(filter (lambda (s) (not (equal? (xaccSplitGetParent s) txn)))
invoice-splits))
(if (gncInvoiceIsPaid invoice)
'()
(list
(list (gnc:make-html-table-cell/size 1 2 (_ "Outstanding"))
(make-cell
(gnc:make-gnc-monetary
currency
(gnc-lot-get-balance
(gncInvoiceGetPostedLot invoice)))))))))
(define (make-payment->invoices-list invoice payment-splits)
(list
(list
(apply
gnc:make-html-text
(map
(lambda (inv-splits)
(gnc:html-markup-anchor
(gnc:invoice-anchor-text (car inv-splits))
(gnc-get-num-action
(gncInvoiceGetPostedTxn (car inv-splits))
#f)))
payment-splits)))))
(define (make-payment->invoices-table split payment-splits currency)
(if (null? payment-splits)
(list (list (gnc:make-html-table-cell/size 1 2 (_ "Prepayments"))
(make-cell
(gnc:make-gnc-monetary
currency (- (xaccSplitGetAmount split))))))
(map
(lambda (inv-splits)
(let ((inv (car inv-splits))
(inv-split (cadr inv-splits)))
(list
(qof-print-date
(gncInvoiceGetDatePosted inv))
(gnc:make-html-text
(gnc:html-markup-anchor
(gnc:invoice-anchor-text inv)
(gnc-get-num-action
(gncInvoiceGetPostedTxn inv) #f)))
(make-cell
(gnc:make-gnc-monetary
currency
(- (xaccSplitGetAmount inv-split)))))))
payment-splits)))
(define (split->type-str split)
(let* ((txn (xaccSplitGetParent split))
(invoice (gncInvoiceGetInvoiceFromTxn txn)))
(cond
((and (txn-is-invoice? txn)
(not (null? invoice)))
(gnc:make-html-text
(gnc:html-markup-anchor
(gnc:invoice-anchor-text invoice)
(gncInvoiceGetTypeString invoice))))
((txn-is-payment? txn)
(gnc:make-html-text
(gnc:html-markup-anchor
(gnc:split-anchor-text split)
(_ "Payment"))))
(else (_ "Unknown")))))
(define (invoice->sale invoice)
(and (not (null? invoice))
((if (gncInvoiceGetIsCreditNote invoice) - identity)
(gncInvoiceGetTotalSubtotal invoice))))
(define (invoice->tax invoice)
(and (not (null? invoice))
((if (gncInvoiceGetIsCreditNote invoice) - identity)
(gncInvoiceGetTotalTax invoice))))
(define (invoice->due-date invoice)
(and (not (null? invoice))
(gncInvoiceIsPosted invoice)
(gncInvoiceGetDateDue invoice)))
(let lp ((printed? #f)
(odd-row? #t)
(splits splits)
(total 0)
(debit 0)
(credit 0)
(tax 0)
(sale 0)
(links '()))
(cond
((null? splits)
;;Balance row may not have been added if all transactions were before
;;start-date (and no other rows would be added either) so add it now
(when (and (not printed?) (value-col used-columns) (not (zero? total)))
(add-balance-row odd-row? total))
(print-totals total debit credit tax sale)
(gnc:html-table-set-style!
table "table"
'attribute (list "border" 1)
'attribute (list "cellspacing" 0)
'attribute (list "cellpadding" 4))
table)
;; not an invoice/payment. skip transaction.
((not (or (txn-is-invoice? (xaccSplitGetParent (car splits)))
(txn-is-payment? (xaccSplitGetParent (car splits)))))
(lp printed? odd-row? (cdr splits) total debit credit tax sale links))
;; invalid case: txn-type-invoice but no associated invoice, nor lot
((let* ((txn (xaccSplitGetParent (car splits)))
(invoice (gncInvoiceGetInvoiceFromTxn txn)))
(and (txn-is-invoice? txn)
(or (null? invoice)
(null? (gncInvoiceGetPostedLot invoice)))))
(gnc:warn "sanity check fail" txn)
(lp printed? odd-row? (cdr splits) total debit credit tax sale links))
;; start printing txns.
(else
(let* ((split (car splits))
(txn (xaccSplitGetParent split))
(date (xaccTransGetDate txn))
(value (xaccSplitGetAmount split))
(value (if reverse? (- value) value))
(invoice (gncInvoiceGetInvoiceFromTxn txn))
(invoice-splits
(and (txn-is-invoice? txn)
(gnc-lot-get-split-list
(gncInvoiceGetPostedLot invoice))))
(payment-splits
(and (txn-is-payment? txn)
(filter
(lambda (inv-split)
(member txn (map xaccSplitGetParent (cdr inv-split))))
links))))
(cond
;; txn-date < start-date. skip display, accumulate amounts
((< date start-date)
(lp printed? odd-row? (cdr splits) (+ total value)
(if (negative? value) (+ debit value) debit)
(if (negative? value) credit (+ credit value))
tax sale (if (null? invoice) links
(acons invoice invoice-splits links))))
;; if balance row hasn't been rendered, consider
;; adding here. skip if value=0.
((not printed?)
(let ((print? (and (value-col used-columns) (not (zero? total)))))
(if print? (add-balance-row odd-row? total))
(lp #t (not print?) splits total debit credit tax sale links)))
(else
(add-row
table odd-row? used-columns date (invoice->due-date invoice)
(gnc-get-num-action txn split) (split->type-str split)
(xaccSplitGetMemo split) currency (+ total value)
(and (>= value 0) value) (and (< value 0) value)
(invoice->sale invoice) (invoice->tax invoice)
(cond
((and invoice-splits (eq? link-option 'simple))
(if (gnc-lot-is-closed (gncInvoiceGetPostedLot invoice))
(list (list (_ "Paid")))
(list (list #f))))
((and invoice-splits (eq? link-option 'detailed))
(make-invoice->payments-table invoice invoice-splits currency txn))
((and payment-splits (eq? link-option 'simple))
(make-payment->invoices-list invoice payment-splits))
((and payment-splits (eq? link-option 'detailed))
(make-payment->invoices-table split payment-splits currency))
;; some error occurred, show 1 line containing empty-list
(else '(()))))
(lp printed? (not odd-row?) (cdr splits) (+ total value)
(if (negative? value) (+ debit value) debit)
(if (negative? value) credit (+ credit value))
(+ tax (or (invoice->tax invoice) 0))
(+ sale (or (invoice->sale invoice) 0))
(if (null? invoice) links
(acons invoice invoice-splits links))))))))))
(define (options-generator owner-type)
(define gnc:*report-options* (gnc:new-options))
(define (gnc:register-inv-option new-option)
(gnc:register-option gnc:*report-options* new-option))
(gnc:register-inv-option
(gnc:make-owner-option
owner-page (owner-string owner-type) "v"
(N_ "The company for this report.")
(lambda () '()) #f owner-type))
(gnc:options-add-date-interval!
gnc:*report-options* gnc:pagename-general
optname-from-date optname-to-date "a")
;; Use a default report date of 'today'
(gnc:option-set-default-value
(gnc:lookup-option gnc:*report-options* gnc:pagename-general optname-to-date)
(cons 'relative 'today))
(gnc:register-inv-option
(gnc:make-simple-boolean-option
(N_ "Display Columns") date-header
"b" (N_ "Display the transaction date?") #t))
(gnc:register-inv-option
(gnc:make-simple-boolean-option
(N_ "Display Columns") due-date-header
"c" (N_ "Display the transaction date?") #t))
(gnc:register-inv-option
(gnc:make-simple-boolean-option
(N_ "Display Columns") reference-header
"d" (N_ "Display the transaction reference?") #t))
(gnc:register-inv-option
(gnc:make-simple-boolean-option
(N_ "Display Columns") type-header
"g" (N_ "Display the transaction type?") #t))
(gnc:register-inv-option
(gnc:make-simple-boolean-option
(N_ "Display Columns") desc-header
"ha" (N_ "Display the transaction description?") #t))
(gnc:register-inv-option
(gnc:make-simple-boolean-option
(N_ "Display Columns") sale-header
"haa" (N_ "Display the sale amount column?") #f))
(gnc:register-inv-option
(gnc:make-simple-boolean-option
(N_ "Display Columns") tax-header
"hab" (N_ "Display the tax column?") #f))
(gnc:register-inv-option
(gnc:make-simple-boolean-option
(N_ "Display Columns") credit-header
"hac" (N_ "Display the period credits column?") #t))
(gnc:register-inv-option
(gnc:make-simple-boolean-option
(N_ "Display Columns") debit-header
"had" (N_ "Display a period debits column?") #t))
(gnc:register-inv-option
(gnc:make-simple-boolean-option
(N_ "Display Columns") amount-header
"hb" (N_ "Display the transaction amount?") #t))
(gnc:register-inv-option
(gnc:make-multichoice-option
(N_ "Display Columns") linked-txns-header
"hc" (N_ "Show linked transactions") 'none
(list (vector 'none
(N_ "Disabled")
(N_ "Linked transactions are hidden."))
(vector 'simple
(N_ "Simple")
(N_ "Invoices show if paid, payments show invoice numbers."))
(vector 'detailed
(N_ "Detailed")
(N_ "Invoices show list of payments, payments show list of \
invoices and amounts.")))))
(gnc:register-inv-option
(gnc:make-multichoice-option
gnc:pagename-general optname-date-driver "k"
(N_ "Leading date.") 'duedate
(list
;; Should be using standard label for due date?
(vector 'duedate
(N_ "Due Date")
(N_ "Due date is leading."))
;; Should be using standard label for post date?
(vector 'postdate
(N_ "Post Date")
(N_ "Post date is leading.")))))
(gnc:options-set-default-section gnc:*report-options* "General")
gnc:*report-options*)
(define (multiline-to-html-text str)
;; simple function - splits string containing #\newline into
;; substrings, and convert to a gnc:make-html-text construct which
;; adds gnc:html-markup-br after each substring.
(let loop ((list-of-substrings (string-split str #\newline))
(result '()))
(if (null? list-of-substrings)
(apply gnc:make-html-text (if (null? result) '() (reverse (cdr result))))
(loop (cdr list-of-substrings)
(cons* (gnc:html-markup-br) (car list-of-substrings) result)))))
(define (setup-job-query q owner accounts end-date)
(let ((guid (gncOwnerReturnGUID owner)))
(qof-query-add-guid-match
q (list SPLIT-TRANS INVOICE-FROM-TXN INVOICE-OWNER QOF-PARAM-GUID)
guid QOF-QUERY-OR)
(qof-query-add-guid-match
q (list SPLIT-LOT OWNER-FROM-LOT QOF-PARAM-GUID)
guid QOF-QUERY-OR)
(qof-query-add-guid-match
q (list SPLIT-LOT INVOICE-FROM-LOT INVOICE-OWNER QOF-PARAM-GUID)
guid QOF-QUERY-OR)
(xaccQueryAddAccountMatch q accounts QOF-GUID-MATCH-ANY QOF-QUERY-AND)
(xaccQueryAddDateMatchTT q #f end-date #t end-date QOF-QUERY-AND)
(qof-query-set-book q (gnc-get-current-book))
(qof-query-set-sort-order q (list SPLIT-TRANS TRANS-DATE-POSTED) '() '())
q))
(define (setup-query q owner accounts end-date)
(let ((guid (gncOwnerReturnGUID (gncOwnerGetEndOwner owner))))
(qof-query-add-guid-match
q (list SPLIT-TRANS INVOICE-FROM-TXN INVOICE-OWNER OWNER-PARENTG)
guid QOF-QUERY-OR)
(qof-query-add-guid-match
q (list SPLIT-LOT OWNER-FROM-LOT OWNER-PARENTG)
guid QOF-QUERY-OR)
(qof-query-add-guid-match
q (list SPLIT-LOT INVOICE-FROM-LOT INVOICE-OWNER OWNER-PARENTG)
guid QOF-QUERY-OR)
(xaccQueryAddAccountMatch q accounts QOF-GUID-MATCH-ANY QOF-QUERY-AND)
(xaccQueryAddDateMatchTT q #f end-date #t end-date QOF-QUERY-AND)
(qof-query-set-book q (gnc-get-current-book))
(qof-query-set-sort-order q (list SPLIT-TRANS TRANS-DATE-POSTED) '() '())
q))
(define (make-owner-table owner)
(let ((table (gnc:make-html-table)))
(gnc:html-table-set-style!
table "table"
'attribute (list "border" 0)
'attribute (list "cellspacing" 0)
'attribute (list "cellpadding" 0)
'attribute (list "valign" "top"))
(gnc:html-table-append-row!
table (multiline-to-html-text (gnc:owner-get-name-and-address-dep owner)))
table))
(define (make-myname-table book date-format)
(let* ((table (gnc:make-html-table))
(name (gnc:company-info book gnc:*company-name*))
(addy (gnc:company-info book gnc:*company-addy*)))
(gnc:html-table-set-style!
table "table"
'attribute (list "border" 0)
'attribute (list "align" "right")
'attribute (list "valign" "top")
'attribute (list "cellspacing" 0)
'attribute (list "cellpadding" 0))
(when name
(gnc:html-table-append-row! table (list name)))
(when addy
(gnc:html-table-append-row! table (multiline-to-html-text addy)))
(gnc:html-table-append-row!
table (list (gnc-print-time64 (gnc:get-today) date-format)))
table))
(define (make-break! document)
(gnc:html-document-add-object!
document
(gnc:make-html-text
(gnc:html-markup-br))))
(define (reg-renderer report-obj type reverse?)
(define options (gnc:report-options report-obj))
(define (opt-val section name)
(gnc:option-value
(gnc:lookup-option options section name)))
(let* ((accounts (filter (compose xaccAccountIsAPARType xaccAccountGetType)
(gnc-account-get-descendants-sorted
(gnc-get-current-root-account))))
(start-date (gnc:time64-start-day-time
(gnc:date-option-absolute-time
(opt-val gnc:pagename-general optname-from-date))))
(end-date (gnc:time64-end-day-time
(gnc:date-option-absolute-time
(opt-val gnc:pagename-general optname-to-date))))
(book (gnc-get-current-book))
(date-format (gnc:options-fancy-date (gnc-get-current-book)))
(used-columns (build-column-used options))
(link-option
(gnc:option-value
(gnc:lookup-option options "Display Columns" linked-txns-header)))
(owner-descr (owner-string type))
(date-type (opt-val gnc:pagename-general optname-date-driver))
(owner (opt-val owner-page owner-descr))
(query (qof-query-create-for-splits))
(document (gnc:make-html-document))
(table (gnc:make-html-table))
(headings (make-heading-list used-columns link-option))
(report-title (string-append (owner-string type) " " (_ "Report"))))
(cond
((not (gncOwnerIsValid owner))
(gnc:html-document-add-object!
document (gnc:html-make-generic-warning
report-title (gnc:report-id report-obj)
(cadr (get-info type)) (caddr (get-info type)))))
((null? accounts)
(gnc:html-document-add-object!
document
(gnc:html-make-generic-warning
(string-append report-title ": " (gncOwnerGetName owner))
(gnc:report-id report-obj)
(_ "No valid account found")
(_ "This report requires a valid AP/AR account to be available."))))
(else
(if (eqv? GNC-OWNER-JOB type)
(setup-job-query query owner accounts end-date)
(setup-query query owner accounts end-date))
(let ((splits (xaccQueryGetSplitsUniqueTrans query)))
(qof-query-destroy query)
(gnc:html-document-set-title!
document (string-append report-title ": " (gncOwnerGetName owner)))
(gnc:html-document-set-headline!
document (gnc:html-markup
"span" (owner-string type) " " (_ "Report:") " "
(gnc:html-markup-anchor
(if (eqv? GNC-OWNER-JOB type)
(gnc:job-anchor-text (gncOwnerGetJob owner))
(gnc:owner-anchor-text owner))
(gncOwnerGetName owner))))
(cond
((null? splits)
(gnc:html-document-add-object!
document
(gnc:make-html-text
(gnc:html-markup-h2 (_ "No transactions found."))
(gnc:html-markup-p
(format #f (_ "No transactions were found associated with the ~a.")
(string-downcase (car (get-info type)))))
(gnc:html-make-options-link (gnc:report-id report-obj)))))
(else
;; loops in 2 passes: 1st loop. for each APAR account, filter
;; splits into each account. accumulate non-null results into
;; accounts-and-splits accumulator.
(let loop ((accounts accounts)
(accounts-and-splits '())
(splits splits))
(cond
((null? accounts)
;; 2nd loop: for-each accounts-and-splits accumulator, add
;; owner-txns into the html-table. only show header if >1
;; account has splits.
(for-each
(lambda (acc-splits-pair)
(let* ((account (car acc-splits-pair))
(splits (cdr acc-splits-pair)))
(when (> (length accounts-and-splits) 1)
(gnc:html-table-append-row!
table (gnc:make-html-table-cell/size
1 (length headings)
(gnc:make-html-text
(gnc:html-markup-h3
(string-append (_ "Account") ": "
(xaccAccountGetName account)))))))
(add-owner-table table splits account start-date end-date
date-type used-columns reverse? link-option)))
accounts-and-splits))
(else
;; each 1st loop will slice splits into account-splits and
;; non-account splits, add to accounts-and-splits; and send
;; the non-account splits to be processed in the next loop
;; iteration.
(let-values (((acc-splits other-acc-splits)
(partition
(lambda (split)
(equal? (car accounts) (xaccSplitGetAccount split)))
splits)))
(loop (cdr accounts)
(if (null? acc-splits)
accounts-and-splits
(cons (cons (car accounts) acc-splits)
accounts-and-splits))
other-acc-splits)))))
(gnc:html-document-add-object!
document (make-myname-table book date-format))
(gnc:html-document-add-object!
document (make-owner-table owner))
(gnc:html-document-add-object!
document (gnc:make-html-text
(string-append (_ "Date Range") ": " (qof-print-date start-date)
" - " (qof-print-date end-date))))
(make-break! document)
(gnc:html-table-set-col-headers! table headings)
(gnc:html-document-add-object! document table))))))
document))
(define (customer-renderer obj)
(reg-renderer obj GNC-OWNER-CUSTOMER #f))
(define (vendor-renderer obj)
(reg-renderer obj GNC-OWNER-VENDOR #t))
(define (employee-renderer obj)
(reg-renderer obj GNC-OWNER-EMPLOYEE #t))
(define (job-renderer obj)
(reg-renderer obj GNC-OWNER-JOB #f))
(gnc:define-report
'version 1
'name (N_ "Customer Report (beta)")
'report-guid "c146317be32e4948a561ec7fc89d15c1-new"
'menu-path (list gnc:menuname-experimental)
'options-generator (lambda () (options-generator GNC-OWNER-CUSTOMER))
'renderer customer-renderer
'in-menu? #t)
(gnc:define-report
'version 1
'name (N_ "Vendor Report (beta)")
'report-guid "d7d1e53505ee4b1b82efad9eacedaea0-new"
'menu-path (list gnc:menuname-experimental)
'options-generator (lambda () (options-generator GNC-OWNER-VENDOR))
'renderer vendor-renderer
'in-menu? #t)
(gnc:define-report
'version 1
'name (N_ "Employee Report (beta)")
'report-guid "08ae9c2e884b4f9787144f47eacd7f44-new"
'menu-path (list gnc:menuname-experimental)
'options-generator (lambda () (options-generator GNC-OWNER-EMPLOYEE))
'renderer employee-renderer
'in-menu? #t)
(gnc:define-report
'version 1
'name (N_ "Job Report (beta)")
'report-guid "5518ac227e474f47a34439f2d4d049de-new"
'menu-path (list gnc:menuname-experimental)
'options-generator (lambda () (options-generator GNC-OWNER-JOB))
'renderer job-renderer
'in-menu? #t)

91
gnucash/report/stylesheets/easy.scm
View File

@ -188,37 +188,29 @@
(lambda (section name)
(gnc:color-option->html
(gnc:lookup-option options section name))))
(preparer (opt-val (N_ "General") (N_ "Preparer")))
(prepared-for (opt-val (N_ "General") (N_ "Prepared for")))
(show-preparer? (opt-val (N_ "General") (N_ "Show preparer info")))
(links? (opt-val (N_ "General") (N_ "Enable Links")))
(bgcolor (color-val (N_ "Colors") (N_ "Background Color")))
(textcolor (color-val (N_ "Colors") (N_ "Text Color")))
(linkcolor (color-val (N_ "Colors") (N_ "Link Color")))
(normal-row-color (color-val (N_ "Colors") (N_ "Table Cell Color")))
(alternate-row-color (color-val (N_ "Colors")
(N_ "Alternate Table Cell Color")))
(preparer (opt-val "General" "Preparer"))
(prepared-for (opt-val "General" "Prepared for"))
(show-preparer? (opt-val "General" "Show preparer info"))
(links? (opt-val "General" "Enable Links"))
(bgcolor (color-val "Colors" "Background Color"))
(textcolor (color-val "Colors" "Text Color"))
(linkcolor (color-val "Colors" "Link Color"))
(normal-row-color (color-val "Colors" "Table Cell Color"))
(alternate-row-color (color-val "Colors" "Alternate Table Cell Color"))
(primary-subheading-color
(color-val (N_ "Colors")
(N_ "Subheading/Subtotal Cell Color")))
(color-val "Colors" "Subheading/Subtotal Cell Color"))
(secondary-subheading-color
(color-val (N_ "Colors")
(N_ "Sub-subheading/total Cell Color")))
(grand-total-color (color-val (N_ "Colors")
(N_ "Grand Total Cell Color")))
(bgpixmap (opt-val (N_ "Images") (N_ "Background Tile")))
(headpixmap (opt-val (N_ "Images") (N_ "Heading Banner")))
(logopixmap (opt-val (N_ "Images") (N_ "Logo")))
(align (gnc:value->string(opt-val (N_ "Images") (N_ "Heading Alignment"))))
(spacing (opt-val (N_ "Tables") (N_ "Table cell spacing")))
(padding (opt-val (N_ "Tables") (N_ "Table cell padding")))
(border (opt-val (N_ "Tables") (N_ "Table border width")))
(color-val "Colors" "Sub-subheading/total Cell Color"))
(grand-total-color (color-val "Colors" "Grand Total Cell Color"))
(bgpixmap (opt-val "Images" "Background Tile"))
(headpixmap (opt-val "Images" "Heading Banner"))
(logopixmap (opt-val "Images" "Logo"))
(align (gnc:value->string (opt-val "Images" "Heading Alignment")))
(spacing (opt-val "Tables" "Table cell spacing"))
(padding (opt-val "Tables" "Table cell padding"))
(border (opt-val "Tables" "Table border width"))
(headcolumn 0))
; center the document without elements inheriting anything
(gnc:html-document-add-object! ssdoc
(gnc:make-html-text "<center>"))
(gnc:html-document-set-style!
ssdoc "body"
'attribute (list "bgcolor" bgcolor)
@ -330,25 +322,25 @@
(gnc:html-document-set-style!
ssdoc "a" 'tag ""))
(add-css-information-to-doc options ssdoc doc)
(let ((t (gnc:make-html-table)))
;; we don't want a bevel for this table, but we don't want
;; that to propagate
(gnc:html-table-set-style!
t "table"
'attribute (list "border" 0)
'attribute (list "style" "margin-left:auto; margin-right:auto")
'inheritable? #f)
; set the header column to be the 2nd when we have a logo
; do this so that when logo is not present, the document
; is perfectly centered
;; set the header column to be the 2nd when we have a logo
;; do this so that when logo is not present, the document
;; is perfectly centered
(if (and logopixmap (> (string-length logopixmap) 0))
(set! headcolumn 1))
(add-css-information-to-doc options ssdoc doc)
(let* ((title (gnc:html-document-title doc))
(doc-headline (gnc:html-document-headline doc))
(headline (if (eq? doc-headline #f) title doc-headline)))
(let* ((headline (or (gnc:html-document-headline doc)
(gnc:html-document-title doc))))
(gnc:html-table-set-cell!
t 1 headcolumn
@ -372,34 +364,25 @@
(gnc:html-markup-h3 headline))))
)
; only setup an image if we specified one
;; only setup an image if we specified one
(if (and logopixmap (> (string-length logopixmap) 0))
(begin
(gnc:html-table-set-cell!
t 0 0
(gnc:make-html-text
(gnc:html-markup-img (make-file-url logopixmap))))))
(gnc:html-table-set-cell!
t 0 0
(gnc:make-html-text
(gnc:html-markup-img (make-file-url logopixmap)))))
(if (and headpixmap (> (string-length headpixmap) 0))
(begin
(gnc:html-table-set-cell!
t 0 headcolumn
(gnc:make-html-text
(string-append
"<div align=\"" align "\">"
"<img src=\"" (make-file-url headpixmap) "\">"
"</div>")))
)
(gnc:html-table-set-cell!
t 0 headcolumn
(gnc:make-html-text "&nbsp;")))
(let* ((div (gnc:html-markup-img (make-file-url headpixmap)))
(cell (gnc:make-html-table-cell (gnc:make-html-text div))))
(gnc:html-table-cell-set-style! cell "td" 'attribute `("align" ,align))
(gnc:html-table-set-cell! t 0 headcolumn cell))
(gnc:html-table-set-cell! t 0 headcolumn (gnc:make-html-text " ")))
(apply
gnc:html-table-set-cell!
t 2 headcolumn
(gnc:html-document-objects doc))
(gnc:html-document-add-object! ssdoc t))
(gnc:html-document-add-object! ssdoc (gnc:make-html-text "</center>")) ;;TODO: make this a div instead of <center> (deprecated)
ssdoc))
(gnc:define-html-style-sheet

96
gnucash/report/stylesheets/fancy.scm
View File

@ -182,43 +182,34 @@
(lambda (section name)
(gnc:color-option->html
(gnc:lookup-option options section name))))
(preparer (opt-val (N_ "General") (N_ "Preparer")))
(prepared-for (opt-val (N_ "General") (N_ "Prepared for")))
(show-preparer? (opt-val (N_ "General") (N_ "Show preparer info")))
(links? (opt-val (N_ "General") (N_ "Enable Links")))
(bgcolor (color-val (N_ "Colors") (N_ "Background Color")))
(textcolor (color-val (N_ "Colors") (N_ "Text Color")))
(linkcolor (color-val (N_ "Colors") (N_ "Link Color")))
(normal-row-color (color-val (N_ "Colors") (N_ "Table Cell Color")))
(alternate-row-color (color-val (N_ "Colors")
(N_ "Alternate Table Cell Color")))
(preparer (opt-val "General" "Preparer"))
(prepared-for (opt-val "General" "Prepared for"))
(show-preparer? (opt-val "General" "Show preparer info"))
(links? (opt-val "General" "Enable Links"))
(bgcolor (color-val "Colors" "Background Color"))
(textcolor (color-val "Colors" "Text Color"))
(linkcolor (color-val "Colors" "Link Color"))
(normal-row-color (color-val "Colors" "Table Cell Color"))
(alternate-row-color (color-val "Colors" "Alternate Table Cell Color"))
(primary-subheading-color
(color-val (N_ "Colors")
(N_ "Subheading/Subtotal Cell Color")))
(color-val "Colors" "Subheading/Subtotal Cell Color"))
(secondary-subheading-color
(color-val (N_ "Colors")
(N_ "Sub-subheading/total Cell Color")))
(grand-total-color (color-val (N_ "Colors")
(N_ "Grand Total Cell Color")))
(bgpixmap (opt-val (N_ "Images") (N_ "Background Tile")))
(headpixmap (opt-val (N_ "Images") (N_ "Heading Banner")))
(logopixmap (opt-val (N_ "Images") (N_ "Logo")))
(align (gnc:value->string(opt-val (N_ "Images") (N_ "Heading Alignment"))))
(spacing (opt-val (N_ "Tables") (N_ "Table cell spacing")))
(padding (opt-val (N_ "Tables") (N_ "Table cell padding")))
(border (opt-val (N_ "Tables") (N_ "Table border width")))
(color-val "Colors" "Sub-subheading/total Cell Color"))
(grand-total-color (color-val "Colors" "Grand Total Cell Color"))
(bgpixmap (opt-val "Images" "Background Tile"))
(headpixmap (opt-val "Images" "Heading Banner"))
(logopixmap (opt-val "Images" "Logo"))
(align (gnc:value->string (opt-val "Images" "Heading Alignment")))
(spacing (opt-val "Tables" "Table cell spacing"))
(padding (opt-val "Tables" "Table cell padding"))
(border (opt-val "Tables" "Table border width"))
(headcolumn 0))
; center the document without elements inheriting anything
(gnc:html-document-add-object! ssdoc
(gnc:make-html-text "<center>"))
(gnc:html-document-set-style!
ssdoc "body"
'attribute (list "bgcolor" bgcolor)
'attribute (list "text" textcolor)
'attribute (list "link" linkcolor))
;;;;
;;;;
;;;;
@ -333,17 +324,17 @@
(gnc:html-table-set-style!
t "table"
'attribute (list "border" 0)
'attribute (list "style" "margin-left:auto; margin-right:auto")
'inheritable? #f)
(let* ((title (gnc:html-document-title doc))
(doc-headline (gnc:html-document-headline doc))
(headline (if (eq? doc-headline #f) title doc-headline)))
;; set the header column to be the 2nd when we have a logo
;; do this so that when logo is not present, the document
;; is perfectly centered
(if (and logopixmap (> (string-length logopixmap) 0))
(set! headcolumn 1))
; set the header column to be the 2nd when we have a logo
; do this so that when logo is not present, the document
; is perfectly centered
(if (and logopixmap (> (string-length logopixmap) 0))
(set! headcolumn 1))
(let* ((headline (or (gnc:html-document-headline doc)
(gnc:html-document-title doc))))
(gnc:html-table-set-cell!
t 1 headcolumn
@ -367,40 +358,25 @@
(gnc:html-markup-h3 headline))))
)
(if (and logopixmap
(not (string=? logopixmap "")))
;; check for logo image file name non blank
;; only setup an image if we specified one
(if (and logopixmap (> (string-length logopixmap) 0))
(gnc:html-table-set-cell!
t 0 0
(gnc:make-html-text
(gnc:html-markup-img (make-file-url logopixmap)))) )
(gnc:html-markup-img (make-file-url logopixmap)))))
(if (and headpixmap
(not (string=? headpixmap "")))
;; check for header image file name nonblank
(begin
(gnc:html-table-set-cell!
t 0 headcolumn
(gnc:make-html-text
;; XX: isn't there some way to apply the alignment to
;; (gnc:html-markup-img headpixmap)?
(string-append
"<div align=\"" align "\">"
"<img src=\"" (make-file-url headpixmap) "\">"
"</div>")))
)
(gnc:html-table-set-cell!
t 0 headcolumn
(gnc:make-html-text "&nbsp;")))
(if (and headpixmap (> (string-length headpixmap) 0))
(let* ((div (gnc:html-markup-img (make-file-url headpixmap)))
(cell (gnc:make-html-table-cell (gnc:make-html-text div))))
(gnc:html-table-cell-set-style! cell "td" 'attribute `("align" ,align))
(gnc:html-table-set-cell! t 0 headcolumn cell))
(gnc:html-table-set-cell! t 0 headcolumn (gnc:make-html-text " ")))
(apply
gnc:html-table-set-cell!
t 2 headcolumn
(gnc:html-document-objects doc))
(gnc:html-document-add-object! ssdoc t))
(gnc:html-document-add-object! ssdoc
(gnc:make-html-text "</center>")) ;;TODO: make this a div instead of <center> (deprecated)
ssdoc))
(gnc:define-html-style-sheet

85
gnucash/report/stylesheets/footer.scm
View File

@ -201,38 +201,30 @@
(lambda (section name)
(gnc:color-option->html
(gnc:lookup-option options section name))))
(preparer (opt-val (N_ "General") (N_ "Preparer")))
(prepared-for (opt-val (N_ "General") (N_ "Prepared for")))
(show-preparer? (opt-val (N_ "General") (N_ "Show preparer info")))
(links? (opt-val (N_ "General") (N_ "Enable Links")))
(footer-text (opt-val (N_ "General") (N_ "Footer")))
(bgcolor (color-val (N_ "Colors") (N_ "Background Color")))
(textcolor (color-val (N_ "Colors") (N_ "Text Color")))
(linkcolor (color-val (N_ "Colors") (N_ "Link Color")))
(normal-row-color (color-val (N_ "Colors") (N_ "Table Cell Color")))
(alternate-row-color (color-val (N_ "Colors")
(N_ "Alternate Table Cell Color")))
(preparer (opt-val "General" "Preparer"))
(prepared-for (opt-val "General" "Prepared for"))
(show-preparer? (opt-val "General" "Show preparer info"))
(links? (opt-val "General" "Enable Links"))
(footer-text (opt-val "General" "Footer"))
(bgcolor (color-val "Colors" "Background Color"))
(textcolor (color-val "Colors" "Text Color"))
(linkcolor (color-val "Colors" "Link Color"))
(normal-row-color (color-val "Colors" "Table Cell Color"))
(alternate-row-color (color-val "Colors" "Alternate Table Cell Color"))
(primary-subheading-color
(color-val (N_ "Colors")
(N_ "Subheading/Subtotal Cell Color")))
(color-val "Colors" "Subheading/Subtotal Cell Color"))
(secondary-subheading-color
(color-val (N_ "Colors")
(N_ "Sub-subheading/total Cell Color")))
(grand-total-color (color-val (N_ "Colors")
(N_ "Grand Total Cell Color")))
(bgpixmap (opt-val (N_ "Images") (N_ "Background Tile")))
(headpixmap (opt-val (N_ "Images") (N_ "Heading Banner")))
(logopixmap (opt-val (N_ "Images") (N_ "Logo")))
(align (gnc:value->string(opt-val (N_ "Images") (N_ "Heading Alignment"))))
(spacing (opt-val (N_ "Tables") (N_ "Table cell spacing")))
(padding (opt-val (N_ "Tables") (N_ "Table cell padding")))
(border (opt-val (N_ "Tables") (N_ "Table border width")))
(color-val "Colors" "Sub-subheading/total Cell Color"))
(grand-total-color (color-val "Colors" "Grand Total Cell Color"))
(bgpixmap (opt-val "Images" "Background Tile"))
(headpixmap (opt-val "Images" "Heading Banner"))
(logopixmap (opt-val "Images" "Logo"))
(align (gnc:value->string (opt-val "Images" "Heading Alignment")))
(spacing (opt-val "Tables" "Table cell spacing"))
(padding (opt-val "Tables" "Table cell padding"))
(border (opt-val "Tables" "Table border width"))
(headcolumn 0))
;; center the document without elements inheriting anything
(gnc:html-document-add-object! ssdoc
(gnc:make-html-text "<center>"))
(gnc:html-document-set-style!
ssdoc "body"
'attribute (list "bgcolor" bgcolor)
@ -341,7 +333,8 @@
;; don't surround marked-up links with <a> </a>
(if (not links?)
(gnc:html-document-set-style! ssdoc "a" 'tag ""))
(gnc:html-document-set-style!
ssdoc "a" 'tag ""))
(add-css-information-to-doc options ssdoc doc)
@ -351,6 +344,7 @@
(gnc:html-table-set-style!
t "table"
'attribute (list "border" 0)
'attribute (list "style" "margin-left:auto; margin-right:auto")
'inheritable? #f)
;; set the header column to be the 2nd when we have a logo
@ -359,9 +353,8 @@
(if (and logopixmap (> (string-length logopixmap) 0))
(set! headcolumn 1))
(let* ((title (gnc:html-document-title doc))
(doc-headline (gnc:html-document-headline doc))
(headline (if (eq? doc-headline #f) title doc-headline)))
(let* ((headline (or (gnc:html-document-headline doc)
(gnc:html-document-title doc))))
(gnc:html-table-set-cell!
t 1 headcolumn
@ -387,25 +380,17 @@
;; only setup an image if we specified one
(if (and logopixmap (> (string-length logopixmap) 0))
(begin
(gnc:html-table-set-cell!
t 0 0
(gnc:make-html-text
(gnc:html-markup-img (make-file-url logopixmap))))))
(gnc:html-table-set-cell!
t 0 0
(gnc:make-html-text
(gnc:html-markup-img (make-file-url logopixmap)))))
(if (and headpixmap (> (string-length headpixmap) 0))
(begin
(gnc:html-table-set-cell!
t 0 headcolumn
(gnc:make-html-text
(string-append
"<div align=\"" align "\">"
"<img src=\"" (make-file-url headpixmap) "\">"
"</div>")))
)
(gnc:html-table-set-cell!
t 0 headcolumn
(gnc:make-html-text "&nbsp;")))
(let* ((div (gnc:html-markup-img (make-file-url headpixmap)))
(cell (gnc:make-html-table-cell (gnc:make-html-text div))))
(gnc:html-table-cell-set-style! cell "td" 'attribute `("align" ,align))
(gnc:html-table-set-cell! t 0 headcolumn cell))
(gnc:html-table-set-cell! t 0 headcolumn (gnc:make-html-text " ")))
(apply
gnc:html-table-set-cell!
@ -417,8 +402,6 @@
(gnc:html-table-set-cell!
t 3 headcolumn
(gnc:make-html-text footer-text)))
(gnc:html-document-add-object! ssdoc (gnc:make-html-text "</center>"))
;;TODO: make this a div instead of <center> (deprecated)
ssdoc))
(gnc:define-html-style-sheet

209
gnucash/report/stylesheets/head-or-tail.scm
View File

@ -257,47 +257,40 @@
(lambda (section name)
(gnc:color-option->html
(gnc:lookup-option options section name))))
(preparer (opt-val (N_ "General") (N_ "Preparer")))
(prepared-for (opt-val (N_ "General") (N_ "Prepared for")))
(show-preparer? (opt-val (N_ "General") (N_ "Show preparer info")))
(show-receiver? (opt-val (N_ "General") (N_ "Show receiver info")))
(show-date? (opt-val (N_ "General") (N_ "Show date")))
(show-time? (opt-val (N_ "General") (N_ "Show time in addition to date")))
(show-gnucash-version? (opt-val (N_ "General") (N_ "Show GnuCash Version")))
(show-preparer-at-bottom? (opt-val (N_ "General") (N_ "Show preparer info at bottom")))
(show-receiver-at-bottom? (opt-val (N_ "General") (N_ "Show receiver info at bottom")))
(show-date-time-at-bottom? (opt-val (N_ "General") (N_ "Show date/time at bottom")))
(show-comments-at-bottom? (opt-val (N_ "General") (N_ "Show comments at bottom")))
(show-gnucash-version-at-bottom? (opt-val (N_ "General") (N_ "Show GnuCash version at bottom")))
(links? (opt-val (N_ "General") (N_ "Enable Links")))
(additional-comments (opt-val (N_ "General") (N_ "Additional Comments")))
(bgcolor (color-val (N_ "Colors") (N_ "Background Color")))
(textcolor (color-val (N_ "Colors") (N_ "Text Color")))
(linkcolor (color-val (N_ "Colors") (N_ "Link Color")))
(normal-row-color (color-val (N_ "Colors") (N_ "Table Cell Color")))
(alternate-row-color (color-val (N_ "Colors")
(N_ "Alternate Table Cell Color")))
(preparer (opt-val "General" "Preparer"))
(prepared-for (opt-val "General" "Prepared for"))
(show-preparer? (opt-val "General" "Show preparer info"))
(show-receiver? (opt-val "General" "Show receiver info"))
(show-date? (opt-val "General" "Show date"))
(show-time? (opt-val "General" "Show time in addition to date"))
(show-gnucash-version? (opt-val "General" "Show GnuCash Version"))
(show-preparer-at-bottom? (opt-val "General" "Show preparer info at bottom"))
(show-receiver-at-bottom? (opt-val "General" "Show receiver info at bottom"))
(show-date-time-at-bottom? (opt-val "General" "Show date/time at bottom"))
(show-comments-at-bottom? (opt-val "General" "Show comments at bottom"))
(show-gnucash-version-at-bottom?
(opt-val "General" "Show GnuCash version at bottom"))
(links? (opt-val "General" "Enable Links"))
(additional-comments (opt-val "General" "Additional Comments"))
(bgcolor (color-val "Colors" "Background Color"))
(textcolor (color-val "Colors" "Text Color"))
(linkcolor (color-val "Colors" "Link Color"))
(normal-row-color (color-val "Colors" "Table Cell Color"))
(alternate-row-color (color-val "Colors" "Alternate Table Cell Color"))
(primary-subheading-color
(color-val (N_ "Colors")
(N_ "Subheading/Subtotal Cell Color")))
(color-val "Colors" "Subheading/Subtotal Cell Color"))
(secondary-subheading-color
(color-val (N_ "Colors")
(N_ "Sub-subheading/total Cell Color")))
(grand-total-color (color-val (N_ "Colors")
(N_ "Grand Total Cell Color")))
(bgpixmap (opt-val (N_ "Images") (N_ "Background Tile")))
(headpixmap (opt-val (N_ "Images") (N_ "Heading Banner")))
(logopixmap (opt-val (N_ "Images") (N_ "Logo")))
(align (gnc:value->string(opt-val (N_ "Images") (N_ "Heading Alignment"))))
(spacing (opt-val (N_ "Tables") (N_ "Table cell spacing")))
(padding (opt-val (N_ "Tables") (N_ "Table cell padding")))
(border (opt-val (N_ "Tables") (N_ "Table border width")))
(color-val "Colors" "Sub-subheading/total Cell Color"))
(grand-total-color (color-val "Colors" "Grand Total Cell Color"))
(bgpixmap (opt-val "Images" "Background Tile"))
(headpixmap (opt-val "Images" "Heading Banner"))
(logopixmap (opt-val "Images" "Logo"))
(align (gnc:value->string (opt-val "Images" "Heading Alignment")))
(spacing (opt-val "Tables" "Table cell spacing"))
(padding (opt-val "Tables" "Table cell padding"))
(border (opt-val "Tables" "Table border width"))
(headcolumn 0))
;; center the document without elements inheriting anything
(gnc:html-document-add-object! ssdoc
(gnc:make-html-text "<center>"))
(gnc:html-document-set-style!
ssdoc "body"
'attribute (list "bgcolor" bgcolor)
@ -416,6 +409,7 @@
(gnc:html-table-set-style!
t "table"
'attribute (list "border" 0)
'attribute (list "style" "margin-left:auto; margin-right:auto")
'inheritable? #f)
;; set the header column to be the 2nd when we have a logo
@ -424,9 +418,8 @@
(if (and logopixmap (> (string-length logopixmap) 0))
(set! headcolumn 1))
(let* ((title (gnc:html-document-title doc))
(doc-headline (gnc:html-document-headline doc))
(headline (if (eq? doc-headline #f) title doc-headline)))
(let* ((headline (or (gnc:html-document-headline doc)
(gnc:html-document-title doc))))
(gnc:html-table-set-cell!
t 1 headcolumn
@ -438,23 +431,17 @@
(gnc:make-html-text
(gnc:html-markup-i
(_ "Prepared by: ")
(gnc:html-markup-b preparer)
)
(gnc:html-markup-br)
)
" "
)
(gnc:html-markup-b preparer))
(gnc:html-markup-br))
" ")
(if (and show-receiver? (not show-receiver-at-bottom?))
;; print receiver info as additional header info
(gnc:make-html-text
(gnc:html-markup-i
(_ "Prepared for: ")
(gnc:html-markup-b prepared-for)
(gnc:html-markup-br)
)
)
" "
)
(gnc:html-markup-br)))
" ")
(if (and show-date? (not show-date-time-at-bottom?))
;; print date/time info as additional header info
(if show-time?
@ -463,55 +450,39 @@
(_ "Report Creation Date: ")
(qof-print-date (gnc:get-today))
" "
(gnc-print-time64 (current-time) "%X %Z")
)
(gnc:html-markup-br)
)
(gnc-print-time64 (current-time) "%X %Z"))
(gnc:html-markup-br))
(gnc:make-html-text
(gnc:html-markup-i
(_ "Report Creation Date: ")
(qof-print-date (gnc:get-today))
)
(gnc:html-markup-br)
)
)
" "
)
(qof-print-date (gnc:get-today)))
(gnc:html-markup-br)))
" ")
(if (and show-gnucash-version? (not show-gnucash-version-at-bottom?))
;; print the GnuCash version string as additional header info
(gnc:make-html-text
(gnc:html-markup-i
"GnuCash "
gnc:version
)
(gnc:html-markup-br)
)
" "
)
gnc:version)
(gnc:html-markup-br))
" ")
(if (not show-comments-at-bottom?)
;; print additional comments as additional header info
(gnc:make-html-text
(gnc:html-markup-br)
(gnc:html-markup-i additional-comments)
(gnc:html-markup-br)
)
" "
)
(gnc:html-markup-br))
" ")
;; add separator line if any additional header info is printed
(if (or
(and show-preparer? (not show-preparer-at-bottom?))
(and show-receiver? (not show-receiver-at-bottom?))
(and show-date? (not show-date-time-at-bottom?))
(and show-gnucash-version? (not show-gnucash-version-at-bottom?))
(not show-comments-at-bottom?)
)
(not show-comments-at-bottom?))
(gnc:make-html-text
(gnc:html-markup-br)
)
" "
)
)
)
(gnc:html-markup-br))
" ")))
;; only setup an image if we specified one
(if (and logopixmap (> (string-length logopixmap) 0))
@ -522,18 +493,11 @@
(gnc:html-markup-img (make-file-url logopixmap))))))
(if (and headpixmap (> (string-length headpixmap) 0))
(begin
(gnc:html-table-set-cell!
t 0 headcolumn
(gnc:make-html-text
(string-append
"<div align=\"" align "\">"
"<img src=\"" (make-file-url headpixmap) "\">"
"</div>")))
)
(gnc:html-table-set-cell!
t 0 headcolumn
(gnc:make-html-text "&nbsp;")))
(let* ((div (gnc:html-markup-img (make-file-url headpixmap)))
(cell (gnc:make-html-table-cell (gnc:make-html-text div))))
(gnc:html-table-cell-set-style! cell "td" 'attribute `("align" ,align))
(gnc:html-table-set-cell! t 0 headcolumn cell))
(gnc:html-table-set-cell! t 0 headcolumn (gnc:make-html-text " ")))
(apply
gnc:html-table-set-cell!
@ -550,36 +514,28 @@
(and show-preparer? show-preparer-at-bottom?)
(and show-receiver? show-receiver-at-bottom?)
(and show-date? show-date-time-at-bottom?)
(and show-gnucash-version? show-gnucash-version-at-bottom?)
show-comments-at-bottom?
)
(and show-gnucash-version?
show-gnucash-version-at-bottom?)
show-comments-at-bottom?)
(gnc:make-html-text
(gnc:html-markup-br)
)
" "
)
(gnc:html-markup-br))
" ")
(if (and show-preparer? show-preparer-at-bottom?)
;; print preparer info as additional header info
(gnc:make-html-text
(gnc:html-markup-i
(_ "Prepared by: ")
(gnc:html-markup-b preparer)
)
(gnc:html-markup-br)
)
" "
)
(gnc:html-markup-b preparer))
(gnc:html-markup-br))
" ")
(if (and show-receiver? show-receiver-at-bottom?)
;; print receiver info as additional header info
(gnc:make-html-text
(gnc:html-markup-i
(_ "Prepared for: ")
(gnc:html-markup-b prepared-for)
)
(gnc:html-markup-br)
)
" "
)
(gnc:html-markup-b prepared-for))
(gnc:html-markup-br))
" ")
(if (and show-date? show-date-time-at-bottom?)
;; print date/time info as additional header info
(if show-time?
@ -588,42 +544,29 @@
(_ "Report Creation Date: ")
(qof-print-date (gnc:get-today))
" "
(gnc-print-time64 (current-time) "%X %Z")
)
(gnc:html-markup-br)
)
(gnc-print-time64 (current-time) "%X %Z"))
(gnc:html-markup-br))
(gnc:make-html-text
(gnc:html-markup-i
(_ "Report Creation Date: ")
(qof-print-date (gnc:get-today))
(gnc:html-markup-br)
)
)
)
" "
)
(gnc:html-markup-br))))
" ")
(if (and show-gnucash-version? show-gnucash-version-at-bottom?)
;; print the GnuCash version string as additional header info
(gnc:make-html-text
(gnc:html-markup-i
(_ "GnuCash ")
gnc:version
)
(gnc:html-markup-br)
)
" "
)
gnc:version)
(gnc:html-markup-br))
" ")
(if show-comments-at-bottom?
;; print additional comments as additional header info
(gnc:make-html-text
(gnc:html-markup-br)
(gnc:html-markup-i additional-comments)
(gnc:html-markup-br)
)
" "
)
))
(gnc:html-document-add-object! ssdoc (gnc:make-html-text "</center>")) ;;TODO: make this a div instead of <center> (deprecated)
(gnc:html-markup-br))
" ")))
ssdoc))
(gnc:define-html-style-sheet

2
libgnucash/engine/Recurrence.c
View File

@ -419,7 +419,7 @@ recurrenceGetAccountPeriodValue(const Recurrence *r, Account *acc, guint n)
g_return_val_if_fail(r && acc, gnc_numeric_zero());
t1 = recurrenceGetPeriodTime(r, n, FALSE);
t2 = recurrenceGetPeriodTime(r, n, TRUE);
return xaccAccountGetBalanceChangeForPeriod (acc, t1, t2, TRUE);
return xaccAccountGetNoclosingBalanceChangeForPeriod (acc, t1, t2, TRUE);
}
void

3
libgnucash/engine/Recurrence.h
View File

@ -140,7 +140,8 @@ time64 recurrenceGetPeriodTime(const Recurrence *r, guint n, gboolean end);
/**
* @return the amount that an Account's value changed between the beginning
* and end of the nth instance of the Recurrence.
* and end of the nth instance of the Recurrence. Please note this function
* is only used in budget reports and will exclude closing entries.
**/
gnc_numeric recurrenceGetAccountPeriodValue(const Recurrence *r,
Account *acct, guint n);

4
libgnucash/engine/gnc-budget.h
View File

@ -147,8 +147,12 @@ void gnc_budget_unset_account_period_value(
gboolean gnc_budget_is_account_period_value_set(
const GncBudget *budget, const Account *account, guint period_num);
/* get the budget account period's budgeted value */
gnc_numeric gnc_budget_get_account_period_value(
const GncBudget *budget, const Account *account, guint period_num);
/* get the budget account period's actual value, including children,
excluding closing entries */
gnc_numeric gnc_budget_get_account_period_actual_value(
const GncBudget *budget, Account *account, guint period_num);

5
libgnucash/engine/test/test-engine-extras.scm
View File

@ -839,6 +839,7 @@
(budget (gnc-budget-new book))
(bank (cdr (assoc "Bank" account-alist)))
(income (cdr (assoc "Income" account-alist)))
(equity (cdr (assoc "Equity" account-alist)))
(expense (cdr (assoc "Expenses" account-alist))))
(gnc-budget-set-name budget "test budget")
(gnc-budget-begin-edit budget)
@ -861,7 +862,9 @@
(env-create-transaction env (midperiod 2) bank income 67)
(env-create-transaction env (midperiod 3) bank income 77)
(env-create-transaction env (midperiod 0) expense bank 20)
(env-create-transaction env (midperiod 1) expense bank 20))
(env-create-transaction env (midperiod 1) expense bank 20)
(let ((clos (env-create-transaction env (midperiod 1) income equity 55)))
(xaccTransSetIsClosingTxn clos #t)))
(gnc-budget-set-account-period-note budget income 0 "income-0 -$60")
(gnc-budget-set-account-period-note budget expense 1 "expense-1 $25")
budget))

2
po/POTFILES.in
View File

@ -476,6 +476,8 @@ gnucash/report/reports/standard/income-statement.scm
gnucash/report/reports/standard/invoice.scm
gnucash/report/reports/standard/job-report.scm
gnucash/report/reports/standard/net-charts.scm
gnucash/report/reports/standard/new-aging.scm
gnucash/report/reports/standard/new-owner-report.scm
gnucash/report/reports/standard/owner-report.scm
gnucash/report/reports/standard/payables.scm
gnucash/report/reports/standard/portfolio.scm