Sunday, January 22, 2017

ES2015 (modern JavaScript) Implementation of Delphi's TList VCL Class with Multi-Field Sort Algorigthm and more

ES2015 Source Code: Class — JavaScript implementation of Delphi VCL TList Class including flexible multi-property List-Sort algorithm and more

Just for fun, I created this ECMAScript 2015 (i.e., ES2015 or modern object-oriented JavaScript) version of a Borland / Embarcadero Delphi TList VCL Class equivalent (or, at least partial equivalent) to demonstrate one approach to Object Oriented Programming (OOP) in JavaScript, and I call the class "DList". I originally implemented this years ago in straight JavaScript, and have updated it to take advantage of ES2015 syntax and encapsulation. I have implemented some of the core TList methods like Add(), Insert(), InsertRange(), Delete(), IndexOf(), Delete, and Sort() in hopes of demonstrating the power and speed of JavaScript.  This DList class wraps up the native JS array object and adds some nice extra functionality.

My DList JS/ES Class also implements my proprietary multi-column / multi-property sort algorithm that is very adaptable and flexible and should be easy to understand (see comments in source code) where I use a powers-of-two column-precedence algorithm within the sort-comparison closure callback method (in particular, see the Sorter: function(a, b) {} closure code in the source comments).

When I first wrote the original JS code, ES2015 Classes were not even an agreed standard, so I was quite excited to move on to the much simpler and much better real object oriented web-development language and framework: Google's Dart programming language. And, even though this JS/ES class makes life in JavaScript easier, simply put, Google Dart makes this type of functionality ultra-simple since their core API / framework / library includes a rich set of List / Collections classes. But, just in case you want to stick with JavaScript / ECMAScript, this should be an interesting example for you.

Live Example

In addition to the DList Object-List Class source-code, I also included the source-code I use for running various tests to confirm sorting and list-object(s) manipulation.  Just call the test routine in your HTML body tag by including: onload="DListTest();"

And, to make demonstrating this easier, I have included an embedded JSFiddle (see below my source code).  This Fiddle (link to full fiddle) ES / JavaScript TList Class (Delphi-like) Example also shows it in action. Presuming you are a developer, you will find it very easy to examine the page-source code and see the ECMAScript / JavaScript programming (.js files) used by the example and so forth.

NOTE: you definitely need a modern browser (e.g., Chrome or FireFox) with ES2015 Class support. Either one has rather fantastic built in developer tools for stepping, tracing, object-interrogation, and other features you may also want for seeing how this all works.


ECMAScript ES2015 Source Code

/********************************************************************************
This source code is Copyright (c) 2017
     Author: Mike Eberhart

I hereby release this code under the terms of the MIT License (for freeware).

Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:

The above copyright notice and this permission notice shall be included in
all copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
THE SOFTWARE.
********************************************************************************/
'use strict';

/*
███████████████████████████████████████████████████████████████████████████████████████████
DList Class

NOTE: this code uses the modern syntactic-sugar of ECMAScript 2015 CLASSES, and thus
requires a modern browser which supports their usage (e.g., Chrome, Firefox)

DESCRIPTION
This Class defines a List designed to hold objects of any type.
For proper encapsulation, the ONLY outside access to the internally maintained list is
through the Items[] array property (read only).

▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪
PROPERTIES

PROPERTIES
- Items[] ............ an Array of any objects you wish to store in a List.
  Because it is an Array, all methods available to arrays can be used in
  addition to the custom DList methods defined herein; though, not all Array
  methods/properties will make sense depending on what you store in the List.
- Count .............. the number of elements in the list.
- InstanceName ....... String value assigned during constructor; nice for debugging

TODO (PERHAPS):
- EnforceUnique (true/false)... in case non-unique list requirements exist
- MaxListElements (int)........ if this becomes an issue
- Sorted (true/false).......... maintain list as sorted at all times?
  And, binary-search (IndexOf) if sorted and unique)

▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪
METHODS
Add(item) ............ Add one item to list (by reference) and return index to that item
AddRange(arrayObj) ... Add list of Items at end of list
Clear() .............. Completely empty the list; i.e., Count = 0; Items=[]
Delete(index) ........ Remove item at [index] position
Equals(a,b) .......... [CLOSURE, via parm @ create] : Compare two objects
                       and return true (=) or false (!=)
Insert(index, objToInsert) ... Insert item at specified [index]
IndexOf(item) ........ Find first position of item, if not found return -1
Sort() ............... Sorts Items array based on array object's property
                       value(s) according to Sorter() method logic.
Sorter(a,b) .......... [CLOSURE, via parm  @ create] : used by Sort() method
                       to determine sort-order of Items.  See DETAILS below.
Update(index, objNew)  Update the object at specified Index with new one.

TODO (PERHAPS): Move(), Exchange(), First(), Last(), Next(), Prev()

***********************
METHOD DETAILS / NOTES:
***********************
................................................................................
Equals() method
List creator can implement, via constructor parameter, a closure for this.
See example code.
This method is used to determine whether two objects in our Items array
are to be considered as Equals for the purposes of IndexOf() operations, which
can be used for:
 1) enforcing a UNIQUE CONSTRAINT on array contents;
 2) locating an array item to Delete;
 3) locate a position in the array for an Insert.

NOTE: Equals() is NOT for testing true array-element-objects equivalence.

................................................................................
Sorter() method, used by Sort()
List creator can implement, via constructor parameter, a closure for this, which
the Sort() method will call internally.  The Sorter method must compare two
Item-array objects (let's call them "a" and "b") and return a value that
is either:
 Zero: indicating "a" and "b" are considered equal and no sorting required
       for these two objects (i.e., their order relative to each other in
       the Items array is already as we desire, since they are the "same"
       for our sorting purposes).
  <0 : less than 0, indicating that we want to Sort object "a" into a lower
       Items-array position (index) than object "b"
  >0 : greater than 0, indicating the opposite of our less-than-zero condition.

................................................................................
Insertion and Deletion methods act on an Index value that is simply the Items
array's Index position at which to perform the operation.  If you wish to
Insert or Delete at a position determined by object-property value(s) stored
within the Items array, acquire the target-index first by calling the IndexOf()
method with object-search-criteria; the result of that call will be your index
for Insert/InsertRange or Delete.
  e.g., mylist.Delete(mylist.IndexOf({id:123, name:"number123"}));
▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪
EXAMPLES:

This is a how to create a new DList object and pass the Closures (functions)
for the Equals() and Sorter() methods the object should use.
--------------------------------------------------------------------------------
var mylist = new DList(
    'MyInstanceNameHere',

    //Equals() closure:
    //E.g., we may want to ensure uniqueness on the combination of two properties
    //present on each of our array Items, like id and lastname properties; if so,
    //our code is as follows (NOTE: REMEMBER CASE-SENSITIVITY ISSUES):
    function(a,b)
    {
        return (a.id == b.id && a.lastname == b.lastname);
    },

    //Sorter() closure:
    Sorter: function(a, b) {
        {
            //Example algorithm for sorting on multiple columns; adapts with ease!
            //Sort ascending by id, name
            //<variable> = <expression> ? <true clause=""> : <false clause="">
            //Use Powers-of-Two multiplier to set column-sort-order-precedence
            //IMPORTANT NOTE: HIGHER power of two implies higher precedence
            //
            //REMEMBER THIS TOO: JS array sort is CASE-SENSITIVE by default.
            //Use .toUpperCase() or such to level this, e.g. before our return-algorithm:

            return (
                    1 * ((a.id == b.id) ? 0 : (a.id < b.id) ? -1 : 1) +
                    2 * ((a.firstname == b.firstname) ? 0 : (a.firstname < b.firstname) ? -1 : 1) +
                    4 * ((a.lastname.toUpperCase() == b.lastname.toUpperCase()) ? 0
                        : (a.lastname.toUpperCase() < b.lastname.toUpperCase()) ? -1 : 1)
            )
        }
    }
);

███████████████████████████████████████████████████████████████████████████████████████████
*/
class DList {

    constructor(instancename = '[InstanceName not specified in List constructor]',
                //default closure for Sorter: default to no sort-ordering
                equals = function(a, b) {return 0},
                //default closure for Equals: default to no match
                sorter = function(a, b) {return 0}) {

        this._InstanceName = instancename;
        this.Sorter = sorter;
        this.Equals = equals;

        //create the array that will contain our list Items
        this._items = [];
    } //constructor


    //Read-only InstanceName property accessor (set during construction)
    get InstanceName() {
        return this._InstanceName;
    }

    //Provide read-only access to the internal items-array
    get Items() {
        return this._items;
    }

    //Read-only Count property
    get Count() {
        return this._items.length;
    }


    //Add single object reference to our list's Items[] array, and return its index position
    Add(objToAdd) {
        let newItemIndex = this._items.length;
        this._items[newItemIndex] = objToAdd;
        return newItemIndex;
    }

    //Use AddRange when merging an array of objects to our Items[].
    //This adds Items to the end of our list's Items[] array;
    //use Add() when adding only one item (more efficient).
    //AddRange is just an InsertRange at end-of-Items-array.
    AddRange(objArrayToAdd) {
        this.InsertRange(this._items.length, objArrayToAdd);
    }

