Liren Large Software Subsidy 6/06.iso/b/b094/4.img/COLORCEL.L!S/COLORCEL.L!S

Text File | 1993-02-22 | 14.5 KB | 433 lines

'<<Name>> Globals : System Use Only

'*    Copyright (c) Lotus Development Corporation 1990, 1991, 1992, 1993

'************Globals : System Use Only************************************
'* This script is the main Module for Color Cells
'* It should only be run once, and it managed by main Color Cells script
'* When run, this script declares the functions that:
'*     (1) manage the Dialog Box - put it up, and retrieve user settings
'*     (2) Determine what cells the "current selection" refers to, i.e.,
'*               if formula selection, use cells calculated by the formula
'*               if item selection, use cells in the item(s)
'*     (3) Take action based on the user's dialog box selections
'*        (4) Actually color each cell based on its value
'******************************************************************************

MODULE ColorCells

LIBRARY MYTRIG("colortrg.dll")
DECLARE GLOBAL Function RegisterColorRecalc LIB MYTRIG () as INTEGER
DECLARE GLOBAL Function UnregisterColorRecalc LIB MYTRIG () as INTEGER

BOOLEAN alreadyregistered?
alreadyregistered?=FALSE
BOOLEAN ranonce?

string ltcond
string gtcond
string eqcond

integer redv%,bluev%,yellowv%,magentav%,cyanv%,blackv%, bold%

integer logand%    ' global variable to hold value of "logical AND" (if 0, "OR" is used)
integer trig%
integer clr          ' to hold color user chooses from dialog

const BLACK=255
const RED=128
const YELLOW=50
const BLUE=168
const MAGENTA = 124
const GREEN=68
const CYAN=70


const LTCTRL=8000    ' all the edit controls and buttons as they are assigned in the color.dlg file.
const GTCTRL=8001
const EQCTRL=8002
const REDBTN=23
const BLUEBTN=24
const YELLOWBTN=25
const MAGENTABTN=26
const CYANBTN=27
const BLACKBTN=28
const BOLDBTN=31

const ANDBTN=29
const ORBTN=30

const TRIGRECALC=32

const OK=1
const CANCEL = 2

textval$ = string$(100," ") ' this is the variable to contain text values of cells, in case user wants to color the cell if EQUAL to a string
                    ' Handle cell values with strings up to 100 characters
OPTION GLOBAL    ' all function definitions below will be globally accessible

Function CreateCellSelection(cellsel%) as BOOLEAN

' this is called only when original selection is in the datapane
    r%=ModifySelHandle(cellsel%,"",sel_CELLSONLY)     ' try to create a cell selection out of it,if at all possible
    SetSelection(cellsel%)
    GetIntProperty(cellsel%,IT_SELTYPE, seltype&)
' each of the following types are all valid cell selections
    if seltype&=sel_CELLSONLY  or seltype&=sel_REFINED or seltype&=sel_CELL  then
        CreateCellSelection = TRUE
        else
        CreateCellSelection=FALSE
    end if
end Function



Function PutUpDialog as BOOLEAN

'this function fills the dialog and gets resulting values into global variables
if NOT ranonce? then
FillButton(REDBTN,1) ' dialog defaults to "Red if Negative" the first time

' Just to be sure, make sure all the others are "off"
for button=REDBTN+1 to BLACKBTN    ' this is dependent on the button control numbers being consecutive
FillButton(button,0)
next button

FillButton(BOLDBTN,0)
FillText(LTCTRL,"0")
' Just to be sure, fill the other text fields with nothing
FillText(GTCTRL,"")
FillText(EQCTRL,"")

FillButton(TRIGRECALC,0) ' don't check this box

FillButton(ANDBTN,1)    ' to default to "OR" case, set this global var to 0 during initialization
FillButton(ORBTN,0)

end if

DialBox("colorcel.dlg","colorcond",res%) ' since no path is given, scripts path will be searched.

if res%=OK then
PutUpDialog=TRUE
ranonce?=TRUE

ltcond=string$(100," ") ' to contain the value of the "less than" number typed into the dialog
gtcond=string$(100," ") ' to contain the value of the "greater than" number
eqcond=string$(100," ") ' to contain the value of the "equals" number or string


