| 1 | TMGWSBR1 ;TMG/kst/OO Scroll Bar ;05/10/07
|
|---|
| 2 | ;;1.0;TMG-LIB;**1**;05/10/07
|
|---|
| 3 |
|
|---|
| 4 | ;"Kevin Toppenberg MD
|
|---|
| 5 | ;"GNU General Public License (GPL) applies
|
|---|
| 6 | ;"------------------------------------------
|
|---|
| 7 | ;"Object oriented window object setup code below
|
|---|
| 8 | ;"------------------------------------------
|
|---|
| 9 |
|
|---|
| 10 | Constructor(instanceName) ;"Module MUST have 'Constructor' procedure
|
|---|
| 11 | ;"Purpose -- A constructor for object Window
|
|---|
| 12 | ;"Input: instanceName -- the NAME of the type of the object to be defined.
|
|---|
| 13 | ;" This should be a variable (global or otherwise) of the object.
|
|---|
| 14 | ;"Note: This function should NOT be called directly, but instead is called
|
|---|
| 15 | ;" via new^TMGOOL
|
|---|
| 16 | ;"Result: none <--- REQUIRED TO NOT RETURN A RESULT
|
|---|
| 17 |
|
|---|
| 18 | ;"Here we define the default values for vars and functions.
|
|---|
| 19 |
|
|---|
| 20 | ;"----------------All constructors should copy this format --------------------
|
|---|
| 21 | new TMGthis set TMGthis=instanceName
|
|---|
| 22 |
|
|---|
| 23 | do inheritFrom^TMGOOL(instanceName,"TMGWGOJ")
|
|---|
| 24 |
|
|---|
| 25 | ;"---------------------------------------------------------
|
|---|
| 26 | ;"register PROCEDURES/FUNCTIONS
|
|---|
| 27 | do regFn^TMGOOL(TMGthis,"PAINT","Paint^TMGWSBR1()")
|
|---|
| 28 |
|
|---|
| 29 | ;"---------------------------------------------------------
|
|---|
| 30 | ;"Register Event Handlers
|
|---|
| 31 | do regEvent^TMGOOL(TMGthis,"CLICK","HandleClick^TMGWSBR1(LOC)") ;"override
|
|---|
| 32 |
|
|---|
| 33 | ;"---------------------------------------------------------------------
|
|---|
| 34 | ;"Register Properties
|
|---|
| 35 | do regProp^TMGOOL(TMGthis,"MAX VALUE",100,"setMax^TMGWSBR1") ;"
|
|---|
| 36 | do regProp^TMGOOL(TMGthis,"MIN VALUE",0,"setMin^TMGWSBR1") ;"
|
|---|
| 37 | do regProp^TMGOOL(TMGthis,"VALUE",50,"setValue^TMGWSBR1") ;"
|
|---|
| 38 | do regProp^TMGOOL(TMGthis,"PERCENT",50,"setPercent^TMGWSBR1") ;"
|
|---|
| 39 | do regProp^TMGOOL(TMGthis,"ORIENTATION","H") ;"[H]ORIZ VS. [V]ERT
|
|---|
| 40 |
|
|---|
| 41 | ;"--------------------------------------------------------------------------------
|
|---|
| 42 | ;"Optional initialization of some instance-specific variables.
|
|---|
| 43 |
|
|---|
| 44 |
|
|---|
| 45 | ;"--------------------------------------------------------------------------------
|
|---|
| 46 | ;"Startup code here...
|
|---|
| 47 |
|
|---|
| 48 | quit
|
|---|
| 49 |
|
|---|
| 50 |
|
|---|
| 51 | Destructor(instanceName) ;"Module MUST have 'Destructor' procedure
|
|---|
| 52 | ;"Purpose: A destructor for object Widget
|
|---|
| 53 | ;" any needed clean up code would go here first.
|
|---|
| 54 | ;"Input: instanceName -- the name of the object instance to be deleted.
|
|---|
| 55 | ;" This should be the value returned from defWidget
|
|---|
| 56 | ;"Note: Don't actually delete the object here. Just perform code needed to
|
|---|
| 57 | ;" save the object variables etc. Anything neeed before the object
|
|---|
| 58 | ;" is deleted by delete^TMGOOL
|
|---|
| 59 |
|
|---|
| 60 | ;"-----------------
|
|---|
| 61 |
|
|---|
| 62 | ;" Here I would put code that needs to be called before destruction of the object.
|
|---|
| 63 |
|
|---|
| 64 | ;"-----------------
|
|---|
| 65 |
|
|---|
| 66 | quit
|
|---|
| 67 |
|
|---|
| 68 |
|
|---|
| 69 | ;"------------------------------------------
|
|---|
| 70 | ;"Object member functions below
|
|---|
| 71 | ;"------------------------------------------
|
|---|
| 72 |
|
|---|
| 73 | ;"Note: A variable (with global scope) TMGthis is available as a 'this' pointer (this instance)
|
|---|
| 74 | ;"Note: ALL members must have QUIT xx (even if xx is meaningless, as in a procedure)
|
|---|
| 75 |
|
|---|
| 76 | Paint()
|
|---|
| 77 | ;"Purpose: To paint the scroolbar
|
|---|
| 78 | ;"Input: instanceName -- the name/ref of this instance
|
|---|
| 79 |
|
|---|
| 80 | new T,L,B,R,H,W,LOC
|
|---|
| 81 | new scrap set scrap=$$getProp^TMGOOL(TMGthis,"LOC",.LOC)
|
|---|
| 82 | do proc^TMGOOL(TMGthis,"CONVERT TO FRAME",.LOC,"SCREEN")
|
|---|
| 83 | set T=+$get(LOC("TOP")),L=+$get(LOC("LEFT"))
|
|---|
| 84 | set B=+$get(LOC("BOTTOM")),R=+$get(LOC("RIGHT"))
|
|---|
| 85 | set H=+$get(LOC("HEIGHT")),W=+$get(LOC("WIDTH"))
|
|---|
| 86 |
|
|---|
| 87 | new o set o=$$getProp^TMGOOL(TMGthis,"ORIENTATION")
|
|---|
| 88 | new pct set pct=$$getProp^TMGOOL(TMGthis,"PERCENT")
|
|---|
| 89 | new len set len=$select(o="H":(W),1:(H))
|
|---|
| 90 | set len=len-1 ;"avoid overlap in bottom-right corner.
|
|---|
| 91 | new tempS set tempS=$$getDispS(len,o,pct)
|
|---|
| 92 |
|
|---|
| 93 | if o="H" do SAY^TMGXGF(T,L,tempS)
|
|---|
| 94 | else do VSAY^TMGXGF(T,L,tempS)
|
|---|
| 95 |
|
|---|
| 96 | do setProp^TMGOOL(TMGthis,"NEEDS REPAINT",0) ;"flag as painted.
|
|---|
| 97 |
|
|---|
| 98 | quit 0
|
|---|
| 99 |
|
|---|
| 100 |
|
|---|
| 101 | ;"------------------------------------------
|
|---|
| 102 | ;"Property Getters & Setters below
|
|---|
| 103 | ;"------------------------------------------
|
|---|
| 104 |
|
|---|
| 105 | setMax(TMGthis,PropName,value)
|
|---|
| 106 | ;"Purpose: to set MAX value possible for scroll bar
|
|---|
| 107 | ;"Input: TMGthis -- a this pointer for properter setter.
|
|---|
| 108 | ;" PropName -- the name of the property -- not used here
|
|---|
| 109 | ;" value -- value to set
|
|---|
| 110 |
|
|---|
| 111 | set @TMGthis@("PROP","MAX")=$get(value)
|
|---|
| 112 | do setActualPct
|
|---|
| 113 | quit ;"<-- required not return value for property setter.
|
|---|
| 114 |
|
|---|
| 115 |
|
|---|
| 116 | setMin(TMGthis,PropName,value)
|
|---|
| 117 | ;"Purpose: to set MIN value possible for scroll bar
|
|---|
| 118 | ;"Input: TMGthis -- a this pointer for properter setter.
|
|---|
| 119 | ;" PropName -- the name of the property -- not used here
|
|---|
| 120 | ;" value -- value to set
|
|---|
| 121 |
|
|---|
| 122 | set @TMGthis@("PROP","MIN")=$get(value)
|
|---|
| 123 | do setActualPct
|
|---|
| 124 | quit ;"<-- required not return value for property setter.
|
|---|
| 125 |
|
|---|
| 126 |
|
|---|
| 127 | setValue(TMGthis,PropName,value)
|
|---|
| 128 | ;"Purpose: to set value for scroll bar
|
|---|
| 129 | ;"Input: TMGthis -- a this pointer for properter setter.
|
|---|
| 130 | ;" PropName -- the name of the property -- not used here
|
|---|
| 131 | ;" value -- value to set
|
|---|
| 132 |
|
|---|
| 133 | new max,min
|
|---|
| 134 | set max=$get(@TMGthis@("PROP","MAX"))
|
|---|
| 135 | set min=$get(@TMGthis@("PROP","MIN"))
|
|---|
| 136 | set value=+$get(value)
|
|---|
| 137 | if (value'>max)&(value'<min) do
|
|---|
| 138 | . set @TMGthis@("PROP","VALUE")=value
|
|---|
| 139 | . do setActualPct
|
|---|
| 140 | do setProp^TMGOOL(TMGthis,"NEEDS REPAINT",1)
|
|---|
| 141 | quit ;"<-- required not return value for property setter.
|
|---|
| 142 |
|
|---|
| 143 |
|
|---|
| 144 | setPercent(TMGthis,PropName,pct)
|
|---|
| 145 | ;"Purpose: to set percent value for scroll bar
|
|---|
| 146 | ;"Input: TMGthis -- a this pointer for properter setter.
|
|---|
| 147 | ;" PropName -- the name of the property -- not used here
|
|---|
| 148 | ;" pct -- value to set: expected input=0-100 (NOT 0.00-1.00)
|
|---|
| 149 |
|
|---|
| 150 | new max,min
|
|---|
| 151 | set max=$get(@TMGthis@("PROP","MAX"))
|
|---|
| 152 | set min=$get(@TMGthis@("PROP","MIN"))
|
|---|
| 153 | set pct=+$get(pct)
|
|---|
| 154 | if pct>100 set pct=100
|
|---|
| 155 | else if pct<0 set pct=0
|
|---|
| 156 | new range set range=max-min
|
|---|
| 157 | new value set value=(range*(pct/100))+min
|
|---|
| 158 | set @TMGthis@("PROP","VALUE")=value
|
|---|
| 159 | set @TMGthis@("PROP","PERCENT")=pct
|
|---|
| 160 | quit ;"<-- required not return value for property setter.
|
|---|
| 161 |
|
|---|
| 162 |
|
|---|
| 163 | setOrient(TMGthis,PropName,value)
|
|---|
| 164 | ;"Purpose: to set percent value for scroll bar
|
|---|
| 165 | ;"Input: TMGthis -- a this pointer for properter setter.
|
|---|
| 166 | ;" PropName -- the name of the property -- not used here
|
|---|
| 167 | ;" pct -- value to set: expected input="H" or "V"
|
|---|
| 168 |
|
|---|
| 169 | set value=$$UP^XLFSTR($extract(value,1))
|
|---|
| 170 | if (value="H")!(value="V") set @TMGthis@("PROP","ORIENTATION")=value
|
|---|
| 171 | quit ;"<-- required not return value for property setter.
|
|---|
| 172 |
|
|---|
| 173 | ;"------------------------------------------
|
|---|
| 174 | ;"Event handlers below
|
|---|
| 175 | ;"------------------------------------------
|
|---|
| 176 |
|
|---|
| 177 | HandleClick(LOC)
|
|---|
| 178 | ;"Purpose: do something here with a mouse click. Note: descendents can
|
|---|
| 179 | ;" overwrite this function to customize their control.
|
|---|
| 180 | ;"Input: LOC -- PASS BY REFERNCE. Expected input format:
|
|---|
| 181 | ;" coordinates in LOCAL frame of refeernces.
|
|---|
| 182 | ;" LOC("TOP")=
|
|---|
| 183 | ;" LOC("LEFT")=
|
|---|
| 184 | ;" LOC("HEIGHT")= ;"optional
|
|---|
| 185 | ;" LOC("WIDTH")= ;"optional
|
|---|
| 186 | ;" LOC("BOTTOM")= ;"optional
|
|---|
| 187 | ;" LOC("RIGHT")= ;"optional
|
|---|
| 188 | ;"Note: It has already been determined that the click belongs to this window
|
|---|
| 189 | ;" (and not a child of this window), so it should be handled here.)
|
|---|
| 190 |
|
|---|
| 191 | ;"Click belongs to this window, so handle it.
|
|---|
| 192 |
|
|---|
| 193 | ;"Put default click handler code here...
|
|---|
| 194 |
|
|---|
| 195 | do proc^TMGOOL(TMGthis,"CONVERT TO FRAME",.LOC,TMGthis) ;"ensure coordinates in TMGthis's frame
|
|---|
| 196 |
|
|---|
| 197 | new L set L=$get(LOC("LEFT"))
|
|---|
| 198 | new T set T=$get(LOC("TOP"))
|
|---|
| 199 |
|
|---|
| 200 | new orient set orient=$$getProp^TMGOOL(TMGthis,"ORIENTATION")
|
|---|
| 201 | if orient="H" do
|
|---|
| 202 | . new W set W=$$getProp^TMGOOL(TMGthis,"WIDTH")
|
|---|
| 203 | . if L=0 do scrlMinus(1)
|
|---|
| 204 | . ;"For line below: why W-2?
|
|---|
| 205 | . ;" A: numbering starts at 0, so W seems 1 too long
|
|---|
| 206 | . ;" then subtract another 1 to avoid overlap with Vscroll bar
|
|---|
| 207 | . else if L=(W-2) do scrlPlus(1)
|
|---|
| 208 | . else do
|
|---|
| 209 | . . new pos set pos=$$getMrkPos()
|
|---|
| 210 | . . if L<pos do scrlPLeft
|
|---|
| 211 | . . if L>pos do scrlPRight
|
|---|
| 212 | else if orient="V" do
|
|---|
| 213 | . new H set H=$$getProp^TMGOOL(TMGthis,"HEIGHT")
|
|---|
| 214 | . if T=0 do scrlMinus(1)
|
|---|
| 215 | . ;"For line below: why H-1?
|
|---|
| 216 | . ;" A: numbering starts at 0, so H seems 1 too long
|
|---|
| 217 | . ;" no need to subtract another 1 re overlap, because Vscroller has corner
|
|---|
| 218 | . else if T=(H-2) do scrlPlus(1)
|
|---|
| 219 | . else do
|
|---|
| 220 | . . new pos set pos=$$getMrkPos()
|
|---|
| 221 | . . if T<pos do scrlPUp
|
|---|
| 222 | . . if T>pos do scrlPDown
|
|---|
| 223 |
|
|---|
| 224 |
|
|---|
| 225 | HCDone
|
|---|
| 226 | quit ;"<-- required: NO return value for event handler
|
|---|
| 227 |
|
|---|
| 228 |
|
|---|
| 229 |
|
|---|
| 230 |
|
|---|
| 231 | ;"------------------------------------------
|
|---|
| 232 | ;"Private functions below
|
|---|
| 233 | ;"------------------------------------------
|
|---|
| 234 |
|
|---|
| 235 | getMrkPos()
|
|---|
| 236 | ;"Purpose: to get the graphical position of the marker on
|
|---|
| 237 | ;" the scroll bar.
|
|---|
| 238 | new o set o=$$getProp^TMGOOL(TMGthis,"ORIENTATION")
|
|---|
| 239 | new pct set pct=$$getProp^TMGOOL(TMGthis,"PERCENT")
|
|---|
| 240 | new len set len=$select(o="H":(W),1:(H))
|
|---|
| 241 | set len=len-1 ;"avoid overlap in bottom-right corner.
|
|---|
| 242 | new tempS set tempS=$$getDispS(len,o,pct)
|
|---|
| 243 | new s set s=$piece(tempS,"*",1)
|
|---|
| 244 | quit $length(s)
|
|---|
| 245 |
|
|---|
| 246 | scrlPLeft
|
|---|
| 247 | ;"Purpose: to handle a request to scroll a page to the left
|
|---|
| 248 | new W set W=$$getProp^TMGOOL(TMGthis,"WIDTH")
|
|---|
| 249 | do scrlMinus(W)
|
|---|
| 250 | quit
|
|---|
| 251 |
|
|---|
| 252 | scrlPRight
|
|---|
| 253 | ;"Purpose: to handle a request to scroll a page to the left
|
|---|
| 254 | new W set W=$$getProp^TMGOOL(TMGthis,"WIDTH")
|
|---|
| 255 | do scrlPlus(W)
|
|---|
| 256 | quit
|
|---|
| 257 |
|
|---|
| 258 | scrlPUp
|
|---|
| 259 | ;"Purpose: to handle a request to scroll a page to the left
|
|---|
| 260 | new H set H=$$getProp^TMGOOL(TMGthis,"HEIGHT")
|
|---|
| 261 | do scrlMinus(H)
|
|---|
| 262 | quit
|
|---|
| 263 |
|
|---|
| 264 | scrlPDown
|
|---|
| 265 | ;"Purpose: to handle a request to scroll a page to the left
|
|---|
| 266 | new H set H=$$getProp^TMGOOL(TMGthis,"HEIGHT")
|
|---|
| 267 | do scrlPlus(H)
|
|---|
| 268 | quit
|
|---|
| 269 |
|
|---|
| 270 | scrlMinus(num)
|
|---|
| 271 | ;"Purpose: to handle a request to scroll to the minus direction (left, or up)
|
|---|
| 272 | new value set value=$$getProp^TMGOOL(TMGthis,"VALUE")
|
|---|
| 273 | set value=value-num
|
|---|
| 274 | do setProp^TMGOOL(TMGthis,"VALUE",value)
|
|---|
| 275 | quit
|
|---|
| 276 |
|
|---|
| 277 | scrlPlus(num)
|
|---|
| 278 | ;"Purpose: to handle a request to scroll to the plus direction (right or down)
|
|---|
| 279 | new value set value=$$getProp^TMGOOL(TMGthis,"VALUE")
|
|---|
| 280 | set value=value+num
|
|---|
| 281 | do setProp^TMGOOL(TMGthis,"VALUE",value)
|
|---|
| 282 | quit
|
|---|
| 283 |
|
|---|
| 284 |
|
|---|
| 285 |
|
|---|
| 286 | setActualPct
|
|---|
| 287 | ;"Purpose: to set the value of PERCENT to match current values
|
|---|
| 288 |
|
|---|
| 289 | new max,min,value
|
|---|
| 290 | set max=$get(@TMGthis@("PROP","MAX"))
|
|---|
| 291 | set min=$get(@TMGthis@("PROP","MIN"))
|
|---|
| 292 | set value=$get(@TMGthis@("PROP","VALUE"))
|
|---|
| 293 |
|
|---|
| 294 | new range set range=max-min
|
|---|
| 295 | new pos set pos=value-min
|
|---|
| 296 | new pct set pct=0
|
|---|
| 297 |
|
|---|
| 298 | if range'=0 set pct=((pos/range)*100)
|
|---|
| 299 | set @TMGthis@("PROP","PERCENT")=pct
|
|---|
| 300 | quit
|
|---|
| 301 |
|
|---|
| 302 |
|
|---|
| 303 | getDispS(len,o,pct)
|
|---|
| 304 | ;"Purpose: get a string that represents the scroll bar
|
|---|
| 305 | ;" e.g. '<---#------>'
|
|---|
| 306 | ;" or if orientation is vertical: '^||||#|||v'
|
|---|
| 307 | ;"Input: len -- the total length of the string to be returned
|
|---|
| 308 | ;" o -- orientation: 'H' or 'V'
|
|---|
| 309 | ;" pct -- the percent position
|
|---|
| 310 | ;"results: returns string, or "" if length<3
|
|---|
| 311 |
|
|---|
| 312 | new result set result=""
|
|---|
| 313 | set len=$get(len)-2 ;"shrink for arrows on ends
|
|---|
| 314 | if len'>0 goto gDSDone
|
|---|
| 315 | set o=$get(o,"H")
|
|---|
| 316 | set pct=+$get(pct)
|
|---|
| 317 | ;"if o="H" set len=len-1 ;"avoid overlap with HORIZ bar at the corner
|
|---|
| 318 |
|
|---|
| 319 | new bar
|
|---|
| 320 | ;"if o="V" set $piece(bar,$get(IOVL,"|"),len+2)=" "
|
|---|
| 321 | ;"else set $piece(bar,$get(IOHL,"-"),len+2)=" "
|
|---|
| 322 | if o="V" set $piece(bar,"|",len+2)=" "
|
|---|
| 323 | else set $piece(bar,"-",len+2)=" "
|
|---|
| 324 |
|
|---|
| 325 | new pre,post
|
|---|
| 326 | set pre=(len*pct\100),post=len-pre
|
|---|
| 327 | set result=result_$extract(bar,1,pre-1)_"*"_$extract(bar,1,post)
|
|---|
| 328 |
|
|---|
| 329 | if o="V" set result="^"_result_"v"
|
|---|
| 330 | else set result="<"_result_">"
|
|---|
| 331 |
|
|---|
| 332 | gDSDone
|
|---|
| 333 | quit result
|
|---|
| 334 |
|
|---|
| 335 |
|
|---|
| 336 |
|
|---|