    Clear() {
        this._items = [];
    }

    //TODO: Delete/DeleteRange with bad (i.e. -1 or non-existent) index must fail!
    //      Set to EOList?
    Delete(index) {
        this._items.splice(index, 1);
    }

    //Remove several entries at index (RemoveCount = how many to delete)
    DeleteRange(index, RemoveCount) {
        this._items.splice(index, RemoveCount);
    }

    IndexOf(obj) {
        let i = this._items.length;
        while (i--) {
            if (this.Equals(this._items[i], obj)) {
                return i;
            }
        }
        return -1;
    }

    Insert(index, objToInsert) {
        //make sure insertion-index is valid; TODO: real error check/range-warn.
        index = Math.max(0, Math.min(index, this._items.length));

        //splice obj into array at index, remove zero elements in the process.
        this._items.splice(index, 0, objToInsert);
    }

    //Insert an array of objects, at index position, into Items[]
    //Use Insert() method for single object insertion.
    InsertRange(index, objArrayToInsert) {
        //make sure insertion-index is valid; TODO: real error check/range-warn.
        index = Math.max(0, Math.min(index, this._items.length));

        let tmpArray1 = [];
        //get any portion of existing Items[] array before insertion point
        //Note: slice uses Zero-based begin/end indexes for extraction and extracts up to,
        //but NOT including end index value (i.e., stops at ending index -1).
        if (index > 0) {
            tmpArray1 = this._items.slice(0, index);
        }

        //add our new values at array insertion point
        tmpArray1 = tmpArray1.concat(objArrayToInsert);
        //use slice() to get portion after insertion point; join that with beginning + added
        this._items = tmpArray1.concat(this._items.slice(index, this._items.length));
    }

    //If sorting is desired, when creating a new() List, the creator must implement, via an
    //optional parameter, a closure which will be assigned to the method named "Sorter".
    Sort() {
        this._items.sort(this.Sorter);
    }

    //Place a new object into Items array where old object was.
    //Caller must pass valid index (TODO: test index)
    Update(index, objNew) {
        if ((this.IndexOf(objNew) == -1) || //OK if objNew's key-field-values are new (unique)
            (this.Equals(objNew, this._items[index])))   //OK to update same unique "key"
        {
            this._items[index] = objNew;
        } else {
            //TODO: REPLACE THIS with raise error if unique constraint will be broken on update...
            console.log(this.InstanceName + '.List.Update() violated unique constraint');
        }
    }

}  //DList



/*
███████████████████████████████████████████████████████████████████████████████████████████
Various test-conditions and web / browser-console logging routines...
███████████████████████████████████████████████████████████████████████████████████████████
*/
function DListTest(){

    const sSeparatorLine1 = '███████████████████████████████████████████████████████████████████████████████████████████';
    const sSeparatorLine2 = '■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■';
    const sSeparatorLine3 = '▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪';

    let traceDiv = document.getElementById('trace');

    function LogToScreen(stringToLog) {
        if (stringToLog == '<hr />') {
            console.log(sSeparatorLine1);
        } else {
            console.log(stringToLog);
        }

        if (typeof(stringToLog) == 'object') {
            traceDiv.innerHTML += '
[' + stringToLog.InstanceName + '] SEE CONSOLE FOR FULL OBJECT INSPECTION CAPABILITY; Inspect the Items (array) objects';
        } else {
            traceDiv.innerHTML += '
' + stringToLog;
        }
    }


    function LogItemsToScreen() {
        for (let i = 0; i < mylist.Count; i++) {
            LogToScreen('List Item[' + i + ']: ID=' + mylist.Items[i].id + ';    firstname=' + mylist.Items[i].firstname + ';    lastname=' + mylist.Items[i].lastname  );
        }
    }


    /*
    ■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■
    BEGIN: create instance of the DList Class and get these tests rolling...
    ■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■
    */
    let mylist = new DList(
        'mylist',

        //Equals() closure:
        // E.g., we may want to ensure uniqueness on the combination of two properties
        // present on each of our array Items, like id and lastname properties; if so,
        // our code is as follows:
        function(a, b) {
            return (a.id == b.id && a.lastname == b.lastname);
        },

        //Sorter() closure:
        function(a, b) {
            {
                //Example algorithm for sorting on multiple columns; adapts with ease!
                //Sort ascending by id, name
                //<variable> = <expression> ? <true clause=""> : <false clause="">
                //Use Powers-of-Two multiplier to set column-sort-order-precedence
                //IMPORTANT NOTE: HIGHER power of two implies higher precedence
                //REMEMBER THIS TOO: JS array sort is CASE-SENSITIVE by default.
                //  Use .toUpperCase() or such to level this, e.g. we make lastname case-insensitive:
                return (
                        1 * ((a.id == b.id) ? 0 : (a.id < b.id) ? -1 : 1) +
                        2 * ((a.firstname == b.firstname) ? 0 : (a.firstname < b.firstname) ? -1 : 1) +
                        4 * ((a.lastname.toUpperCase() == b.lastname.toUpperCase()) ? 0 : (a.lastname.toUpperCase() < b.lastname.toUpperCase()) ? -1 : 1)
                )
            }
        }
    );

//------------------------------------------------------------------------------
    mylist.Add({id:4, firstname:'first-4', lastname:'last-4'});
    mylist.Add({id:5, firstname:'first-5', lastname:'last-5'});
    mylist.Add({id:13, firstname:'first-2', lastname:'last-1'});
    mylist.Add({id:1, firstname:'first-2', lastname:'last-1'});
    mylist.Add({id:1, firstname:'first-1', lastname:'last-1'});
    mylist.Add({id:2, firstname:'FIRST-2', lastname:'last-2'});
    mylist.Add({id:3, firstname:'first-3', lastname:'last-3'});

    //List was build unsorted, now SORT it (on last, first, id) USING CLOSURE provided in constructor
    //The items will then be ordered as: id:1-5, firstname:"first-1...first-5", lastname:"last-1...last-5"
    mylist.Sort();


    //Create another list loaded from mylist (so each console.log object-ref remains valid),
    //otherwise, if we just log "mylist" over and over, in the end, all logged mylist refs will
    //point to the final state (vs. each stepped-state of these tests)
    let mylistInitialLoad = new DList('mylistInitialLoad');
    mylistInitialLoad.AddRange(mylist.Items);

    LogToScreen('Sorted (by lastname, firstname, id) initial 5-item list "mylistInitialLoad" follows:');
    LogToScreen('Count: ' + mylistInitialLoad.Count);
    LogToScreen('Items.length: ' + mylistInitialLoad.Items.length);
    LogToScreen(mylistInitialLoad);
    LogItemsToScreen();
    LogToScreen('<hr />');


//------------------------------------------------------------------------------
    mylist.Add({id:1, firstname:'dup-id-1', lastname:'dup-id-1'});
    mylist.Add({id:2, firstname:'dup-id-2', lastname:'dup-id-2'});
    mylist.Add({id:3, firstname:'dup-id-3', lastname:'dup-id-3'});

    let mylistAdds = new DList('mylistAdds2');
    mylistAdds.AddRange(mylist.Items);

    LogToScreen('Sorted List with 3 items added (duplicate id values for id 1-3) to initial sorted 5-item list;
' +
        'List not re-sorted after additions; "mylistAdds" follows:');
    LogToScreen('Count: ' + mylistAdds.Count);
    LogToScreen(mylistAdds);
    LogItemsToScreen();
    LogToScreen('<hr />');


//------------------------------------------------------------------------------
    mylist.Sort();

    let mylistSorted2 = new DList('mylistSorted2');
    mylistSorted2.AddRange(mylist.Items);


    LogToScreen('Same 8-item list, but RE-SORTED NOW (by lastname, firstname, id)... new instance dump follows;');
    LogToScreen(mylistSorted2);
    LogItemsToScreen();
    LogToScreen('<hr />');

//------------------------------------------------------------------------------
    mylist.Insert(mylist.IndexOf({id:1, firstname:'dup-id-1', lastname:'dup-id-1'}),
    {id:111, firstname:'insert-before-id-1, dup-id-1', lastname:'inserted'});

    let mylistAfterIns1 = new DList('mylistAfterIns1');
    mylistAfterIns1.AddRange(mylist.Items);

    LogToScreen('Insertion test (1 row, before dup-id-1)...;
' +
        'List not re-sorted after inserts; "mylistAfterIns1" follows:');
    LogToScreen('Count: ' + mylistAfterIns1.Count);
    LogToScreen(mylistAfterIns1);
    LogItemsToScreen();
    LogToScreen('<hr />');

//------------------------------------------------------------------------------
    mylist.Delete(mylist.IndexOf({id:4, firstname:'first-4', lastname:'last-4'}));

    let mylistAfterDel1 = new DList('mylistAfterDel1');
    mylistAfterDel1.AddRange(mylist.Items);

    LogToScreen('Deletion test (id:4 removed)...;
' +
        'List not re-sorted after delete; "mylistAfterDel1" follows:');
    LogToScreen('Count: ' + mylistAfterDel1.Count);
    LogToScreen(mylistAfterDel1);
    LogItemsToScreen();
    LogToScreen('<hr />');

//------------------------------------------------------------------------------
    //attempt to insert into invalid position
    mylist.Insert(999, {id:999, firstname:'WayOutFirst', lastname:'WayOutLast'});

    let mylistAfterBogusInsPos = new DList('mylistAfterBogusInsPos');
    mylistAfterBogusInsPos.AddRange(mylist.Items);

    LogToScreen('Attempt to INSERT OUTSIDE Items[] Bounds (id:999)... should simply place new item at end of list;
' +
        '"mylistAfterBogusInsPos" follows:');
    LogToScreen('Count: ' + mylistAfterBogusInsPos.Count);
    LogToScreen(mylistAfterBogusInsPos);
    LogItemsToScreen();
    LogToScreen('<hr />');

//------------------------------------------------------------------------------
    mylist.Sort();
    LogToScreen('RE-SORTED our list (by lastname, firstname, id)...');
    LogItemsToScreen();
    LogToScreen('<hr />');

//------------------------------------------------------------------------------
    //attempt to update a value in the Items array with new object
    mylist.Update(mylist.IndexOf({id:2, firstname:'dup-id-2', lastname:'dup-id-2'}),
    {id:222, firstname:'updated-id-2(first)', lastname:'updated-id-2(last)'});

    let mylistAfterUpdate1 = new DList('mylistAfterUpdate1');
    mylistAfterUpdate1.AddRange(mylist.Items);

    LogToScreen('List should now have dup-id-2 values changed...
' +
        '"mylistAfterUpdate1" follows:');
    LogToScreen('Count: ' + mylistAfterUpdate1.Count);
    LogToScreen(mylistAfterUpdate1);
    LogItemsToScreen();
    LogToScreen('<hr />');

//------------------------------------------------------------------------------
    //attempt update with SAME object (same, per Equals CLOSURE, which is: same id/last-name)
    mylist.Update(mylist.IndexOf({id:222, firstname:'updated-id-2(first)', lastname:'updated-id-2(last)'}),
    {id:222, firstname:'updated-id-2(first-fixed)', lastname:'updated-id-2(last)'});

    let mylistAfterUpdate2 = new DList('mylistAfterUpdate2');
    mylistAfterUpdate2.AddRange(mylist.Items);

    LogToScreen('List should now have id=222 values changed again...
' +
        '"mylistAfterUpdate2" follows:');
    LogToScreen('Count: ' + mylistAfterUpdate2.Count);
    LogToScreen(mylistAfterUpdate2);
    LogItemsToScreen();
    LogToScreen('<hr />');

//------------------------------------------------------------------------------
    LogToScreen('UNIQUE CONSTRAINT VIOLATION ERROR should follow in Console:');
    //attempt update with and violate our UNIQUE Constraint (Equals)
    mylist.Update(mylist.IndexOf({id:222, firstname:'updated-id-2(first-fixed)', lastname:'updated-id-2(last)'}),
    {id:1, firstname:'first-1', lastname:'last-1'});
    LogToScreen('<hr />');

//------------------------------------------------------------------------------
    let traceDiv2 = document.getElementById('trace2');

    let myObjList = new DList(
        'myObjectList',

        function(a, b) {
            return (a.id == b.id );
        }
    );


//------------------------------------------------------------------------------
// Test storing some references to external objects now...

    let ElementRef1 = document.getElementById('trace-mod-1');
    myObjList.Add({id:1, ElementName:'testdiv1', Element: ElementRef1, toString : function() {
        return ('toString() closure fired: ' + this.id + ', ' + this.ElementName );
    }});

    let ElementRef2 = document.getElementById('trace-mod-2');
    myObjList.Add({id:2, ElementName:'testdiv2', Element: ElementRef2});
    let ElementRef3 = document.getElementById('trace-mod-3');
    myObjList.Add({id:3, ElementName:'testdiv3', Element: ElementRef3});

    myObjList.Items[myObjList.IndexOf({id:1})].Element.innerHTML =
        'testdiv1 : REPLACEMENT via CODE; div referenced via List.Element (stored reference); stored closure results: ' +
            myObjList.Items[myObjList.IndexOf({id:1})].toString();
    myObjList.Items[myObjList.IndexOf({id:2})].Element.innerHTML = 'testdiv2 : REPLACEMENT via CODE; div referenced via List.Element (stored reference)';
    myObjList.Items[myObjList.IndexOf({id:3})].Element.innerHTML = 'testdiv3 : REPLACEMENT via CODE; div referenced via List.Element (stored reference)';

} //end function DListTest