'get color
    GetDialogState(REDBTN,redv%)
    FillButton(REDBTN,redv%)        'Fill it for next time
    GetDialogState(BLUEBTN,bluev%)
    FillButton(BLUEBTN,bluev%)
    GetDialogState(YELLOWBTN,yellowv%)
    FillButton(YELLOWBTN,yellowv%)
    GetDialogState(MAGENTABTN,magentav%)
    FillButton(MAGENTABTN,magentav%)
    GetDialogState(CYANBTN,cyanv%)
    FillButton(CYANBTN,cyanv%)
    GetDialogState(BLACKBTN,blackv%)
    FillButton(BLACKBTN,blackv%)
    select case 1
    case redv%:
         clr=RED
    case bluev%:
        clr=BLUE
    case yellowv%:
        clr=YELLOW
    case magentav%:
        clr=MAGENTA
    case cyanv%:
        clr=CYAN
    case blackv%:
        clr=BLACK
    case else:
        print "No color chosen" ' should never happen
    end select

GetDialogState(BOLDBTN,bold%)     'Bold box checked?
FillButton(BOLDBTN,bold%)        ' set state for next time

GetDialogState(TRIGRECALC,trig%) ' Get check box state of "Trigger on Recalc"
if trig%=1 and not alreadyregistered? then
    RegisterColorRecalc()
    alreadyregistered?=TRUE
end if
if trig%=0 and alreadyregistered? then
    UnRegisterColorRecalc()
    alreadyregistered?=FALSE
end if

FillButton(TRIGRECALC,trig%) ' Set it again for next time
GetDialogState(ANDBTN,logand%) ' Gets Logical AND (if logand? is 0, then logical OR)
FillButton(ANDBTN,logand%)
if logand%=0 then FillButton(ORBTN,1)
'get value conditions

GetDialogField(LTCTRL,ltcond,len(ltcond)-1,actlen%)
FillText(LTCTRL,ltcond)
GetDialogField(GTCTRL,gtcond,len(gtcond)-1,actlen%)
FillText(GTCTRL,gtcond)
GetDialogField(EQCTRL,eqcond,len(eqcond)-1,actlen%)
FillText(EQCTRL,eqcond)


end if

if res%=CANCEL then
PutUpDialog=FALSE
'Even on Cancel, still have to fill dialog with previous values for next time
FillText(LTCTRL,ltcond)
FillText(GTCTRL,gtcond)
FillText(EQCTRL,eqcond)
FillButton(REDBTN,redv%)
FillButton(BLUEBTN,bluev%)
FillButton(YELLOWBTN,yellowv%)
FillButton(MAGENTABTN,magentav%)
FillButton(CYANBTN,cyanv%)
FillButton(BLACKBTN,blackv%)
FillButton(BOLDBTN,bold%)
FillButton(ANDBTN,logand%)
if logand%=0 then FillButton(ORBTN,1)
FillButton(TRIGRECALC,trig%)

print "Canceled"
end if

end Function

Function NumberP (string cellvalue) as BOOLEAN
' This function determines whether a given string can be converted to a number
on error ERR_COERCE
    NumberP=FALSE
end on
NumberP=TRUE
s#=Number(cellvalue)    ' if this operation triggers an ERR_COERCE, then the value is not a number
end Function

Function CheckAndColor(cellselection%)
golt?=FALSE
gogt?=FALSE
goeq?=FALSE
        if len(ltcond) > 0 then    ' if there's a string in the dialog field, convert to number
        ltnum=Val(ltcond)     ' this is where ltnum gets a value (otherwise its datatype remains NULL)
        golt?=TRUE
        end if

        if len(gtcond) > 0 then
        gtnum=Val(gtcond)    ' this is where gtnum gets a value (otherwise its datatype remains NULL)
        gogt?=TRUE
        end if

        if len(eqcond) > 0 then
            if NumberP(eqcond) then
                eqnum=Val(eqcond)    ' this is where eqnum gets a value (otherwise its datatype remains NULL
                'otherwise eqcond (string value) will be used
            end if
        goeq?=TRUE
        end if