ES2015 DList Class embedded JSFiddle...





Continue to read this Software Development and Technology Blog for computer programming, software development, and technology Techniques, How-To's, Fixes, Reviews, and News — focused on Dart Language, SQL Server, Delphi, Nvidia CUDA, VMware, TypeScript, SVG, other technology tips and how-to's, and my varied political and economic opinions.

Delphi VCL TMemo Class-Helper: Calculate SelStart when WordWrap is enabled

DELPHI Source Code — Class Enhancement: VCL TMemo Class Helper : Calculate SelStart in Memos where WordWrap is True (adjusts for "soft carriage returns")

The Delphi VCL TMemo controls are very useful for multi-line text input, as they support embedded "hard" carriage-returns / line-feeds (CR / LF), but they also support "soft" carriage returns via the WordWrap = True property value. When Word-Wrap functionality is enabled, some tasks that should be simple become rather difficult, like inserting text (a string) into the Memo control's existing text and having that Text then show immediately as "selected" / highlighted using SelText related properties of SelStart and SelLength.

This Delphi TMemo Class-Helper adds a very handy function to the standard TMemo control that will make the task of highlighting (selecting) newly-inserted text simple, regardless of whether WordWrap is True (On) or False (Off). See the inline (in source code below) comments for more details about how this method works.

This has been tested with Delphi 2006 and 2010 and should work with any version of Delphi with the standard VCL TMemo control and the class helpers language feature. In absence of classhelpers, you can certainly still use this as a standalone function in earlier versions of Delphi (pre-Delphi 2005).

You may need to adjust the Uses clause(s), but hopefully all references to the units and/or functions you will need have been included. No matter what, the core algorithm for determining the proper SelStart within the TMemo should give you what you need to work with soft line feeds / carriage returns within a TMemo just like you would as if WordWrap was not enabled.

SQL-Server User Defined Function (UDF) Source Code

//********************************************************************************
//This source code is Copyright (c) 2007-2017
//     Author: Mike Eberhart
//
//I hereby release this code under the terms of the MIT License (for freeware).
//
//Permission is hereby granted, free of charge, to any person obtaining a copy
//of this software and associated documentation files (the "Software"), to deal
//in the Software without restriction, including without limitation the rights
//to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
//copies of the Software, and to permit persons to whom the Software is
//furnished to do so, subject to the following conditions:
//
//The above copyright notice and this permission notice shall be included in
//all copies or substantial portions of the Software.
//
//THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
//IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
//FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
//AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
//LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
//OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
//THE SOFTWARE.
//********************************************************************************
unit ClassHelpers_VCL_Example;

interface

uses
  Classes,
  StdCtrls;
  
  
type
  
  procedure LockWindowUpdateEx(Handle: HWnd; SleepTicks: LongWord; Retries: LongWord);

  {▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪
  Extend the Memo controls
  {▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪}
  TMemoHelper = class helper for TMemo
  public
    procedure SelectCharsEndingAtLineCol(const Row, Col : Integer; const NumCharsToSelect: Integer);
  end;

  
implementation

uses
  SysUtils,
  StrUtils;
  

{■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■
Procedure: SelectCharsEndingAtLineCol

Parms:
  Row, Col:   These are the Line, Column coordinates in the Memo where your
              Characters-to-Select END.

  NumCharsToSelect: obvious


Note:
  In a TMemo, Line and Col are 1-INDEXED variables, meaning Line = 1 when
  at top or memo, and Col = 1 when at leftmost side of memo.

  If WordWrap is True on the Memo, this procedure contains necessary algorithm
  to "detect" and adjust for any "Soft Carriage Returns" that WordWrap is
  injecting into the memo for visual display.

  If only SelStart was specified in Line, Col format like everything else in
  Memo-control coordinates, this custom-code would not be necessary.
  
Example of how this is useful:
  //Let us consider wanting to programmatically insert text into a memo control and
  //have that inserted-text instantly show as "selected" (seltext) upon its insertion.
  //We will Insert our text (at current cursor location or to replaced existing
  //selected text) via SelText; then, call this helper routine to "highlight" our
  //newly inserted text.
  //See the source-code comments for how we ultimately determine and set the new
  //values for SelStart and SelLength to accomplish our goal.
  
  SelText := OurTextToInsertIntoMemoContents;
  SelectCharsEndingAtLineCol(self.Line, self.Column, Length(OurTextToInsertIntoMemoContents));
{■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■}
procedure TMemoHelper.SelectCharsEndingAtLineCol(const Row, Col : Integer; const NumCharsToSelect: Integer);
var
  SoftCRLFsToRemove, LineToSkip, SkipChars : Integer;
  slNoWrap, slWrapped : TStringlist;
  WrappedIndex, NoWrapIndex, NoWrapLength, AccumWrapLength : Integer;
begin
  SkipChars         := 0;
  SoftCRLFsToRemove := 0;

  //No use processing unless these conditions are met...
  if (Lines.Count > 0) and
     (Row <= Lines.Count ) and
     (NumCharsToSelect > 0 ) then
  begin
    {═══════════════════════════════════════════════════════════════════════════════
    Due to the INSANITY of a Memo's "SOFT-CARRIAGE-RETURNS" (if WordWrap is True)
    it is impossible to calculate SelStart without doing some really whacky
    processing.  In particular, we create a "duplicate" of the Memo-Lines with the
    lines of text up to Cursor-Position, and then count the difference between
    the "lines" that exist pre/post WordWrap -- will need to later subtract off
    the difference in lines (times 2 - one each for CR, LF chars).
    {═══════════════════════════════════════════════════════════════════════════════}
    if (WordWrap = True) and
       (Row > 1) then        //if row to insert/select on is first row, no "adjustment" will be needed...
    begin
      slNoWrap  := TStringlist.Create;
      slWrapped := TStringlist.Create;

      try
        slWrapped.Assign(Lines);

        Lines.BeginUpdate;
        LockWindowUpdateEx(Handle, 20, 5);

        WordWrap := False;
        slNoWrap.Assign(Lines);

        //ShowMessage(IntToStr(slNoWrap.Count) + '    ' + IntToStr(slWrapped.Count));

        WrappedIndex := 0;
        for NoWrapIndex := 0 to slNoWrap.Count - 1 do
        begin
          NoWrapLength := Length(slNoWrap.Strings[NoWrapIndex]);
          if Length(slWrapped.Strings[WrappedIndex]) < NoWrapLength then
          begin
            AccumWrapLength := 0;

            While (AccumWrapLength < NoWrapLength) do
            begin
              AccumWrapLength := AccumWrapLength + Length(slWrapped.Strings[WrappedIndex]);
              Inc(WrappedIndex);

              //if we have gone as far as the Row (Line) in which the cursor was
              //positioned while wordwrap was on, then time to break out of here...
              if WrappedIndex = Row then
              begin
                AccumWrapLength := NoWrapLength + 1; //to break out of while... (and, indicate to break the "for"
                break;  //break out of While...
              end
              else
                if AccumWrapLength < NoWrapLength then
                  Inc(SoftCRLFsToRemove);

            end; //while

            if AccumWrapLength = NoWrapLength + 1 then
              break; //break FOR loop if Row target met.

          end
          else
          begin
            Inc(WrappedIndex);

            if WrappedIndex = Row then
                break;  //break out of For...
          end;

        end; //for NoWrapIndex

      finally
        slNoWrap.Free;
        slWrapped.Free;
        LockWindowUpdateEx(0, 20, 5);
        WordWrap := True;
        Lines.EndUpdate;
        Application.ProcessMessages;
      end;

    end; //if WordWrap was on and adjustment calc needed...


    //Count characters in line(s) up to, but not including the line on which
    //our selected text is on.
    for LineToSkip := 0 to Row - 2 do
      SkipChars := SkipChars + Length(Lines[LineToSkip]) + 2;   //the "+2" adjusts for CR/LF not otherwise counted

    //Now move over appropriate number of columns, less length of string we'll select
    SkipChars := SkipChars + Col - 1 - NumCharsToSelect - (SoftCRLFsToRemove * 2);

    //Now, "select" the appropriate region in memo
    SelStart  := SkipChars;
    SelLength := NumCharsToSelect;
  end; //if
end; //SelectCharsEndingAtLineCol
  
  
  
{▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪
Prevent repainting of window/control during heavy manipulation of visual items
 - especially useful with visual "lists" (e.g., memos, treeviews, shelltrees, etc).
{▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪▪}
procedure LockWindowUpdateEx(Handle: HWnd; SleepTicks, Retries: LongWord);
var
  CurrentRetry : LongWord;
begin
  CurrentRetry := 0;

  If Handle = 0
  then LockWindowUpdate(Handle)
  else
    While (CurrentRetry <= Retries) and not LockWindowUpdate(Handle) do
      begin
        Inc(CurrentRetry);
        Sleep(SleepTicks);
      end;

end; //LockWindowUpdateEx



end.


Continue to read this Software Development and Technology Blog for computer programming, software development, and technology Techniques, How-To's, Fixes, Reviews, and News — focused on Dart Language, SQL Server, Delphi, Nvidia CUDA, VMware, TypeScript, SVG, other technology tips and how-to's, and my varied political and economic opinions.

Saturday, January 21, 2017

Delphi Source Code to Convert between TColor and RGB Color in String Format

DELPHI Source Code — Function: Convert between TColor and RGB Color (as String representation)

Here is the code for a pair of useful Delphi functions for converting and moving color values between Delphi TColor (object / class) type and string representations of an RGB Color value (with or without leading # character).

If you use Delphi to output HTML code or CSS code that includes RGB color values, and you are using Delphi to edit colors or are otherwise manipulating colors using the Delphi TColor type, these routines should make it simple to convert between TColor and RGB-encoded strings.

The surrounding code shows the few USES units that were referenced. (and, this was tested through Delphi 2010)

Delphi Functions Source Code

--********************************************************************************
--This source code is Copyright (c) 2007-2017
--     Author: Mike Eberhart
--
--I hereby release this code under the terms of the MIT License (for freeware).
--
--Permission is hereby granted, free of charge, to any person obtaining a copy
--of this software and associated documentation files (the "Software"), to deal
--in the Software without restriction, including without limitation the rights
--to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
--copies of the Software, and to permit persons to whom the Software is
--furnished to do so, subject to the following conditions:
--
--The above copyright notice and this permission notice shall be included in
--all copies or substantial portions of the Software.
--
--THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
--IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
--FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
--AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
--LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
--OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
--THE SOFTWARE.
--********************************************************************************

unit ColorsUtilRGB;

interface

uses
  Windows,   //for RGB Macros
  Math,      //IfThen
  StrUtils,  //IfThen
  SysUtils,  //Format
  Classes,
  Graphics;  //for Shape type

type

  //Our RGB/Color Routines
  function GetColorASRGBString(
    const ColorToConvert : TColor; 
    const IncludePrefixChar : Boolean = True) : String;
    
  function GetRGBStringAsColor(const RGBString : String) : TColor;

implementation

 

{==============================================================================
GetColorASRGBString:

Convert a Tcolor Type to a String representation of the TColor's RGB equivalent
value in Hexadecimal digits.  If IncludePrefixChar (true by default), append
the "#" prefix to the string (showing Hex prefix).


Some TColor Notes:
  To assign a HEX value to a TColor type, cast as follows (example is for a 
constant declaration): clLightTan    = TColor($00CCEEEE);

  The HEX values represent RGB, but are in low-order byte to high-order byte
arrangement (i.e., it's really BRG reading left-to-right, so read right-to-left
for two-byte pairs of Red/Green/Blue)
===============================================================================}
function GetColorASRGBString(
  const ColorToConvert : TColor; 
  const IncludePrefixChar: Boolean): String;
var
  r,g,b         : Byte;
  CurrentColor  : TColor;
  HexColorWithSpaces : String;
const
  HexFormatStr  : String = '%2x';
begin
  CurrentColor  := ColorToConvert;

  CurrentColor  := ColorToRGB(CurrentColor);
  r := GetRValue(CurrentColor);
  g := GetGValue(CurrentColor);
  b := GetBValue(CurrentColor);

  HexColorWithSpaces := IfThen(IncludePrefixChar, '#','') 
    + Format(HexFormatStr, [r]) 
    + Format(HexFormatStr, [g]) 
    + Format(HexFormatStr, [b]);
  Result := AnsiReplaceStr(HexColorWithSpaces, ' ', '0');
end;


{==============================================================================
GetRGBStringAsColor:
This is the opposite of the prior function... Take a string representation of 
an RGB-encoded color and return a Delphi TColor equivalent.

ASSUMES inbound RGB String is EITHER:
  6 CHARACTERS LONG, NUMBERS/LETTERS ONLY!!
    OR
  7 CHARACTERS (WHERE FIRST CHAR IS "#" PREFIX)
===============================================================================}
function GetRGBStringAsColor(const RGBString : String) : TColor;
var
  RGBStringToConvert    : String[9];
  RBGStringChecked      : String;
begin
  if LeftStr(RGBString, 1) = '#' then
    RBGStringChecked := RightStr(RGBString, Length(RGBString) -1)
  else
    RBGStringChecked := RGBString;

  //Put in proper order for the StrToInt conversion 
  //(expects as B, G, R and NOT IN RGB order).
  RGBStringToConvert    := '$00' 
    + Copy(RBGStringChecked, 5, 2) 
    + Copy(RBGStringChecked, 3, 2) 
    + Copy(RBGStringChecked, 1, 2);

  Result := TColor(StrToInt(RGBStringToConvert));
end;



end.


Continue to read this Software Development and Technology Blog for computer programming, software development, and technology Techniques, How-To's, Fixes, Reviews, and News — focused on Dart Language, SQL Server, Delphi, Nvidia CUDA, VMware, TypeScript, SVG, other technology tips and how-to's, and my varied political and economic opinions.

DELPHI Source Code Function: GetAlternateColor, alternating row color, Color-Shifting algorithm

DELPHI Source Code — Function: GetAlternateColor Color-Shifting for alternating grid-row color

If you ever wanted to create a (Borland, CodeGear, Embarcadero) Delphi grid, or other control, with alternating row-colors / highlight-colors, the first thing you will need is a function with an algorithm that helps automate the determination of the alternate-row-color, based on a given TColor value, that is a rather well coordinated and appropriate color.

In the source code I provide here for one such function, this alternating row-color / highlight-color calculation is done by shifting the individual color-channels (R/G/B) based on their current values. You should be able to modify the code quite easily to your own specific requirements.

Note: To see this method put to use, read my blog entry about how to include this functionality within the Delphi DBGrids.pas source code as a modification which enables alternating grid row colors as demonstrated in these images:

Delphi Grid Control using this Alternating-Row-Color / Highlight logic ("Classic" look)

Delphi Grid Control using this Alternating-Row-Color / Highlight logic ("Aero" / modern look)
This procedure has been tested within Delphi version from Delphi 7 through Delphi 2010.

Delphi Function Source Code

--********************************************************************************
--This source code is Copyright (c) 2007-2017
--     Author: Mike Eberhart
--
--I hereby release this code under the terms of the MIT License (for freeware).
--
--Permission is hereby granted, free of charge, to any person obtaining a copy
--of this software and associated documentation files (the "Software"), to deal
--in the Software without restriction, including without limitation the rights
--to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
--copies of the Software, and to permit persons to whom the Software is
--furnished to do so, subject to the following conditions:
--
--The above copyright notice and this permission notice shall be included in
--all copies or substantial portions of the Software.
--
--THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
--IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
--FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
--AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
--LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
--OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
--THE SOFTWARE.
--********************************************************************************

{*******************************************************************************
GetAlternateColor is just a color-shifting algorithm, where if any component
of a color code (R, G, or B) gets too "close" to either 00 or FF, it is shifted
in the opposite direction.
I use this to achieve a "green-bar" effect in the DBGrid, regardless of what
background color someone has chosen for the grid.  This algorithm makes a fairly
logical guess at what the alternating-band-color should be for a given color.

See other example on this blog https://suretalent.blogspot.com 
for how this code was plugged into Borland / Embarcadero Delphi source-code 
(as tested with Delphi 2006 through 2010)
*******************************************************************************}
function GetAlternateColor(CurrentColor : TColor) : TColor;
var
  r,g,b : Byte;
const
  //The amount of "shifting" per color channel we're going to make (out of 256 max)
  ColorShiftBy = 24;  
  MinShiftThreshold = ColorShiftBy * 2;
  MaxValue = 255;
begin
  CurrentColor := ColorToRGB(CurrentColor);
  r := GetRValue(CurrentColor);
  g := GetGValue(CurrentColor);
  b := GetBValue(CurrentColor);

  //nearly "black" in color already... brighten all channels
  if (r < MinShiftThreshold) and (g < MinShiftThreshold) and (b < MinShiftThreshold) then
  begin
    r := r + ColorShiftBy;
    g := g + ColorShiftBy;
    b := b + ColorShiftBy;
    Result := RGB(r,g,b);
    exit;
  end;

  //Special case to handle "white" fields.  
  //In one of our product GUIs, white fields indicated editable fields in Grids;
  //perform a MINIMAL "shift" in color so field is almost white, but yet visibly different
  if (r = MaxValue ) and (g = MaxValue) and (b = MaxValue) then
  begin
    r := r - ColorShiftBy div 2;
    g := g - ColorShiftBy div 2;
    b := b - ColorShiftBy div 2;
    Result := RGB(r,g,b);
    exit;
  end;

  if r > MinShiftThreshold then
    r := r - ColorShiftBy
  else
    if r > 0 then
      r := r + ColorShiftBy;

  if g > MinShiftThreshold then
    g := g - ColorShiftBy
  else
    if g > 0 then
      g := g + ColorShiftBy;

  if b > MinShiftThreshold then
    b := b - ColorShiftBy
  else
    if b > 0 then
      b := b + ColorShiftBy;

  Result := RGB(r,g,b);

end; //function GetAlternateColor



{*******************************************************************************
Some useful CONSTANTS for row-color testing.
Note:
The HEX values represent RGB, but are in low-order byte to high-order byte
arrangement (i.e., it's really BRG reading left-to-right, so read right-to-left
for two-byte pairs of Red/Green/Blue).  So, use ($00BBGGRR) patterns.
*******************************************************************************}
const
  //                        BBGGRR
  clLightTan    = TColor($00CCEEEE);
  clMidTan      = TColor($00B6D4D4);
  clDarkTan     = TColor($00A0BABA);



Continue to read this Software Development and Technology Blog for computer programming, software development, and technology Techniques, How-To's, Fixes, Reviews, and News — focused on Dart Language, Delphi, SQL Server, Nvidia CUDA, VMware, TypeScript, SVG, other technology tips and how-to's, and my varied political and economic opinions.

Delphi Source Code: DBGrids.pas enhancement for automatic alternating grid row colors / highlights

DELPHI Class Enhancement: DBGrids.pas Delphi source-code modification to implement alternating grid row colors

NOTE: This Delphi DBGrids.pas source code modification makes use of my GetAlternateColor Delphi function (source code here) for alternating grid-row-colors calculations. See comments within this Delphi source code (below) for where to insert that function (search for "GetAlternateColor").

Have you ever wanted to create a (Borland, CodeGear, Embarcadero) Delphi-based DBgrid with alternating row-colors / highlight-colors, like what is shown in these images:

Delphi Grid Control using this Alternating-Row-Color / Highlight logic ("Classic" look)

Delphi Grid Control using this Alternating-Row-Color / Highlight logic ("Aero" / modern look)

A requirement for such "green-bar" effects (alternating row-colors or row-highlight-colors in a DBGrid) came up a lot for various applications I have developed, and I was honestly frustrated by the fact that Delphi did not included this functionality to begin with, especially after so many releases. With every new Delphi release... Delphi 7, Delphi 2005, Delphi 2006, Delphi 2009, and Delphi 2010, I just kept hoping for this to just be included, but it was not.

My solution was to modify the source code provided with Delphi, since the DBGrid.pas DrawCell (TCustomDBGrid.DrawCell method) provided no simple way to extend this routine. The code that follows (below) will hopefully guide you through where to "hack" the existing Delphi DBGrid source code if you choose to. Next, I simply move the modified Delphi DBGrids.pas file into the directory with the rest of my project source-code and compile it in (thus, overriding the existing outdated-looking Grid).

See the somewhat detailed comments within the source-code modifications for why I made that changes that I did. I do not just alternate the grid-row colors, I also do some other things like modifying how bookmarks work and selected-rows work and such.

Even if this does not do exactly what you want, it should provide you with enough guidance to be able to modify DBGRID.pas quite easily to meet your specific requirements.

This procedure has been tested within Delphi version from Delphi 7 through Delphi 2010.

Delphi Function Source Code

--********************************************************************************
--This source code is Copyright (c) 2007-2017
--     Author: Mike Eberhart
--
--I hereby release this code under the terms of the MIT License (for freeware).
--
--Permission is hereby granted, free of charge, to any person obtaining a copy
--of this software and associated documentation files (the "Software"), to deal
--in the Software without restriction, including without limitation the rights
--to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
--copies of the Software, and to permit persons to whom the Software is
--furnished to do so, subject to the following conditions:
--
--The above copyright notice and this permission notice shall be included in
--all copies or substantial portions of the Software.
--
--THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
--IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
--FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
--AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
--LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
--OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
--THE SOFTWARE.
--********************************************************************************

procedure TCustomDBGrid.DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState);
...
...

//NOTE: I simply PLACED MY GetAlternateColor method here; get the source code from my other blog entry at:
//https://suretalent.blogspot.com/2017/01/delphi-source-code-function-alternating-highlight-row-color-algorithm.html


//Now, look for the following lines of code (at the start of the DrawCell method body)
var
  OldActive: Integer;
  Indicator: Integer;
  Value: string;
  DrawColumn: TColumn;
  MultiSelected: Boolean;
  ALeft: Integer;

  {*******************************************************************************
  I placed my constants here... ADDITIONS BEGIN
  *******************************************************************************}
  const
  //                        BBGGRR
  clLightTan    = TColor($00CCEEEE);
  clMidTan      = TColor($00B6D4D4);
  clDarkTan     = TColor($00A0BABA);
  {*******************************************************************************
  ADDITIONS - END
  *******************************************************************************}

begin
  if csLoading in ComponentState then
  begin
    Canvas.Brush.Color := Color;
    Canvas.FillRect(ARect);
    Exit;
  end;

  ...
  ... (about 70 lines of code here...;  look for the following...)
  ...
  
    if ARow < 0 then
      DrawTitleCell(ACol, ARow + FTitleOffset, DrawColumn, AState)
    else if (FDataLink = nil) or not FDataLink.Active then
      FillRect(ARect)
    else
    begin
      Value := '';
      OldActive := FDataLink.ActiveRecord;
      try
        FDataLink.ActiveRecord := ARow;
        if Assigned(DrawColumn.Field) then
          Value := DrawColumn.Field.DisplayText;
        if HighlightCell(ACol, ARow, Value, AState) and DefaultDrawing then
          DrawCellHighlight(ARect, AState, ACol, ARow);
        if not Enabled then
          Font.Color := clGrayText;
        if FDefaultDrawing then
          WriteText(Canvas, ARect, 3, 2, Value, DrawColumn.Alignment,
            UseRightToLeftAlignmentForField(DrawColumn.Field, DrawColumn.Alignment));
        if Columns.State = csDefault then
          DrawDataCell(ARect, DrawColumn.Field, AState);
  
//>> LOOK FOR THE PREVIOUS DELPHI DBGRID SOURCE CODE LINES ABOVE (appearning near the END of DrawCell method body)
//>> and place this provided custom code right below it...

        {*******************************************************************************
        ADDITIONS - BEGIN

        This section of code is required to accomplish a few particular GUI
        goals for the DBGrid that the standard DBGrid does not provide:
          1) Alternate colors between each row in grid to make it visually
             simple to quickly scan a row's data from left-to-right.
          2) maintain Bookmarks, even when I just want to allow ONLY one-row to
             be selected, since my applications regularly depend on Bookmarks
             to return to a particular row in the grid.
             The DBGrid normally only maintains bookmarks if dgMultiSelect
             option is True/Enabled, and in that state, DBGrid (as expected)
             allows the user to select as many rows as they want.
             My alterations make dgMultiSelect truly mean MULTI-SELECT ONLY WHEN
             the dgIndicator Option is True/Enabled at the same time
             dgMultiSelect is True/Enabled.
             When dgMultiSelect is used WITHOUT dgIndicator, only ONE ROW at
             a time (i.e., one row maximum) can be set to "selected" state.
             This allows for TRUE multiselect as well as my ONE-ROW-ONLY
             "multiselect" (where I am relying on multi-select just to set the
             bookmark on my one selected row).
          4) Highlight "selected" row(s) in a color/theme that makes the selection
             quickly apparent, whether just one row is selected or many rows are selected.
          5) Only show "Selected" rows when the grid has Focus, OR when the
             dgAlwaysShowSelection option is True (to be consistent with normal
             DBGrid behaviour).

        CODE COMMENTS:
        Make sure only ONE record selected UNLESS dgIndicator is TRUE.
        Set Current "Active" Row to "Selected" row if allowing only one row to be selected.
        Only do this if we have focus on the grid, or if AlwaysShowSelection is ON.
        For all other situations, color the alternating lines in the grid or
        any other selected-rows (if TRUE MULTI-select is in effect).
        *******************************************************************************}
        if ((DataLink.ActiveRecord = Row - 1) and ((dgAlwaysShowSelection in Options) or Focused)) or
           ((dgAlwaysShowSelection in Options) and SelectedRows.CurrentRowSelected and not (dgIndicator in Options)) then
        begin
          if (ACol = 0) then  //only need to set "Selected" once per row - do so when painting Column Zero, lest flicker ensue
          begin
            if not (dgIndicator in Options) then   //use the showing INDICATOR to mean ALLOW TRUE MULTI-SELECT!
              if SelectedRows.Count > 1 then       //Remove stragglers from MultiSelect
                SelectedRows.Clear;

            SelectedRows.CurrentRowSelected := True;
          end;

          //NOTE: for "classic" look only, replace following 3 lines with: Canvas.Brush.Color := clSelectedRow;
          Canvas.Brush.Color  := clHighlight;
          Canvas.Brush.Style  := bsClear;
          Canvas.Font.Color   := IfThen(DrawingStyle <> gdsClassic, clWindowText, clHighlightText); //set optimal text-color per draw-style
        end
        else  //Logic for coloring other rows.
        begin
          Font.Color            := clWindowText;

          //This only kicks in for the multi-selection (TRUE multiselection that is, which requires dgIndicator to be on too),
          //since above logic only highlights the SINGLE ACTIVE/SELECTED ROW (this catches other multi-select rows)
          if SelectedRows.CurrentRowSelected then
          begin
            //NOTE: for "classic" look only, replace following 3 lines with: Canvas.Brush.Color := clSelectedRow;
            Canvas.Brush.Color  := clHighlight;
            Canvas.Brush.Style  := bsClear;
            Canvas.Font.Color   := IfThen(DrawingStyle <> gdsClassic, clWindowText, clHighlightText); //set optimal text-color per draw-style
          end
          else
            if ((Columns[ACol].Field.DataSet.RecNo mod 2) =1) then  //Is it an "alternating-line" to have "green-bar paper" effect?
              Canvas.Brush.Color    := GetAlternateColor(Columns[ACol].Color)
            else
              Canvas.Brush.Color    := Columns[ACol].Color;   //TPrevent weird line-coloration if focused moved off grid after a row is selected
        end;

        DefaultDrawColumnCell( ARect, ACol, Columns[ACol], AState );  //Perform our chosen coloration
        
        {*******************************************************************************
        ADDITIONS - END
        *******************************************************************************}        