'Get the conditions that make sense based on the above
' Use the "GO" variables to later determine whether the cell value should be checked for the condition

    SetIntProperty(cellselection%,TextFGColor,BLACK)     ' All cells first set to BLACK
    SetIntProperty(cellselection%,TextBold,0)        ' Set them to UnBold

    CreateIterator(cellselection%, SM_CELL, iHandle%)     ' Create an iterator to go through each cell in the selection

    r%= GetNextElement(iHandle%, cHandle%)         ' get the first cell in the selection
    Do While r% = err_OK                          ' GetNextElement will return an error when there are no more elements (cells)
        textval$ = string$(100," ")    ' make sure to reinitialize the size of the textval$ buffer for each cell value
                            ' because it gets truncated to the length of the text value
                            ' on the next command.
        GetCellValue(cHandle%, ct%,n#,textval$,len(textval$) -1,a%)
        'print n#
    if logand% = 1 then
        ltok? = TRUE    ' These variables say whether the cell value actually meets the condition
        gtok? = TRUE    ' Used later for logical AND case
        eqok? = TRUE    ' Initialize them all to true for AND case
    else
        ltok? = FALSE    ' this is for the logical OR case
        gtok? = FALSE
        eqok? = FALSE
    end if
        if golt?  then
            if ct%=cval_NUMBER then
                if n#<ltnum then
                ltok? = TRUE ' redundant, but logical
                else ltok? = FALSE
                end if
            else ltok? = FALSE
            end if
        end if
        if gogt? then
            if ct%=cval_NUMBER then
                if n# > gtnum then
                gtok? = TRUE ' redundant, but logical
                else gtok? = FALSE
                end if
            else gtok? = FALSE
            end if
        end if
        if goeq? then
            if numberp(eqcond)   then
                if n# = eqnum then
                eqok? = TRUE ' redundant, but logical
                else eqok? = FALSE
                end if
            else
                if ucase$(textval$) =ucase$(ltrim$(rtrim$(eqcond))) then    'Note:  ucase$ here  makes the matching case insensitive
                    eqok? = TRUE ' redundant, but logical
                    else eqok? = FALSE
                end if
            end if
        end if
'Finally, check the conditions, and do the work

    if logand% = 1 then
        if ltok? AND gtok? AND eqok? then
             SetIntProperty(cHandle%,TextFGColor, clr)
            if bold%=1 then SetIntProperty(cHandle%,TextBold,1)
        end if
    else
        if ltok? OR gtok? OR eqok? then
             SetIntProperty(cHandle%,TextFGColor, clr)
            if bold%=1 then SetIntProperty(cHandle%,TextBold,1)
        end if
    end if

        r%=GetNextElement(iHandle%, cHandle%)     ' get the next cell in the selection
    Loop

    FreeIterator(iHandle%)

end Function

end MODULE

'<<Name>> Selection : System Use Only
'***********Selection : System Use Only **********************************************
'* This script is called by Color Cells and  takes the current selection
'* to determine the most appropriate cell selection to CheckAndColor
'* This script is not called by the recalc trigger, which operates on all the cells in the
'* current worksheet
'****************************************************************************************
EnableRefresh(0)
GetIntGlobalProperty(GP_StatusBar,origsb&) ' capture original setting
SetIntGlobalProperty(GP_StatusBar,0) ' scripts run faster with it not displaying


origname$=string$(100," ")
long origseltype&

GetSelection(origsel%)
r%=GetStringProperty(origsel%,IT_SELNAME,origname$,len(origname$)-1,nameact%) 'get the name of the original selection
GetIntProperty(origsel%,IT_SELTYPE,origseltype&)     ' get the original selection type to change back later
select case origseltype&
    case sel_FORMULA :    ' if selection is formula(e), color cells it(they) calculate
        d%=PutUpDialog()
        if d% then
        CreateIterator(0,SM_FORMULA,formiter%)
        f%=GetNextElement(formiter%,nextform%)
            while f% = err_OK
            GetCellsForFormula(nextform%,cellsel%)
            CheckAndColor(cellsel%)
            f%=GetNextElement(formiter%,nextform%)
            wend
        else
        r%=ModifySelHandle(0,origname$,origseltype&) ' Set selection back to user's original selection
        end if
    case else :            ' if selection other than formula, make sure you can create cell selection from it.
        if CreateCellSelection(origsel%) then
            d%=PutUpDialog()
            if d% then
            SetSelectionByName(formula1%,"1",sel_FORMULA,"","","")     ' change the current selection to the formula pane (looks prettier)
            CheckAndColor(origsel%)
            r%=ModifySelHandle(0,origname$,origseltype&) ' Set selection back to user's original selection
            FreeSelHandle(formula1%)
        else
        r%=ModifySelHandle(0,origname$,origseltype&) ' Set selection back to user's original selection
            end if
        end if
end select

EnableRefresh(1)
SetIntGlobalProperty(GP_StatusBar,origsb&) ' reset status bar

'<<Name>> Recalc : System Use Only
'*****************Recalc : System Use Only **************************************************
'*  This is the script called by the Trigger Function after it's been registered;
'*  Registration happens  in CheckAndColor Function in Globals
'* and Color By Cell Value Script has already been run at least once,
'* so Global Functions are available
'* This script is different from the Selection script, in that it uses
'* All Cells in the Current Worksheet, instead of just those selected
'************************************************************************************************
EnableRefresh(0)
GetIntGlobalProperty(GP_StatusBar,origsb&) ' capture original setting
SetIntGlobalProperty(GP_StatusBar,0) ' scripts run faster with it not displaying
GetIntGlobalProperty(GP_UNDO,origundo&)
SetIntGlobalProperty(GP_UNDO,0)
viewname$=string$(80," ")
sheetname$=string$(80," ")
modelname$=string$(80," ")
catname$=string$(80," ")

GetSelection(current%)
GetStringProperty(current%,IT_CONTEXT1,viewname$, len(viewname$) -1,actlen%)
GetStringProperty(current%,IT_CONTEXT2,sheetname$, len(sheetname$) -1,actlen%)
GetStringProperty(current%,IT_MODELNAME,modelname$,len(modelname$)-1,actlen%)
CreateSelHandle(sheetsel%,sheetname$,sel_SHEET,viewname$,sheetname$,modelname$)

r%=CreateIterator(sheetsel%,SM_CATEGORY,sheetiter%)
GetNextElement(sheetiter%,onecat%)
'one category gives me all the cells in the worksheet
GetStringProperty(onecat%,IT_SELNAME,catname$,len(catname$)-1,actlen%)
CreateSelHandle(allcells%,catname$,sel_CELLSONLY,"","","")

CheckAndColor(allcells%)
SetIntGlobalProperty(GP_StatusBar,origsb&)
SetIntGlobalProperty(GP_UNDO,origundo&)
'<<Name>> Color Cells
'******************* Color Cells **************************************************************
'*    This script is the main procedure and when invoked will:
'*    (1) Load Global definitions, if not already loaded
'*    (2) Bring up a dialog box for user to choose conditions for coloring cells
'*          in the current selection.
'*    (3) If the user selects "All Cells on Recalc", a trigger will be registered,
'*          and all cells in the current worksheet will be colored according to the
'*          most recent conditions set in the dialog box.
'*    (4) This script can be invoked repeatedly to change the conditions for coloring
'*             and should also be used to remove the Recalc trigger (by unchecking the box)
'***********************************************************************************************

thisfile$="colorcel.lss"

GetIntGlobalProperty(GP_StatusBar,origsb&) ' capture original setting
SetIntGlobalProperty(GP_StatusBar,0) ' scripts run faster with it not displaying
GetIntGlobalProperty(GP_UNDO,origundo&)
SetIntGlobalProperty(GP_UNDO, 0)

cmodexists=FALSE
for i in session
if nameof(i) = "COLORCELLS" then
cmodexists=TRUE
end if
next

if cmodexists= FALSE then
RunScript(thisfile$,"Globals : System Use Only")
end if

RunScript(thisfile$,"Selection : System Use Only")


EnableRefresh(1)
SetIntGlobalProperty(GP_StatusBar,origsb&) ' scripts run faster with it not displaying
SetIntGlobalProperty(GP_UNDO,origundo&)