//>> LOOK FOR THE FOLLOWING DELPHI DBGRID.pas SOURCE CODE (near the END of DrawCell method body)
//>> and place provided custom code right above it
           
        DrawColumnCell(ARect, ACol, DrawColumn, AState);
      finally
        FDataLink.ActiveRecord := OldActive;
      end;
      Canvas.Brush.Style := bsSolid;
      if FDefaultDrawing and (gdSelected in AState)
        and ((dgAlwaysShowSelection in Options) or Focused)
        and not (csDesigning in ComponentState)
        and not (dgRowSelect in Options)
        and (UpdateLock = 0)
        and (ValidParentForm(Self).ActiveControl = Self) then
      begin
        if (FInternalDrawingStyle = gdsThemed) and (Win32MajorVersion >= 6) then
          InflateRect(ARect, -1, -1);
        Windows.DrawFocusRect(Handle, ARect);
      end;
    end;
  end;
  if (gdFixed in AState) and ([dgRowLines, dgColLines] * Options =
     [dgRowLines, dgColLines]) and (FInternalDrawingStyle = gdsClassic) and
     not (gdPressed in AState) then
  begin
    InflateRect(ARect, 1, 1);
    DrawEdge(Canvas.Handle, ARect, BDR_RAISEDINNER, BF_BOTTOMRIGHT);
    DrawEdge(Canvas.Handle, ARect, BDR_RAISEDINNER, BF_TOPLEFT);
  end;
end;



Continue to read this Software Development and Technology Blog for computer programming, software development, and technology Techniques, How-To's, Fixes, Reviews, and News — focused on Dart Language, Delphi, SQL Server, Nvidia CUDA, VMware, TypeScript, SVG, other technology tips and how-to's, and my varied political and economic opinions.

Friday, January 20, 2017

SQL-Server Procedure for Parameterized GROUP BY Without Using Dynamic-SQL

SQL SERVER Procedure: Parameterized GROUP BY Without Using Dynamic-SQL : the "impossible" is possible.

NOTE: This procedure and source code builds upon my previous parameterized ORDER BY without using Dynamic-SQL examples:

In this blog entry, I present a Microsoft SQL-Server query / procedure that can accomplish what many would consider truly impossible: performing a parameterized GROUP BY without using Dynamic-SQL to do it. This method builds on some other examples I have provided demonstrating parameterized ORDER BY operations (also without using Dynamic-SQL). This method of performing a GROUP BY on one or more columns, as specified by parameters/directives, is very flexible though it has the drawback of not executing as quickly as if we knew ahead of time (when writing our SQL code) what column(s) an ORDER BY / GROUP BY / aggregation was to act on.

Avoidance of Dynamic-SQL is primarily motivated by security considerations, and this procedure does not use any dynamic-SQL to perform what would otherwise be considered a "dynamic GROUP BY" operation, where the column(s) for sorting and grouping on are variable. SQL-injection exploits can be avoided completely by not using dynamic-SQL. This is particularly important for applications that provide the "public" with access to a database via web-interfaces and the like. And, very often, data-selection and sorting options are provided to the public (or are a desired application feature) that would typically make dynamic-SQL a requirement.

DISCUSSION:

Just in case (pun) you wondered how far can SQL-Server be pushed by using CASE statements to accomplish what would otherwise only be possible with Dynamic-SQL, I put together this procedural example that demonstrates how you can even perform GROUP BY (i.e., for aggregation operations) dynamically via run-time parameters, without dynamic-SQL.

Not only does this example demonstrate how, at execution time, I can force the GROUP BY operation to vary what column is used to group information by, but how I can also cause the aggregation level to happen for one column, two columns, three columns, etc.

This can be some wonderful time-saving code for management reporting where "drill-down" capabilities are required in an application, and simply by specifying additional column(s) to slice and dice our data by, we can view ever increasing detail and be quite flexible about the grouping of that data.

Although it is really an interesting experiment in regards to what is possible with non-dynamic set-based SQL using a single SQL SELECT to perform a tricky piece of logic, there are definitely some drawbacks to the approach. First, there is the need to essentially duplicate a large portion of the logic (pattern) within the SELECT result-column definitions as well as the ORDER BY and the GROUP BY column definitions, since we need to handle all possible cases without dynamic SQL.

NOTE: even though this works and works completely, it is presented as a "proof of concept" solution more than anything, due to the fact it is rather inefficient when used against large tables. The query-optimizer can not do much to help with performance when everything about the query is unknown until run-time (as each row has its table-column values evaluated).

But, now that I have presented a quick argument against this techniques use, I will consider a few of the reasons it is actually a worthwhile approach:

  • We can achieve, with a single procedure, what would otherwise take many procedures to accomplish (presuming dynamic-SQL is not an option)
  • Although the code may appear a bit lengthy, it is not terribly difficult to maintain, as changes are made to the overall "pattern" of the code within each major section — meaning, if you change the format of an output column in one CASE condition, it's a simple matter of copying and pasting that change to the other region(s) where it is used, with minor changes to the surrounding code; 
  • It is easily extended to include additional grouping levels, should that be necessary.


This procedure has been tested against the AdventureWorks sample databases in SQL-Server 2005 and SQL-Server 2008.

SQL-Server Stored Procedure (SP) Source Code

--********************************************************************************
--This source code is Copyright (c) 2007-2017
--     Author: Mike Eberhart
--
--I hereby release this code under the terms of the MIT License (for freeware).
--
--Permission is hereby granted, free of charge, to any person obtaining a copy
--of this software and associated documentation files (the "Software"), to deal
--in the Software without restriction, including without limitation the rights
--to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
--copies of the Software, and to permit persons to whom the Software is
--furnished to do so, subject to the following conditions:
--
--The above copyright notice and this permission notice shall be included in
--all copies or substantial portions of the Software.
--
--THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
--IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
--FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
--AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
--LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
--OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
--THE SOFTWARE.
--********************************************************************************

--**********************************************************************************************
-- BEGIN: NON-DYNAMIC-SQL for Dynamically/Variably-Grouped data at run-time via Parameters.
--
-- This procedure builds on the prior example(s) by adding the ability to perform aggregate
-- operations dynamically on one or more columns as directed by parameters.
--**********************************************************************************************

--**********************************************************************************************
-- Using the AdventureWorks database's Production.TransactionHistory Table for this example.
-- I will refer to the various Columns I want to (potentialy) GROUP BY as columns 1 through 3,
-- with the values being assigned as follows:
-- 1 = ProductID
-- 2 = ReferenceOrderID
-- 3 = TransactionDate
--**********************************************************************************************
CREATE PROCEDURE uspProducts_ReturnProductsDynamicallyGrouped
 @GroupColumn1  TINYINT,
 @GroupColumn2  TINYINT,
 @GroupColumn3  TINYINT
AS
BEGIN
 SELECT
  MAX
  (CONVERT(VARCHAR(80),
   COALESCE(
   CASE
    WHEN @GroupColumn1 = 1 THEN 
     'ProductID: ' + 
     dbo.[udfGetIntegerAsPaddedString](T.ProductID, 8, ' ')
    WHEN @GroupColumn1 = 2 THEN
     'ReferenceOrderID: ' + 
     dbo.[udfGetIntegerAsPaddedString](T.ReferenceOrderID, 8, ' ')
    WHEN @GroupColumn1 = 3 THEN
     'TransactionDate: ' + 
     dbo.udfConvertDateToString(T.TransactionDate)
    ELSE NULL
   END, '')
  +
   COALESCE(
   CASE
    WHEN @GroupColumn2 = 1 THEN 
     ', ProductID: ' + 
     dbo.[udfGetIntegerAsPaddedString](T.ProductID, 8, ' ')
    WHEN @GroupColumn2 = 2 THEN
     ', ReferenceOrderID: ' + 
     dbo.[udfGetIntegerAsPaddedString](T.ReferenceOrderID, 8, ' ')
    WHEN @GroupColumn2 = 3 THEN
     ', TransactionDate: ' + 
     dbo.udfConvertDateToString(T.TransactionDate)
    ELSE NULL
   END, '')
  +
   COALESCE(
   CASE
    WHEN @GroupColumn3 = 1 THEN 
     ', ProductID: ' + 
     dbo.[udfGetIntegerAsPaddedString](T.ProductID, 8, ' ')
    WHEN @GroupColumn3 = 2 THEN
     ', ReferenceOrderID: ' + 
     dbo.[udfGetIntegerAsPaddedString](T.ReferenceOrderID, 8, ' ')
    WHEN @GroupColumn3 = 3 THEN
     ', TransactionDate: ' + 
     dbo.udfConvertDateToString(T.TransactionDate)
    ELSE NULL
   END, '')
  ))     AS 'Grouping-Value',
  COUNT(1)   AS 'Count', 
  SUM(ActualCost)  AS 'Total Cost' 
 FROM 
  Production.TransactionHistory AS T
 GROUP BY 
  (
   CASE
    WHEN @GroupColumn1 = 1 THEN 
     dbo.[udfGetIntegerAsPaddedString](T.ProductID, 8, '0')
    WHEN @GroupColumn1 = 2 THEN
     dbo.[udfGetIntegerAsPaddedString](T.ReferenceOrderID, 8, '0')
    WHEN @GroupColumn1 = 3 THEN
     dbo.udfConvertDateToString(T.TransactionDate)
    ELSE NULL
   END
  ),
  (
   CASE
    WHEN @GroupColumn2 = 1 THEN 
     dbo.[udfGetIntegerAsPaddedString](T.ProductID, 8, '0')
    WHEN @GroupColumn2 = 2 THEN
     dbo.[udfGetIntegerAsPaddedString](T.ReferenceOrderID, 8, '0')
    WHEN @GroupColumn2 = 3 THEN
     dbo.udfConvertDateToString(T.TransactionDate)
    ELSE NULL
   END
  ),
  (
   CASE
    WHEN @GroupColumn3 = 1 THEN 
     dbo.[udfGetIntegerAsPaddedString](T.ProductID, 8, '0')
    WHEN @GroupColumn3 = 2 THEN
     dbo.[udfGetIntegerAsPaddedString](T.ReferenceOrderID, 8, '0')
    WHEN @GroupColumn3 = 3 THEN
     dbo.udfConvertDateToString(T.TransactionDate)
    ELSE NULL
   END
  )
 ORDER BY 
  (
   CASE
    WHEN @GroupColumn1 = 1 THEN 
     dbo.[udfGetIntegerAsPaddedString](T.ProductID, 8, '0')
    WHEN @GroupColumn1 = 2 THEN
     dbo.[udfGetIntegerAsPaddedString](T.ReferenceOrderID, 8, '0')
    WHEN @GroupColumn1 = 3 THEN
     dbo.udfConvertDateToString(T.TransactionDate)
    ELSE NULL
   END
  ),
  (
   CASE
    WHEN @GroupColumn2 = 1 THEN 
     dbo.[udfGetIntegerAsPaddedString](T.ProductID, 8, '0')
    WHEN @GroupColumn2 = 2 THEN
     dbo.[udfGetIntegerAsPaddedString](T.ReferenceOrderID, 8, '0')
    WHEN @GroupColumn2 = 3 THEN
     dbo.udfConvertDateToString(T.TransactionDate)
    ELSE NULL
   END
  ),
  (
   CASE
    WHEN @GroupColumn3 = 1 THEN 
     dbo.[udfGetIntegerAsPaddedString](T.ProductID, 8, '0')
    WHEN @GroupColumn3 = 2 THEN
     dbo.[udfGetIntegerAsPaddedString](T.ReferenceOrderID, 8, '0')
    WHEN @GroupColumn3 = 3 THEN
     dbo.udfConvertDateToString(T.TransactionDate)
    ELSE NULL
   END
  )
END --Procedure



--**********************************************************************************************
--TESTING / EXAMPLE EXECUTIONS
--**********************************************************************************************

--No grouping: get grand totals only
EXEC uspProducts_ReturnProductsDynamicallyGrouped NULL, NULL, NULL
--Grouping-Value                                              Count       Total Cost
------------------------------------------------------------- ----------- ---------------------
--                                                            113443      27307331.1537


--Group totals by TransactionDate
EXEC uspProducts_ReturnProductsDynamicallyGrouped 3, NULL, NULL
--Grouping-Value                                              Count       Total Cost
------------------------------------------------------------- ----------- ---------------------
--TransactionDate: 20030901                                   3944        1675058.5669
--TransactionDate: 20030902                                   227         39771.10
--TransactionDate: 20030903                                   203         39824.63
--...


--Group totals by TransactionDate and ProductID
EXEC uspProducts_ReturnProductsDynamicallyGrouped 3, 1, NULL
--Grouping-Value                                              Count       Total Cost
------------------------------------------------------------- ----------- ---------------------
--...
--TransactionDate: 20030901, ProductID:      996              32          2786.9806
--TransactionDate: 20030901, ProductID:      997              10          4039.1252
--TransactionDate: 20030901, ProductID:      998              26          9871.0172
--TransactionDate: 20030901, ProductID:      999              22          8553.4416
--TransactionDate: 20030902, ProductID:        3              1           0.00
--TransactionDate: 20030902, ProductID:      316              1           0.00
--...


--Group totals by ProductID and TransactionDate (and show how NULL parms do not affect outcome)
EXEC uspProducts_ReturnProductsDynamicallyGrouped 1, NULL, 3
--Grouping-Value                                              Count       Total Cost
------------------------------------------------------------- ----------- ---------------------
--...
--ProductID:      971, TransactionDate: 20040622              1           0.00
--ProductID:      971, TransactionDate: 20040626              1           1214.85
--ProductID:      971, TransactionDate: 20040629              3           2429.70
--ProductID:      971, TransactionDate: 20040702              1           0.00
--ProductID:      972, TransactionDate: 20030901              31          26240.76
--ProductID:      972, TransactionDate: 20030904              1           0.00
--...


--**********************************************************************************************
-- END: NON-DYNAMIC-SQL for Dynamically/Variably-Grouped data at run-time via Parameters.
--**********************************************************************************************


Continue to read this Software Development and Technology Blog for computer programming, software development, and technology Techniques, How-To's, Fixes, Reviews, and News — focused on Dart Language, SQL Server, Nvidia CUDA, VMware, TypeScript, SVG, other technology tips and how-to's, and my varied political and economic opinions.

Transact-SQL: Set-Based SQL Technique for Running-List of Accumulated Values (String/Number), with Break-Level Resets

MS SQL Server: Algorithm and Query for Set-Based Running Accumulators (i.e., Accumulate Row-Level Values across multiple Rows) into a String of Delimited-values, with Break-Level Resets

Have you ever wanted to perform a set-based running-subtotal operation or running-accumulation-of-values (across multiple rows) in SQL-Server — i.e., have row-level accumulators store a running total or running subtotal or aggregation of values within a "break level", stored in a String as delimited-values (i.e., delimited-list of values)? Want the solution to not use cursors?

Well, in this blog I present one such cursorless method of implementing that type of functionality in a SQL-Server Query, Stored-Procedure, or Function.

The source code provided here is for a Microsoft SQL-Server Transact-SQL (T-SQL) solution that provides a basis for a query / stored procedure (SP) that you wish to perform Set-Based Running String Accumulation with Break-Level Resets operations in. This demonstrates how to accumulate values from multiple rows in a table into a single string, and how to perform a "reset" of that accumulator at your chosen break-level.

This code is very handy for reporting requirements where you need to display on a report a single field whose value is really made up of the aggregation of values from multiple rows in a database. The example scenario used here is reporting all OrderLineIDs related to a product. The AdventureWorks database (sample) from Microsoft provided the basis and data for this example.

WHY DO THIS?

I have run into a few situations where this has been extremely useful. A typical situation involves reporting functionality, where a report is supposed to show a list of values that exist for all items in a group, but only report this information in summary at a group level. Like, e.g., you have a part number with (potentially) a lot of sub-parts / components that make up the "parent" product, and you want to generate a report showing (at the product level) information like price, cost, build-time, and a list of sub-components (in summary - like just their part numbers). Well, this query demonstrates one method for how that can be accomplished. Also, I have used this as a technique to "bind" two reporting procedures together where a master-detail report links the details as a comma-delimited list of primary-key values (and then, in the detail report, I use the power of a user-defined function to transform that delimited list of key-values into a table (link to source code here on my blog) for joining, using this user-defined delimited-list parser SQL function.

I have seen running totals done before, with varied methods, but what I have not seen much about elsewhere is how to do running subtotals. The code I wrote that appears below can easily do both, and does. It is easily adapted to do multi-column break-value running subtotals, as noted in the code comments.

Note: for this example, I used the SQL Server 2012 Adventureworks sample database, which provided me with a test case of approximately 113,000 rows against which I perform the running-subtotal (by product level) logic and do my row-level accumulator manipulations (using SET logic). This query is relatively efficient and took only just under 6 seconds to execute on my early Core-i7 Desktop development PC within a VMware Workstation virtual machine, for the entire operation (before I limited output with TOP() function.

SQL-Server Query Source Code

--********************************************************************************
--This source code is Copyright (c) 2007-2017
--     Author: Mike Eberhart
--
--I hereby release this code under the terms of the MIT License (for freeware).
--
--Permission is hereby granted, free of charge, to any person obtaining a copy
--of this software and associated documentation files (the "Software"), to deal
--in the Software without restriction, including without limitation the rights
--to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
--copies of the Software, and to permit persons to whom the Software is
--furnished to do so, subject to the following conditions:
--
--The above copyright notice and this permission notice shall be included in
--all copies or substantial portions of the Software.
--
--THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
--IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
--FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
--AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
--LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
--OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
--THE SOFTWARE.
--********************************************************************************

--**********************************************************************************************
-- BEGIN: SET-BASED Running-String-Accumulator Technique
--**********************************************************************************************
DBCC DROPCLEANBUFFERS WITH NO_INFOMSGS; -- Clears the data cache
DBCC FREEPROCCACHE    WITH NO_INFOMSGS; -- Clears the procedure cache

SET NOCOUNT ON;
SET TRANSACTION ISOLATION LEVEL READ UNCOMMITTED;

DECLARE @starttime DATETIME = GetDate();

--Variable to accumulate our delimited string of values-per-break-level
DECLARE @RunningSubtotalDelimString VARCHAR(MAX) = '';

--Our break-level-value variables (Data-Types match those of the columns we are comparing to)
--Initialize these to some values that will NOT exist in each break-column's actual data.
DECLARE @SubTotalBreakValue1 INT = -999; 

--Our work-table, where we can ensure the ORDER with which we later access the data, being
--by default, the order of the PRIMARY KEY declared here in UniqueID column.
DECLARE @Results TABLE
(
  UniqueID                INT IDENTITY NOT NULL PRIMARY KEY,
  SubtotalBreakColumn1    INT,
  ReferenceOrderID        INT,
  OrderLineIDsForProduct  VARCHAR(MAX)
);


--Insert all values to be totaled, into our work table in the REQUIRED BREAK-LEVEL(S) ORDER
INSERT INTO @Results(
    SubtotalBreakColumn1,
    ReferenceOrderID)
SELECT
    ProductID,
    ReferenceOrderID
FROM
    Production.TransactionHistory
ORDER BY
    ProductID,        --Insert into table in our subtotal-breaking order (IMPORTANT!)
    ReferenceOrderID  --and, if we care, sort the OrderIDs too
;

--**********************************************************************************************
-- ALGORITHM EXPLANATION:
--    See SET-BASED RUNNING SUBTOTALS Example 1, which this builds upon and can easily be
--    extended per the comments therein and/or as demonstrated in Subtotals Example 2.
--**********************************************************************************************
UPDATE
    @Results
SET
    @RunningSubtotalDelimString   = 
        OrderLineIDsForProduct    = 
            CASE 
            WHEN @SubTotalBreakValue1 = SubtotalBreakColumn1 
                THEN @RunningSubtotalDelimString + 
                CASE WHEN @RunningSubtotalDelimString <> '' THEN ',' ELSE '' END +  
                CONVERT(VARCHAR(10), ReferenceOrderID) 
            ELSE CONVERT(VARCHAR(10), ReferenceOrderID) 
            END,
    @SubTotalBreakValue1= SubtotalBreakColumn1
;


SELECT DateDiff(ms, @starttime, GetDate()); --Display elapsed Milliseconds 
--**********************************************************************************************
--Output the results, showing a few rows to demonstrate the accumulation...
--**********************************************************************************************
SELECT TOP(200) * FROM @results
ORDER BY UniqueID

--UniqueID    SubtotalBreakColumn1 ReferenceOrderID OrderLineIDsForProduct
------------- -------------------- ---------------- ---------------------------------------
--1           1                    426              426
--2           1                    505              426,505
--3           1                    588              426,505,588
--4           1                    675              426,505,588,675
--5           1                    758              426,505,588,675,758
--6           1                    841              426,505,588,675,758,841
--...
--...
--45          1                    3931             426,505,588,[...etc...],3852,3931
--46          2                    425              425
--47          2                    504              425,504
--48          2                    587              425,504,587
--49          2                    674              425,504,587,674
--...
--...


--**********************************************************************************************
--Perhaps we only want one row with the delimited list of unique values for entire break-level 
--(i.e., accumulator level, "subtotal level", aggregation level, running subtotal level)
--NOTE: Limit sample using TOP here.  Demonstrate GROUP BY with MAX to get just break-level val.
--**********************************************************************************************
SELECT TOP(10)
    SubtotalBreakColumn1,
    MAX(OrderLineIDsForProduct) AS AccumulatedOrderIDs  --The "MAX()" row has the most OrderIDs
FROM @results
GROUP BY SubtotalBreakColumn1
ORDER BY SubtotalBreakColumn1
;

--SubtotalBreakColumn1 AccumulatedOrderIDs 
---------------------- -------------------------------------------------------------------------
--1                    426,505,588,675,758,841,[...etc...]3457,3536,3615,3694,3773,3852,3931
--2                    425,504,587,674,757,836,[...etc...]3456,3535,3614,3693,3772,3851,3930

--**********************************************************************************************
-- END: SET-BASED Running-String-Accumulator Technique
--**********************************************************************************************


Continue to read this Software Development and Technology Blog for computer programming, software development, and technology Techniques, How-To's, Fixes, Reviews, and News — focused on Dart Language, SQL Server, Nvidia CUDA, VMware, TypeScript, SVG, other technology tips and how-to's, and my varied political and economic opinions.