Module Windows.pkg
1// Windows.pkg - provides basic class for windows classes.
2
3Use VDFBase.pkg
4
5// Current Package version - can be used by programs to
6// make sure the packages are up to date (use command Validate_packages)
7#Replace PKG_Version |CI16
8#Replace PKG_Revision |CI1
9#REPLACE PKG_Build |CI0
10
11Enum_List // Text Alignment
12 Define taLeftJustify
13 Define taCenterJustify
14 Define taRightJustify
15End_Enum_List
16
17Enum_List // control alignment within parent
18 Define alTop
19 Define alBottom
20 Define alNone
21End_Enum_List
22
23
24// used by dbCombo and dbGrid with combos to determine what is displayed in the window
25Enum_list // what to display in the data window
26 Define CB_Code_Display_Description
27 Define CB_Code_Display_Code
28 Define CB_Code_Display_Both
29End_Enum_list
30
31Define kSwitch_Panel FOR KEY_ALT+KEY_F6
32Define kSwitch_Panel_Back FOR KEY_CTRL+KEY_F6
33
34
35Use GlobalFunctionsProcedures.pkg // adds global functions and procs used by VDF
36
37Global_Variable Integer ghoApplication // define handle to global application object. Many packages use this to determine
38Move 0 to ghoApplication // if an application object exists.
39
40Global_Variable Integer ghoSkinFramework // define handle to global skin framework object.
41Move 0 to ghoSkinFramework
42
43Global_Variable Integer ghoToolTipController // define handle to global ToolTip handler object.
44Move 0 to ghoToolTipController
45
46// these are used by DataDict (and perhaps others) in error support.
47Global_Variable integer ghoErrorSource
48Move 0 to ghoErrorSource
49// ghoErrorSource object is expected to support this message
50Register_Function Extended_Error_Message returns string
51
52
53Define DEFAULT_DIALOG_NeighborHood for nhPublic
54Define DEFAULT_CONTAINER_NeighborHood for nhNo
55
56Use VersionControl.pkg // version control checking commands and procedure
57 // this package will gen compiler and RT errors if fmac
58 // packages or runtime are out of synch.
59Use DfColor.pkg // symbolic replacements for colors
60Use Help_mx.pkg // Context help protocol
61Use Modal_mx.pkg // modal object support
62Use WinUser.pkg // windows API support
63Use WinKern.pkg
64Use CommCtrl.pkg
65Use Autolcmx.pkg // Auto-locate override logic for windows
66Use StHlp_mx.pkg // Status help mixin
67Use DFAutmgn.pkg // auto form_margin, form_column, form_datatype support
68use kbdfix.pkg
69
70
71Define Capslock_Bit for 19 // can be used in Item_Option.
72Define Capslock_Bit_Value for |CI$00080000 // The value when bit 19 is set
73
74// Redefine Exit-application beahviors so that:
75//
76// 1. Exit_Application is always delegated to the desktop
77// 2. From desktop it gets exit_system_confirmation
78// 3. Exit_system_confirmation Broadcasts verify_exit_application and
79// if successful broadcasts Notify_Exit_application (these will be
80// (received by main_panels to do with what they want).
81//
82{ Visibility=Private }
83Function Desktop_Verify_Exit_Application For cDesktop Returns Integer
84 Integer Fail
85 Broadcast Get Broadcast_Verify_Exit_Application To Fail
86 Function_Return Fail
87End_Function
88
89{ Visibility=Private }
90Procedure Desktop_Notify_Exit_Application For cDesktop
91 Broadcast Send Broadcast_Notify_Exit_Application
92End_Procedure // Notify_Exit_Application
93
94Function Exit_System_Confirmation For cDesktop Returns Integer
95 Integer Fail
96 Get Desktop_Verify_Exit_Application of desktop To Fail
97 If Not Fail ;
98 Send Desktop_Notify_Exit_Application to desktop
99 Function_Return (Not(Fail))
100End_Function
101
102// We want this to delegate right up to Desktop object. So create for cObject that
103// simply delegates and a for cDesktop, that does that actual work
104
105Procedure Exit_Application For cObject
106 Delegate Send Exit_Application
107End_Procedure
108
109{ Visibility=Public }
110Procedure Exit_Application For cDesktop
111 If (Exit_System_Confirmation(self)) Abort
112End_Procedure
113
114
115// Take the last key processed by the Key message and return
116// its ANSI value. Returns 0, if a non-printable character (e.g. F1).
117// This should normally only get called within a Key message handler
118{ Visibility=Private }
119Function AnsiKey FOR cUIObject Returns integer
120 integer vkCode
121 integer iShift iCapsLock
122 integer iCh
123 get virtual_key to vkcode
124 get shift_state to iShift // this has Key_Alt, Key_Shift and Key_Ctrl
125 Get_Key_State VK_CAPITAL to iCapslock // is the capslock key currently depressed?
126 Get To_Ascii vkCode (iShift IAND KEY_SHIFT<>0) (iCapslock=1) to iCh
127 Function_Return iCh
128End_Function
129
130// Take the last key processed by the Key message and return
131// its OEM value. Returns 0, if a non-printable character (e.g. F1).
132// This should normally only get called within a Key message handler. This is what
133// you want if you are comparing this with other data in your proggrams
134{ Visibility=Private }
135Function OemKey FOR cUIObject Returns integer
136 Function_Return (ascii(ToOEM(Character(AnsiKey(self)))))
137end_function
138
139// Take the last key processed by the Key message and return
140// its DF value. If a printable character it returns OEM value. If
141// a special key (f1, Key_save, etc.) returns the DF name of this key.
142//
143{ Visibility=Private }
144Function DFKey FOR cUIObject integer iKey Returns integer
145 integer iCh
146 Get OemKey to iCh
147 // if non-zero return OEM char value, If zero return the DF value (which is passed)
148 // first stripping off the shift bits. The passed key would be the key sent by the
149 // Key message.
150 Function_Return (if(ich, iCh, (iKey iAND $F1FF))) // $F1FF= Not (Key_Shift+Key_Alt+Key_Ctrl)
151End_Function
152
153
154
155//*** Mixin class: Bitmap_Support_Mixin
156//***
157//*** 1. Adds support for get Bitmap property to those classes which can
158//*** already support [set] bitmap.
159//
160Class Bitmap_Support_Mixin Is A Mixin
161 { Visibility=Private }
162 Procedure Define_Bitmap_Support_Mixin
163 { Visibility=Private }
164 Property String private.bitmap ""
165 End_Procedure
166
167 { MethodType=Property }
168 Procedure Set Bitmap String sBitmap
169 set private.bitmap to sBitmap
170 forward set bitmap to sBitmap
171 End_Procedure
172
173 { MethodType=Property }
174 Function Bitmap Returns string
175 Function_Return (private.bitmap(self))
176 End_Function
177
178End_Class
179
180
181//
182// Mixin Classes
183//
184
185Class Label_Mixin Is A Mixin
186
187 { MethodType=Property }
188 { Category=Appearance }
189 { InitialValue="" }
190 Procedure Set Label String Val
191 Set Value Item 0 To Val
192 End_Procedure
193
194 { MethodType=Property }
195 Function Label Returns String
196 Function_Return (Value(self,0))
197 End_Function
198
199End_Class
200
201//
202// This mixin is used by single item and no item objects for shadow
203// support.
204//
205// Note that an object supports three levels of shadowing. A single item
206// can be shadowed (if applicable), an object can be explicitly shadowed
207// or an object can be indirectly shadowed by a parent.
208//
209// Public Interface:
210//
211// Get/Set Object_Shadow_State Sets the object's explicit SS.
212// Gets object's explicit IOR Implicit SS
213// Get/Set Item_Shadow_State (if items are applicable)
214// Get Implicit_Shadow_State if shadowed as group by ancestor
215// Get Explicit_Shadow_State if shadowed by self
216// Get Implicit_Hidden_State if hidden by an active parent (like a parent tab page)
217// Send Shadow_Display
218//
219// Get/Set Shadow_State (if item based, sets item, else object)
220// An object is shadowed if it is explicitly or implicitly shadowed. We now have two flavors of
221// implicit. Either shadowed by a parent or hidden by a parent (e.g. parent tab page). If shadowed under
222// any of these conditions the physical shadow_state must be true so that navigation skips it.
223
224Class Shadow_Mixin Is A Mixin
225
226 { Visibility=Private }
227 Procedure Define_Shadow_Mixin
228 // Should child objects receive shadow notification?
229 { Visibility=Private }
230 Property Integer Broadcast_Implicit_Shadow_State False
231
232 { Visibility=Private }
233 Property Integer Private.Explicit_Shadow_State False
234
235 { Visibility=Private }
236 Property Integer Private.Implicit_Shadow_State False
237
238 { Visibility=Private }
239 Property Integer Private.Implicit_Hidden_State False // PRIVATE
240
241 // will be used by objects that have no runtime shadow_state
242 // item property (edits and containers)
243 //
244 { Visibility=Private }
245 Property Integer Private.Shadow_State False
246 End_Procedure // Construct_Object
247
248 Register_Function Object_Shadow_State returns integer
249
250 // Returns true if the object is shadowed as part of a group shadow.
251 //
252 { MethodType=Property Visibility=Private }
253 Function Implicit_Shadow_State returns Boolean
254 Function_Return (Private.Implicit_Shadow_State(self))
255 End_Function // Implicit_Shadow_State
256
257 // Returns true if the object is explicitly shadowed by self
258 //
259 { MethodType=Property }
260 Function Explicit_Shadow_State returns Boolean
261 Function_Return (Private.Explicit_Shadow_State(self))
262 End_Function // Explicit_Shadow_State
263
264 // Returns true if the object is active but hidden (like a child of a tab page)
265 { MethodType=Property Visibility=Private }
266 Function Implicit_Hidden_state returns integer
267 Function_Return (Active_State(self) and Private.Implicit_Hidden_State(self))
268 End_Function // Implicit_Shadow_State
269
270 // Private: Should only be sent by an ancestor object which is
271 // notifying all descendants that they have been shadowed as part
272 // of a group
273 //
274 { MethodType=Property Visibility=Private }
275 Procedure Set Implicit_Shadow_State integer iState
276 Set Private.Implicit_Shadow_State to iState // store group shadow status
277 // If the object is explicitly shadowed by the object we don't do anything
278 // because if state=T it is already shadowed (nothing to do) and if
279 // state=F we don't want to unshadow this one anyway
280 If Not (Explicit_Shadow_State(self)) Begin
281 Set Current_Shadow_State to iState
282 Send Shadow_display
283 if (Broadcast_Implicit_Shadow_State(self)) ;
284 Broadcast Set Implicit_Shadow_State to iState
285 End
286 End_Procedure // Set Implicit_Shadow_State
287
288 // private. This sets implicit shadowing for child objects within a tab page. This is similar to
289 // Implicit_shadow_state except that it should not send shadow_display. Shadowing
290 // and unShadowing causes color side effects (unshadow ignores the old background color) so when shadowing
291 // for tab children (which you will never see) we just do nothing. Set the implicit shadowing is still needed
292 // to make the navigation work properly.
293
294 { Visibility=Private }
295 Procedure DoImplicitTabHide integer iState
296 Set Private.Implicit_Hidden_State to iState // = hidden by a parent
297 // broadcast so all private hidden states are correct
298 Broadcast Send DoImplicitTabHide iState // change here
299 End_Procedure // DoImplicitTabHide
300
301 { MethodType=Property }
302 { InitialValue=False }
303 { DesignTime=False }
304 { PropertyType=Boolean }
305 Procedure Set Object_Shadow_State Integer iState
306 // If explictly shadowed, nothing to do. It's already shadowed
307 If (Explicit_Shadow_state(self)=iState) Procedure_return
308 Set Private.Explicit_Shadow_State to iState
309 // If not implicitly shadowed skip....
310 If Not (Implicit_Shadow_State(self)) Begin
311 Set Current_Shadow_State to iState
312 Send Shadow_display
313 if (Broadcast_Implicit_Shadow_State(self)) ;
314 Broadcast Set Implicit_Shadow_State to iState
315 End
316 End_Procedure // Set Object_Shadow_State
317
318
319 { MethodType=Event }
320 Procedure Shadow_Display
321 End_Procedure
322
323 // Item_shadow_state always gets the item's SS
324 //
325 { MethodType=Property }
326 { InitialValue=False }
327 Procedure Set Item_Shadow_State integer iItem integer iState
328 Forward Set Shadow_State item iItem to iState
329 End_Procedure // Set Item_Shadow_State
330
331 { MethodType=Property }
332 Function Item_Shadow_State integer iItem Returns integer
333 integer iState
334 Forward Get Shadow_State item iItem to iState
335 Function_Return iState
336 End_Function // Item_Shadow_State
337
338 // Current_Shadow_State sets the object's true shadow-state
339 // With single item objects we use
340 // the shadow_state of item 0 (the only item) to let store this
341 // information. In multi-item this must be replaced (see multi-item below)
342 // This is for the single item model
343 //
344 { MethodType=Property Visibility=Private }
345 Procedure Set Current_Shadow_State integer iState
346 Set Item_Shadow_State item 0 to iState
347 End_Procedure // Set Current_Shadow_State
348
349 // This returns if the object is truly shadowed. In single item we
350 // use item 0
351 //
352 { MethodType=Property }
353 Function Object_Shadow_State returns integer
354 Function_Return (Item_shadow_State(self,0))
355 End_Function // Object_Shadow_State
356
357 // Enabled_State, for this rev, simply calls Object_Shadow_State but
358 // inverts the parameter logic because Enabled_State is "enable centric"
359 // vs. Shadow_State which is "disable centric". KCR
360 //
361 { MethodType=Property }
362 { InitialValue=True }
363 { Category=Appearance }
364 { PropertyType=Boolean }
365 Procedure Set Enabled_State Integer bState
366 set Object_Shadow_State to (not(bState))
367 End_Procedure
368
369 // Again, we're calling upon Object_Shadow_State and simply inverting
370 // the return value to match the context of the "enable centric"
371 // property. KCR
372 //
373 { MethodType=Property }
374 Function Enabled_State returns Integer
375 Function_Return (not(object_shadow_state(self)))
376 End_Function
377
378 // Shadow_State can apply either to the object or the item. In single
379 // item or no item objects it refers to the object. In multi-item it
380 // refers to the item. This is the single item model
381 { MethodType=Property Visibility=Private Obsolete=True }
382 Procedure Set Shadow_State integer iItem integer iState
383 Set Object_Shadow_State to iState
384 End_Procedure
385
386 { MethodType=Property Visibility=Private Obsolete=True }
387 Function Shadow_State integer iItem returns Integer
388 Function_Return (Object_Shadow_State(self))
389 End_Function
390
391
392 // if next or prior object results in a ring it cannot get out of, it calls this
393 // and expects this to return an object ID or 0, to tell what to do
394 { Visibility=Private }
395 Function StuckInRing integer bDown returns handle
396 handle hoID
397 if (scope_state(self)) function_return 0 // if scope, nothing we can do.
398 if (bDown) ; // else, we can try to get out
399 get next_object_id 1 to hoId // of the ring
400 else ;
401 get prior_object_id 1 to hoId
402 function_return hoId
403 end_function
404
405
406 { MethodType=Property Visibility=Private }
407 Function private.Next_object_id integer fg returns integer
408 integer hId
409 Forward Get Next_object_id fg to hId
410 function_return hId
411 end_function
412
413 { MethodType=Property Visibility=Private }
414 Function private.prior_object_id integer fg returns integer
415 integer hId
416 Forward Get prior_object_id fg to hId
417 function_return hId
418 end_function
419
420 // Private:
421 // needed by navigation (next_object_id). If the selected object is a container
422 // it will receive the activate message. If the container already has the focus, it
423 // will not do anything. We need to know if that will be the case. This is augmented
424 // by tab-pages which actually will change the focus when sent activate.
425 //
426 { Visibility=Private }
427 function ContainerFocusWillNotChange returns integer
428 function_return (client_area_state(self) and containsFocus(self))
429 end_function
430
431 Function Prior_Object_Id integer bNoDescend returns integer
432 Handle hoID hoFirst
433
434 // If object is not if focus tree, we cannot do this. You should never
435 // send this to a non-active object
436 If (not(Active_state(self))) Function_return 0
437
438 If (Implicit_Shadow_State(self) OR Implicit_Hidden_State(self)) ;
439 Move 1 to bNoDescend
440 Get Private.Prior_object_id bNoDescend to hoId
441 // Keep track of first object we check. This way if we descend into
442 // a ring we will know it.
443 Move hoId to hoFirst // use to test if we are stuck in a ring
444 While (hoId>Desktop AND (Object_Shadow_State(hoId) OR Implicit_Hidden_state(hoId) or Focus_mode(hoId)=Pointer_only))
445 If (Implicit_Hidden_State(hoId)) Begin
446 Repeat // if hidden, go up until you find not-hidden item (will be tab page)
447 get Prior_level of hoId to hoId
448 until (hoId<=desktop or Implicit_Hidden_state(hoId)=0)
449 end
450 else If (Implicit_Shadow_State(hoId)) Begin
451 Repeat // if implicit shadow, go up until it is not shadowed
452 get Prior_level of hoId to hoId
453 until (hoId<=desktop or Implicit_Shadow_state(hoId)=0)
454 end
455 If (hoId>Desktop) ;
456 Get Private.Prior_Object_Id of hoId 0 to hoId
457 // if back to first object...get out
458 If (hoId=hoFirst) begin
459 get ringparent of hoId to hoId
460 If (hoId) ;
461 get StuckInRing of hoId 0 to hoId
462 Function_Return hoId
463 end
464 End
465 If (hoID=self or hoID<=Desktop) move 0 to hoId
466 Function_Return hoId
467 End_Function
468
469 Function Next_Object_Id integer bNoDescend returns integer
470 Handle hoID hoFirst
471 integer iCount
472 // If object is not if focus tree, we cannot do this. You should never
473 // send this to a non-active object
474 If (not(Active_state(self))) Function_return 0
475
476 // Never descend into shadowed objects...there's no point
477 If (bNoDescend=0 AND Object_Shadow_State(self)) ;
478 Move 1 to bNoDescend
479 Get Private.Next_object_id bNoDescend to hoId
480 Move hoId to hoFirst // use to test if we are stuck in a ring
481 // Loop until we find a valid object. Skip shadowed objects
482 While (hoId>Desktop AND (Object_Shadow_State(hoId) Or Implicit_hidden_state(self) or Focus_mode(hoId)=Pointer_only))
483 // if shadowed, get id up one level
484 Get Private.Next_Object_Id of hoId 1 to hoId
485 // if back to first object...get out
486 If (hoId=hoFirst) begin
487 get ringparent of hoId to hoId
488 If (hoId) ;
489 get StuckInRing of hoId 1 to hoId
490 Function_Return hoId
491 end
492 increment iCount
493 If (iCount>5000) begin
494 function_return 0
495 end
496
497 Loop
498 // If we have a valid next object check to see if it is a container and if it has the focus
499 // If it does, sending activate will do nothing. So we must look inside the container to find
500 // the next focusable object.
501 Move 0 to hoFirst
502 While ( hoID<>self AND hoID>Desktop and ContainerFocusWillNotChange(hoId) and hoId<>hoFirst)
503 // use to test if we are stuck in a loop. This is unlikely, I can not think of any situations
504 // where it might occur, but we should protect against this anyway.
505 Move hoId to hoFirst
506 Get Next_object_id of hoId 0 to hoId
507 end
508 If (hoID=self or hoID<=Desktop) move 0 to hoId
509 Function_Return hoId
510 End_Function // Next_object_id
511
512
513 procedure Top_of_Panel
514 handle hoFirst
515 // protect against sending this to a non active view
516 If (Active_state(self)) Begin
517 Get Next_Object_ID 0 to hoFirst
518 if hoFirst Begin
519 if (client_area_state(hoFirst) AND containsFocus(hoFirst)) ;
520 Send top_of_panel to hoFirst
521 else ;
522 send activate of hoFirst
523 end
524 else ;
525 Send Activate
526 end
527 end_procedure
528
529 procedure Bottom_of_Panel
530 handle hoLast
531 // protect against sending this to a non active view
532 If (Active_state(self)) Begin
533 get next_level to holast
534 if hoLast ;
535 get Prior_object_id of hoLast 0 to hoLast
536 if hoLast ;
537 send activate of hoLast
538 else ;
539 Send Activate
540 end
541 end_procedure
542
543 // Move focus to first focusable object in panel
544 // "Panel" is defined as the scope object
545 //
546 procedure Beginning_of_Panel
547 if (Scope_State(self)) Begin
548 // you can not send beginning of panel to a non-active view because
549 // it send activate to some object within the (non-active) view
550 If (Active_State(self)) Begin // if not active, do nothing
551 send top_of_panel
552 // This sends OnBeginningOfPanel to all objects in panel
553 Send NotifyBeginningOfPanel self
554 end
555 end
556 else ; // delegate message to scope object
557 delegate send Beginning_of_Panel
558 end_procedure
559
560
561 procedure End_of_Panel
562 if (Scope_State(self)) Begin
563 // you can not send end of panel to a non-active view because
564 // it send activate to some object within the (non-active) view
565 If (Active_State(self)) send bottom_of_panel
566 end
567 else ;
568 delegate send End_of_Panel
569 end_procedure
570
571 // When Beginning_of_panel is called all child objects need to be sent the message
572 // OnBeginningOfPanel. This is the private notification process.
573 //
574 { Visibility=Private }
575 Procedure NotifyBeginningOfPanel integer hoPanel
576 Send OnBeginningOfPanel hoPanel
577 Broadcast Send NotifyBeginningOfPanel hoPanel
578 End_procedure
579
580 // Public Event sent to all objects after a Beginning_of_panel is sent
581 //
582 { MethodType=Event }
583 Procedure OnBeginningOfPanel integer hoPanel
584 end_procedure
585
586
587 { NoDoc=True }
588 Procedure Activate returns integer
589 integer rVal
590 If (active_state(self) AND (Object_Shadow_State(self) or implicit_hidden_state(self))) ;
591 Move 1 to rVal
592 else ;
593 Forward Get MSG_Activate to rVal
594 Procedure_Return rVal
595 End_Procedure // Activate
596
597 { MethodType=Event NoDoc=True }
598 Procedure Entering Returns Integer
599 Integer rVal
600 // if entering is ok and single item check shadow state of that item.
601 Get Object_Shadow_State To rVal
602 If not rVal ;
603 Forward Get Msg_Entering To rVal // Do Normal Entering
604 Procedure_Return rVal
605 End_Procedure
606
607 // Activate an object Area. If the object is not in the focus tree
608 // delegate until a popup object, scoped object, or child of desktop is
609 // encountered and activate that group. If TakeFocusFg is true, make sure
610 // this object ends up with the focus. The is similar in logic to
611 // deactivate area_flag. Used by Validate_Items to make sure a popup
612 // object or a popup group takes the focus properly.
613 //
614 Procedure Activate_Area Integer TakeFocusFg
615 Integer PopSt
616 Get Popup_State to PopSt
617 // If not in focus tree make sure the entire object area is
618 // added to focus-tree. Treat popup and non-popup the same.
619
620 // In VDF7 tab controls in tab pages can be active but hidden.
621 // So must be active and not hidden. If active and hidden, it is within a tab page and the
622 // entire page needs repaging.
623 If not (Active_State(Self) AND (not(implicit_Hidden_state(self))) ) Begin
624 If PopSt Send Popup
625 Else If ( Scope_State(self) OR ;
626 Parent(self)=DESKTOP ) Send Activate
627 Else Delegate Send Activate_Area False
628 End
629 // make sure this object has the focus if required.
630 If ( TakeFocusFg AND Active_State(self) AND ;
631 Focus(Desktop)<>self ) Begin
632 If popSt Send Popup
633 else Send Activate
634 End
635 End_Procedure
636
637
638End_Class
639
640// This replaces the message in shadow_mixin. With entry based single item
641// objects you must set the item options for noenter and noput to make
642// shadowing work. However, setting noenter, sends shadow_state which will
643// call this. This allows us to set displayonly fields by sending
644//
645// Set Object_Shadow_State to T|F
646//
647Class Entry_Shadow_Mixin is a Mixin
648
649 { MethodType=Property NoDoc=True }
650 { DesignTime=False }
651 Procedure Set Object_Shadow_State Integer iState
652 integer SS bHidden bOldSS
653
654 // If the object is hidden then this may be getting called when it is not needed.
655 // A DEO refresh will see the shadow_state and think it must be changed. So, if hidden
656 // checkif the explicit SS is already set correctly. If so, do nothing.
657 Get Implicit_Hidden_State to bHidden
658 If (bHidden and Explicit_Shadow_state(self)=iState) Procedure_return
659
660 // if we have an item (we should) we will see if the item
661 // option NOENTER is correct. If not, we will set it Setting this can call
662 // set shadow_state which could cause recursion. So if needed we set shadow-state
663 // first, do the changes, and then reset SS. If SS should really be changed, it will happen
664 // later. This keeps item options and Shadow_state in synch
665 If (Item_Count(self)) Begin
666 Get Item_Options item 0 to SS
667 // We must also check skipfound (since this sets shadow_State) if
668 // this is a skipfound item we assume that it is the skipfound that
669 // is setting the shadow state and we do not change noenter or noput
670 // 16 = SkipFound
671 If ( (SS IAND 16)=0) Begin // only check if skipfound is not used
672 // 8 = Noenter
673 Move ( (SS IAND 8)<>0 ) to SS // SS = T if NOENTER not set (yet)
674 if SS ne iState Begin // if item opt is not what we want, set it
675 Get Item_Shadow_state item 0 to bOldSS // the current item SS
676 If (bOldSS<>iState) Set Item_shadow_state item 0 to iState
677 // by setting the item's SS state first (above) we will
678 // not trigger a change in shadow_state which would cause recursion
679 // Note that the order matters. NoEnter MUST be first or shadow_state will get sent in C
680 Set Item_Option item 0 NOENTER to iState
681 Set Item_Option item 0 NOPUT to iState
682 // if we changed Item-SS we need to set it back.
683 If (bOldSS<>iState) Set Item_shadow_state item 0 to bOldSS
684 End
685 End
686 End
687 //
688 Set Private.Explicit_Shadow_State to iState
689 If Not (Implicit_Shadow_State(self)) Begin
690 Set Current_Shadow_State to iState
691 Send Shadow_display
692 if (Broadcast_Implicit_Shadow_State(self)) ;
693 Broadcast Set Implicit_Shadow_State to iState
694 End
695 End_Procedure // Set Object_Shadow_State
696End_Class
697
698
699//
700// This mixin is used by multi objects for shadow support.
701//
702
703Class Multi_Item_Shadow_Mixin Is A Mixin
704
705 Import_Class_Protocol Shadow_Mixin
706
707 { Visibility=Private }
708 Procedure Define_Multi_Item_Shadow_Mixin
709 Send Define_Shadow_Mixin
710 End_Procedure
711
712 { MethodType=Property Visibility=Private }
713 Procedure Set Current_Shadow_State integer iState
714 Set Private.Shadow_State to iState
715 End_Procedure // Set Current_Shadow_State
716
717 { MethodType=Property NoDoc=True }
718 Function Object_Shadow_State returns integer
719 Function_Return (Private.shadow_State(self))
720 End_Function // Object_Shadow_State
721
722 { MethodType=Property Visibility=Private }
723 Procedure Set Shadow_State integer iItem integer iState
724 Set Item_Shadow_State item iItem to iState
725 End_Procedure
726
727 { MethodType=Property Visibility=Private }
728 Function Shadow_State integer iItem returns Integer
729 Function_Return (Item_Shadow_State(self,iItem))
730 End_Function
731
732End_Class
733
734{ HelpTopic=FormFloatingPopupMenu }
735Class FormFloatingPopupMenu IS A DFBaseEditPullDown
736 { NoDoc=True Visibility=Public }
737 Procedure Popup
738 Integer Loc
739 Get Absolute_Mouse_Location of Desktop to Loc
740 // set location relative to mouse
741 Set GuiLocation To (Hi(Loc)) (Low(Loc))
742 Forward Send Popup
743 End_Procedure
744End_Class
745
746{ HelpTopic=FloatingPopupMenu }
747Class FloatingPopupMenu IS A FormFloatingPopupMenu
748 Procedure Construct_Object
749 Forward Send Construct_Object
750 Send Delete_Data
751 End_Procedure // Construct_Object
752End_Class
753
754// We use a global default context menu id for speed purposes. Every form
755// will need to set this and if we do this via delegation it will take
756// much longer.
757Integer Default_Form_Floating_Menu_ID
758
759Object FormFloatingMenu is a FormFloatingPopupMenu
760 Move self to Default_Form_Floating_Menu_Id
761End_Object
762
763Class FloatingPopupMenu_Mixin is a Mixin
764
765 { Visibility=Private }
766 Procedure Define_FloatingPopupMenu_Mixin
767 { Category=Appearance }
768 Property Integer Floating_Menu_Object Default_Form_Floating_Menu_Id
769 End_Procedure
770
771 // augment right mouse down to pop up a floating panel. Only do this if
772 // the object successfully takes the focus.
773 //
774 { MethodType=Event NoDoc=True }
775 Procedure Mouse_Down2 Integer iWindowNumber Integer iPosition
776 integer obj rval iCur
777 Forward Send mouse_down2 iWindowNumber iPosition
778 // The item number should be 1 based, Hence a 0 is invalid. This can happen
779 // when you click in a grid to the right of the last column.
780 If (iWindowNumber>0) Begin
781 Get Floating_Menu_object to obj
782 if obj Begin
783 If (Focus(desktop)<>self) ;
784 get msg_Activate to rval
785 if ( focus(desktop)=self) Begin
786 Move (iWindowNumber-1+Top_Item(self)) to iCur
787 If (iCur < Item_Count(self)) Begin // make sure the item is valud
788 If (not(shadow_state(self,iCur))) Begin
789 if ( Item_window(self)<>iWindowNumber ) ;
790 Set Current_Item to iCur
791 if ( Item_window(self)=iWindowNumber) ;
792 Send Popup to obj
793 end
794 end
795 end
796 end
797 end
798 End_Procedure // mouse_down2
799End_Class
800
801
802Class RGB_Support_Temp_Mixin Is A Mixin
803 //
804 { Visibility=Private }
805 Procedure Define_RGB_Support_Temp_Mixin
806 { Visibility=Private }
807 Property Integer private.Object_Color 0
808 // always force a set object_color, by passing 0,0 VDF
809 // convert these to system colors ($10xx) and pass them on to
810 // set Dynamic_colors. We will augment Dynamic_colors to set our
811 // internal object_color. This way we always have object_color set
812 set object_color to 0 0
813 End_Procedure
814
815 { Visibility=Private }
816 Procedure set Dynamic_Colors integer i1 integer i2
817 // if sent when within init_instance, ignore. Our property is not yet defined.
818 // Keep track of object_color manually.
819 if buildingObjectid eq 0 set Private.Object_color to (i1*65536 + i2)
820
821 forward set dynamic_colors to i1 i2
822
823 // if a system color convert from old DF color to new GetSysColor.
824 // This way changes in the windows color will get set right away.
825 // DF system colors are $10xx, New Rgb is $800000xx).
826 If (i1 iAND $1000) Set TextColor to ((I1 iAND $FF) iOR $80000000)
827 If (i2 iAND $1000) Set Color to ((I2 iAND $FF) iOR $80000000)
828 End_Procedure
829
830 { MethodType=Property Visibility=Private Obsolete=True }
831 Function Object_Color Returns integer
832 Function_Return (Private.Object_color(self))
833 End_Function
834End_Class
835
836
837Class ToolTip_Support_Mixin is a Mixin
838
839 // Define_ToolTip_Support_Mixin:
840
841 { Visibility=Private }
842 Procedure Define_ToolTip_Support_Mixin
843 { Visibility=Private }
844 Property String psToolTip_private ""
845
846 { Visibility=Private }
847 Property Boolean pbCenterToolTip_private False
848
849 { Visibility=Private }
850 Property Boolean pbUseFormWindowHandle_private True
851
852 { Visibility=Private }
853 Property Handle phToolWnd 0
854
855 { Visibility=Private }
856 Property Handle phoToolTipController_private 0
857
858 // Assign the default tooltip controller....
859 Set phoToolTipController_private to ghoToolTipController
860 End_Procedure // Define_ToolTip_Support_Mixin
861
862
863 // pbCenterToolTip:
864 { MethodType=Property }
865 { Category=Appearance }
866 { InitialValue=False }
867 Procedure Set pbCenterToolTip Boolean bValue
868 Boolean bOldValue
869 Handle hToolWnd
870
871 Get pbCenterToolTip_private to bOldValue
872
873 If (bValue <> bOldValue) Begin
874 Set pbCenterToolTip_private to bValue
875
876 Get phToolWnd to hToolWnd
877
878 If (hToolWnd = 0) Begin
879 // If there has never been any tooltip then create one....
880 Send AddToolTip
881 End
882 Else Begin
883 // Otherwise delete it, then re-create it with the new style....
884 Send DeleteToolTip
885 Send AddToolTip
886 End
887 End
888 End_Procedure
889
890 { MethodType=Property }
891 Function pbCenterToolTip Returns Boolean
892 Boolean bValue
893 Get pbCenterToolTip_private to bValue
894 Function_Return bValue
895 End_Function // pbCenterToolTip
896
897
898 // implemented as function so that it can be overridden in class.
899 { MethodType=Property }
900 { Visibility=Private }
901 Function pbUseFormWindowHandle Returns Boolean
902 Function_Return (pbUseFormWindowHandle_private(Self))
903 End_Function // pbUseFormWindowHandle
904
905 { MethodType=Property }
906 { Visibility=Private }
907 Procedure Set pbUseFormWindowHandle Boolean bValue
908 Set pbUseFormWindowHandle_private to bValue
909 End_Procedure
910
911
912 // phoToolTipController:
913
914 // Use this method to attach to a different tooltip handler object than the global
915 // tooltip object. Pass the object handle of the tooltip handler.
916 { MethodType=Property }
917 { Category=Behavior }
918 { InitialValue=0 }
919 Procedure Set phoToolTipController Handle hoToolTip
920 Send DeleteToolTip
921 Set phoToolTipController_private to hoToolTip
922 Send AddToolTip
923 End_Procedure
924
925 { MethodType=Property }
926 Function phoToolTipController Returns Handle
927 Handle hoValue
928 Get phoToolTipController_private to hoValue
929 Function_Return hoValue
930 End_Function // phoToolTipController
931
932
933 // psToolTip:
934 { MethodType=Property }
935 { Category=Appearance }
936 { InitialValue="" }
937 Procedure Set psToolTip String sText
938 String sOldText
939 Handle hToolWnd
940
941 Get psToolTip_private to sOldText
942
943 If (sOldText <> sText) Begin
944 Set psToolTip_private to sText
945
946 // Test if this object has been paged yet...
947 If (Window_Handle(Self) <> 0) Begin
948 // If there has never been any tooltip then create one....
949 Get phToolWnd to hToolWnd
950
951 If (hToolWnd = 0) Begin
952 Send AddToolTip
953 End
954 Else Begin
955 Send UpdateToolTip
956 End
957 End
958 End
959 End_Procedure
960
961 { MethodType=Property }
962 Function psToolTip Returns String
963 String sValue
964 Get psToolTip_private to sValue
965 Function_Return sValue
966 End_Function // psToolTip
967
968
969 // AddToolTip:
970
971 // Register the tooltip with the tooltip control.
972 { Visibility=Private }
973 Procedure AddToolTip
974 Boolean bCenterToolTip
975 UInteger uFlags
976 Handle hToolWnd
977 Handle hoToolTip
978 String sText
979 Pointer lpText lpToolInfo
980 tWinToolInfo ToolInfo
981
982 Get phoToolTipController to hoToolTip
983 If (hoToolTip = 0) Procedure_Return
984
985 Move (TTF_SUBCLASS ior TTF_IDISHWND) to uFlags
986 Get pbCenterToolTip to bCenterToolTip
987 If (bCenterToolTip) Move (AddBitValue(TTF_CENTERTIP, uFlags)) to uFlags
988
989 Get psToolTip_private to sText
990 Move (ToANSI(Trim(sText))) to sText
991
992 If (sText <> "" and hoToolTip <> 0) Begin
993 If (pbUseFormWindowHandle(Self)) Get Form_Window_Handle to hToolWnd
994 Else Get Window_Handle to hToolWnd
995
996 Move (AddressOf(sText)) to lpText
997
998 Move (SizeOfType(tWinToolInfo)) to ToolInfo.cbSize
999 Move uFlags to ToolInfo.uFlags
1000 Move hToolWnd to ToolInfo.hwnd
1001 Move (Cast(hToolWnd,UInteger)) to ToolInfo.uID
1002 Move lpText to ToolInfo.lpszText
1003
1004 Move (AddressOf(ToolInfo)) to lpToolInfo
1005
1006 Send AddToolTip to hoToolTip lpToolInfo
1007 Set phToolWnd to hToolWnd
1008 End
1009 End_Procedure // AddToolTip
1010
1011
1012 // DeleteToolTip:
1013
1014 // Remove the registered tooltip from the ToolTip control.
1015 { Visibility=Private }
1016 Procedure DeleteToolTip
1017 Handle hToolWnd
1018 Handle hoToolTip
1019 Integer iRet
1020 Pointer lpToolInfo
1021 tWinToolInfo ToolInfo
1022
1023 Get phoToolTipController to hoToolTip
1024 If (hoToolTip = 0) Procedure_Return
1025 Get phToolWnd to hToolWnd
1026
1027 If (hToolWnd <> 0 and hoToolTip <> 0) Begin
1028 Move (SizeOfType(tWinToolInfo)) to ToolInfo.cbSize
1029 Move hToolWnd to ToolInfo.hwnd
1030 Move (Cast(hToolWnd,UInteger)) to ToolInfo.uID
1031 Move (AddressOf(ToolInfo)) to lpToolInfo
1032
1033 // Remove the tool from the ToolTip control.
1034 Send DeleteTooltip to hoToolTip lpToolInfo
1035 Set phToolWnd to 0
1036 End
1037 End_Procedure // DeleteToolTip
1038
1039
1040 // UpdateToolTip:
1041
1042 // Register the tooltip with the tooltip control.
1043 { Visibility=Private }
1044 Procedure UpdateToolTip
1045 Boolean bCenterToolTip
1046 UInteger uFlags
1047 Handle hToolWnd
1048 Handle hoToolTip
1049 String sText
1050 Pointer lpText lpToolInfo
1051 tWinToolInfo ToolInfo
1052
1053 Get phToolWnd to hToolWnd
1054
1055 If (hToolWnd = 0) Begin
1056 Error DFERR_PROGRAM "Assertion: UpdateToolTip called before AddToolTip"
1057 End
1058
1059 Get phoToolTipController to hoToolTip
1060 If (hoToolTip = 0) Procedure_Return
1061
1062 Move (TTF_SUBCLASS ior TTF_IDISHWND) to uFlags
1063 Get pbCenterToolTip to bCenterToolTip
1064 If (bCenterToolTip) Move (AddBitValue(TTF_CENTERTIP, uFlags)) to uFlags
1065
1066 Get psToolTip_private to sText
1067 Move (ToANSI(Trim(sText))) to sText
1068
1069 If (sText <> "" and hoToolTip <> 0) Begin
1070 Move (AddressOf(sText)) to lpText
1071
1072 Move (SizeOfType(tWinToolInfo)) to ToolInfo.cbSize
1073 Move uFlags to ToolInfo.uFlags
1074 Move hToolWnd to ToolInfo.hwnd
1075 Move (Cast(hToolWnd,UInteger)) to ToolInfo.uID
1076 Move lpText to ToolInfo.lpszText
1077
1078 Move (AddressOf(ToolInfo)) to lpToolInfo
1079
1080 Send UpdateToolTip to hoToolTip lpToolInfo
1081 End
1082 End_Procedure // UpdateToolTip
1083End_Class // ToolTip_Support_Mixin
1084
1085
1086// Class: Dftextbox
1087//
1088// 1. Support Autosizing (auto_size_state). Default to T.
1089// 2. Set skip_state to true.
1090// 3. Determine color by looking at parent object
1091// 4. Default J_mode is left, vertical centered.
1092// 5. Understands GET/SET Label
1093//
1094Enum_List
1095 Define TBSHADOW_ON_NONE
1096 Define TBSHADOW_ON_LOCAL
1097 Define TBSHADOW_ON_GROUP
1098 Define TBSHADOW_ON_ALL
1099End_Enum_List
1100
1101{ DesignerClass=cDTTextBox }
1102{ OverrideProperty=Color InitialValue=clBtnFace }
1103{ OverrideProperty=TextColor InitialValue=clWindowText }
1104{ OverrideProperty=Justification_Mode InitialValue=JMode_VCenter }
1105{ HelpTopic=TextBox }
1106
1107{ OverrideProperty=Attach_Parent_State DesignTime=False }
1108{ OverrideProperty=Block_Mouse_State DesignTime=False }
1109{ OverrideProperty=Client_Area_State DesignTime=False }
1110{ OverrideProperty=Physical_FontSize DesignTime=False }
1111{ OverrideProperty=Popup_State DesignTime=False }
1112{ OverrideProperty=Ring_State DesignTime=False }
1113{ OverrideProperty=Scope_State DesignTime=False }
1114{ OverrideProperty=Search_Case DesignTime=False }
1115{ OverrideProperty=Skip_State DesignTime=False }
1116
1117Class TextBox Is A DfBaseTextBox
1118
1119 Procedure Construct_Object
1120 Forward Send Construct_Object
1121 Send Define_RGB_Support_Temp_Mixin
1122
1123 { Category=Appearance }
1124 { PropertyType=Boolean }
1125 Property Integer Auto_Size_State True
1126
1127 { EnumList="TBShadow_On_None, TBShadow_On_Local, TBShadow_On_Group, TBShadow_On_All" }
1128 { InitialValue=TBShadow_On_Group }
1129 { Category=Appearance }
1130 Property Integer Label_Shadow_Display_Mode TBShadow_On_Group
1131
1132 Set Skip_State To True
1133 Set Justification_Mode To JMode_VCenter // Vcenter/Left
1134 Send Use_Parent_Color
1135
1136 Send Define_Shadow_Mixin
1137 // we don't set this because you can get an odd bleed through with panels
1138 //Set Transparent_State to True
1139 Send Define_Bitmap_Support_Mixin
1140 Send Define_ToolTip_Support_Mixin
1141
1142 Set pbUseFormWindowHandle to False // must come after Define_ToolTip_Support_Mixin
1143 End_Procedure // Construct_Object
1144
1145 Import_Class_Protocol RGB_Support_Temp_Mixin
1146 Import_Class_Protocol Label_Mixin
1147 Import_Class_Protocol Shadow_Mixin
1148 Import_Class_Protocol Bitmap_Support_Mixin
1149 Import_Class_Protocol ToolTip_Support_Mixin
1150
1151 //
1152 { Visibility=Private }
1153 Procedure Use_Parent_Color
1154 Integer Txtclr Backclr
1155 Delegate Get TextColor To TxtClr
1156 Delegate Get Color To backClr
1157 If Backclr Eq Txtclr Move CLBlack To Txtclr
1158 Set TextColor To TxtClr
1159 Set Color To backClr
1160 End_Procedure
1161
1162 { MethodType=Property NoDoc=True }
1163 Procedure Set Value Integer Item# String Val
1164 If (Auto_Size_State(self)) Send Autosize Val
1165 Forward Set Value Item Item# To Val
1166 End_Procedure
1167
1168 { Visibility=Private }
1169 Procedure Autosize String Val
1170 Integer Ext
1171 Get Text_Extent Val To Ext
1172 Set Guisize To (Hi(Ext)+3) (Low(Ext)+2)
1173 Send Adjust_logicals
1174 End_Procedure
1175
1176 { MethodType=Event Visibility=Private }
1177 Procedure Shadow_Display
1178 Integer iMode iEnable
1179 Get Label_Shadow_Display_Mode to iMode
1180 if ( ( (iMode=TBSHADOW_ON_GROUP OR iMode=TBSHADOW_ON_ALL) AND ;
1181 (Implicit_Shadow_State(self)) ) OR ;
1182 ( (iMode=TBSHADOW_ON_LOCAL OR iMode=TBSHADOW_ON_ALL) AND ;
1183 Explicit_Shadow_State(self) ) ) ;
1184 Move 0 to iEnable
1185 else ;
1186 Move 1 to iEnable
1187 Send Enable_Window iEnable
1188 End_Procedure // Shadow_Display
1189
1190 { Visibility=Private }
1191 Procedure Enable_Window integer iState
1192 integer hWnd
1193 Get Window_Handle to hWnd
1194 If hWnd ;
1195 Move (EnableWindow(hWnd,iState)) To hWnd
1196 End_procedure
1197
1198 { Visibility=Private }
1199 Procedure Page_Object Integer iState
1200 Handle hWnd
1201 Get Window_Handle To hWnd
1202 Forward Send Page_Object iState
1203
1204 // Handle tooltip support....
1205 If (iState = 0) Begin
1206 Send RequestDeleteToolTip
1207 End
1208 Else Begin
1209 Send RequestAddToolTip
1210 End
1211
1212 If (hWnd=0 and iState) Begin
1213 Send Shadow_Display
1214 End
1215 End_Procedure
1216
1217
1218 // Called by Page_Object. Handles tooltip creation. We use a dedicated
1219 // method to perform AddToolTip because it is often the case that Page_Object
1220 // is implemented in a mixin class.
1221 { Visibility=Private }
1222 Procedure RequestAddToolTip
1223 Send AddToolTip
1224 End_Procedure // RequestAddToolTip
1225
1226
1227 // Called by Page_Object. Handles tooltip removal.
1228 { Visibility=Private }
1229 Procedure RequestDeleteToolTip
1230 Send DeleteToolTip
1231 End_Procedure // RequestDeleteToolTip
1232End_Class // TextBox
1233
1234
1235//Use Dflblmx.pkg // Auto label support for controls
1236// this used to be in dflblmx.pkg - now it directly inserted here
1237Integer DEFAULT_LABEL_OFFSET
1238Move 60 to DEFAULT_LABEL_OFFSET
1239
1240Integer DEFAULT_LABEL_JMODE
1241Move JMODE_LEFT to DEFAULT_LABEL_JMODE
1242
1243{ Visibility=Private }
1244Class AutoLabel is a TextBox
1245
1246 Procedure Construct_Object
1247 Forward Send Construct_Object
1248 { Visibility=Private }
1249 Property Integer Owner_Object 0
1250 End_Procedure // Construct_Object
1251
1252 { MethodType=Event NoDoc=True }
1253 Procedure Mouse_Down
1254 Integer obj rval
1255 Get owner_object to obj
1256 if (obj AND Focus(Desktop)<>obj) ;
1257 Get Msg_Activate of obj to rval
1258 else Forward Send Mouse_Down
1259 End_Procedure // Mouse_Down
1260
1261 // Augmented to Ask owner to locate itself. Owner will only do this
1262 // if required.
1263 //
1264 { Visibility=Private }
1265 Procedure Page_Object integer iState
1266 Integer obj
1267 Get owner_object to obj
1268 If (iState AND Obj) ;
1269 Send Request_Locate_Label to Obj // optimized version
1270 Forward Send page_Object iState
1271 End_Procedure
1272
1273 { MethodType=Event Visibility=Private }
1274 Procedure Shadow_Display
1275 Integer iMode iEnable
1276 Integer obj
1277 Get Owner_object to obj
1278 If Obj Begin
1279 Get Label_Shadow_Display_Mode of Obj to iMode
1280 if ( ( (iMode=TBSHADOW_ON_GROUP OR iMode=TBSHADOW_ON_ALL) AND ;
1281 Implicit_Shadow_State(Obj) ) OR ;
1282 ( (iMode=TBSHADOW_ON_LOCAL OR iMode=TBSHADOW_ON_ALL) AND ;
1283 Explicit_shadow_state(Obj) ) ) ;
1284 Move 0 to iEnable
1285 else ;
1286 Move 1 to iEnable
1287 Send Enable_Window iEnable
1288 End
1289 End_Procedure // Shadow_Display
1290
1291 { Visibility=Private }
1292 Procedure Set Implicit_Shadow_State integer iState
1293 End_procedure
1294
1295 // see notes for this message in dfbase
1296 //
1297 { Visibility=Private }
1298 Procedure DoImplicitTabHide integer iState
1299 End_Procedure
1300
1301 { MethodType=Event NoDoc=True }
1302 Procedure Destroy_Object
1303 Integer obj
1304 Get owner_object to obj // if we have an owner
1305 if obj ; // object break the link
1306 Set Label_Object of obj to 0 // This is always called before the
1307 Forward Send Destroy_Object // owner is destroyed!
1308 End_Procedure // Destroy_Object
1309
1310 Procedure Add_Focus integer id
1311 End_Procedure // Add_Focus
1312
1313 // auto-labels should not do this. They will be given their colors
1314 // by their owner object. Cancel text box behavior.
1315 //
1316 { Visibility=Private }
1317 Procedure Use_Parent_Color
1318 End_Procedure
1319End_Class
1320
1321Class DFLabel_Mixin is a Mixin
1322 { Visibility=Private }
1323 Procedure Define_DFLabel_Mixin
1324
1325 { DesignTime=False }
1326 Property Handle Label_Object 0
1327
1328 { Visibility=Private }
1329 Property Integer Label_Needs_sizing_State True
1330
1331 { Visibility=Private }
1332 Property Integer Private.Label_Row_Offset 0
1333
1334 { Visibility=Private }
1335 Property Integer Private.Label_Col_Offset DEFAULT_LABEL_OFFSET
1336
1337 { Visibility=Private }
1338 Property Integer Private.Label_Justification_Mode DEFAULT_LABEL_JMODE
1339
1340 { Visibility=Private }
1341 Property Integer Private.Label_Shadow_Display_Mode TBSHADOW_ON_GROUP
1342
1343 { Visibility=Private }
1344 Property Integer PrivateLabel_Color clNone
1345
1346 { Visibility=Private }
1347 Property Integer PrivateLabel_TextColor clNone
1348
1349 { Visibility=Private }
1350 Property Integer PrivateLabel_FontUnderline False
1351
1352 { Visibility=Private }
1353 Property Integer PrivateLabel_FontItalics False
1354
1355 { Visibility=Private }
1356 Property Integer PrivateLabel_FontWeight 0
1357
1358 { Visibility=Private }
1359 Property Integer PrivateLabel_FontSize 0
1360
1361 { Visibility=Private }
1362 Property String PrivateLabel_TypeFace ''
1363
1364 End_Procedure
1365
1366 { Visibility=Private MethodType=Property }
1367 Procedure Set Label_Shadow_Display_Mode Integer mode
1368 Integer obj
1369 Set Private.Label_Shadow_Display_Mode to mode
1370 If (Window_Handle(Self)) Begin
1371 Get Label_object to obj
1372 If Obj Send Shadow_Display to obj
1373 End
1374 End_Procedure
1375
1376 { MethodType=Property Visibility=Private }
1377 Function Label_Shadow_Display_Mode Returns Integer
1378 Function_Return (private.label_Shadow_Display_Mode(Self))
1379 End_Function // Label_Justification_mode
1380
1381 { Visibility=Private }
1382 Function Create_Label_Object Returns Integer
1383 Boolean bOn bTestColor
1384 Integer iVal
1385 String sVal
1386 Handle hoLabel
1387
1388 Get Label_object to hoLabel
1389 If (hoLabel=0) Begin
1390
1391 Object Tb is a AutoLabel
1392 Move Self to hoLabel
1393 End_Object
1394 Set Owner_Object of hoLabel to Self
1395
1396 // following added in 15.0 for greater label font support
1397 // With the exception of italics and underline, the label will inherit it's font default
1398 // from the parent. So we only explicitly set Label_X properties if they are non-default values
1399
1400 Send AdjustLabelColors hoLabel // sets Color and TextColor of label
1401
1402 Get Label_Typeface to sVal
1403 If (sVal<>"") Begin
1404 Delegate Get Typeface to sVal
1405 If (sVal<>"") Begin
1406 Set Typeface of hoLabel to sVal
1407 End
1408 End
1409
1410 Get Label_FontSize to iVal
1411 If (iVal<>0) Begin
1412 Delegate Get FontSize to iVal
1413 If (iVal<>0) Begin
1414 Set FontSize of hoLabel to (Hi(iVal)) (Low(iVal))
1415 End
1416 End
1417
1418 Get Label_FontWeight to iVal
1419 If (iVal<>0) Begin
1420 Delegate Get FontWeight to iVal
1421 If (iVal<>0) Begin
1422 Set FontWeight of hoLabel to iVal
1423 End
1424 End
1425
1426 // This is not 100% backwards compatible but we will assume that nonone intentionally sets
1427 // the control's italics and underline and wants it to appear in label. We are treating the old behavior
1428 // as a bug
1429 Get Label_FontItalics to iVal
1430 Set FontItalics of hoLabel to iVal
1431
1432 Get Label_FontUnderline to iVal
1433 Set FontUnderline of hoLabel to iVal
1434
1435 Set Label_object to hoLabel
1436
1437 End
1438 Function_Return hoLabel
1439
1440 End_Function
1441
1442 // Allow label object to be destroyed. If active, first deactivate
1443 // Only destroy if the object is gone,
1444 //
1445 { Visibility=Private }
1446 Procedure Destroy_Label_Object
1447 Handle hoLabel hWnd
1448 Get Label_object to hoLabel
1449 If hoLabel Begin // only if label exists already
1450 // if label is paged it must be unpaged. We must check
1451 // window handle because this label is not in the focus tree (it's paged)
1452 Get Window_Handle of hoLabel to hWnd
1453 If (hWnd) Begin
1454 Send Page_Object of hoLabel False
1455 End
1456 Send Destroy of hoLabel // destroy object and mark it as gone
1457 Set Label_object to 0
1458 End
1459 End_Procedure
1460
1461 { MethodType=Event NoDoc=True }
1462 Procedure Destroy_Object
1463 Send Destroy_Label_Object // make sure label is destroyed first
1464 Forward Send Destroy_Object
1465 End_Procedure
1466
1467 { FoldedProperty=True }
1468 { MethodType=Property }
1469 { DesignTime=False }
1470 Procedure Set Label_Offset Integer i1 Integer i2
1471 Set Label_Row_Offset to i1
1472 Set Label_Col_Offset to i2
1473 End_Procedure // SET Label_Offset
1474
1475 { MethodType=Property }
1476 Function Label_Offset Returns Integer
1477 Integer icRow icCol
1478 Get Label_Row_Offset to icRow
1479 Get Label_Col_Offset to icCol
1480 Function_Return (icRow *65536 + icCol)
1481 End_Function // GET Label_Offset
1482
1483 { MethodType=Property }
1484 { InitialValue=0 }
1485 { Category=Label }
1486 Procedure Set Label_Row_Offset Integer icRow
1487 Set Private.Label_Row_Offset to icRow
1488 Send ReSize_Label
1489 End_Procedure // SET Label_Row_Offset
1490
1491 { MethodType=Property }
1492 Function Label_row_offset Returns Integer
1493 Function_Return (private.label_row_offset(Self))
1494 End_Function // Label_row_offset
1495
1496 { MethodType=Property }
1497 { InitialValue=60 }
1498 { Category=Label }
1499 Procedure Set Label_Col_Offset Integer icCol
1500 Set Private.Label_Col_Offset to icCol
1501 Send ReSize_Label
1502 End_Procedure // SET Label_Col_Offset
1503
1504 { MethodType=Property }
1505 Function Label_col_offset Returns Integer
1506 Function_Return (private.label_col_offset(Self))
1507 End_Function // Label_col_offset
1508
1509 { MethodType=Property }
1510 { EnumList="JMode_Left, JMode_Right, JMode_Top, JMode_Bottom" }
1511 { InitialValue=JMode_Left }
1512 { Category=Label }
1513 Procedure Set Label_Justification_Mode Integer mode
1514 Set Private.Label_Justification_mode to mode
1515 Send Resize_Label
1516 End_Procedure
1517
1518 { MethodType=Property }
1519 Function Label_Justification_mode Returns Integer
1520 Function_Return (private.label_Justification_mode(Self))
1521 End_Function // Label_Justification_mode
1522
1523 // Set label value, if value becomes '' destroy the label object
1524 //
1525 { MethodType=Property }
1526 { Category=Label }
1527 { InitialValue="" }
1528 Procedure Set Label String Val
1529 Integer Id
1530 If Val ne '' Begin
1531 Get Create_Label_Object to Id // force create if needed
1532 Set Label of id to val
1533 Send Resize_Label
1534 If (Window_Handle(Self) and Window_Handle(Id)=0) ;
1535 Send Page_Object to Id True
1536 End
1537 Else ;
1538 Send Destroy_Label_Object
1539 End_Procedure
1540
1541 { MethodType=Property }
1542 Function Label Returns String
1543 Integer obj
1544 String Lbl
1545 Get Label_object to obj
1546 If Obj Get Label of obj to lbl
1547 Function_Return lbl
1548 End_Function // Label
1549
1550 { MethodType=Property }
1551 { PropertyType=Color }
1552 { EnumList= "clScrollBar, clBackground, clActiveCaption, clInactiveCaption, clMenu, clWindow, clWindowFrame, clMenuText, clWindowText, clCaptionText, clActiveBorder, clInactiveBorder" }
1553 { EnumList+="clAppWorkSpace, clHighlight, clHighlightText, clBtnFace, clBtnShadow, clGrayText, clBtnText, clInactiveCaptionText, clBtnHighlight, cl3DDkShadow, cl3DLight, clInfoText, clInfoBk, clDefault, clNone" }
1554 { EnumList+="clAqua, clBlack, clBlue, clDkGray, clFuchsia, clGray, clGreen, clLime, clLtGray, clMaroon, clNavy, clOlive, clPurple, clRed, clSilver, clTeal, clWhite, clYellow" }
1555 { InitialValue=clNone }
1556 { Category=Label }
1557 Procedure Set Label_TextColor Integer iColor
1558 Handle hoLabel
1559 Set PrivateLabel_TextColor to iColor
1560 Get Label_Object to hoLabel
1561 If hoLabel Begin
1562 Send AdjustLabelColors hoLabel
1563 End
1564 End_Procedure
1565
1566 { MethodType=Property }
1567 Function Label_TextColor Returns Integer
1568 Integer iVal
1569 Get PrivateLabel_TextColor to iVal
1570 Function_Return iVal
1571 End_Function
1572
1573 { MethodType=Property }
1574 { PropertyType=Color }
1575 { EnumList= "clScrollBar, clBackground, clActiveCaption, clInactiveCaption, clMenu, clWindow, clWindowFrame, clMenuText, clWindowText, clCaptionText, clActiveBorder, clInactiveBorder" }
1576 { EnumList+="clAppWorkSpace, clHighlight, clHighlightText, clBtnFace, clBtnShadow, clGrayText, clBtnText, clInactiveCaptionText, clBtnHighlight, cl3DDkShadow, cl3DLight, clInfoText, clInfoBk, clDefault, clNone" }
1577 { EnumList+="clAqua, clBlack, clBlue, clDkGray, clFuchsia, clGray, clGreen, clLime, clLtGray, clMaroon, clNavy, clOlive, clPurple, clRed, clSilver, clTeal, clWhite, clYellow" }
1578 { InitialValue=clNone }
1579 { Category=Label }
1580 Procedure Set Label_Color Integer iColor
1581 Handle hoLabel
1582 Set PrivateLabel_Color to iColor
1583 Get Label_Object to hoLabel
1584 If hoLabel Begin
1585 Send AdjustLabelColors hoLabel
1586 End
1587 End_Procedure
1588
1589 { MethodType=Property }
1590 Function Label_Color Returns Integer
1591 Integer iVal
1592 Get PrivateLabel_Color to iVal
1593 Function_Return iVal
1594 End_Function
1595
1596 { MethodType=Property }
1597 { InitialValue=False }
1598 { Category=Label }
1599 Procedure Set Label_FontUnderLine Boolean bOn
1600 Handle hoLabel
1601 Set PrivateLabel_FontUnderline to bOn
1602 Get Label_Object to hoLabel
1603 If hoLabel Begin
1604 Set FontUnderline of hoLabel to bOn
1605 End
1606 End_Procedure
1607
1608 { MethodType=Property }
1609 Function Label_FontUnderline Returns Boolean
1610 Boolean bOn
1611 Get PrivateLabel_FontUnderline to bOn
1612 Function_Return bOn
1613 End_Function
1614
1615 { MethodType=Property }
1616 { InitialValue=False }
1617 { Category=Label }
1618 Procedure Set Label_FontItalics Boolean bOn
1619 Handle hoLabel
1620 Set PrivateLabel_FontItalics to bOn
1621 Get Label_Object to hoLabel
1622 If hoLabel Begin
1623 Set FontItalics of hoLabel to bOn
1624 End
1625 End_Procedure
1626
1627 { MethodType=Property }
1628 Function Label_FontItalics Returns Boolean
1629 Boolean bOn
1630 Get PrivateLabel_FontItalics to bOn
1631 Function_Return bOn
1632 End_Function
1633
1634 // In setting default values for weight, typeface and size we are using the
1635 // value of the conainer and not the control. Using the control is actually
1636 // a bug and assumes that fonts for label and forms are the same.
1637
1638 { MethodType=Property }
1639 { InitialValue=0 }
1640 { Category=Label }
1641 Procedure Set Label_FontWeight Integer iWeight
1642 Handle hoLabel
1643 Set PrivateLabel_FontWeight to iWeight
1644 Get Label_Object to hoLabel
1645 If hoLabel Begin
1646 // if weight is default, get the weight of the control
1647 If (iWeight=0) Begin
1648 Delegate Get FontWeight to iWeight
1649 End
1650 Set FontWeight of hoLabel to iWeight
1651 Send ReSize_Label
1652 End
1653 End_Procedure
1654
1655 { MethodType=Property }
1656 Function Label_FontWeight Returns Integer
1657 Boolean iVal
1658 Get PrivateLabel_FontWeight to iVal
1659 Function_Return iVal
1660 End_Function
1661
1662 { MethodType=Property }
1663 { InitialValue=0,0 }
1664 { FoldedProperty=True }
1665 { Category=Label }
1666 Procedure Set Label_FontSize Integer iHeight Integer iWidth
1667 Handle hoLabel
1668 Integer iSize
1669 Move (iHeight*65536 + iWidth) to iSize
1670 Set PrivateLabel_FontSize to iSize
1671 Get Label_Object to hoLabel
1672 If hoLabel Begin
1673 If (iSize=0) Begin
1674 Delegate Get FontSize to iSize
1675 End
1676 Set FontSize of hoLabel to (Hi(iSize)) (Low(iSize))
1677 Send ReSize_Label
1678 End
1679 End_Procedure
1680
1681 { MethodType=Property }
1682 Function Label_FontSize Returns Integer
1683 Boolean iVal
1684 Get PrivateLabel_FontSize to iVal
1685 Function_Return iVal
1686 End_Function
1687
1688 { MethodType=Property }
1689 { InitialValue="" }
1690 { Category=Label }
1691 Procedure Set Label_TypeFace String sTypeFace
1692 Handle hoLabel
1693 Set PrivateLabel_TypeFace to sTypeFace
1694 Get Label_Object to hoLabel
1695 If hoLabel Begin
1696 If (sTypeFace="") Begin
1697 Delegate Get Typeface to sTypeFace
1698 End
1699 Set Typeface of hoLabel to sTypeFace
1700 Send ReSize_Label
1701 End
1702 End_Procedure
1703
1704 { MethodType=Property }
1705 Function Label_TypeFace Returns String
1706 String sValue
1707 Get PrivateLabel_TypeFace to sValue
1708 Function_Return sValue
1709 End_Function
1710
1711
1712 // augmented so that the visible state of the label is
1713 // adjusted with the control
1714 { NoDoc=True }
1715 Procedure Set Visible_state Boolean bVisible
1716 Handle hoLabel
1717 Forward Set Visible_State to bVisible
1718 Get Label_Object to hoLabel
1719 If hoLabel Begin
1720 Set Visible_State of hoLabel to bVisible
1721 End
1722 End_Procedure
1723
1724 // Marks label info as dirty. If the object is active it
1725 // actually makes the change. As of 15.0, this is public
1726 // and can be used to force a resize if you change the
1727 // font metrics of an active label.
1728 Procedure ReSize_Label
1729 Set Label_Needs_Sizing_State to True // dirty label mark
1730 // if object is active, we will immediately update the changes
1731 If (Window_Handle(Self)) Send Locate_label
1732 End_Procedure
1733
1734 // Optimized locate label. Only does it if needed
1735 //
1736 { Visibility=Private }
1737 Procedure Request_Locate_Label
1738 If (Label_Needs_Sizing_State(Self)) ;
1739 Send Locate_label
1740 End_Procedure
1741
1742 // called when a label color is set. It sets new text and back colors
1743 // if needed. It handle clNone colors, which means get the color from the
1744 // container. If both colors are clNone it makes sure they are not the same.
1745 { Visibility=Private }
1746 Procedure AdjustLabelColors Handle hoLabel
1747 Integer iTxtClr iBackClr
1748 Integer iCurrentColor
1749 Boolean bTestColor
1750
1751 Get Label_Color to iBackClr
1752 Get Label_TextColor to iTxtClr
1753
1754 // if both colors are inherited from container we do
1755 // a test for them being the same color.
1756 Move (iTxtClr=clNone and iBackClr=clNone) to bTestColor
1757
1758 If (iTxtClr=clNone) Begin
1759 Delegate Get TextColor to iTxtClr
1760 End
1761 If (iBackClr=clNone) Begin
1762 Delegate Get Color to iBackClr
1763 End
1764 If (bTestColor and iBackClr=iTxtClr) Begin
1765 Move clBtnText to iTxtClr
1766 End
1767 Get Color of hoLabel to iCurrentColor
1768 If (iCurrentColor<>iBackClr) Begin
1769 Set Color of hoLabel to iBackClr
1770 End
1771 Get TextColor of hoLabel to iCurrentColor
1772 If (iCurrentColor<>iTxtClr) Begin
1773 Set TextColor of hoLabel to iTxtClr
1774 End
1775 End_Procedure
1776
1777 { Visibility=Private }
1778 Procedure Locate_Label
1779 Integer iLoc iRow iCol iRowOff iColOff iSz
1780 Integer eDelMode eJMode
1781 String sLabel
1782 Handle hoLabel
1783
1784 Get Label_object to hoLabel
1785 If hoLabel Begin
1786 Get Delegation_mode to eDelMode
1787 Set Delegation_mode to Delegate_to_Parent // for label sizing to work, delegation *must* be enabled
1788
1789 Send Adjust_Logicals
1790 Get Value of hoLabel to sLabel
1791 Set Value of hoLabel to sLabel // this forces an autosize & Adjust logicals
1792
1793 Get Label_Row_Offset to iRowOff
1794 Move (iRowOff-2) to iRowOff // This forces this down so that it properly aligns against text in a form
1795 Get Label_Col_Offset to iColOff
1796 Get Location to iLoc
1797 Get Label_Justification_Mode to eJMode
1798
1799 Move (Low(iLoc)-iColOff) to iCol
1800
1801 // we get the GuiSize of the Label object and then convert it
1802 // to Dialog units using dialog container object. This way it is
1803 // located relative to the container and not the label
1804 Get GuiSize of hoLabel to iSz
1805 Delegate Get GuiToDialog (Hi(iSz)) (Low(iSz)) to iSz // as of 15.0, dialog units based on container
1806
1807 If (eJMode iand JMODE_Right) Begin
1808 Move (iCol - Low(iSz)-1) to iCol
1809 End
1810
1811 If (eJMode iand JMODE_TOP) Begin
1812 Move (iRowOff + Hi(iSz) + 2) to iRowOff
1813 If (eJMode iand JMODE_Right) ;
1814 Move (iCol + Low(iSz)) to iCol
1815 End
1816
1817 Move (Hi(iLoc)-iRowOff) to iRow
1818
1819 Set Location of hoLabel to iRow iCol
1820
1821 // legacy behavior. Anytime we adjust the location we check the colors
1822 Send AdjustLabelColors hoLabel
1823
1824 Set Label_Needs_Sizing_state to False
1825
1826 Set Delegation_mode to eDelMode
1827 End
1828 End_Procedure // Locate_label
1829
1830 { MethodType=Property Visibility=Private }
1831 Procedure Set GuiSize Integer cy Integer cx
1832 Integer Sz NewSz
1833 Get GuiSize to Sz
1834 Forward Set GuiSize to cy cx
1835 If (not(BuildingObjectId)) Begin
1836 Get GuiSize to NewSz
1837 If NewSz ne Sz ;
1838 Send Resize_Label
1839 End
1840 End_Procedure
1841
1842 { MethodType=Property Visibility=Private }
1843 Procedure Set GuiLocation Integer y Integer x
1844 Integer lc NewLc
1845 Get GuiLocation to Lc
1846 Forward Set GUILocation to y x
1847 Get GuiLocation to NewLc
1848 If Lc ne NewLc ;
1849 Send Resize_Label
1850 End_Procedure
1851
1852 { Visibility=Private }
1853 Procedure Label_Shadow_Display
1854 Integer obj
1855 Get Label_object to obj
1856 If Obj Send Shadow_display to Obj
1857 End_Procedure
1858
1859 // Augment to Page Label if required
1860 //
1861 { Visibility=Private }
1862 Procedure Page_Object Integer iState
1863 Integer obj
1864 Get Label_object to obj
1865 Forward Send Page_Object iState
1866
1867 // Handle tooltip support....
1868 If (iState = 0) Begin
1869 Send RequestDeleteToolTip
1870 End
1871 Else Begin
1872 Send RequestAddToolTip
1873 End
1874
1875 If (Obj and iState) Begin
1876 // this forces an AutoSize of the label. This handles any changes in font, fontweight, etc. that might have occurred
1877 // after the value was set.
1878 Set Label of Obj to (Label(obj))
1879 Send page_Object to Obj iState
1880 End
1881 End_Procedure
1882
1883
1884 // Called by Page_Object. Handles tooltip creation.
1885 { Visibility=Private }
1886 Procedure RequestAddToolTip
1887 // Do nothing: This is augmented in classes that support tooltips.
1888 End_Procedure // RequestAddToolTip
1889
1890
1891 // Called by Page_Object. Handles tooltip creation.
1892 { Visibility=Private }
1893 Procedure RequestDeleteToolTip
1894 // Do nothing: This is augmented in classes that support tooltips.
1895 End_Procedure // RequestDeleteToolTip
1896
1897
1898 // Augment to remove Page Label if required
1899 //
1900 { MethodType=Event Visibility=Private }
1901 Procedure Page_Delete
1902 Handle hoLabel
1903 Get Label_object to hoLabel
1904 If (hoLabel and Window_Handle(hoLabel)) Begin
1905 // if the textbox is still paged we must unpage it. We must use page_object
1906 // and not page_delete or the runtime will still think the object is in the "paged list".
1907 Send Page_Object of hoLabel False
1908 End
1909 Forward Send Page_Delete
1910 End_Procedure
1911
1912End_Class
1913
1914
1915
1916{ HelpTopic=MenuBar }
1917Class MenuBar Is A DfBaseActionBar
1918
1919 Register_Procedure Set Shadow_Status_Help
1920
1921 Procedure Construct_Object
1922 Forward Send Construct_Object
1923 Send Define_StatusHelp_Item_mixin
1924 End_Procedure // Construct_Object
1925
1926 Import_Class_Protocol StatusHelp_Item_Mixin
1927
1928 { MethodType=Event }
1929 Procedure OnInitMenu
1930 End_Procedure
1931
1932 { MethodType=Event Visibility=Private }
1933 Procedure Initialize_Menu
1934 Integer SbId
1935 Delegate Get Statusbar_Id to SbId
1936 If SbId Send Initialize_Menu to SbId
1937 Send OnInitMenu
1938 End_Procedure
1939
1940 { MethodType=Event }
1941 Procedure OnChange
1942 End_Procedure
1943
1944 { Visibility=Private }
1945 Procedure Change_Menu integer item# integer obj integer iFlags
1946 Integer SbId
1947 String sStatus_Help
1948 Send OnChange
1949 Delegate Get Statusbar_Id to SbId
1950 If SbId begin
1951 Get Menu_Status_Help of obj item# iFlags To sStatus_Help
1952 Send Show_Status_Help to SbId sStatus_Help
1953 End
1954 End_Procedure
1955
1956 { Visibility=Private }
1957 Procedure Exit_Menu
1958 Integer SbId
1959 Delegate Get Statusbar_Id to SbId
1960 If SbId Send Exit_Menu to SbId
1961 End_Procedure
1962
1963 // if nothing else can take the focus, the menubar may have the focus.
1964 // We want it to send help to its parent
1965 { NoDoc=True }
1966 Procedure Help
1967 Delegate send Help
1968 End_Procedure
1969
1970
1971End_class // MenuBar
1972
1973// Class: PopupMenu
1974//
1975// 1. Tells KEY to send redirect message. I think we are now doing this
1976// but I don't have the message names. I expect this will go away.
1977//
1978
1979{ HelpTopic=PopupMenu }
1980Class PopupMenu Is A DfBasePullDown
1981
1982 Procedure Construct_Object
1983 Forward Send Construct_Object
1984 Send Define_Statushelp_Item_Mixin
1985 End_Procedure // Construct_Object
1986
1987 Import_Class_Protocol Statushelp_Item_Mixin
1988
1989 // Redirect_Message
1990 //
1991 // If destination object exists send message to destintion else
1992 // send message to the focus object (if a focus object exists).
1993 //
1994 // It expects the current selected item to CURRENT.
1995 //
1996 // This is a good message for augmentation.
1997 //
1998 { Visibility=Private }
1999 Procedure Redirect_Message Returns Integer
2000 Integer Msg# Aux# Rval
2001 Get Message To Msg#
2002 Get Aux_Value To Aux#
2003 //
2004 If Msg# Begin // Since Menupopup Is 0, This Will Get Skipped
2005 If Aux# Eq 0 Begin // If No Destination
2006 Get Focus of desktop To Aux# // Try To Send To Focus
2007 If Aux# Le Desktop ; // As Long As Focus Is Not The Desktop.
2008 Move 0 To Aux#
2009 End
2010 If Aux# Get Msg# Of Aux# To Rval
2011 Procedure_Return Rval
2012 End
2013 End_Procedure // Redirect_Message
2014
2015 //
2016 // Augment Key to send Redirect_Message (which is
2017 // what the old pulldowns did.) Let's keep this private
2018 //
2019 { MethodType=Event NoDoc=True }
2020 Procedure Key Integer Ky Returns Integer
2021 Integer Rval
2022 Get Msg_Redirect_Message To Rval
2023 Procedure_Return Rval
2024 End_Procedure // Key
2025
2026 { Visibility=Private }
2027 Procedure Exit_Menu
2028 Delegate Send Exit_Menu
2029 End_Procedure // Exit_Menu
2030
2031 { MethodType=Event }
2032 Procedure OnInitMenu
2033 End_Procedure
2034
2035 { MethodType=Event }
2036 Procedure OnChange
2037 End_Procedure
2038
2039 { Visibility=Private }
2040 Procedure Change_Menu integer item# integer obj integer iFlags
2041 Delegate Send change_menu item# obj iFlags
2042 Send OnChange
2043 End_Procedure
2044
2045 { MethodType=Event Visibility=Private }
2046 Procedure Initialize_Menu
2047 Forward Send Initialize_Menu
2048 Send OnInitMenu
2049 End_Procedure
2050
2051End_Class
2052
2053
2054#REPLACE TB_Style_Flat |CI$800
2055
2056// Defines supported display styles for ToolBars. Currently Microsoft has has two
2057// styles, Flat (as seen in Office '97 and Windows 98) and Raised [not flat]. More
2058// styles are anticipated which is why the Display_Style property is being implemented
2059// as a "style" rather than a "flat state".
2060//
2061Enum_List
2062 Define TOOLBAR_STYLE_FLAT
2063 Define TOOLBAR_STYLE_RAISED
2064End_Enum_List
2065
2066
2067{ Obsolete=True }
2068Class BasicToolBar Is A DFBaseToolbar
2069
2070 Procedure Construct_Object
2071 Forward Send Construct_Object
2072 Send Define_StatusHelp_Item_mixin
2073
2074 { Visibility=Private }
2075 Property Integer private.Display_Style TOOLBAR_STYLE_FLAT
2076
2077 Set Window_Style To CCS_ADJUSTABLE False
2078 Set Display_Style to TOOLBAR_STYLE_FLAT
2079 End_Procedure // Construct_Object
2080
2081 Import_Class_Protocol StatusHelp_Item_Mixin
2082
2083 { Visibility=Private MethodType=Event }
2084 Procedure Command Integer I1 Integer I2
2085 Send Redirect_Button_Message I1
2086 End_Procedure
2087
2088 { MethodType=Property }
2089 Procedure Set Display_Style Integer iStyle
2090 if iStyle eq TOOLBAR_STYLE_FLAT Set Window_Style To TB_STYLE_FLAT True
2091 if iStyle eq TOOLBAR_STYLE_RAISED Set Window_Style To TB_STYLE_FLAT False
2092 set private.Display_Style to iStyle
2093 End_Procedure
2094
2095 { MethodType=Property }
2096 Function Display_Style Returns Integer
2097 Function_Return (private.Display_Style(self))
2098 End_Function
2099
2100 { Visibility=Private }
2101 Procedure Redirect_Button_Message Integer Itm
2102 Integer Msg Obj Rval
2103 If (Shadow_State(self,Itm)) Procedure_Return
2104 Get Message Item Itm To Msg
2105 Get Aux_Value Item Itm To Obj
2106 If Obj Eq 0 Begin
2107 Get Focus Of Desktop To Obj
2108 If (Msg And Obj) Get Msg Of Obj To Rval
2109 End
2110 Else Get Msg Of Obj To Rval
2111 Procedure_Return Rval
2112 End_Procedure // Construct_Object
2113
2114 Procedure Add_Button Integer Img# Integer Msg# Integer Obj#
2115 Integer Cnt
2116 Get Item_Count To Cnt
2117 Send Add_Item Msg# ''
2118 Set Form_Image_Index Item Cnt To Img#
2119 If Num_Arguments Gt 2 Set Aux_Value Item Cnt To Obj#
2120 End_Procedure
2121
2122 Procedure Add_Button_Type Integer Type#
2123 Integer Cnt
2124 Get Item_Count To Cnt
2125 Decrement Cnt
2126 If Cnt Ge 0 Set Button_Style Item Cnt To Type#
2127 End_Procedure // Add_Button_Type
2128
2129 Procedure Add_Tooltip String Tip
2130 Integer Itm
2131 Get Item_Count To Itm
2132 Decrement Itm
2133 If Itm Ge 0 Set Tooltip_Value Item Itm To Tip
2134 End_Procedure
2135
2136 Procedure Add_Space
2137 Send Add_Item Msg_None ''
2138 End_Procedure
2139
2140 { MethodType=Property Visibility=Private }
2141 Function GuiSize Returns Integer
2142 Handle hWnd
2143 Integer x y x1 y1 cy cx iVoid
2144 Pointer lpsRect
2145 String sRect
2146 Get Window_Handle To hWnd
2147 If hWnd Begin
2148 ZeroType tRECT To sRect
2149 GetAddress of sRect To lpsRect
2150 Move (GetWindowRect(hWnd, lpsRect)) To iVoid
2151
2152 GetBuff From sRect At tRECT.left To x
2153 GetBuff From sRect At tRECT.top To y
2154 GetBuff From sRect At tRECT.right To x1
2155 GetBuff From sRect At tRECT.bottom To y1
2156
2157 Move (x1-x) To cx
2158 Move (y1-y) To cy
2159 End
2160 Else Begin
2161 Move 28 to cy
2162 Move 28 to cx
2163 End
2164 Function_Return ( cy*65536 + cx )
2165 End_Function
2166
2167 { MethodType=Event }
2168 Procedure OnShowHint integer iItem
2169 End_Procedure
2170
2171 { MethodType=Event }
2172 Procedure OnHideHint integer iItem
2173 End_Procedure
2174
2175 { Visibility=Private MethodType=Event NoDoc=True }
2176 Procedure Notify Integer wParam Integer lParam
2177 Integer iVoid iCode
2178 Pointer lpsNMHDR
2179 String sNMHDR
2180 ZeroType tNMHDR To sNMHDR
2181 GetAddress of sNMHDR To lpsNMHDR
2182 Move (CopyMemory(lpsNMHDR, lParam, tNMHDR_size)) To iVoid
2183
2184 GetBuff FROM sNMHDR at tNMHDR.code To iCode
2185 If (iCode = TTN_SHOW) Send Initialize_Hint wParam
2186 Else If (iCode = TTN_POP) Send Hide_Hint wParam
2187 End_Procedure
2188
2189 { Visibility=Private }
2190 Procedure Initialize_Hint integer iItem
2191 Integer SbId
2192 String sStatus_Help
2193 String sShadowed
2194 Send OnShowHint iItem
2195 Delegate Get Statusbar_Id to SbId
2196 If SbId Begin
2197 Get Status_Help iItem To sStatus_Help
2198 If ( sStatus_Help<>'' AND Shadow_State(self,iItem)) Begin
2199 Get Shadow_Status_Help To sShadowed
2200 Append sStatus_Help sShadowed
2201 End
2202 If sStatus_Help ne '' Begin
2203 Send Initialize_Menu to SbId
2204 Send Show_Status_Help to SbId sStatus_Help
2205 End
2206 End
2207 End_Procedure
2208
2209 { Visibility=Private }
2210 Procedure Hide_Hint Integer iItem
2211 Integer SbId
2212 Delegate Get Statusbar_Id to SbId
2213 If SbId Send Exit_Menu to SbId
2214 Send OnHideHint iItem
2215 End_Procedure
2216
2217End_Class
2218
2219// Mixin-Class: Standard_Object_Mixin
2220//
2221// 1. Define Help interface
2222// 2. Define alternate switch logic
2223// 3. Define Status bar help support
2224//
2225
2226Class Standard_Object_Mixin Is A Mixin
2227
2228 { Visibility=Private }
2229 Procedure Define_Standard_Object_Mixin
2230 Send Define_RGB_Support_Temp_Mixin
2231
2232 { Visibility=Private }
2233 Property Integer Switch_Skip_State False
2234
2235 { Visibility=Private }
2236 Property String Private.Status_Help ''
2237
2238 { Category=Help }
2239 { PropertyType=Boolean }
2240 Property Integer Use_Parent_Status_Help False
2241
2242 { Visibility=Private }
2243 Property Integer Disable_Default_Action_Button_state False
2244
2245 Send Define_Help_Mixin
2246 //Send Define_Modal_Mixin
2247
2248 On_Key Kswitch Send Switch_Next_Area Private
2249 On_Key Kswitch_Back Send Switch_Prior_Area Private
2250 End_Procedure
2251
2252 Import_Class_Protocol RGB_Support_Temp_Mixin
2253 Import_Class_Protocol Help_Mixin
2254
2255 { MethodType=Property }
2256 { InitialValue="" }
2257 { ItemParameter=1 }
2258 { Category=Help }
2259 Procedure Set Status_Help String Item# String Shelp
2260 Set Private.Status_Help To Item#
2261 End_Procedure
2262
2263 { MethodType=Property }
2264 Function Status_Help Integer Item# Returns String
2265 String Shelp
2266 Get Private.Status_Help To Shelp
2267 If (Shelp Eq '' And Use_Parent_Status_Help(self)) ;
2268 Delegate Get Status_Help To Shelp
2269 Function_Return Shelp
2270 End_Function
2271
2272 // New Message
2273 Procedure Switch_Next_Area
2274 Send Switch
2275 End_Procedure // Switch_Next_Area
2276
2277 // New Message
2278 Procedure Switch_Prior_Area
2279 Send Switch_Back
2280 End_Procedure // Switch_Prior_Area
2281
2282 Procedure Request_Status_Help Integer Fg
2283 String Sstatus_Help
2284 Integer Sbid
2285 If Fg Begin
2286 Get Statusbar_Id To Sbid
2287 If Not Sbid Procedure_Return
2288 Get Status_Help To Sstatus_Help
2289 Send Show_Status_Help To Sbid Sstatus_Help
2290 End
2291 End_Procedure
2292
2293 // when the object takes the focus make sure that the default button, if any
2294 // is highlighted. Note that buttons override this message and handle this
2295 // a bit differently.
2296 //
2297 { Visibility=Private }
2298 Procedure PrivateSetCurrentButton
2299 integer hoButton
2300 If not (disable_default_action_button_state(self)) Begin
2301 get Default_Action_Button to hoButton
2302 if hoButton set CurrentButtonState of hoButton to TRUE
2303 end
2304 end_Procedure
2305
2306 // when the object loses the focus the default button highlight must
2307 // be removed - it will be restored, as needed, by the next object
2308 // that takes the focus. If we do not do this, the button will not
2309 // lose the highlight when switching between other panels and
2310 // programs (and it should).
2311 //
2312 { Visibility=Private }
2313 Procedure PrivateKillCurrentButton
2314 integer hoButton
2315 get Current_Action_Button to hoButton
2316 if hoButton set CurrentButtonState of hoButton to FALSE
2317 end_Procedure
2318
2319 // this forces a reset of the default button....This should only be sent to this
2320 // object when it is the focus object since it is the focus that determines
2321 // what should or should not be highlighted.
2322 //
2323 { Visibility=Private }
2324 Procedure doResetCurrentButton
2325 Send PrivateKillCurrentButton
2326 Send PrivateSetCurrentButton
2327 End_Procedure
2328
2329 { MethodType=Event Visibility=Private }
2330 Procedure Notify_Focus_Change Integer Fg
2331 //***Forward Send Notify_Focus_Change Fg
2332 if Fg begin
2333 Send OnSetFocus
2334 send PrivateSetCurrentButton
2335 end
2336 Else begin
2337 send PrivateKillCurrentButton
2338 Send OnKillFocus
2339 end
2340 Send Request_Status_Help Fg
2341
2342 If Fg Begin
2343 // if taking the focus, tell containers about this focus change
2344 Delegate Send NotifyFocusSetInContainer Self
2345 End
2346 End_Procedure // Notify_Focus_Change
2347
2348 { MethodType=Event }
2349 Procedure OnSetFocus
2350 end_Procedure
2351
2352 { MethodType=Event }
2353 Procedure OnKillFocus
2354 end_Procedure
2355
2356 // dbLists now send this callback message. By adding this at this low
2357 // level all objects can safely use prompt lists.
2358 //
2359 { MethodType=Event }
2360 Procedure Prompt_Callback integer hPrompt
2361 End_Procedure
2362
2363// as of 8.2 this is no longer needed (you can not pass self w/ delegation)
2364// // explicitly delegate so that self can be passed as a
2365// // parameter without it getting changed. self gets lost
2366// // past 1 level of delegation. Panels that actually support this message will
2367// // override this and make it do something useful.
2368// //
2369// //Doc/ Visibility=Private
2370// Procedure Set Default_Action_Button Integer hoButton
2371// delegate set Default_Action_Button to hoButton
2372// End_Procedure
2373
2374End_Class
2375
2376
2377// This is used to determine of Enter should next or nothing. By making
2378// this a global a change will immediately affect all objects. At some
2379// point this may become internal (with a public access).
2380Integer gbKenterNext
2381Move 0 to gbKenterNext
2382
2383// this gets mixed into "panel" classes (views, panels,
2384// modal panels) and defines support for a default button. The only
2385// public interface exposed for default buttons is:
2386// get/set default_action_button
2387//
2388Class DefaultActionButton_Mixin Is A Mixin
2389 { Visibility=Private }
2390 Procedure Define_DefaultActionButton_Mixin
2391 { Visibility=Private }
2392 property integer private.Default_Action_Button 0
2393
2394 { Visibility=Private }
2395 Property Integer private.Current_Action_Button 0
2396
2397 on_key kEnter send Default_Action // this makes it easy to augment!
2398 End_Procedure
2399
2400 { MethodType=Property }
2401 Function Default_Action_Button Returns Integer
2402 // we return object Id in the unlikely case that the object was deleted.
2403 Function_Return (object_id(private.default_action_button(self)))
2404 End_Function
2405
2406 { MethodType=Property }
2407 { InitialValue=0 }
2408 { Category=Behavior }
2409 Procedure Set Default_Action_Button Integer hoButton
2410 integer hFoc
2411 set private.default_action_button to hoButton
2412 // anytime the default button changes the highlighted button
2413 // may or may not change. So we reset the action button just in case. This
2414 // means that ALL objects must understand this message (which is mixed into
2415 // standard object mixin).
2416 get focus of desktop to hFoc
2417 If hFoc gt desktop ;
2418 send DoResetCurrentButton to hFoc
2419 End_Procedure
2420
2421 // notice there is no Set for this. The set is private
2422 //
2423 { MethodType=Property }
2424 Function Current_Action_Button Returns Integer
2425 // we return object Id in the unlikely case that the object was deleted.
2426 Function_Return (object_id(private.current_action_button(self)))
2427 End_Function
2428
2429 Register_Procedure KeyAction
2430
2431 // called by kEnter. By default it should send the message
2432 // KeyAction to the default button. If possible, avoid augmenting
2433 // this ... change the Default_action_button property instead.
2434 //
2435 { Visibility=Private }
2436 Procedure Default_Action
2437 integer hoButton iRetVal
2438 get Current_Action_Button to hoButton
2439 if hoButton Begin
2440 Get msg_KeyAction of hoButton to iRetVal
2441 Function_Return iRetVal
2442 End
2443 else if gbKEnterNext ;
2444 Send Next to (focus(desktop))
2445 End_Procedure
2446
2447End_Class
2448
2449
2450// Mixin-Class: Standard_Container_Mixin
2451//
2452// 1. Define standard object stuff
2453// 2. Set default color
2454// 3. Add Get/Set Label support
2455// (4. Auto-locate capability - not right now - only in deos)
2456// 5. Add Modal object suppport
2457//
2458Class Standard_Container_Mixin Is A Mixin
2459 { Visibility=Private }
2460 Procedure Define_Standard_Container_Mixin
2461 Send Define_Standard_Object_Mixin
2462 //property integer Private.Object_color 0
2463 //Send Define_Modal_Mixin
2464 Send Define_dfAuto_Locate
2465 Set Color to clBtnFace
2466 Set TextColor to clWindowText
2467
2468 Send define_Shadow_Mixin
2469 Send Define_Bitmap_Support_Mixin
2470
2471 Set Broadcast_Implicit_Shadow_State to True
2472 End_Procedure
2473
2474 Import_Class_Protocol Standard_Object_Mixin
2475 //Import_Class_Protocol Modal_Mixin
2476 Import_Class_Protocol Label_Mixin
2477 Import_Class_Protocol dfAuto_Locate_Mixin
2478 Import_Class_Protocol Shadow_Mixin
2479 Import_Class_Protocol Bitmap_Support_Mixin
2480
2481 { Visibility=Private MethodType=Property }
2482 Procedure Set Current_Shadow_State integer iState
2483 Set Private.Shadow_State to iState
2484 End_Procedure // Set Current_Shadow_State
2485
2486 { MethodType=Property NoDoc=True }
2487 Function Object_Shadow_State returns integer
2488 Function_Return (Private.Shadow_State(self))
2489 End_Function // Object_Shadow_State
2490
2491 Procedure End_Construct_Object
2492 Forward Send End_Construct_Object
2493 // if already shadowed by parent...do nothing. Else set changed
2494 // state and broadcast to children
2495 If (Explicit_Shadow_State(self) AND ;
2496 Not(Implicit_Shadow_State(self)) AND ;
2497 Broadcast_Implicit_Shadow_State(self) ) ;
2498 Broadcast Set Implicit_Shadow_State to True
2499 End_procedure
2500
2501End_Class
2502
2503
2504Class NonVisual_Container_Mixin is a Mixin
2505 { Visibility=Private MethodType=Property Obsolete=True }
2506 Function Object_Color returns integer
2507 integer rval
2508 Delegate Get Object_color to rval
2509 function_return rval
2510 End_Function
2511
2512 { MethodType=Property NoDoc=True }
2513 Function Color Returns Integer
2514 integer rval
2515 Delegate Get Color to rval
2516 function_return rval
2517 End_Function
2518
2519 { MethodType=Property NoDoc=True }
2520 Function TextColor Returns Integer
2521 integer rval
2522 Delegate Get TextColor to rval
2523 function_return rval
2524 End_Function
2525
2526 { MethodType=Property NoDoc=True }
2527 Function Container_Handle Returns integer
2528 Integer rVal
2529 Delegate Get Container_Handle to rVal
2530 Function_Return rVal
2531 End_Function // Function
2532
2533 { MethodType=Event Visibility=Private }
2534 Procedure Page integer state
2535 End_Procedure // Page
2536
2537 { MethodType=Event Visibility=Private }
2538 Procedure Page_Delete
2539 End_Procedure // Page_Delete
2540End_Class // NonVisual_Container_Mixin
2541
2542
2543Class Panel_Mixin is a Mixin
2544 { Visibility=Private }
2545 Procedure Define_Panel_Mixin
2546 Send Define_Modal_Mixin
2547 Send Define_DefaultActionButton_Mixin
2548
2549 // this is part of a special codejock skinning accomodation. See Page
2550 { Category=Appearance }
2551 { Visibility=Private }
2552 Property Boolean pbMaintainGuiSizeOnPage True
2553
2554 { Visibility=Private }
2555 Property Integer piPrePageGuiSize 0
2556
2557 // these will get replaced in MDI dialogs w/ appropriate messages
2558 On_Key Kswitch_Panel Send none // this has a default alt behavior, which we never want.
2559 On_Key Kswitch_Panel_Back Send none
2560 End_Procedure
2561
2562 Import_Class_Protocol Modal_Mixin
2563 Import_Class_Protocol DefaultActionButton_Mixin
2564
2565 { NoDoc=True }
2566 Procedure Exit_Application
2567 If (Exit_Application_Local_State(self)) ;
2568 Send Close_Panel
2569 Else ;
2570 Forward Send Exit_Application
2571 End_Procedure // Exit_Application
2572
2573 Procedure Close_Panel
2574 Send Deactivate
2575 End_Procedure
2576
2577 { MethodType=Event }
2578 Procedure OnResize
2579 End_Procedure
2580
2581 { MethodType=Event }
2582 Procedure OnPaint
2583 End_Procedure
2584
2585 { MethodType=Property Visibility=Private }
2586 Procedure Set GuiSize Integer cy Integer cx
2587 Integer cxy
2588 Get GuiSize To cxy
2589 Forward Set GuiSize to cy cx
2590 If (BuildingObjectId=0 AND ;
2591 Window_Handle(self) AND ;
2592 ( Hi(cxy)<>cy or Low(cxy)<>cx) ) ;
2593 Send OnResize
2594 End_Procedure
2595
2596 { Visibility=Private }
2597 Procedure Paint
2598 Forward Send Paint
2599 Send OnPaint
2600 End_Procedure
2601
2602// { MethodType=Event Visibility=Private }
2603// Procedure Page Integer iState
2604// Forward Send Page iState
2605// If (iState =1) Send OnResize
2606// End_Procedure
2607
2608 { MethodType=Event Visibility=Private }
2609 Procedure Page Integer iPageObject
2610 Integer iOld iNew
2611 // This special code to make Codejock skinning work better. When skins are applied the window size
2612 // is maintained and the clientsize if changed. If we are using client-sizing we want to keep the size
2613 // the same. pbMaintainGuiSizeOnPage allows one to disable this special behavior.
2614 If (iPageObject=1 and pbMaintainGuiSizeOnPage(Self) and pbSizeToClientArea(Self)) Begin
2615 // when modal dialog windows are created they are created in create_dialog and the size has already
2616 // been skin adjusted. We store the value before that happens and use it here
2617 // this should only happen with modal dialogs. At this point they should have a window_handle but we
2618 // check just to be careful.
2619 Send OnPreApplySkin False
2620 Forward Send Page iPageObject
2621 Send OnPostApplySkin False
2622 End
2623 Else Begin
2624 Forward Send Page iPageObject
2625 End
2626 If (iPageObject =1) Begin
2627 Send OnResize
2628 End
2629 End_Procedure
2630
2631 // When skins are applied to views we want to maintain the client size. I theory we want to do this to all objects
2632 // with pbSizeToClientArea=T. Views are the most likely objects to need this which is what I've tested this with.
2633 { MethodType=Event }
2634 { Visibility=Private }
2635 Procedure OnPreApplySkin Boolean bReApply
2636 Handle hWnd
2637 Integer iVoid
2638 Get Window_Handle to hWnd
2639 // if we are repapplying a skin and it is not active we end
2640 // if we are not reapplying (page) and it has a window then this has already
2641 // been called by create_dialog - we end
2642 If ((bReApply and hWnd=0) or (not(bReApply) and hWnd)) Begin
2643 Procedure_Return
2644 End
2645
2646 If (pbSizeToClientArea(Self)) Begin
2647 Set piPrePageGuiSize to (GuiSize(Self))
2648 If (hWnd and bReApply) Begin
2649 Move (SendMessage(hWnd, WM_SETREDRAW, 0, 0)) to iVoid // turn off painting
2650 End
2651 End
2652 Broadcast Send OnPreApplySkin bReApply
2653 End_Procedure
2654
2655 { MethodType=Event }
2656 { Visibility=Private }
2657 Procedure OnPostApplySkin Boolean bReApply
2658 Integer iNew iVoid
2659 Handle hWnd
2660 Boolean bOk
2661 Get Window_Handle to hWnd
2662
2663 If (bReApply and hWnd=0) Begin
2664 Procedure_Return
2665 End
2666
2667 Broadcast Send OnPostApplySkin bReApply
2668 If (hWnd and pbSizeToClientArea(Self)) Begin
2669 Get GuiSize to iNew
2670 If (iNew<>0 and iNew<>piPrePageGuiSize(Self)) Begin
2671 Set GuiSize to (hi(piPrePageGuiSize(Self))) (low(piPrePageGuiSize(Self)))
2672 End
2673 If bReApply Begin
2674 Move (SendMessage(hWnd, WM_SETREDRAW, 1, 0)) to iVoid // turn back on painting
2675 Move (RedrawWindow(hWnd, 0, 0, RDW_ERASE ior RDW_FRAME ior RDW_INVALIDATE ior RDW_ALLCHILDREN ior RDW_ERASENOW ior RDW_UPDATENOW)) to bOk
2676 End
2677 Set piPrePageGuiSize to 0 0
2678 End
2679 End_Procedure
2680
2681
2682 // These switch view messages should be disabled if the object is modal.
2683 // if not modal, delegate until we hit the client area (which knows this message)
2684 // This protects against modal objects placed inside of a MDI view.
2685 //
2686 { Visibility=Private }
2687 Procedure Switch_Next_View
2688 If not (modal_state(self)) delegate send Switch_next_view
2689 end_procedure
2690
2691 { Visibility=Private }
2692 Procedure Switch_Prior_View
2693 If not (modal_state(self)) delegate send Switch_Prior_View
2694 end_procedure
2695
2696 // When DEOs are properly placed within DEO clients this message will never be needed.
2697 // This is called via delegation in server.pkg inside of get default_static_server_state.
2698 // This will only get called when you've got an improper DEO nesting. At some point in the
2699 // future we might remove this message so you will see a runtime error which would identify this
2700 // as a bug. Since this has always worked we are leaving this in 8.3 so existing applications
2701 // keep working. In the future this may get removed.
2702 { MethodType=Property Visibility=Private }
2703 Function Static_Server_State Returns Integer
2704 End_Function // Static_Server_State
2705
2706 // panels need their own version of this which do not send the NotifyFocusSetInContainer
2707 // notification. Actually panels never really take the focus, but this message does get sent.
2708 { MethodType=Event Visibility=Private }
2709 Procedure Notify_Focus_Change Integer Fg
2710 //***Forward Send Notify_Focus_Change Fg
2711 If Fg Begin
2712 Send OnSetFocus
2713 Send PrivateSetCurrentButton
2714 End
2715 Else Begin
2716 Send PrivateKillCurrentButton
2717 Send OnKillFocus
2718 End
2719 Send Request_Status_Help Fg
2720
2721 End_Procedure // Notify_Focus_Change
2722
2723 // do nothing and stop the delegation. We do not delegate notification beyond panel
2724 { MethodType=Event Visibility=Private }
2725 Procedure NotifyFocusSetInContainer Handle hoControlFocus
2726 End_Procedure
2727
2728End_Class
2729
2730//
2731// Mixin-Class: Mask_Form_Mixin
2732//
2733String Default_Currency_Mask Default_Numeric_Mask Default_Date_Mask
2734Integer Default_Date_Window
2735
2736
2737Get Default_Currency_Symbol to Default_Currency_Mask
2738// create default currency mask using windows currency symbol
2739Move (Default_Currency_Mask + ",*;(" + Default_Currency_Mask + ",*)") to Default_Currency_Mask
2740Move "*" to Default_Numeric_Mask
2741Move '' to Default_Date_Mask
2742Move DATE_WINDOW to Default_Date_Window
2743
2744
2745Class Mask_Form_Mixin Is A Mixin
2746 { MethodType=Property Visibility=Private }
2747 Procedure Set Private.Numeric_Mask integer item# integer MaskType ;
2748 integer LeftDigit integer RightDigit ;
2749 string DfltMask
2750 Set Form_DataType item item# to MaskType
2751 Set Form_Mask item item# to ;
2752 (Number_Default_Mask(LeftDigit,RightDigit,DfltMask))
2753 If RightDigit gt 0 increment RightDigit
2754 Set Form_Margin item item# to (LeftDigit+RightDigit)
2755 End_procedure
2756
2757 Procedure Set Currency_Mask integer item# ;
2758 integer LeftDigit integer RightDigit ;
2759 String DfltMask
2760 String sMask
2761 If Num_Arguments Gt 3 ;
2762 Move DfltMask to sMask
2763 Else ;
2764 Move Default_Currency_Mask to sMask
2765 Set Private.Numeric_Mask item# to MASK_CURRENCY_WINDOW ;
2766 LeftDigit RightDigit sMask
2767 End_procedure
2768
2769 Procedure Set Numeric_Mask integer item# ;
2770 integer LeftDigit integer RightDigit ;
2771 string DfltMask
2772 String sMask
2773 If Num_Arguments Gt 3 ;
2774 Move DfltMask to sMask
2775 Else ;
2776 Move Default_Numeric_Mask to sMask
2777 Set Private.Numeric_Mask item# to MASK_NUMERIC_WINDOW ;
2778 LeftDigit RightDigit sMask
2779 End_procedure
2780
2781End_Class
2782
2783// Mixin-Class: Single_item_Navigate_Mixin
2784//
2785// This used by form and entry classes to handle the differences that
2786// occur because DF thinks as a multi-item object and these are single item
2787//
2788//
2789// 1. define alternate switch behavior for single items form and entry
2790//
2791Class Single_Item_Navigate_Mixin is a Mixin
2792 { Visibility=Private }
2793 Procedure Define_Single_Item_Navigate_Mixin
2794 // This will tell the object that it should switch/switch_back
2795 // by skipping other dfentry_forms. The reason we made this a
2796 // property is so it can be overridden. Switch_Next_area and
2797 // Switch_Prior_area uses this.
2798 //
2799 Set Switch_Skip_State To True
2800 Send Define_Shadow_Mixin
2801 End_Procedure
2802
2803 Import_Class_Protocol Shadow_Mixin
2804
2805 // The switch_next_area and switch_Prior_area messages are sent by the
2806 // F6/Shift+F6 keys. Changes are made here to make a switch do something
2807 // useful in entry_forms. The current goal is to make it act like the
2808 // character mode product. We do this by making the switch skip all
2809 // dfentry_forms until it hits a DEO that is not an entry-form. This
2810 // changed behavior only occurs when switching FROM a dfentry_form
2811 // TO another dfentry_form.
2812 //
2813 Procedure Switch_Next_Area
2814 Integer Obj Ef Rval hoRing
2815 // if there are multiple items in the form, treat it like a normal
2816 // entry-form and do the normal switch message.
2817 If (Item_Count(self)>1) Send Switch
2818 Else Begin
2819 Move self To Obj
2820 move 0 to ef
2821 // we want to keep looking until the next object is a container (we switch into containers)
2822 // or the next object is in a different container than the one we are in (which handles
2823 // switching out of a container)
2824 Repeat
2825 Get Next_Object_Id Of Obj 0 To Obj // Normal Switch Behavior
2826 If (Obj=0 Or Obj=self) begin
2827 // if no next object or we are back to this object. We are either in a ring
2828 // or we are done. See if we have a ring parent. If we have a ring parent see
2829 // if the ring contains the focus and the object we found is ourselves. If that's the
2830 // case, switch tried its best and there is nowhere to go. Return a zero.
2831 // If the ring does not have the focus or there was not object then if not
2832 // a scope (not a view) Send next_object_id noDescend to it. This is created to provide a
2833 // way to next get stuck inside of rings with no focusable objects.
2834 get RingParent to hoRing
2835 // if ring contains focus and we've come back to ourselves assume we've tried
2836 // our best and there is nowhere to go.
2837 If (hoRing and ContainsFocus(hoRing) and obj=self) ;
2838 Move 0 to Obj
2839 else Begin
2840 If (hoRing and scope_state(hoRing)=0) ;
2841 Get next_object_id of hoRing 1 to obj
2842 else move 0 to obj
2843 end
2844 If (Obj=0) Procedure_Return
2845 end
2846 If (Client_area_state(obj) or parent(self)<>parent(obj) ) move 1 to Ef
2847 Until Ef
2848
2849 Get Msg_Activate Of Obj To Rval // Try To Activate Object
2850 // if we fail activation we want to do what switch normally does
2851 // which is to keep trying to switch.
2852 If Rval Send Switch To Obj // Send To Object That Didn'T Activate
2853 End
2854 End_Procedure // Switch_Next_Area
2855
2856
2857 Procedure Switch_Prior_Area // See Comments In Switch_Next_Area
2858 Integer Obj Ef Rval hoRing
2859 If (Item_Count(self)>1) Send Switch_Back
2860 Else Begin
2861 Move self To Obj
2862 repeat
2863 Get Prior_Object_Id of obj 0 To Obj
2864 If (Obj=0 Or Obj=self) begin
2865 get RingParent to hoRing
2866 If (hoRing and ContainsFocus(hoRing) and obj=self) ;
2867 Move 0 to Obj
2868 else Begin
2869 If (hoRing and scope_state(hoRing)=0) ;
2870 Get prior_object_id of hoRing 0 to obj
2871 else move 0 to obj
2872 End
2873 If (Obj=0) Procedure_Return
2874 end
2875 If (parent(self)<>parent(obj) ) move 1 to Ef
2876 Until Ef
2877 //delegate Get Prior_Object_Id 0 To Obj
2878 //If (Obj=0 Or Obj=self or parent(obj)=parent(self)) Procedure_Return
2879 Get Msg_Activate Of Obj To Rval
2880 If Rval Send Switch_Back To Obj
2881 End
2882 End_Procedure // Switch_Prior_Area
2883
2884 // Navigational work-around. In single item objects previous does not
2885 // work when the previous item is displayonly (any shadow-state condition).
2886 // The previous key remains where it is. While next works, it does not
2887 // work well in that the NEXT is sent recursively - place enough display
2888 // only object together and the stack would overflow. Switch/Switch_back
2889 // will continue searching if the object's activation fails (activate,
2890 // entering or exiting). We will trigger entering to return a non-zero
2891 // value if 1) it was already going to do that, or 2) we've got a single
2892 // item object and that single item's shadow-state is set. This seems to
2893 // address all possibilities.
2894 //
2895 { MethodType=Event NoDoc=True }
2896 Procedure Entering Returns Integer
2897 Integer Rval
2898 Forward Get Msg_Entering To Rval // Do Normal Entering
2899 // if entering is ok and single item check shadow state of that item.
2900 If (Rval=0 And Item_Count(self)=1) ;
2901 Get Shadow_State item 0 to Rval
2902 Procedure_Return Rval
2903 End_Procedure
2904End_Class
2905
2906
2907
2908// Mixin-Class: Standard_Form_Mixin - single item form mixin
2909//
2910// 1. Define standard object stuff
2911// 2. Set default border to entry_field
2912// 3. Add "Set Label" auto-label support
2913//
2914Class Standard_Form_Mixin Is A Mixin
2915 { Visibility=Private }
2916 Procedure Define_Standard_Form_Mixin
2917 { Visibility=Private }
2918 Property integer piPriorEnabledColor 0 // private, used by shadow_display
2919 Send Define_Standard_Object_Mixin
2920 Send Define_Dflabel_Mixin
2921 Send Define_Single_Item_Navigate_Mixin
2922 Send Define_FloatingPopupMenu_Mixin
2923 //Send Define_Mask_form_Mixin
2924 End_Procedure // Construct_Object
2925
2926 Import_Class_Protocol Standard_Object_Mixin
2927 Import_Class_Protocol Dflabel_Mixin
2928 Import_Class_Protocol Single_Item_Navigate_Mixin
2929 Import_Class_Protocol Mask_form_Mixin
2930 Import_Class_Protocol FloatingPopupMenu_Mixin
2931
2932 { MethodType=Event }
2933 Procedure Shadow_Display
2934 Integer Clr Brdr State
2935 Get Shadow_State to State
2936 // as of 8.3 this has been altered so that the control remembers what its prior
2937 // enabled color was.
2938 If State begin
2939 If (piPriorEnabledColor(self)=0) ;
2940 Set piPriorEnabledColor to (Color(self))
2941 Delegate Get Color To Clr
2942 end
2943 Else Begin
2944 Get piPriorEnabledColor to Clr // this could be zero, if it is, do nothing..it was never disabled
2945 Set piPriorEnabledColor to 0
2946 End
2947 If (Clr<>0) Set Color To Clr
2948 Send Label_Shadow_Display
2949 End_Procedure // Shadow_Display
2950
2951 { MethodType=Event }
2952 Procedure OnMaxText
2953 End_Procedure
2954
2955 { MethodType=Event }
2956 Procedure OnChange
2957 End_Procedure
2958
2959 { Visibility=Private MethodType=Event }
2960 Procedure Command Integer wParam Integer lParam
2961 Forward Send Command wParam lParam
2962 If (Hi(wParam)) eq EN_CHANGE Begin
2963 Send OnChange
2964 End
2965 Else If (Hi(wParam)) eq EN_MAXTEXT Begin
2966 Send OnMaxText
2967 End
2968 End_Procedure
2969
2970 { MethodType=Property NoDoc=True }
2971 Procedure Set Value Integer iItem String sValue
2972 Forward Set Value item iItem To sValue
2973 Send OnChange
2974 End_Procedure
2975
2976End_Class
2977
2978
2979// Special symbols for piLastColumn. Value can be a column number or
2980// one of these.
2981Enum_List
2982 Define rcLastColumn
2983 Define rcAll
2984 Define rcNone
2985 Define rcSelectedColumn
2986End_Enum_List
2987
2988
2989// Mixin-Class: Standard_Grid_Mixin
2990//
2991// 1. Define standard object stuff
2992// 2. Set default border to entry_field
2993// 3. Add "Set formLabel" auto-label support
2994//
2995define C_WHEELDELTA for |CI120 // number of divisions within a single wheel click - MS constant
2996
2997Class Standard_Grid_Mixin Is A Mixin
2998 { Visibility=Private }
2999 Procedure Define_Standard_Grid_Mixin
3000 Send Define_Standard_Object_Mixin
3001 Send Define_Multi_Item_Shadow_Mixin
3002 Send Define_FloatingPopupMenu_Mixin
3003
3004 // added for prompt and spin button support. These should be set in OnInitSpin
3005 { Category=Behavior }
3006 Property Integer Minimum_Position -32767
3007 { Category=Behavior }
3008 Property Integer Maximum_Position 32767
3009
3010 { Visibility=Private }
3011 Property Integer Current_Position 0
3012
3013 { Visibility=Private }
3014 property integer piLastResizedColumn 0 // private. System uses it
3015
3016 { EnumList="rcLastColumn, rcAll, rcNone, rcSelectedColumn" }
3017 { Category=Behavior }
3018 property integer peResizeColumn rcLastColumn // mode for reszing columns when grid is resized
3019 { Category=Behavior }
3020 property integer piResizeColumn 0 // if peResize column is set to rcSelectedColumn, this determines which column is sized
3021
3022 { Visibility=Private }
3023 property integer piWheelDelta 0 // internal, accumulates mouse wheel clicks
3024
3025 Set Border_Style To Border_Clientedge
3026 Set CurrentRowColor to clWindow // by default highlight color will be same as background
3027 Set CurrentCellColor to clWindow
3028 Set Gridline_Mode to GRID_VISIBLE_BOTH
3029
3030 Object Statushelp_Array Is An Array
3031 End_Object
3032
3033 Set Line_Width to 1 0
3034 Set Header_Label Item 0 to ""
3035
3036 // This should be of standard grid support.
3037 on_key kBegin_of_Data Send Beginning_of_Data
3038 on_key kEnd_of_Data Send End_of_Data
3039
3040 // All in all, this probably is the best default
3041 Set Auto_Top_Item_State to False
3042
3043 // In VDF8 w/ anchors setting this false is a much better starting point
3044 Set AutoSize_Height_State to False
3045 End_Procedure
3046
3047 Import_Class_Protocol Standard_Object_Mixin
3048 Import_Class_Protocol Multi_Item_Shadow_Mixin
3049 Import_Class_Protocol Mask_form_Mixin
3050 Import_Class_Protocol FloatingPopupMenu_Mixin
3051 Import_Class_Protocol Auto_Setup_Mixin
3052
3053 Procedure Activate_Item Integer Item# Returns Integer
3054 Integer Irval
3055 Integer Ioldst
3056 Get Auto_Top_Item_State To Ioldst
3057 Set Auto_Top_Item_State To False
3058 If (Focus(Desktop)<>self) ;
3059 Get Msg_Activate To Irval
3060 Set Auto_Top_Item_State To Ioldst
3061 If (Irval=0 And Current_Item(self)<>item#) Begin
3062 Set Current_Item To Item#
3063 Move (Current_Item(self)<>item#) To Irval
3064 End
3065 Procedure_Return Irval
3066 End_Procedure
3067
3068 Procedure Activate_Column Integer Item# Returns Integer
3069 Integer Irval Citem Lwidth
3070 Get Line_Size To Lwidth
3071 Get Current_Item To Citem
3072 // integer math will return first column of crnt row
3073 Add (Citem/Lwidth*Lwidth) To Item#
3074 Get Msg_Activate_Item Item# To Irval
3075 Procedure_Return Irval
3076 End_Procedure
3077
3078 { MethodType=Event }
3079 Procedure Header_Mouse_Click Integer Item#
3080 Integer Irval
3081 Get Msg_Activate_Column Item# To Irval
3082 End_Procedure
3083
3084 { MethodType=Event }
3085 Procedure Header_Mouse_Double_Click Integer Item#
3086 End_Procedure
3087
3088 #REPLACE HD_NOTIFY_MOUSE_CLICK -302
3089 #REPLACE HD_NOTIFY_MOUSE_DBLCLICK -303
3090 #REPLACE HD_NOTIFY_DIVIDER_DBLCLICK -305
3091
3092 { MethodType=Event Visibility=Private }
3093 Procedure Header_Notification Integer Mode Integer Item#
3094 // This will force the button to pop out. This way it is right
3095 // before a modal popup freezes it
3096 Send release_mouse_capture
3097
3098 // This forces a new paint just on the header
3099 set header_label item item# to (header_label(self,item#))
3100
3101 If Mode Eq Hd_Notify_Mouse_Click ;
3102 Send Header_Mouse_Click Item#
3103 If Mode Eq Hd_Notify_Mouse_Dblclick ;
3104 Send Header_Mouse_Double_Click Item#
3105 End_Procedure
3106
3107 { MethodType=Property }
3108 { InitialValue="" }
3109 { ItemParameter=1 }
3110 { Category=Help }
3111 Procedure Set Status_Help String Item# String Shelp
3112 Set Value Of (Statushelp_Array(self)) Item Item# To Shelp
3113 End_Procedure
3114
3115 { MethodType=Property }
3116 Function Status_Help Integer Item# Returns String
3117 String Shelp
3118 Integer Lwidth
3119 Integer Obj
3120 Get Line_Size To Lwidth
3121 // Integer Math Will Return First Column Of Crnt Row
3122 If Lwidth Move (Mod(Item#,Lwidth)) To Item#
3123 Move (Statushelp_Array(self)) To Obj
3124 If (Item#<item_Count(Obj)) ;
3125 Get Value Of Obj Item Item# To Shelp
3126 If (Shelp Eq '' And Use_Parent_Status_Help(self)) ;
3127 Delegate Get Status_Help To Shelp
3128 Function_Return Shelp
3129 End_Function
3130
3131 { Visibility=Private }
3132 Procedure Request_Status_Help Integer Fg
3133 String Sstatus_Help
3134 Integer Sbid
3135 If Fg Begin
3136 Get Statusbar_Id To Sbid
3137 If Not Sbid Procedure_Return
3138 Get Status_Help Item (Current_Item(self)) To Sstatus_Help
3139 Send Show_Status_Help To Sbid Sstatus_Help
3140 End
3141 End_Procedure
3142
3143 { MethodType=Event }
3144 Procedure OnChange integer iItem
3145 End_Procedure
3146
3147 { MethodType=Event }
3148 Procedure OnMaxText integer iItem
3149 End_Procedure
3150
3151// //Doc/ Visibility=Private MethodType=Event
3152// Procedure Command Integer wParam Integer lParam
3153// Forward Send Command wParam lParam
3154// If (Hi(wParam)) eq EN_CHANGE Begin
3155// Send OnChange (Current_Item(self))
3156// End
3157// Else If (Hi(wParam)) eq EN_MAXTEXT Begin
3158// Send OnMaxText
3159// End
3160// End_Procedure
3161
3162 { Visibility=Private MethodType=Event }
3163 Procedure Command integer wParam integer lParam
3164 integer iParam iItem
3165 get current_item to iItem
3166 Move (hi(wParam)) to iParam
3167 Forward Send Command wParam lParam
3168 Case Begin
3169 Case (iParam=EN_CHANGE) Send OnChange iItem
3170 Case (iParam=EN_MAXTEXT) Send OnMaxText iItem
3171 Case (iParam=CBN_SELCHANGE) Send Combo_Item_Changed iItem
3172 Case (iParam=CBN_EDITCHANGE OR iParam=CBN_EDITUPDATE) send Combo_Edit_Changed iItem
3173 Case (iParam=CBN_DROPDOWN) Send OnDropDown iItem
3174 Case (iParam=CBN_CLOSEUP) Send OnCloseUp iItem
3175 Case end
3176 end_procedure
3177
3178 { MethodType=Event }
3179 Procedure Combo_Item_Changed integer iItem
3180 Set item_Changed_State iItem to true
3181 Send OnChange iItem
3182 end_Procedure
3183
3184 { MethodType=Event }
3185 Procedure Combo_Edit_Changed integer iItem
3186 Set item_Changed_State iItem to true
3187 Send OnChange iItem // jvh - 13 Jun 97
3188 end_Procedure
3189
3190 { MethodType=Event }
3191 Procedure OnDropDown integer iItem
3192 End_Procedure
3193
3194 { MethodType=Event }
3195 Procedure OnCloseUp integer iItem
3196 End_Procedure
3197
3198
3199 { MethodType=Property Nodoc=True}
3200 Procedure Set Value Integer iItem String sValue
3201 Forward Set Value item iItem To sValue
3202 Send OnChange iItem
3203 End_Procedure
3204
3205 { MethodType=Property Visibility=Private Obsolete=True }
3206 Procedure Set Form_Label integer iItem string svalue
3207 Set Header_Label item iItem to sValue
3208 End_Procedure // Set Form_Label
3209
3210
3211 // Set Current_Item / Set New_Item
3212 //
3213 // 1. Modified to optimize painting and make scrolling work properly
3214 // 2. Add Request_Status_Help for item changes.
3215 //
3216 { MethodType=Property NoDoc=True }
3217 Procedure Set Current_Item Integer Itm
3218 Integer IsFoc
3219 integer oldst oldtop
3220 Move (Focus(Desktop)=self) to IsFoc
3221 If IsFoc Send Request_Status_Help False
3222 get dynamic_update_state to oldst
3223 Set Dynamic_Update_State to False
3224 get top_item to oldtop // we need to know if to-item changes
3225 Forward Set Current_Item to Itm
3226 // If dyn had been on, we pass 1 (refresh all) if we scrolled and a
3227 // 2 (refresh dirty cells) if we did not scroll. Note that other
3228 // processes might have dirtied the cells so that a "2" becomes
3229 // equivalent to a "1"
3230 if oldst ; // if top_Item changed we scrolled!
3231 Move (If(Top_Item(self)<>OldTop,1,2)) to OldSt
3232 Set dynamic_update_State to OldSt
3233 if IsFoc Send Request_Status_Help True
3234 End_Procedure // Set Current_Item
3235
3236 { Visibility=Private }
3237 Procedure Set New_Item Integer Itm
3238 Integer IsFoc
3239 integer oldst oldtop
3240 Move (Focus(Desktop)=self) to IsFoc
3241 If IsFoc Send Request_Status_Help False
3242 get dynamic_update_state to oldst
3243 Set Dynamic_Update_State to False
3244 get top_item to oldtop // we need to know if to-item changes
3245 Forward Set New_Item to Itm
3246 // If dyn had been on, we pass 1 (refresh all) if we scrolled and a
3247 // 2 (refresh dirty cells) if we did not scroll. Note that other
3248 // processes might have dirtied the cells so that a "2" becomes
3249 // equivalent to a "1"
3250 if oldst ; // if top_Item changed we scrolled!
3251 Move (If(Top_Item(self)<>OldTop,1,2)) to OldSt
3252 Set dynamic_update_State to OldSt
3253 if IsFoc Send Request_Status_Help True
3254 End_Procedure // Set New_Item
3255
3256 // when active a grid does not repaint new items on the screen
3257 // This forces a repaint when an item is added.
3258 { NoDoc=True }
3259 procedure Add_Item integer iMessage string sValue
3260 integer bOld
3261 get dynamic_update_state to bOld
3262 Set Dynamic_Update_State to False
3263 forward send add_item iMessage sValue
3264 Set dynamic_update_State to bOld
3265 end_procedure
3266
3267 // Set Dynamic_Update_State
3268 //
3269 // Modified to works as follows:
3270 // If 0, turn DUS off
3271 // If 1, Invalidate all cells and make it "2"
3272 // If 2, repaint only invalid cells plus scroll bars. Not Header
3273 // If 3, repaint everything (including headers)
3274 // When complete a 1,2 or 3 will set this property to 1.
3275 //
3276 { MethodType=Property NoDoc=True }
3277 Procedure Set Dynamic_Update_State integer st
3278 If St eq 1 Begin
3279 Send Scroll_Paint // this invalidates all cells
3280 Move 2 to st // Change state to only paint invalid cells
3281 End // plus scroll bars
3282 else ;
3283 If St eq 3 Move 1 to st // if 3, repaint EVERYTHING
3284 // runtime understands 0,1,2. If 2, final prop value will be 1
3285 Forward Set Dynamic_Update_State to st
3286 End_Procedure // Set Dynamic_Update_State
3287
3288 // Return the column of the passed item
3289 //
3290 Function Column Integer Item# returns Integer
3291 If (Item#=CURRENT) Begin // if the CURRENT symbol replace with current Item
3292 Get Current_Item to Item#
3293 end
3294 Function_Return (Mod(Item#,Line_Size(self)))
3295 End_Function
3296
3297 // Return the column of the current-item
3298 //
3299 { MethodType=Property }
3300 Function Current_Col Returns Integer
3301 Function_Return (Column(self,Current_Item(self)))
3302 End_Function
3303
3304 // Support for Beginning_of_Data and End_of_Data
3305 // Note that these messsages are Column sensitive. They do not
3306 // switch columns.
3307
3308
3309 // Jump to the first column
3310 Procedure Beginning_of_Data
3311 set current_item to (Current_Col(self))
3312 End_Procedure // beginning_of_Data
3313
3314 // jump to the last column
3315 Procedure End_of_Data
3316 integer col cols itmCnt
3317 get line_size to cols // columns in a row
3318 Get Current_col to col // the current column of the item
3319 get item_count to itmCnt
3320 decrement ItmCnt
3321 // Integer math at work.
3322 move ( (ItmCnt/cols)*cols+col) to col // column in last row
3323 // if we had a case where the last item was not in the last column
3324 // we could get an error. While unlikely we we check for this.
3325 set current_item to (itmCnt min col)
3326 End_Procedure // end_of_data
3327
3328 // Scroll
3329 // 1. Is column sensitive. It will never scroll out of the
3330 // current column
3331 // 2. Painting fixes and optimizations - no flickering
3332 Procedure Scroll Integer eDirection Integer iNumLines
3333 integer oldst oldtop itm cols col col2 st items
3334 Get Current_Item to Itm // current item
3335 Get Line_Size to cols // number of columns
3336 If iNumLines eq 0 ; // if iNumLines is not passed,
3337 Get Displayable_Rows to Items // use # displayable rows
3338 Else Move iNumLines to Items
3339 Move (Items * Cols) to Items // number of items we are scrolling
3340
3341 // If we are at the end of the list jump to the last column
3342 // Else if we are at the top of the list, jump to the first column
3343 // Else do a normal scroll
3344
3345 // We do this because the runtime scroll at the end of a page
3346 // may change columns which forces a complete repaint.
3347 if (eDirection=DOWNWARD_DIRECTION AND (Itm+Items>Item_Count(self)) ) ;
3348 Send end_of_data
3349 Else If (eDirection=UPWARD_DIRECTION AND (Itm-Items<0) ) ;
3350 Send Beginning_of_data
3351 Else Begin
3352 // This will always involve a top_item change. So we will shut
3353 // off dynamic update and turn it back on with a 1 (which means
3354 // first invalidate all cells)
3355 get dynamic_update_state to oldst
3356 Set Dynamic_Update_State to false
3357 //Forward Send scroll dir dist // normal scroll
3358 // if iNumLines is 0, pass 0 and it figures it out, else you must pass the
3359 // number of items to scroll. Note inconsistency here. You are passed number of rows
3360 // and forward # of items
3361 Forward Send scroll eDirection (if(iNumLines=0,iNumLines,items)) // normal scroll
3362 Set dynamic_update_State to OldSt
3363 End
3364 End_Procedure
3365
3366 // Bug Fix. Focus change to object does not send notify_focus_change.
3367 // This will force this (which also forces onSetFocus)
3368 //
3369 { MethodType=Property NoDoc=True }
3370 Procedure set Focus integer hwNewFoc integer hwOldFoc
3371 Forward Set focus to hwNewFoc hwOldFoc
3372 Send Notify_Focus_Change True
3373 end_procedure
3374
3375 // This fixes a bug in grids where activating a grid whose
3376 // item's entry_state is false does not display the dotted outline
3377 // if the item is not changed (set current_item not called). This is
3378 // a temporary workaround that should be removed as soon as this is
3379 // fixed in the runtime. We want to use base class new_item message
3380 // which paints the rectangle but does little else. Note the use of
3381 // forward send (a technique which is only used as a low level bug fix.
3382 // NOTE: This replaces the activate in Shadow_mixin. When this is fixed
3383 // this can be removed. (it duplicates the shadow activate purpose)
3384 //
3385 { NoDoc=True }
3386 Procedure Activate returns integer
3387 integer rVal itm
3388 If (active_state(self) AND Object_Shadow_State(self)) ;
3389 Move 1 to rVal
3390 Else Begin
3391 Forward Get MSG_Activate to rVal
3392 If (Rval=0 and item_count(self)) Begin
3393 // if activate is ok and we've got items and entry-state
3394 // of the current item is false, force the repaint.
3395 get current_item to itm
3396 if not (entry_state(self,itm)) ;
3397 FORWARD set new_item to itm // !!!!!!! FORWARD !!!!!!!!!
3398 End
3399 End
3400 Procedure_Return rVal
3401 End_Procedure // Activate
3402
3403 //
3404 // Messages added for Prompt and Grid support
3405 //
3406 { MethodType=Event Visibility=Private }
3407 Procedure Value_Spinned Integer iValue
3408 Set Spin_Value to iValue
3409 Set item_changed_State item (current_item(self)) to True
3410 End_Procedure
3411
3412 // We will check for the unlikely case of a two year date.
3413 // If the data value is 2 year-ish we will assume that
3414 // we want a two year date
3415 //
3416 { Visibility=Private }
3417 Function Base_Date returns Date
3418 Date dt
3419 Get Value item (current_item(self)) to dt // get current date value
3420 If (dt>0 AND dt<="01/01/1000") ;
3421 sysdate dt
3422 else ;
3423 sysdate4 dt
3424 function_return dt
3425 End_Function
3426
3427 { MethodType=Property }
3428 { DesignTime=False }
3429 Procedure Set Spin_Value integer iValue
3430 Date dDate
3431 Integer iType iCur
3432 Get Current_item to iCur
3433 Get form_datatype iCur to iType
3434 If (iType=Date_Window or iType=Mask_Date_Window) Begin
3435 Get Base_Date to dDate
3436 Move (dDate +iValue) to dDate
3437 Set Value iCur to dDate
3438 End
3439 Else ;
3440 Set Value iCur To iValue
3441 End_Procedure
3442
3443 { MethodType=Property }
3444 Function Spin_Value returns integer
3445 Integer iRval
3446 Date dDate
3447 Integer iType iCur
3448 Get Current_item to iCur
3449 Get form_datatype iCur to iType
3450 Get Value iCur to iRval
3451 // date support. We will make all dates relative from today
3452 If (iType=Date_Window or iType=Mask_Date_Window) Begin
3453 Get Base_Date to dDate
3454 If (iRval<>0) ;
3455 Move (iRval-dDate) to iRval
3456 end
3457 Function_Return iRval
3458 End_function
3459
3460 // private: called when prompt of spin button is pressed.
3461 // this is augmented to set up ranges for spin buttons
3462 { MethodType=Event Visibility=Private }
3463 Procedure Form_Button_Mouse_Down Integer iItem integer Counter
3464 Integer iValue
3465 Integer iMin
3466 Integer iMax
3467 Handle hBtn
3468 Integer eButtonStyle
3469 Integer iRVal
3470
3471 get Form_button iItem to eButtonStyle
3472 If (eButtonStyle=FORM_BUTTON_SPIN or eButtonStyle=FORM_BUTTON_SPIN_WRAP) Begin
3473 send OnInitSpin
3474 Get Form_Button_Window_Handle 0 to hBtn
3475 If hBtn Begin // there will always be a handle..or this should not get called
3476 Get Minimum_Position to iMin
3477 Get Maximum_Position to iMax
3478 Get Spin_Value to iValue
3479 Set Current_Position to iValue
3480 Move (SendMessage(hBtn, UDM_SETRANGE32, iMin, iMax)) to iRVal
3481 Move (SendMessage(hBtn, UDM_SETPOS32, 0, iValue)) to iRVal
3482 end
3483 end
3484 End_Procedure
3485
3486 // private: called when prompt or spin button is pressed
3487 { MethodType=Event Visibility=Private }
3488 Procedure Form_Button_Notification integer iItem integer iPos
3489 Handle hBtn
3490 Integer eButtonStyle
3491 Integer iVal
3492 get Form_button iItem to eButtonStyle
3493 If (eButtonStyle=FORM_BUTTON_PROMPT) ;
3494 send Prompt
3495 else if (eButtonStyle=FORM_BUTTON_SPIN or eButtonStyle=FORM_BUTTON_SPIN_WRAP) Begin
3496 Get Form_Button_Window_Handle 0 to hBtn
3497 if hBtn Begin
3498 Move (SendMessage(hBtn, UDM_GETPOS32, 0, 0) ) To iPos
3499 Get Current_Position To iVal
3500 If (iVal <> iPos) Begin
3501 Set Current_Position To iPos
3502 Send Value_Spinned iPos
3503 End
3504 End
3505 end
3506 End_Procedure
3507
3508 // private: Used by keys. bUp means add
3509 { Visibility=Private }
3510 Procedure DoSpinOne integer bUp
3511 Integer iCurrentValue iItem
3512 Integer eButtonStyle
3513 get current_item to iItem
3514 get Form_Button iItem to eButtonStyle
3515 If (eButtonStyle=FORM_BUTTON_SPIN or eButtonStyle=FORM_BUTTON_SPIN_WRAP) Begin
3516 Send OnInitSpin
3517 Get Spin_Value To iCurrentValue
3518 If bUp Begin
3519 Increment iCurrentValue
3520 If (iCurrentValue>Maximum_Position(self)) Begin
3521 If (eButtonStyle=FORM_BUTTON_SPIN) Procedure_return
3522 Get Minimum_Position To iCurrentValue
3523 End
3524 End
3525 Else Begin
3526 Decrement iCurrentValue
3527 If (iCurrentValue<Minimum_Position(self)) Begin
3528 If (eButtonStyle=FORM_BUTTON_SPIN) Procedure_return
3529 Get Maximum_Position To iCurrentValue
3530 End
3531 End
3532 Send Value_Spinned iCurrentValue
3533 end
3534 End_Procedure // DoSpinOne
3535
3536 Procedure DoScrollDown
3537 Send DoSpinOne False
3538 End_Procedure // DoScrollDown
3539
3540 Procedure DoScrollUp
3541 Send DoSpinOne True
3542 End_Procedure // DoScrollUp
3543
3544
3545 // by default this does nothing. Called when prompt button is called. Use Current_item to
3546 // figure out what to do.
3547 Procedure Prompt
3548 end_procedure
3549
3550 // Public: for Augmentation
3551 // based on the current_item (get current_item) or current column
3552 // (get current_col or get Column iCurrentItem) set spin params
3553 // can set minimum_position, maximum_position,
3554 { MethodType=Event }
3555 Procedure OnInitSpin
3556 End_procedure
3557
3558 { Visibility=Private }
3559 Procedure DoApplyAnchors integer x integer y
3560 integer iOldSize iNewSize iOldDyn
3561 // since doAdjustGridWidths might cause painting, shut off
3562 // dynamic_update_state so that a grid paint only occurs one time.
3563 get dynamic_update_state to iOldDyn
3564 set dynamic_update_state to false
3565 get guisize to iOldSize
3566 forward send DoApplyAnchors x y
3567 get guisize to iNewSize
3568 Move (low(iNewSize)-low(iOldSize)) to iNewSize
3569 if (iNewSize<>0) ;
3570 Send DoAdjustGridWidths iNewSize
3571 if iOldDyn ;
3572 set dynamic_update_state to 2 // 2=only paint what needs painting, and then set state to true
3573 end_procedure
3574
3575 // adjust columns when anchors change. Uses delta value passed and property
3576 // piResizeColumn
3577 procedure DoadjustGridWidths integer iGuiDelta
3578 integer iResizeColumn eResizeColumn
3579 integer iCols iCol iColWidth
3580 integer i iWidth
3581 integer iRemain
3582 get peResizeColumn to eResizeColumn
3583 if (eResizeColumn=rcLastColumn) begin
3584 get line_size to iCols
3585 Set form_guiwidth (iCols-1) to (form_guiwidth(self,iCols-1)+iGuiDelta)
3586 end
3587 else if (eResizeColumn=rcAll) begin
3588 get line_size to iCols
3589 move (iGuiDelta/iCols) to iColWidth
3590 Move (abs(mod(iGuiDelta,iCols))) to iRemain
3591 get piLastResizedColumn to iCol
3592 for i from 1 to iCols
3593 Move (mod(iCol+1,iCols)) to iCol
3594 Move iColWidth to iWidth
3595 If (iRemain>0) Begin
3596 Move (iWidth + if(iGuiDelta>0,1,-1)) to iWidth
3597 decrement iRemain
3598 If (iRemain=0) set piLastResizedColumn to iCol
3599 end
3600 if (iWidth<>0) ;
3601 Set form_guiwidth iCol to (form_guiwidth(self,iCol)+iWidth)
3602 loop
3603 end
3604 else if (eResizeColumn=rcSelectedColumn) begin
3605 get line_size to iCols
3606 get piResizeColumn to iResizeColumn
3607 If (iResizeColumn<iCols and iResizeColumn>=0) ;
3608 Set form_guiwidth iResizeColumn to (form_guiwidth(self,iResizeColumn)+iGuiDelta)
3609 end
3610 // else if must be rcNone...do nothing
3611 end_procedure
3612
3613
3614 // Sometimes this can get called when the object is disabled. A mouse_up will send
3615 // this even though the object did not take the focus. This stops that behavior.
3616 { Visibility=Private }
3617 Procedure Select_Toggling integer iItm Integer bState
3618 if (enabled_state(self)) ;
3619 Forward Send Select_toggling iItm bState
3620 End_Procedure
3621
3622 // low level notification that wm_mouseWheel was sent. Passes windows
3623 // defined parameters. If you need to do something special, use OnMouseWheel
3624 //
3625 { MethodType=Event Visibility=Private }
3626 Procedure OnWmMouseWheel Integer wParam Integer lParam
3627 integer iWheelDelta iKeys iDelta iClicks
3628 Move (low(abs(wParam))) to iKeys // any keys down when pressed
3629 Move (hi(abs(wParam))) to iDelta // number of click units
3630 If (wParam<0) move (-iDelta) to iDelta // can be up or down
3631 get piWheelDelta to iWheelDelta // Current accumulated micro clicks
3632 Move (iWheelDelta+iDelta) to iWheelDelta
3633 // C_WHEELDATA is 120 as defined by MS as the delta to react to. Once click is usually 120
3634 Move (iWheelDelta/C_WHEELDELTA) to iClicks // Number of clicks to react to
3635 Set piWheelDelta to (mod(iWheelDelta,C_WHEELDELTA)) // remainder unused microclicks
3636 // If we have enough Clicks send OnMouseWheel
3637 if (iClicks<>0) ;
3638 Send OnMouseWheel iClicks iKeys
3639 End_procedure
3640
3641 // public event. By default just move up or down a line
3642 //
3643 { MethodType=Event }
3644 Procedure OnMouseWheel integer iClicks integer iKey
3645 integer i iKeyValue
3646 Move (if(iClicks>0,kUpArrow, kDownArrow)) to iKeyValue
3647 Move (abs(iClicks)) to iClicks
3648 For i from 1 to iClicks
3649 send key iKeyValue
3650 loop
3651 End_procedure
3652End_Class
3653
3654Class Select_Mixin Is A Mixin
3655 { Visibility=Private }
3656 Procedure Define_Select_Mixin
3657 { Category=Appearance }
3658 { PropertyType=Boolean }
3659 Property Integer Auto_Size_State True
3660 End_Procedure
3661
3662 //***
3663 //*** Property: Label
3664 //*** Purpose : Compatibility DAF
3665 //***
3666 { MethodType=Property }
3667 { InitialValue="" }
3668 { Category=Appearance }
3669 Procedure Set Label String Val
3670 If (Auto_Size_State(self)) Send Autosize Val
3671 Set Value Item 0 To Val
3672 End_Procedure // Set Label
3673
3674 { MethodType=Property }
3675 Function Label Returns String
3676 Function_Return (Value(self,0))
3677 End_Function // Label
3678
3679 //***
3680 //*** Procedure: AutoSize
3681 //*** Purpose : This procedure will calculate the size needed to display
3682 //*** the label of the object. It will set the size accordingly.
3683 //***
3684
3685 { Visibility=Private }
3686 Procedure Autosize String Val
3687 Integer Label_Size
3688 If Val ne "" Begin
3689 Get Text_Extent Val To Label_Size
3690 Set Guisize To (Hi(Label_Size) + 3) (Low(Label_Size) + 25)
3691 Send Adjust_logicals
3692 End
3693 End_Procedure // Autosize
3694
3695 { MethodType=Event }
3696 Procedure OnChange
3697 End_Procedure
3698
3699 { MethodType=Property }
3700 Function Checked_State Returns Integer
3701 Function_Return (Select_State(self,0))
3702 End_Function
3703
3704 { MethodType=Property }
3705 { InitialValue=False }
3706 { Category=Appearance }
3707 { PropertyType=Boolean }
3708 Procedure Set Checked_State Integer bCheck
3709 Set Select_State item 0 To bCheck
3710 End_Procedure
3711
3712 { MethodType=Property Visibility=Private }
3713 Procedure Set Select_State Integer iItem Integer bSelect
3714 Forward Set Select_State item iItem To bSelect
3715 Send OnChange
3716 End_Procedure
3717
3718End_Class // Select_Mixin
3719
3720
3721//*** Mixin class: Standard_select_mixin
3722//*** 5
3723//*** 1. Standard messages used by select type objects (radios & checkboxes)
3724//
3725Class Standard_Select_Mixin Is A Mixin
3726 { Visibility=Private }
3727 Procedure Define_Standard_Select_Mixin
3728 Send Define_Standard_Object_Mixin
3729 Send Define_Single_Item_Navigate_Mixin
3730 Send Define_Select_Mixin
3731 Set Color to clBtnFace
3732 Set TextColor to clBtnText
3733 End_Procedure
3734
3735 Import_Class_Protocol Standard_Object_Mixin
3736 Import_Class_Protocol Single_Item_Navigate_Mixin
3737 Import_Class_Protocol Select_Mixin
3738
3739End_Class // Standard_Select_Mixin
3740
3741
3742// Class: Edit
3743//
3744// 1. Add Standard entry support
3745//
3746{ DesignerClass=cDTEdit }
3747{ OverrideProperty=Label_Justification_Mode InitialValue=Jmode_Top }
3748{ OverrideProperty=Label_row_offset InitialValue=1 }
3749{ OverrideProperty=Label_col_offset InitialValue=0 }
3750{ HelpTopic=Edit }
3751
3752{ OverrideProperty=Attach_Parent_State DesignTime=False }
3753{ OverrideProperty=Bitmap DesignTime=False }
3754{ OverrideProperty=Bitmap_Style DesignTime=False }
3755{ OverrideProperty=Block_Mouse_State DesignTime=False }
3756{ OverrideProperty=Client_Area_State DesignTime=False }
3757{ OverrideProperty=Physical_FontSize DesignTime=False }
3758{ OverrideProperty=Popup_State DesignTime=False }
3759{ OverrideProperty=Ring_State DesignTime=False }
3760{ OverrideProperty=Scope_State DesignTime=False }
3761{ OverrideProperty=Search_Case DesignTime=False }
3762{ OverrideProperty=Transparent_State DesignTime=False }
3763
3764Class Edit Is A DfBaseEdit
3765
3766 Procedure Construct_Object
3767 Forward Send Construct_Object
3768 Send Define_Standard_Object_Mixin
3769 Send Define_Dflabel_Mixin
3770 Send Define_ToolTip_Support_Mixin
3771
3772 Set Label_Offset To 1 0
3773 Set Label_Justification_Mode To Jmode_Top
3774
3775 // should edit wrap or not
3776 { Visibility=Private }
3777 Property Integer Private.Wrap_State True
3778
3779 { Visibility=Private }
3780 Property Integer m_Capslock_state False
3781
3782 { Visibility=Private }
3783 Property integer piPriorEnabledColor 0 // private, used by shadow_display
3784
3785 On_key key_Ctrl+Key_W Send Toggle_Wrap
3786
3787 Send Define_Shadow_Mixin
3788 On_Key kenter Send default_key
3789 Set Disable_default_action_button_state to True
3790 Set pbUseFormWindowHandle to False
3791 Set file_name to ""
3792 End_Procedure // Construct_Object
3793
3794 Import_Class_Protocol Standard_Object_Mixin
3795 Import_Class_Protocol Dflabel_Mixin
3796 Import_Class_Protocol Shadow_Mixin
3797 Import_Class_Protocol ToolTip_Support_Mixin
3798
3799 { MethodType=Property }
3800 { Category=Behavior }
3801 { PropertyType=Boolean }
3802 { DesignTime=False }
3803 procedure Set Wrap_State Integer State
3804 integer hndl Foc
3805 Set Private.Wrap_State to State
3806 Get Window_Handle to Hndl
3807 If Hndl Begin
3808 Get Focus of desktop to Foc
3809 Send Page_Object False
3810 Set window_style to ws_hscroll (not(state))
3811 Send Page_Object True
3812 If Foc eq self Send Activate
3813 End
3814 Else ;
3815 Set window_style to ws_hscroll (not(state))
3816 End_procedure
3817
3818 { MethodType=Property }
3819 Function Wrap_State returns Integer
3820 Function_Return (Private.Wrap_State(self))
3821 End_Function // Wrap_State
3822
3823 { Visibility=Private }
3824 Procedure Toggle_Wrap
3825 Set Wrap_State to (Not(Wrap_state(self)))
3826 End_Procedure
3827
3828 // If font changes the edit size stays the same. This make the most
3829 // sense.
3830 { Visibility=Private }
3831 Function Parent_Ratios returns integer
3832 Function_return (map_ratios(parent(self)))
3833 End_Function // Parent_ratios
3834
3835 { MethodType=Property Visibility=Private }
3836 Procedure Set Current_Shadow_State integer iState
3837 Set Private.Shadow_State to iState
3838 End_Procedure // Set Object_Shadow_State
3839
3840 { MethodType=Property NoDoc=True }
3841 Function Object_Shadow_State returns integer
3842 Function_Return (Private.Shadow_State(self))
3843 End_Function // Object_Shadow_State
3844
3845 { MethodType=Event }
3846 Procedure Shadow_Display
3847 Integer Clr Brdr State
3848 Get Object_Shadow_State to State
3849 // as of 8.3 this has been altered so that the control remembers what its prior
3850 // enabled color was.
3851 If State begin
3852 If (piPriorEnabledColor(self)=0) ;
3853 Set piPriorEnabledColor to (Color(self))
3854 Delegate Get Color To Clr
3855 end
3856 Else Begin
3857 Get piPriorEnabledColor to Clr // this could be zero, if it is, do nothing..it was never disabled
3858 Set piPriorEnabledColor to 0
3859 End
3860 If (Clr<>0) Set Color To Clr
3861 Send Label_Shadow_Display
3862 End_Procedure // Shadow_Display
3863
3864 { MethodType=Property Visibility=Private }
3865 Procedure Set Item_Shadow_State integer iItem integer iState
3866 End_Procedure // Set Item_Shadow_State
3867
3868 { MethodType=Property Visibility=Private }
3869 Function Item_Shadow_State integer iItem Returns integer
3870 End_Function // Item_Shadow_State
3871
3872 { MethodType=Event }
3873 Procedure OnChange
3874 End_Procedure
3875
3876 { MethodType=Event }
3877 Procedure OnMaxText
3878 End_Procedure
3879
3880 { Visibility=Private MethodType=Event }
3881 Procedure Command Integer wParam Integer lParam
3882 Forward Send Command wParam lParam
3883 If (Hi(wParam)) eq EN_CHANGE Begin
3884 Send OnChange
3885 End
3886 If (Hi(wParam)) eq EN_MAXTEXT Begin
3887 Send OnMaxText
3888 End
3889 End_Procedure
3890
3891 { MethodType=Property }
3892 Procedure Set Value Integer iItem String sValue
3893 Forward Set Value item iItem To sValue
3894 Send OnChange
3895 End_Procedure
3896
3897 // Get and Set capslock and set windows style to make it work
3898 //
3899 { MethodType=Property }
3900 { Category=Behavior }
3901 { PropertyType=Boolean }
3902 procedure Set Capslock_State Integer bState
3903 Set m_CapsLock_State to bState
3904 Set window_style to ES_UPPERCASE bState
3905 End_procedure
3906
3907 { MethodType=Property }
3908 Function CapsLock_State returns Integer
3909 Function_Return (m_Capslock_State(self))
3910 End_Function // Wrap_State
3911
3912 { MethodType=Property NoDoc=True }
3913 { PropertyType=Boolean }
3914 Procedure set Read_Only_State Integer bState
3915 if (bState<>read_only_state(self)) Begin
3916 if not bState on_key kenter send default_key
3917 else on_key kEnter send default_action
3918 Set disable_default_action_button_state to (not(bState))
3919 end
3920 forward set read_only_state to bstate
3921 // Must set windows style. (s/b moved to C at some point)
3922 Set Window_Style To ES_READONLY bState
3923 End_Procedure
3924
3925 // Base class does not clear changed_state. Also augment to send OnChange
3926 { NoDoc=True }
3927 procedure Delete_Data
3928 forward send delete_data
3929 set changed_state to false
3930 Send OnChange
3931 End_Procedure
3932
3933
3934 // Called by Page_Object. Handles tooltip creation. We use a dedicated
3935 // method to perform AddToolTip because it is often the case that Page_Object
3936 // is implemented in a mixin class.
3937 { Visibility=Private }
3938 Procedure RequestAddToolTip
3939 Send AddToolTip
3940 End_Procedure // RequestAddToolTip
3941
3942
3943 // Called by Page_Object. Handles tooltip removal.
3944 { Visibility=Private }
3945 Procedure RequestDeleteToolTip
3946 Send DeleteToolTip
3947 End_Procedure // RequestDeleteToolTip
3948End_Class
3949
3950// Class: List
3951//
3952// 1. Add Standard entry support
3953//
3954{ DesignerClass=cDTListBox }
3955{ OverrideProperty=Border_style InitialValue=Border_Clientedge }
3956{ HelpTopic=List }
3957
3958{ OverrideProperty=Aux_Value DesignTime=False }
3959{ OverrideProperty=Attach_Parent_State DesignTime=False }
3960{ OverrideProperty=Auto_top_Item_State DesignTime=False }
3961{ OverrideProperty=Bitmap DesignTime=False }
3962{ OverrideProperty=Bitmap_Style DesignTime=False }
3963{ OverrideProperty=Block_Mouse_State DesignTime=False }
3964{ OverrideProperty=Client_Area_State DesignTime=False }
3965{ OverrideProperty=Checkbox_item_state DesignTime=False }
3966{ OverrideProperty=Entry_State DesignTime=False }
3967{ OverrideProperty=Form_Bitmap DesignTime=False }
3968{ OverrideProperty=Form_Border DesignTime=False }
3969{ OverrideProperty=Form_DataType DesignTime=False }
3970{ OverrideProperty=Form_FontHeight DesignTime=False }
3971{ OverrideProperty=Form_FontItalics DesignTime=False }
3972{ OverrideProperty=Form_FontUnderline DesignTime=False }
3973{ OverrideProperty=Form_FontWeight DesignTime=False }
3974{ OverrideProperty=Form_TypeFace DesignTime=False }
3975{ OverrideProperty=Form_Width DesignTime=False }
3976{ OverrideProperty=Message DesignTime=False }
3977{ OverrideProperty=Physical_FontSize DesignTime=False }
3978{ OverrideProperty=Popup_State DesignTime=False }
3979{ OverrideProperty=Ring_State DesignTime=False }
3980{ OverrideProperty=Scope_State DesignTime=False }
3981{ OverrideProperty=Transparent_State DesignTime=False }
3982Class List Is A DFBaseListBox
3983
3984 Procedure Construct_Object
3985 Forward Send Construct_Object
3986 Send Define_Standard_Object_Mixin
3987 Send Define_Dflabel_Mixin
3988 Set Border_Style To Border_Clientedge
3989 Send Define_Multi_Item_Shadow_Mixin
3990 End_Procedure // Construct_Object
3991
3992 Import_Class_Protocol Standard_Object_Mixin
3993 Import_Class_Protocol Dflabel_Mixin
3994 Import_Class_Protocol Multi_Item_Shadow_Mixin
3995
3996 { MethodType=Event }
3997 Procedure OnChange
3998 End_Procedure
3999
4000 { MethodType=Property NoDoc=True }
4001 Procedure Set Current_Item Integer iItem
4002 Integer iLastItem
4003 Get Current_Item To iLastItem
4004 Forward Set Current_Item To iItem
4005 If (iItem <> iLastItem) Send OnChange
4006 End_Procedure
4007
4008 // The following procedures should be moved to C code. This resolves
4009 // certain issues with mapping DF list controls to windows controls.
4010 // Users are encouraged to only use two modes of list selection:
4011 // select_mode = MULTI_SELECT | SINGLE_SELECT
4012 // DO NOT use NO_Select - it won't work right.
4013 //
4014 // Special functionality to Note:
4015 //
4016 // 1. Set Select_Count to TRUE : If multi-select sets all select-states to TRUE
4017 // if single-select sets current item to TRUE
4018 // Set Select_Count to FALSE: Sets all items to false
4019 //
4020 // 2. Space bar no Longer toggles select state. If you want this. Create the following:
4021 // on_key key_space send toggle_Current_item
4022 //
4023 // 3. There is no message that is fired every time the select-state changes.
4024 //
4025 // 4. There is no message that ALWAYS gets sent when an object's select_state is
4026 // toggled (e.g. marking range via shift+mouse). Do not use set select_state or
4027 // item_changed_state for multi-select augmentations. With single select lists
4028 // you CAN use set current_item or set Select_State
4029
4030 // when paging non-multi lists the select-state item is lost. This fixes this
4031 //
4032 { MethodType=Event Visibility=Private }
4033 procedure Page integer bState
4034 integer iCur bSel
4035 get current_item to iCur
4036 If (item_count(self)) begin
4037 get select_state item iCur to bSel // remember what it was
4038 forward send page bState // if single select, select state will be lost
4039 // if paged, and non multi-select and the current item was selected, then
4040 // set select_state again to force it to be correct.
4041 If (bSel and window_handle(self) AND select_mode(self)<>MULTI_SELECT) ;
4042 set select_state item iCur to TRUE // reinstae what was
4043 end
4044 else forward send page bState
4045 end_procedure
4046
4047 // Set Select_Count is supposed to clear or select all items. This fixes
4048 // it to do the following:
4049 // If F - clear all selected items
4050 // if T and Multi - Select all items
4051 // If T and not Multi - Set select-state of current item to True
4052 //
4053 Procedure set Select_Count integer bState
4054 integer i iCnt
4055 get item_count to iCnt
4056 // if true and single item. Just set the one item
4057 if (bState and iCnt and select_mode(self)<>MULTI_SELECT) ;
4058 set select_state item (current_item(self)) to true
4059 else begin
4060 decrement iCnt
4061 For i from 0 to iCnt
4062 set select_state item i to bState
4063 loop
4064 end
4065 end_procedure
4066
4067 // The internal Select_Count gets hopelessly out of synch with the
4068 // select count in the windows control. Here is what we must do:
4069 // 1. If no-window control -find the count the hard way. Count them!
4070 // 2. If window control and Multi select: Forward get count
4071 // this works because when paged, DF just gets the LB_SELCOUNT property
4072 // which is right)
4073 // 3. If window control and not multi: Will either be 0 or 1. Check current_item to
4074 // see if it is selected. We can't use LB_SELCOUNT because it returns -1
4075 //
4076 { MethodType=Property }
4077 function Select_Count returns integer
4078 integer iCnt i iSel
4079 get item_count to iCnt
4080 if (window_handle(self)) begin
4081 if (select_mode(self)=MULTI_SELECT) ;
4082 forward get select_count to iSel
4083 else if iCnt ;
4084 Move (if(Select_state(self,current_item(self)),1,0)) to iSel
4085 end
4086 else Begin
4087 decrement iCnt
4088 For i from 0 to iCnt
4089 If (select_state(self,i)) increment iSel
4090 loop
4091 end
4092 function_return iSel
4093 end_function
4094
4095
4096 // Correct select-states for paged lists.
4097 // When the list is not paged it is fine.
4098 // When paged, and singlethe only way to get the item selected is to set
4099 // its current_item. The only way to clear a selected item is to
4100 // send the windows message LB_SERCURSEL
4101 // when multi, we need to send windows messages LB_SETSEL
4102 //
4103 { MethodType=Property NoDoc=True }
4104 Procedure Set Select_State Integer iItm Integer bSt
4105 integer cnt i sc
4106 // if not paged, just forward..RT handles this find
4107 If (window_handle(self)=0) ;
4108 forward set select_state item iItm to bSt
4109 Else Begin // if paged
4110 //...only change if a change is needed
4111 If (Select_State(self,iItm)<>bSt) Begin
4112 If (select_mode(self)=MULTI_SELECT) ; // if multi-select
4113 send windows_message LB_SETSEL bSt iItm
4114 Else Begin // single item, auto or no select.
4115 // if setting, we must set current_item. If clearing, we
4116 // must clear all (-1)
4117 send windows_message LB_SETCURSEL (if(bSt,iItm,-1)) 0
4118 End
4119 End
4120 end
4121 end_procedure
4122
4123 { Visibility=Private }
4124 procedure toggle_Current_item
4125 integer iCur
4126 Get current_item to iCur
4127 set select_state item iCur to (not(select_state(self,iCur)))
4128 end_procedure
4129End_Class
4130
4131Use PrmpBtMx.pkg // Prompt Button Support
4132
4133// Class: Form
4134//
4135// 1. Add Standard entry support
4136// 2. Support color change when shadowed (right now this is done in flex -
4137// should we try to make this automatic?)
4138// 3. Single item switch behavior
4139//
4140{ DesignerClass=cDTForm }
4141{ HelpTopic=Form }
4142{ OverrideProperty=Attach_Parent_State DesignTime=False }
4143{ OverrideProperty=Auto_top_Item_State DesignTime=False }
4144{ OverrideProperty=Bitmap DesignTime=False }
4145{ OverrideProperty=Bitmap_Style DesignTime=False }
4146{ OverrideProperty=Block_Mouse_State DesignTime=False }
4147{ OverrideProperty=Border_style DesignTime=False }
4148{ OverrideProperty=Client_Area_State DesignTime=False }
4149{ OverrideProperty=Checkbox_item_state DesignTime=False }
4150{ OverrideProperty=Form_Bitmap DesignTime=False }
4151{ OverrideProperty=Form_FontHeight DesignTime=False }
4152{ OverrideProperty=Form_FontItalics DesignTime=False }
4153{ OverrideProperty=Form_FontUnderline DesignTime=False }
4154{ OverrideProperty=Form_FontWeight DesignTime=False }
4155{ OverrideProperty=Form_TypeFace DesignTime=False }
4156{ OverrideProperty=Form_Width DesignTime=False }
4157{ OverrideProperty=Physical_FontSize DesignTime=False }
4158{ OverrideProperty=Popup_State DesignTime=False }
4159{ OverrideProperty=Ring_State DesignTime=False }
4160{ OverrideProperty=Scope_State DesignTime=False }
4161{ OverrideProperty=Search_Mode DesignTime=False }
4162{ OverrideProperty=Search_Case DesignTime=False }
4163{ OverrideProperty=Select_mode DesignTime=False }
4164{ OverrideProperty=Select_State DesignTime=False }
4165{ OverrideProperty=Transparent_State DesignTime=False }
4166{ OverrideProperty=Value DesignTime=True }
4167{ OverrideProperty=Wrap_State DesignTime=False }
4168
4169Class Form is a DFBaseForm
4170 Procedure Construct_Object
4171 Forward Send Construct_Object
4172
4173 // setting this to zero forces current_item to be correct during object definition
4174 Set New_item to 0
4175 Send Define_Standard_Form_Mixin
4176 Send Define_Prompt_Button_Mixin
4177 Send Define_ToolTip_Support_Mixin
4178
4179 { Visibility=Private }
4180 Property Integer m_Prompt_object 0
4181
4182 on_key kPrompt send Prompt
4183
4184 End_Procedure // Construct_Object
4185
4186 Import_Class_Protocol Standard_Form_Mixin
4187 Import_Class_Protocol Prompt_Button_Mixin
4188 Import_Class_Protocol ToolTip_Support_Mixin
4189
4190 { MethodType=Property }
4191 { InitialValue=0 }
4192 { ItemParameter=1 }
4193 { Category=Appearance }
4194 Procedure Set Prompt_Object Integer iItem Integer hoPrompt
4195 Set m_prompt_object to hoPrompt
4196 end_Procedure
4197
4198 { MethodType=Property }
4199 Function Prompt_Object integer iItem returns integer
4200 Function_Return (m_prompt_object(self))
4201 end_function
4202
4203 Procedure Prompt
4204 integer hoPrompt
4205 Get prompt_object to hoPrompt
4206 If hoPrompt Send Popup to hoPrompt
4207 End_Procedure
4208
4209 // With form based objects we can set capslock by setting
4210 // the right bit in forms_options. We use the
4211 // options message instead of the option message because
4212 // form_option doesn't seem to work right.
4213 //
4214 { MethodType=Property }
4215 { InitialValue=False }
4216 { Category=Behavior }
4217 { PropertyType=Boolean }
4218 procedure Set Capslock_State Integer bState
4219 integer iOptions
4220 Get Form_Options item 0 to iOptions
4221 if bState ;
4222 Move (AddBitValue(Capslock_Bit_Value, iOptions)) To iOptions
4223 else ;
4224 Move (RemoveBitValue(Capslock_bit_Value, iOptions)) to iOptions
4225 set form_Options item 0 to iOptions
4226 End_procedure
4227
4228 // check capslock bit for capslock_state
4229 //
4230 { MethodType=Property }
4231 Function CapsLock_State returns Boolean
4232 integer iOptions
4233 get form_Options item 0 to iOptions
4234 Function_Return ( (iOptions IAND CAPSLOCK_BIT_VALUE)<>0 )
4235 End_Function
4236
4237
4238 // Called by Page_Object. Handles tooltip creation. We use a dedicated
4239 // method to perform AddToolTip because it is often the case that Page_Object
4240 // is implemented in a mixin class.
4241 { Visibility=Private }
4242 Procedure RequestAddToolTip
4243 Send AddToolTip
4244 End_Procedure // RequestAddToolTip
4245
4246
4247 // Called by Page_Object. Handles tooltip removal.
4248 { Visibility=Private }
4249 Procedure RequestDeleteToolTip
4250 Send DeleteToolTip
4251 End_Procedure // RequestDeleteToolTip
4252End_Class
4253
4254
4255// Class: Entry
4256//
4257// 1. Add Standard entry support
4258// 2. Support color change when shadowed (right now this is done in flex -
4259// should we try to make this automatic?)
4260// 3. Help_DataFile support
4261// 4. Single item switch behavior
4262// 5. Auto margin, type setting
4263//
4264{ DesignerClass=cDTForm }
4265{ HelpTopic=Entry }
4266{ OverrideProperty=Attach_Parent_State DesignTime=False }
4267{ OverrideProperty=Auto_top_Item_State DesignTime=False }
4268{ OverrideProperty=Bitmap DesignTime=False }
4269{ OverrideProperty=Bitmap_Style DesignTime=False }
4270{ OverrideProperty=Block_Mouse_State DesignTime=False }
4271{ OverrideProperty=Border_style DesignTime=False }
4272{ OverrideProperty=Client_Area_State DesignTime=False }
4273{ OverrideProperty=Checkbox_item_state DesignTime=False }
4274{ OverrideProperty=Data_File DesignTime=False }
4275{ OverrideProperty=Data_Field DesignTime=False }
4276{ OverrideProperty=Form_Bitmap DesignTime=False }
4277{ OverrideProperty=Form_FontHeight DesignTime=False }
4278{ OverrideProperty=Form_FontItalics DesignTime=False }
4279{ OverrideProperty=Form_FontUnderline DesignTime=False }
4280{ OverrideProperty=Form_FontWeight DesignTime=False }
4281{ OverrideProperty=Form_TypeFace DesignTime=False }
4282{ OverrideProperty=Form_Width DesignTime=False }
4283{ OverrideProperty=Physical_FontSize DesignTime=False }
4284{ OverrideProperty=Popup_State DesignTime=False }
4285{ OverrideProperty=Ring_State DesignTime=False }
4286{ OverrideProperty=Scope_State DesignTime=False }
4287{ OverrideProperty=Search_Mode DesignTime=False }
4288{ OverrideProperty=Search_Case DesignTime=False }
4289{ OverrideProperty=Select_mode DesignTime=False }
4290{ OverrideProperty=Select_State DesignTime=False }
4291{ OverrideProperty=Transparent_State DesignTime=False }
4292{ OverrideProperty=Value DesignTime=True }
4293{ OverrideProperty=Wrap_State DesignTime=False }
4294{ OverrideProperty=Aux_Value DesignTime=False }
4295{ OverrideProperty=Message DesignTime=False }
4296{ OverrideProperty=Value DesignTime=False }
4297
4298Class Entry Is A DfBaseEntry
4299
4300 Procedure Construct_Object
4301 Forward Send Construct_Object
4302 Send Define_Standard_Form_Mixin
4303 Send Define_Prompt_Button_Mixin
4304 Send Define_ToolTip_Support_Mixin
4305 On_Key kPrompt Send Prompt
4306 End_Procedure // Construct_Object
4307
4308 Import_Class_Protocol Standard_Form_Mixin
4309 Import_Class_Protocol Auto_Setup_Mixin
4310 Import_Class_Protocol Datafile_Help_Mixin
4311 Import_Class_Protocol Entry_Shadow_Mixin
4312 Import_Class_Protocol Prompt_Button_Mixin
4313 Import_Class_Protocol ToolTip_Support_Mixin
4314
4315 // With entry based objects we can set capslock by setting
4316 // the right bit in item_options AND form_Options. We use the
4317 // options message instead of the option message because form_
4318 // option doesn't seem to work right.
4319 //
4320 { MethodType=Property }
4321 { InitialValue=False }
4322 { Category=Behavior }
4323 { PropertyType=Boolean }
4324 procedure Set Capslock_State Integer bState
4325 integer iOptions
4326 Get Item_Options item 0 to iOptions
4327 if bState ;
4328 Move (AddBitValue(CAPSLOCK_BIT_VALUE, iOptions)) To iOptions
4329 else ;
4330 Move (RemoveBitValue(CAPSLOCK_BIT_VALUE, iOptions)) to iOptions
4331 set Item_Options item 0 to iOptions
4332 // must also set form_options. We assume that item and form options
4333 // should always be the same and the item_options are the boss. This
4334 // is the way the DD handles it.
4335 set form_Options item 0 to iOptions
4336 End_procedure
4337
4338 // check capslock bit for capslock_state
4339 //
4340 { MethodType=Property }
4341 Function CapsLock_State returns Integer
4342 integer iOptions
4343 get Item_Options item 0 to iOptions
4344 Function_Return ( (iOptions IAND CAPSLOCK_BIT_VALUE)<>0 )
4345 End_Function // Wrap_State
4346
4347 Procedure End_Construct_Object
4348 Send Define_Form_Margins
4349 Forward Send End_Construct_Object
4350 End_Procedure // End_Construct_Object
4351
4352
4353 // Called by Page_Object. Handles tooltip creation. We use a dedicated
4354 // method to perform AddToolTip because it is often the case that Page_Object
4355 // is implemented in a mixin class.
4356 { Visibility=Private }
4357 Procedure RequestAddToolTip
4358 Send AddToolTip
4359 End_Procedure // RequestAddToolTip
4360
4361
4362 // Called by Page_Object. Handles tooltip removal.
4363 { Visibility=Private }
4364 Procedure RequestDeleteToolTip
4365 Send DeleteToolTip
4366 End_Procedure // RequestDeleteToolTip
4367End_Class
4368
4369
4370// Class: Grid
4371//
4372// 1. Add Standard entry support
4373// 2. Support color change when shadowed
4374//
4375{ DesignerClass=cDTGrid }
4376{ OverrideProperty=Border_Style InitialValue=Border_Clientedge }
4377{ HelpTopic=Grid }
4378
4379{ OverrideProperty=Attach_Parent_State DesignTime=False }
4380{ OverrideProperty=Aux_Value DesignTime=False }
4381{ OverrideProperty=Bitmap DesignTime=False }
4382{ OverrideProperty=Bitmap_Style DesignTime=False }
4383{ OverrideProperty=Block_Mouse_State DesignTime=False }
4384{ OverrideProperty=Client_Area_State DesignTime=False }
4385{ OverrideProperty=FontItalics DesignTime=False }
4386{ OverrideProperty=FontSize DesignTime=False }
4387{ OverrideProperty=FontUnderline DesignTime=False }
4388{ OverrideProperty=FontWeight DesignTime=False }
4389{ OverrideProperty=Form_Border DesignTime=False }
4390{ OverrideProperty=Maximum_Position DesignTime=False }
4391{ OverrideProperty=Message DesignTime=False }
4392{ OverrideProperty=Minimum_Position DesignTime=False }
4393{ OverrideProperty=Physical_FontSize DesignTime=False }
4394{ OverrideProperty=Popup_State DesignTime=False }
4395//{ OverrideProperty=Ring_State DesignTime=False }
4396{ OverrideProperty=Scope_State DesignTime=False }
4397{ OverrideProperty=Search_Mode DesignTime=False }
4398{ OverrideProperty=Search_Case DesignTime=False }
4399{ OverrideProperty=Select_State DesignTime=False }
4400{ OverrideProperty=Transparent_State DesignTime=False }
4401{ OverrideProperty=Value DesignTime=False }
4402{ OverrideProperty=Entry_State DesignTime=False }
4403{ OverrideProperty=Status_Help DesignTime=False }
4404
4405{ OverrideProperty=Form_Button DesignTime=True }
4406{ OverrideProperty=Form_Button_Value DesignTime=True }
4407{ OverrideProperty=Form_Button_Bitmap DesignTime=True }
4408
4409Class Grid is a DfBaseFormList
4410
4411 Procedure Construct_Object
4412 Forward Send Construct_Object
4413 Send Define_Standard_Grid_Mixin
4414 // This determines if the scroll occurs when the thumb is dragged
4415 // When false, it scrolls when the thumb is released. Only set it to
4416 // false if the scroll takes a long time.
4417 { Category=Behavior }
4418 { PropertyType=Boolean }
4419 Property Integer ScrollOnThumbTrackState True
4420 // This determines if thumb should be sized proportionally to the scroll
4421 // area. When true it acts like a normal windows list. When false, you get
4422 // old vdf behavior where thumb is small and scroll moves up down one line at
4423 // a time
4424 { Category=Behavior }
4425 { PropertyType=Boolean }
4426 Property Integer ThumbScrollState True
4427 // If the developer wishes to augment the vScroll messages they can shut
4428 // the existing customizations by setting this true
4429 { Category=Behavior }
4430 { PropertyType=Boolean }
4431 Property Integer CustomScrollState False
4432 End_Procedure // Construct_Object
4433
4434 Import_Class_Protocol Standard_Grid_Mixin
4435
4436 Procedure End_Construct_Object
4437 Send Define_List_Form_Columns
4438 Forward Send End_Construct_Object
4439 End_Procedure // End_Construct_Object
4440
4441 { Visibility=Private }
4442 Procedure SetVScrollInfo Integer iMin Integer iMax Integer iPage
4443 If not (CustomScrollState(self)) Begin
4444 If (ThumbScrollState(self)) ;
4445 Move (displayable_rows(self)) to iPage
4446 End
4447 // showln iMin ' ' iMax ' ' iPage
4448 Forward Send SetVScrollInfo iMin iMax iPage
4449 End_Procedure
4450
4451 { Visibility=Private }
4452 Procedure SetVScrollPos Integer iPos
4453 If not (CustomScrollState(self)) Begin
4454 If (ThumbScrollState(self)) ;
4455 Move (top_item(self)/line_size(self)) to iPos
4456 //Showln "SetVScrollPos" iPos
4457 End
4458 Forward Send SetVScrollPos iPos
4459 End_Procedure
4460
4461 { Visibility=Private }
4462 Procedure SetVScrollbox Integer iType Integer iData
4463 integer iTop bFast
4464 If not (CustomScrollState(self)) Begin
4465 //Showln "SetVScrollBox" iType ", " iData
4466 If (iType=SB_THUMBPOSITION or iType=SB_THUMBTRACK) Begin
4467 get ScrollOnThumbTrackState to bFast
4468 If (( iType=SB_THUMBPOSITION and bFast) OR ;
4469 (iType=SB_THUMBTRACK and not(bFast))) ;
4470 procedure_return
4471 If Not (ThumbScrollState(self)) ;
4472 Move SB_THUMBPOSITION to iType
4473 Else Begin
4474 Move (Top_item(self)/line_size(self)) to iTop
4475 If (iTop<>iData) Begin
4476 If (iTop>iData) send scroll upward_direction (iTop-iData)
4477 else send Scroll downward_direction (iData-iTop)
4478 End
4479 procedure_return
4480 End
4481 end
4482 End
4483 Forward Send SetVScrollBox iType iData
4484 End_Procedure
4485
4486End_Class
4487
4488// Class: EntryList
4489//
4490// 1. Add Standard entry support
4491// 2. Support color change when shadowed
4492// 3. Help_DataFile support
4493// 4. Auto margin, type setting
4494//
4495{ ClassType=Abstract }
4496{ DesignerClass=cDTGrid }
4497{ OverrideProperty=Border_Style InitialValue=Border_Clientedge }
4498{ HelpTopic=EntryList }
4499
4500{ OverrideProperty=Attach_Parent_State DesignTime=False }
4501{ OverrideProperty=Aux_Value DesignTime=False }
4502{ OverrideProperty=Bitmap DesignTime=False }
4503{ OverrideProperty=Bitmap_Style DesignTime=False }
4504{ OverrideProperty=Block_Mouse_State DesignTime=False }
4505{ OverrideProperty=Client_Area_State DesignTime=False }
4506{ OverrideProperty=Data_File DesignTime=False }
4507{ OverrideProperty=Data_Field DesignTime=False }
4508{ OverrideProperty=FontItalics DesignTime=False }
4509{ OverrideProperty=FontSize DesignTime=False }
4510{ OverrideProperty=FontUnderline DesignTime=False }
4511{ OverrideProperty=FontWeight DesignTime=False }
4512{ OverrideProperty=Form_Border DesignTime=False }
4513{ OverrideProperty=Item_Entry_msg DesignTime=False }
4514{ OverrideProperty=Item_Exit_msg DesignTime=False }
4515{ OverrideProperty=Item_Validate_msg DesignTime=False }
4516{ OverrideProperty=Maximum_Position DesignTime=False }
4517{ OverrideProperty=Message DesignTime=False }
4518{ OverrideProperty=Minimum_Position DesignTime=False }
4519{ OverrideProperty=Physical_FontSize DesignTime=False }
4520{ OverrideProperty=Popup_State DesignTime=False }
4521{ OverrideProperty=Prompt_Object DesignTime=False }
4522//{ OverrideProperty=Ring_State DesignTime=False }
4523{ OverrideProperty=Scope_State DesignTime=False }
4524{ OverrideProperty=Search_Mode DesignTime=False }
4525{ OverrideProperty=Search_Case DesignTime=False }
4526{ OverrideProperty=Select_State DesignTime=False }
4527{ OverrideProperty=Transparent_State DesignTime=False }
4528{ OverrideProperty=Zoom_Object DesignTime=False }
4529{ OverrideProperty=Aux_Value DesignTime=False }
4530{ OverrideProperty=Message DesignTime=False }
4531{ OverrideProperty=Value DesignTime=False }
4532{ OverrideProperty=Entry_State DesignTime=False }
4533{ OverrideProperty=Status_Help DesignTime=False }
4534
4535{ OverrideProperty=Form_Button DesignTime=True }
4536{ OverrideProperty=Form_Button_Value DesignTime=True }
4537{ OverrideProperty=Form_Button_Bitmap DesignTime=True }
4538
4539Class EntryList is a DFBaseEntryList
4540
4541 Procedure Construct_Object
4542 Forward Send Construct_Object
4543 Send Define_Standard_Grid_Mixin
4544 End_Procedure // Construct_Object
4545
4546 Import_Class_Protocol Standard_Grid_Mixin
4547 Import_Class_Protocol Datafile_Help_Mixin
4548
4549 // This replace Set Current_Item in standard grid mixin. It is
4550 // identical except that it checks for noenter fields and it
4551 // handles scroll requests from the thumb.
4552 //
4553 // 1. Modified to optimize painting and make scrolling work properly
4554 // 2. Add Request_Status_Help for item changes.
4555 //
4556 { MethodType=Property NoDoc=True }
4557 Procedure Set Current_Item Integer Itm
4558 Integer IsFoc
4559 integer oldst oldtop
4560 integer opt CrntCol NumCols
4561 Get Line_Size to NumCols
4562 // Currently the C entrylist class returns a big number if the
4563 // thumb is moved to top. It passes -1 (65535)* # cols + cur col.
4564 // This will be value of 65535*#cols or greater!
4565 // If the end of bar is thumbed it will return displayable-rows+1
4566 // * number of cols. This will always be greater than item count.
4567 If (Itm>=65535*NumCols or Itm<0) ;
4568 Send beginning_of_Data
4569 else If (Itm>=item_count(self)) ;
4570 Send End_of_Data
4571 else begin
4572 // if the target is NoEnter (or expression or displayonly) then
4573 // we will move to the selected row but stay in the current column.
4574 get item_option item Itm NoEnter to opt
4575 if Opt Begin
4576 Get current_Col to CrntCol
4577 Move (itm/NumCols*NumCols+CrntCol) to itm
4578 get item_option item itm NoEnter to opt // if still Noenter
4579 if Opt procedure_return // do nothing
4580 End
4581 //
4582 Move (Focus(Desktop)=self) to IsFoc
4583 If IsFoc Send Request_Status_Help False
4584 get dynamic_update_state to oldst
4585 Set Dynamic_Update_State to False
4586 get top_item to oldtop // we need to know if to-item changes
4587 Forward Set Current_Item to Itm
4588 // If dyn had been on, we pass 1 (refresh all) if we scrolled and a
4589 // 2 (refresh dirty cells) if we did not scroll. Note that other
4590 // processes might have dirtied the cells so that a "2" becomes
4591 // equivalent to a "1"
4592 if oldst ; // if top_Item changed we scrolled!
4593 Move (If(Top_Item(self)<>OldTop,1,2)) to OldSt
4594 Set dynamic_update_State to OldSt
4595 if IsFoc Send Request_Status_Help True
4596 End
4597 End_Procedure // Set Current_Item
4598
4599
4600 Procedure End_Construct_Object
4601 Send Define_Form_Margins
4602 Send Define_List_Form_Columns
4603 Forward Send End_Construct_Object
4604 End_Procedure // End_Construct_Object
4605
4606End_Class
4607
4608//-----------Container Classes---------
4609
4610// Class: Panel
4611//
4612// 1. Define Standard container behaviors
4613//
4614
4615{ OverrideProperty=Color InitialValue=clBtnFace }
4616{ OverrideProperty=TextColor InitialValue=clWindowText }
4617{ OverrideProperty=Locate_mode InitialValue=Smart_Locate }
4618{ DesignerClass=cDTPanel }
4619{ HelpTopic=BasicPanel }
4620{ OverrideProperty=Attach_Parent_State DesignTime=False }
4621{ OverrideProperty=Auto_Locate_State DesignTime=False }
4622{ OverrideProperty=Block_Mouse_State DesignTime=False }
4623{ OverrideProperty=Client_Area_State DesignTime=False }
4624{ OverrideProperty=FontItalics DesignTime=False }
4625{ OverrideProperty=FontUnderline DesignTime=False }
4626{ OverrideProperty=FontWeight DesignTime=False }
4627{ OverrideProperty=Physical_FontSize DesignTime=False }
4628{ OverrideProperty=Modal_State DesignTime=False }
4629{ OverrideProperty=Popup_State DesignTime=False }
4630{ OverrideProperty=Ring_State DesignTime=False }
4631{ OverrideProperty=Scope_State DesignTime=False }
4632{ OverrideProperty=Search_Case DesignTime=False }
4633{ OverrideProperty=Transparent_State DesignTime=False }
4634{ OverrideProperty=Key_Path DesignTime=True }
4635{ OverrideProperty=Visible_State DesignTime=False }
4636{ OverrideProperty=Enabled_State DesignTime=False }
4637{ OverrideProperty=pbSizeToClientArea DesignTime=True InitialValue=True }
4638Class BasicPanel is a DFBasePanel
4639
4640 Procedure Construct_Object
4641 Forward Send Construct_Object
4642
4643 Send Define_Standard_Container_Mixin
4644 Send Define_Panel_Mixin
4645
4646 // Support A Tool Bar, A Status Bar, A Client Area. We Will Assume That
4647 // All Objects At Least Understand This Protocol.
4648 { DesignTime=False }
4649 Property Integer Toolbar_Id 0
4650 { DesignTime=False }
4651 Property Integer Statusbar_Id 0
4652 { DesignTime=False }
4653 Property Integer Client_Id 0 // self
4654 // set by commandbars if they exist
4655 { DesignTime=False }
4656 Property Handle phoCommandBars 0
4657
4658 Set Locate_Mode to SMART_LOCATE
4659 Set pbSizeToClientArea to True
4660 End_Procedure // Construct_Object
4661
4662 // This Will Never Get Sent To, But It Keeps The Compiler Content.
4663 { Visibility=Private }
4664 Procedure Show_Status_Help String Shelp
4665 End_Procedure
4666
4667 // This Allows Children To Find The Parent Panel. This Seems Like A
4668 // Pretty Basic Requirement.
4669 { MethodType=Property Visibility=Private }
4670 Function Main_Panel_Id Returns Integer
4671 Function_Return self
4672 End_Function
4673
4674 Import_Class_Protocol Standard_Container_Mixin
4675 Import_Class_Protocol Panel_Mixin
4676
4677 { MethodType=Event }
4678 Function Verify_Exit_Application Returns Integer
4679 End_Function
4680
4681 { MethodType=Event }
4682 Procedure Notify_Exit_Application
4683 End_Procedure // Notify_Exit_Application
4684
4685 { Visibility=Private }
4686 Procedure Broadcast_Notify_Exit_Application
4687 Set Delegation_Mode To Delegate_To_Parent
4688 Send Notify_Exit_Application
4689 End_Procedure // Notify_Exit_Application
4690
4691 { Visibility=Private }
4692 Function Broadcast_Verify_Exit_Application Returns Integer
4693 Set Delegation_Mode To Delegate_To_Parent
4694 Function_Return (Verify_Exit_Application(self))
4695 End_Function
4696
4697 { MethodType=Event }
4698 Procedure OnActivateApp
4699 End_Procedure
4700
4701 { MethodType=Event }
4702 Procedure OnDeactivateApp
4703 End_Procedure
4704
4705 { MethodType=Event Visibility=Private }
4706 Procedure Notify_Application_Activation Integer bActivate
4707 integer hMain
4708 Get Main_Window of desktop to hMain
4709 // if main window exists send event to main window, else just send
4710 // the event to itself. Normally a main window will (should) exist
4711 If hMain eq 0 Move self to hMain
4712 forward send Notify_Application_Activation bActivate
4713 If bActivate Send OnActivateApp to hMain
4714 Else Send OnDeactivateApp to hMain
4715 End_Procedure
4716End_Class
4717
4718// Class: ToolPanel
4719//
4720// 1. Define Standard container behaviors
4721//
4722{ OverrideProperty=Color InitialValue=clBtnFace }
4723{ OverrideProperty=TextColor InitialValue=clWindowText }
4724{ OverrideProperty=peNeighborHood InitialValue=nhPublic }
4725{ OverrideProperty=Minimize_Icon InitialValue=False DesignTime=False }
4726{ OverrideProperty=Maximize_Icon InitialValue=False DesignTime=False }
4727{ OverrideProperty=Locate_mode InitialValue=Smart_Locate }
4728{ ClassType=Abstract }
4729{ HelpTopic=FloatingPanel }
4730{ OverrideProperty=Key_Path DesignTime=True }
4731{ OverrideProperty=pbSizeToClientArea DesignTime=True InitialValue=True }
4732Class FloatingPanel is a DFBaseToolpanel
4733
4734 Procedure Construct_Object
4735 Forward Send Construct_Object
4736
4737 Send Define_Standard_Container_Mixin
4738 Send Define_Panel_Mixin
4739 Set Minimize_Icon to FALSE
4740 Set Maximize_Icon to FALSE
4741
4742 // Support A Tool Bar, A Status Bar, A Client Area. We Will Assume That
4743 // All Objects At Least Understand This Protocol.
4744 { DesignTime=False }
4745 Property Integer Toolbar_Id 0
4746 { DesignTime=False }
4747 Property Integer Statusbar_Id 0
4748 { DesignTime=False }
4749 Property Integer Client_Id Self
4750 Set Locate_Mode to SMART_LOCATE
4751 Set peNeighborHood to DEFAULT_DIALOG_NeighborHood
4752 Set pbSizeToClientArea to True
4753 On_Key kClose_Panel Send Close_Panel
4754 End_Procedure // Construct_Object
4755
4756 Import_Class_Protocol Standard_Container_Mixin
4757 Import_Class_Protocol Panel_Mixin
4758
4759 { MethodType=Event }
4760 Procedure OnActivateApp
4761 End_Procedure
4762
4763 { MethodType=Event }
4764 Procedure OnDeactivateApp
4765 End_Procedure
4766
4767 { MethodType=Event Visibility=Private }
4768 Procedure Notify_Application_Activation Integer bActivate
4769 integer hMain
4770 Get Main_Window of desktop to hMain
4771 // if main window exists send event to main window, else just send
4772 // the event to itself. Normally a main window will (should) exist
4773 If hMain eq 0 Move self to hMain
4774 forward send Notify_Application_Activation bActivate
4775 If bActivate Send OnActivateApp to hMain
4776 Else Send OnDeactivateApp to hMain
4777 End_Procedure
4778
4779End_Class
4780
4781{ DesignerClass=cDTToolPanel }
4782{ HelpTopic=ToolPanel }
4783{ OverrideProperty=Attach_Parent_State DesignTime=False }
4784{ OverrideProperty=Auto_Locate_State DesignTime=False }
4785{ OverrideProperty=Block_Mouse_State DesignTime=False }
4786{ OverrideProperty=Client_Area_State DesignTime=False }
4787{ OverrideProperty=FontItalics DesignTime=False }
4788{ OverrideProperty=FontUnderline DesignTime=False }
4789{ OverrideProperty=FontWeight DesignTime=False }
4790{ OverrideProperty=Physical_FontSize DesignTime=False }
4791{ OverrideProperty=Modal_State DesignTime=False }
4792{ OverrideProperty=Popup_State DesignTime=False }
4793{ OverrideProperty=Ring_State DesignTime=False }
4794{ OverrideProperty=Scope_State DesignTime=False }
4795{ OverrideProperty=Search_Case DesignTime=False }
4796{ OverrideProperty=Transparent_State DesignTime=False }
4797Class ToolPanel is a FloatingPanel
4798
4799 Procedure Construct_Object
4800 Forward Send Construct_Object
4801 Set Extended_Window_Style To WS_EX_TOOLWINDOW True
4802 End_Procedure
4803
4804End_Class
4805
4806//Class ModalPanel is a ToolPanel
4807
4808// Procedure Construct_Object
4809// Forward Send Construct_Object
4810
4811// Set Caption_bar to TRUE
4812// Set Border_Style to Border_Dialog
4813// Set Minimize_Icon to FALSE
4814// Set Maximize_Icon to FALSE
4815// Set SysMenu_Icon to TRUE
4816// Set Modal_State to TRUE
4817// End_Procedure // Construct_Object
4818
4819{ DesignerClass=cDTModalPanel }
4820{ OverrideProperty=Key_Path InitialValue=desktop }
4821{ OverrideProperty=Border_Style InitialValue=Border_Dialog }
4822{ ComponentType=DGClass }
4823{ HelpTopic=ModalPanel }
4824
4825{ OverrideProperty=Attach_Parent_State DesignTime=False }
4826{ OverrideProperty=Auto_Locate_State DesignTime=False }
4827{ OverrideProperty=Block_Mouse_State DesignTime=False }
4828{ OverrideProperty=Client_Area_State DesignTime=False }
4829{ OverrideProperty=Column_Offset DesignTime=True }
4830{ OverrideProperty=FontItalics DesignTime=False }
4831{ OverrideProperty=FontUnderline DesignTime=False }
4832{ OverrideProperty=FontWeight DesignTime=False }
4833{ OverrideProperty=Physical_FontSize DesignTime=False }
4834{ OverrideProperty=Modal_State DesignTime=False }
4835{ OverrideProperty=Popup_State DesignTime=False }
4836{ OverrideProperty=Ring_State DesignTime=False }
4837{ OverrideProperty=Row_Offset DesignTime=True }
4838{ OverrideProperty=Scope_State DesignTime=False }
4839{ OverrideProperty=Search_Case DesignTime=False }
4840{ OverrideProperty=Transparent_State DesignTime=False }
4841{ OverrideProperty=Icon DesignTime=False }
4842{ OverrideProperty=Visible_State DesignTime=False }
4843{ OverrideProperty=Enabled_State DesignTime=False }
4844
4845Class ModalPanel is a FloatingPanel
4846
4847 Procedure Construct_Object
4848 Forward Send Construct_Object
4849 Set Border_Style to Border_Dialog
4850 Set Extended_Window_Style To WS_EX_DLGMODALFRAME True
4851 Set Modal_State to TRUE
4852 End_Procedure // Construct_Object
4853
4854 // created for advanced CD_popup_object support. Returns the true handle of the
4855 // popup object whether it is a regular object or a CD popup object.
4856 Function Popup_Handle Returns Handle
4857 Function_Return Self
4858 End_Function
4859
4860End_Class
4861
4862{ OverrideProperty=Color InitialValue=clBtnFace }
4863{ OverrideProperty=TextColor InitialValue=clWindowText }
4864{ OverrideProperty=peNeighborHood InitialValue=nhNo }
4865{ DesignerClass=cDTContainer3d }
4866{ HelpTopic=Container3d }
4867
4868{ OverrideProperty=Attach_Parent_State DesignTime=False }
4869{ OverrideProperty=Auto_Locate_State DesignTime=False }
4870{ OverrideProperty=Block_Mouse_State DesignTime=False }
4871{ OverrideProperty=Caption_Bar DesignTime=False }
4872{ OverrideProperty=Client_Area_State DesignTime=False }
4873{ OverrideProperty=FontItalics DesignTime=False }
4874{ OverrideProperty=FontUnderline DesignTime=False }
4875{ OverrideProperty=FontWeight DesignTime=False }
4876{ OverrideProperty=Icon DesignTime=False }
4877{ OverrideProperty=Label DesignTime=False }
4878{ OverrideProperty=Locate_Mode DesignTime=False }
4879{ OverrideProperty=Physical_FontSize DesignTime=False }
4880{ OverrideProperty=Minimize_Icon DesignTime=False }
4881{ OverrideProperty=Maximize_Icon DesignTime=False }
4882{ OverrideProperty=Popup_State DesignTime=False }
4883{ OverrideProperty=OEM_Translate_State DesignTime=False }
4884{ OverrideProperty=Ring_State DesignTime=False }
4885{ OverrideProperty=Scope_State DesignTime=False }
4886{ OverrideProperty=Search_Case DesignTime=False }
4887{ OverrideProperty=Sysmenu_Icon DesignTime=False }
4888{ OverrideProperty=TextColor DesignTime=False }
4889{ OverrideProperty=View_Mode DesignTime=False }
4890
4891Class Container3d is a DFBaseDialog
4892
4893 Procedure Construct_Object
4894 Forward Send Construct_Object
4895 Send Define_Standard_Container_Mixin
4896 Set peNeighborHood to DEFAULT_CONTAINER_NeighborHood
4897 Set Ring_State to False // containers should not default as rings
4898 End_Procedure // Construct_Object
4899
4900 Import_Class_Protocol Standard_Container_Mixin
4901
4902End_Class
4903
4904{ DesignerClass=cDTDialog }
4905{ HelpTopic=Dialog }
4906{ OverrideProperty=Key_Path DesignTime=True }
4907{ OverrideProperty=Caption_Bar InitialValue=True }
4908{ OverrideProperty=Label DesignTime=True }
4909{ OverrideProperty=SysMenu_Icon InitialValue=True }
4910{ OverrideProperty=Ring_State InitialValue=True }
4911{ OverrideProperty=pbSizeToClientArea DesignTime=True InitialValue=True }
4912Class Dialog is a Container3d
4913
4914 Procedure Construct_Object
4915 Forward Send Construct_Object
4916 Send Define_Panel_Mixin
4917 Set Caption_Bar To TRUE
4918 Set SysMenu_Icon To TRUE
4919 Set Ring_State to True // Panels should ring
4920 Set pbSizeToClientArea to True
4921 End_Procedure // Construct_Object
4922
4923 Import_Class_Protocol Panel_Mixin
4924
4925End_Class
4926
4927
4928// Class: Group
4929//
4930// 1. Define Standard container behaviors
4931//
4932
4933{ OverrideProperty=Color InitialValue=clBtnFace }
4934{ OverrideProperty=TextColor InitialValue=clWindowText }
4935{ OverrideProperty=peNeighborHood InitialValue=nhNo }
4936{ DesignerClass=cDTGroup }
4937{ HelpTopic=Group }
4938
4939{ OverrideProperty=Attach_Parent_State DesignTime=False }
4940{ OverrideProperty=Auto_Locate_State DesignTime=False }
4941{ OverrideProperty=Block_Mouse_State DesignTime=False }
4942{ OverrideProperty=Border_Style DesignTime=False }
4943{ OverrideProperty=Client_Area_State DesignTime=False }
4944{ OverrideProperty=Locate_Mode DesignTime=False }
4945{ OverrideProperty=Physical_FontSize DesignTime=False }
4946{ OverrideProperty=Popup_State DesignTime=False }
4947{ OverrideProperty=Ring_State DesignTime=False }
4948{ OverrideProperty=Scope_State DesignTime=False }
4949{ OverrideProperty=Search_Case DesignTime=False }
4950
4951Class Group Is a DFBaseGroup
4952
4953 Procedure Construct_Object
4954 Forward Send Construct_Object
4955 Send Define_Standard_Container_Mixin
4956 Set peNeighborHood to DEFAULT_CONTAINER_NeighborHood
4957 End_Procedure // Construct_Object
4958
4959 Import_Class_Protocol Standard_Container_Mixin
4960
4961 { Visibility=Private }
4962 Procedure Enable_Window integer iState
4963 integer hWnd
4964 Get Window_Handle to hWnd
4965 If hWnd ;
4966 Move (EnableWindow(hWnd,iState)) To hWnd
4967 End_procedure
4968
4969 { Visibility=Private }
4970 Procedure Page_Object integer iState
4971 Handle hWnd
4972 Get Window_Handle To hWnd
4973 Forward Send Page_Object iState
4974 If (hWnd=0 and iState) ;
4975 Send Shadow_Display
4976 End_Procedure
4977
4978 { MethodType=Event Visibility=Private }
4979 Procedure Shadow_Display
4980 Send Enable_Window (Not(Object_Shadow_State(self)))
4981 End_Procedure
4982
4983End_Class
4984
4985{ HelpTopic=Container }
4986{ OverrideProperty=Bitmap DesignTime=False }
4987{ OverrideProperty=Bitmap_Style DesignTime=False }
4988{ OverrideProperty=Border_Style DesignTime=False }
4989{ OverrideProperty=Color DesignTime=False }
4990{ OverrideProperty=Focus_Mode DesignTime=False }
4991{ OverrideProperty=FontItalics DesignTime=False }
4992{ OverrideProperty=FontSize DesignTime=False }
4993{ OverrideProperty=FontUnderline DesignTime=False }
4994{ OverrideProperty=FontWeight DesignTime=False }
4995{ OverrideProperty=Location DesignTime=False }
4996{ OverrideProperty=OEM_Translate_State DesignTime=False }
4997{ OverrideProperty=peAnchors DesignTime=False }
4998{ OverrideProperty=piMaxSize DesignTime=False }
4999{ OverrideProperty=piMinSize DesignTime=False }
5000{ OverrideProperty=Size DesignTime=False }
5001{ OverrideProperty=TextColor DesignTime=False }
5002{ OverrideProperty=Transparent_State DesignTime=False }
5003{ OverrideProperty=View_Mode DesignTime=False }
5004{ OverrideProperty=Visible_State DesignTime=False }
5005Class Container is a Container3d
5006 Import_Class_Protocol NonVisual_Container_Mixin
5007End_Class
5008
5009// Class: Button
5010//
5011// 1. Set Default Size to 14 50 // (the win95 standard)
5012// 2. Standard Object
5013// 3. Label Support
5014// 4. Shadow_state support
5015//
5016{ DesignerClass=cDTButton }
5017{ OverrideProperty=size InitialValue=14,50 }
5018{ HelpTopic=Button }
5019{ OverrideProperty=Attach_Parent_State DesignTime=False }
5020{ OverrideProperty=Auto_top_Item_State DesignTime=False }
5021{ OverrideProperty=Aux_Value DesignTime=False }
5022{ OverrideProperty=Bitmap_Style DesignTime=False }
5023{ OverrideProperty=Block_Mouse_State DesignTime=False }
5024{ OverrideProperty=Border_style DesignTime=False }
5025{ OverrideProperty=Client_Area_State DesignTime=False }
5026{ OverrideProperty=Checkbox_item_state DesignTime=False }
5027{ OverrideProperty=Color DesignTime=False }
5028{ OverrideProperty=Entry_state DesignTime=False }
5029{ OverrideProperty=Form_Bitmap DesignTime=False }
5030{ OverrideProperty=Form_Border DesignTime=False }
5031{ OverrideProperty=Form_Datatype DesignTime=False }
5032{ OverrideProperty=Form_FontHeight DesignTime=False }
5033{ OverrideProperty=Form_FontItalics DesignTime=False }
5034{ OverrideProperty=Form_FontUnderline DesignTime=False }
5035{ OverrideProperty=Form_FontWeight DesignTime=False }
5036{ OverrideProperty=Form_TypeFace DesignTime=False }
5037{ OverrideProperty=Form_Width DesignTime=False }
5038{ OverrideProperty=Message DesignTime=False }
5039{ OverrideProperty=Physical_FontSize DesignTime=False }
5040{ OverrideProperty=Popup_State DesignTime=False }
5041{ OverrideProperty=Ring_State DesignTime=False }
5042{ OverrideProperty=Scope_State DesignTime=False }
5043{ OverrideProperty=Search_Mode DesignTime=False }
5044{ OverrideProperty=Search_Case DesignTime=False }
5045{ OverrideProperty=Select_mode DesignTime=False }
5046{ OverrideProperty=Select_State DesignTime=False }
5047{ OverrideProperty=TextColor DesignTime=False }
5048{ OverrideProperty=Transparent_state DesignTime=False }
5049{ OverrideProperty=Wrap_State DesignTime=False }
5050
5051
5052Class Button Is A DfBasepushbutton
5053
5054 { MethodType=Event }
5055 Procedure OnClick
5056 End_Procedure
5057
5058 Procedure Construct_Object
5059 Integer iColor
5060 Forward Send Construct_Object
5061
5062 { Visibility=Private }
5063 Property Integer private.CurrentButtonState False
5064
5065 { Category=Appearance }
5066 { PropertyType=Boolean }
5067 Property Integer MultiLineState False
5068 { Category=Appearance }
5069 { PropertyType=Boolean }
5070 Property Integer FlatState False
5071
5072 Send Define_Standard_Object_Mixin
5073 Send Define_Single_Item_Navigate_Mixin
5074 Send Define_Bitmap_Support_Mixin
5075 Send Define_ToolTip_Support_Mixin
5076
5077 // as a default set background color to the background of the parent
5078 Delegate Get Color To iColor
5079 Set Color To iColor
5080
5081 Set Size To 14 50 // 50 is the same size as MS DLUs buttons
5082 Set Message item 0 To msg_OnClick
5083
5084 // Enter should execute the button function without a visual "push".
5085 // Space-bar should execute the button function while "pressing" the
5086 // button visually.
5087 //
5088 On_Key kEnter Send Default_Key
5089 On_Key Key_Space Send Mouse_Down
5090 End_Procedure // Construct_Object
5091
5092 Import_Class_Protocol Standard_Object_Mixin
5093 Import_Class_Protocol Label_Mixin
5094 Import_Class_Protocol Single_Item_Navigate_Mixin
5095 Import_Class_Protocol Bitmap_Support_Mixin
5096 Import_Class_Protocol ToolTip_Support_Mixin
5097
5098 // KeyAction is the message that should be sent to a button via
5099 // an on_key in support of an underlined hot-key indicator. For
5100 // example, setting a button label to "&Close" will create an
5101 // underlined "C", indicating to a user that Alt+C should also
5102 // be usable for "close". To support that, simply setup an on_key
5103 // message: On_Key Key_Alt+Key_C Send KeyAction to (closebutton(self))
5104 // this was modified to not send OnClick but to send Message to Aux_value.
5105 // Normally, this will be the same as onCLick (onClick will be the message and
5106 // there will be no aux_value).
5107 //
5108 Procedure KeyAction
5109 integer bActive bShadow iRetVal
5110 integer hmMsg hObj
5111 get Active_state to bActive
5112 get Object_shadow_state to bShadow
5113 get Message item 0 to hmMsg
5114 Move 0 to iRetVal // non-inititalized int can stop the UI!
5115 if (bActive and (not(bShadow)) and hmMsg) Begin
5116 get aux_value item 0 to hObj
5117 if hObj eq 0 Move self to hObj
5118 get hmMsg of hObj to iRetVal
5119 end
5120 Procedure_Return iRetVal // should we. (e.g., to stop the ui)
5121 End_Procedure
5122
5123 { MethodType=Property }
5124 Function CurrentButtonState Returns Integer
5125 Function_Return (private.CurrentButtonState(self))
5126 End_Function
5127
5128 // Set CurrentButtonState to FALSE/TRUE will cause the button to display
5129 // the "thick" border seen on "default" buttons. By Default, buttons will
5130 // now set this property to true when ever they take the focus, and false
5131 // when they lose the focus. Logic exists in "panel" objects to set a default
5132 // button which will be highlighted when needed. Note that all highlighting
5133 // is handled by calling this one message.
5134 // Get/Set CurrentButtonState is private, system maintained and dynamic.
5135 // Do not set this as part of an object's attributes.
5136 //
5137 { MethodType=Property }
5138 { DesignTime=False }
5139 Procedure Set CurrentButtonState Integer bState
5140 Handle hWnd hObj
5141 Integer iStyle cxy iTemp
5142 // cannot make a shadowed button the default
5143 If (object_shadow_state(self) AND bState) ;
5144 procedure_return
5145 Get Form_Window_Handle Item 0 To hWnd
5146 if (hWnd and (CurrentButtonState(self)<>bState)) begin
5147 set private.CurrentButtonState to bState
5148 Move (if(bState,self,0)) to hObj
5149 // very private message! Do not send from anywhere else!!!!!
5150 delegate set private.Current_Action_Button to hObj // delegate to panel
5151 Get GuiSize To cxy
5152 Move (GetWindowLong(hWnd, GWL_STYLE)) To iStyle
5153 If bState Begin
5154 Move (SetWindowLong(hWnd, GWL_STYLE, iStyle IOR 1)) To iTemp
5155 Set GuiSize To (Hi(cxy)) (Low(cxy)+1)
5156 end
5157 else begin
5158 Move (SetWindowLong(hWnd, GWL_STYLE, iStyle IAND $FFFFFFFE)) To iTemp
5159 Set GuiSize To (Hi(cxy)) (Low(cxy)-1)
5160 end
5161 end
5162 End_Procedure
5163
5164
5165 // Default_State is the public interface for setting the Default
5166 // Action Button at the button itself. The message CurrentButtonState
5167 // is implementation of part of the mechanism and should not be used
5168 // directly.
5169 //
5170 { MethodType=Property }
5171 { InitialValue=False }
5172 { Category=Behavior }
5173 { PropertyType=Boolean }
5174 Procedure Set Default_State Integer bState
5175 set Default_Action_Button to (if(bState,self,0))
5176 End_Procedure
5177
5178 { MethodType=Property }
5179 Function Default_State Returns Integer
5180 Function_Return (Default_action_Button(self)=self)
5181 End_Function
5182
5183 { Visibility=Private }
5184 Procedure Remove_Object
5185 // we must make sure that the button is normal before removing it. Otherwise
5186 // it will be the wrong size when repaged.
5187 set CurrentButtonState to False
5188 forward send remove_object
5189 End_Procedure
5190
5191 // This is called by notify_focus_change (in std obj mixin). With buttons
5192 // we must make sure that they are always highlighted when the focus and
5193 // not highlighted when the focus is list
5194 //
5195 { Visibility=Private }
5196 Procedure PrivateSetCurrentButton
5197 set CurrentButtonState to TRUE
5198 end_Procedure
5199
5200 // if a button is shadowed it should not be highlighted
5201 //
5202 { MethodType=Event Visibility=Private }
5203 Procedure Shadow_Display
5204 If (Object_shadow_state(self)) ;
5205 set CurrentButtonState to False
5206 End_procedure
5207
5208 { Visibility=Private }
5209 Procedure Page_Object Integer iState
5210 Integer iStyle
5211
5212 If (iState =1) Begin
5213 Move (WS_CHILD + WS_VISIBLE +BS_PUSHBUTTON) To iStyle
5214 If (MultiLineState(self)) Add BS_MULTILINE To iStyle
5215 If (FlatState(self)) Add BS_FLAT To iStyle
5216 Set Form_Style 0 To iStyle
5217 End
5218 Forward Send Page_Object iState
5219
5220 // Handle tooltip support....
5221 If (iState = 0) Begin
5222 Send RequestDeleteToolTip
5223 End
5224 Else Begin
5225 Send RequestAddToolTip
5226 End
5227 End_Procedure
5228
5229
5230 // Called by Page_Object. Handles tooltip creation. We use a dedicated
5231 // method to perform AddToolTip because it is often the case that Page_Object
5232 // is implemented in a mixin class.
5233 { Visibility=Private }
5234 Procedure RequestAddToolTip
5235 Send AddToolTip
5236 End_Procedure // RequestAddToolTip
5237
5238
5239 // Called by Page_Object. Handles tooltip removal.
5240 { Visibility=Private }
5241 Procedure RequestDeleteToolTip
5242 Send DeleteToolTip
5243 End_Procedure // RequestDeleteToolTip
5244End_Class // Button
5245
5246//*** Class: Checkbox
5247//***
5248//*** Assumption:
5249//*** Must be one-item object.
5250//***
5251//*** 1. Label support.
5252//*** 2. Will autosize based on setting of label if auto_size_state is True.
5253//*** 3. Standard object mixin behaviors (help, etc.)
5254//*** 4. Single Item behaviors for switching
5255//
5256{ OverrideProperty=Color InitialValue=clBtnFace }
5257{ OverrideProperty=TextColor InitialValue=clBtnText }
5258{ DesignerClass=cDTCheckBox }
5259{ HelpTopic=CheckBox }
5260
5261{ OverrideProperty=Attach_Parent_State DesignTime=False }
5262{ OverrideProperty=Auto_top_Item_State DesignTime=False }
5263{ OverrideProperty=Aux_Value DesignTime=False }
5264{ OverrideProperty=Bitmap DesignTime=False }
5265{ OverrideProperty=Bitmap_Style DesignTime=False }
5266{ OverrideProperty=Block_Mouse_State DesignTime=False }
5267{ OverrideProperty=Border_style DesignTime=False }
5268{ OverrideProperty=Client_Area_State DesignTime=False }
5269{ OverrideProperty=Checkbox_item_state DesignTime=False }
5270{ OverrideProperty=Entry_state DesignTime=False }
5271{ OverrideProperty=Form_Bitmap DesignTime=False }
5272{ OverrideProperty=Form_Border DesignTime=False }
5273{ OverrideProperty=Form_Datatype DesignTime=False }
5274{ OverrideProperty=Form_FontHeight DesignTime=False }
5275{ OverrideProperty=Form_FontItalics DesignTime=False }
5276{ OverrideProperty=Form_FontUnderline DesignTime=False }
5277{ OverrideProperty=Form_FontWeight DesignTime=False }
5278{ OverrideProperty=Form_TypeFace DesignTime=False }
5279{ OverrideProperty=Form_Width DesignTime=False }
5280{ OverrideProperty=Message DesignTime=False }
5281{ OverrideProperty=Physical_FontSize DesignTime=False }
5282{ OverrideProperty=Popup_State DesignTime=False }
5283{ OverrideProperty=Ring_State DesignTime=False }
5284{ OverrideProperty=Scope_State DesignTime=False }
5285{ OverrideProperty=Search_Mode DesignTime=False }
5286{ OverrideProperty=Search_Case DesignTime=False }
5287{ OverrideProperty=Select_mode DesignTime=False }
5288{ OverrideProperty=Wrap_State DesignTime=False }
5289
5290Class CheckBox is a DFBaseCheckBox
5291
5292 Procedure Construct_Object
5293 Forward Send Construct_Object
5294
5295 // setting this to zero forces current_item to be correct during object definition
5296 Set New_item to 0
5297
5298 { EnumList="taRightJustify, taLeftJustify"}
5299 { Category=Appearance }
5300 Property Integer AlignmentMode taRightJustify
5301
5302 Send Define_Standard_Select_Mixin
5303 Send Define_Bitmap_Support_Mixin
5304 Send Define_ToolTip_Support_Mixin
5305
5306 Set Select_Mode To Multi_Select
5307 End_Procedure // Construct_Object
5308
5309 Import_Class_Protocol Standard_Select_Mixin
5310 Import_Class_Protocol Bitmap_Support_Mixin
5311 Import_Class_Protocol ToolTip_Support_Mixin
5312
5313 { Visibility=Private }
5314 Procedure Page_Object integer iState
5315 If (iState =1) Begin
5316 If (AlignmentMode(self) = taLeftJustify) Set Form_Style 0 To (WS_CHILD + WS_VISIBLE +BS_CHECKBOX +BS_LEFTTEXT)
5317 Else Set Form_Style 0 To (WS_CHILD + WS_VISIBLE +BS_CHECKBOX)
5318 End
5319 Forward Send Page_Object iState
5320
5321 // Handle tooltip support....
5322 If (iState = 0) Begin
5323 Send RequestDeleteToolTip
5324 End
5325 Else Begin
5326 Send RequestAddToolTip
5327 End
5328 End_Procedure
5329
5330
5331 // Called by Page_Object. Handles tooltip creation. We use a dedicated
5332 // method to perform AddToolTip because it is often the case that Page_Object
5333 // is implemented in a mixin class.
5334 { Visibility=Private }
5335 Procedure RequestAddToolTip
5336 Send AddToolTip
5337 End_Procedure // RequestAddToolTip
5338
5339
5340 // Called by Page_Object. Handles tooltip removal.
5341 { Visibility=Private }
5342 Procedure RequestDeleteToolTip
5343 Send DeleteToolTip
5344 End_Procedure // RequestDeleteToolTip
5345End_Class // CheckBox
5346
5347
5348//*** Class: Radiobutton (useful classes are in dfradio.pkg
5349//***
5350//*** Assumption:
5351//*** Must be one-item object.
5352//***
5353//*** 1. Label support.
5354//*** 2. Will autosize based on setting of label.
5355//
5356{ OverrideProperty=Color InitialValue=clBtnFace }
5357{ OverrideProperty=TextColor InitialValue=clBtnText }
5358{ DesignerClass=cDTRadio }
5359{ HelpTopic=RadioButton }
5360
5361{ OverrideProperty=Attach_Parent_State DesignTime=False }
5362{ OverrideProperty=Auto_top_Item_State DesignTime=False }
5363{ OverrideProperty=Aux_Value DesignTime=False }
5364{ OverrideProperty=Bitmap DesignTime=False }
5365{ OverrideProperty=Bitmap_Style DesignTime=False }
5366{ OverrideProperty=Block_Mouse_State DesignTime=False }
5367{ OverrideProperty=Border_style DesignTime=False }
5368{ OverrideProperty=Client_Area_State DesignTime=False }
5369{ OverrideProperty=Checkbox_item_state DesignTime=False }
5370{ OverrideProperty=Entry_state DesignTime=False }
5371{ OverrideProperty=Form_Bitmap DesignTime=False }
5372{ OverrideProperty=Form_Border DesignTime=False }
5373{ OverrideProperty=Form_Datatype DesignTime=False }
5374{ OverrideProperty=Form_FontHeight DesignTime=False }
5375{ OverrideProperty=Form_FontItalics DesignTime=False }
5376{ OverrideProperty=Form_FontUnderline DesignTime=False }
5377{ OverrideProperty=Form_FontWeight DesignTime=False }
5378{ OverrideProperty=Form_TypeFace DesignTime=False }
5379{ OverrideProperty=Form_Width DesignTime=False }
5380{ OverrideProperty=Message DesignTime=False }
5381{ OverrideProperty=Physical_FontSize DesignTime=False }
5382{ OverrideProperty=Popup_State DesignTime=False }
5383{ OverrideProperty=Ring_State DesignTime=False }
5384{ OverrideProperty=Scope_State DesignTime=False }
5385{ OverrideProperty=Search_Mode DesignTime=False }
5386{ OverrideProperty=Search_Case DesignTime=False }
5387{ OverrideProperty=Select_mode DesignTime=False }
5388{ OverrideProperty=Wrap_State DesignTime=False }
5389
5390Class RadioButton Is A DfBaseRadioButton
5391
5392 Procedure Construct_Object
5393 Forward Send Construct_Object
5394
5395 // setting this to zero forces current_item to be correct during object definition
5396 Set New_item to 0
5397
5398 { EnumList="taRightJustify, taLeftJustify"}
5399 { Category=Appearance }
5400 Property Integer AlignmentMode taRightJustify
5401
5402 Send Define_Standard_Select_Mixin
5403 Send Define_Bitmap_Support_Mixin
5404 Send Define_ToolTip_Support_Mixin
5405
5406 Set Select_Mode To Single_Select
5407 End_Procedure // Construct_Object
5408
5409 Import_Class_Protocol Standard_Select_Mixin
5410 Import_Class_Protocol Bitmap_Support_Mixin
5411 Import_Class_Protocol ToolTip_Support_Mixin
5412
5413 { MethodType=Event Visibility=Private }
5414 Procedure Private.Notify_Select_State Integer ObjId Integer Item#
5415 End_Procedure // Private.Notify_Select_State
5416
5417 { Visibility=Private }
5418 Procedure Page_Object integer iState
5419 If (iState =1) Begin
5420 If (AlignmentMode(self) = taLeftJustify) Set Form_Style 0 To (WS_CHILD + WS_VISIBLE +BS_RADIOBUTTON +BS_LEFTTEXT)
5421 Else Set Form_Style 0 To (WS_CHILD + WS_VISIBLE +BS_RADIOBUTTON)
5422 End
5423 Forward Send Page_Object iState
5424
5425 // Handle tooltip support....
5426 If (iState = 0) Begin
5427 Send RequestDeleteToolTip
5428 End
5429 Else Begin
5430 Send RequestAddToolTip
5431 End
5432 End_Procedure
5433
5434
5435 // Called by Page_Object. Handles tooltip creation. We use a dedicated
5436 // method to perform AddToolTip because it is often the case that Page_Object
5437 // is implemented in a mixin class.
5438 { Visibility=Private }
5439 Procedure RequestAddToolTip
5440 Send AddToolTip
5441 End_Procedure // RequestAddToolTip
5442
5443
5444 // Called by Page_Object. Handles tooltip removal.
5445 { Visibility=Private }
5446 Procedure RequestDeleteToolTip
5447 Send DeleteToolTip
5448 End_Procedure // RequestDeleteToolTip
5449
5450
5451 // Sent by a parent object (RadioGroup) to set all child objects to the same tooltip. This is ignored
5452 // when the child object already has a tooltip.
5453 { Visibility=Private }
5454 Procedure SetChildToolTip String sText
5455 String sToolTip
5456
5457 Get psToolTip to sToolTip
5458
5459 If (sToolTip = "") Begin
5460 Set psToolTip to sText
5461 End
5462 End_Procedure // SetChildToolTip
5463End_Class // RadioButton
5464
5465// Class: MdiClientArea
5466//
5467// 1. Set default properties
5468//
5469{ OverrideProperty=Scope_State InitialValue=True }
5470{ OverrideProperty=Attach_Parent_State InitialValue=True }
5471{ OverrideProperty=Caption_Bar InitialValue=False }
5472{ OverrideProperty=Maximize_Icon InitialValue=False }
5473{ OverrideProperty=Sysmenu_Icon InitialValue=False }
5474{ OverrideProperty=Scroll_Bar_Visible_State InitialValue=True }
5475{ OverrideProperty=Border_Style InitialValue=Border_clientEdge }
5476{ OverrideProperty=Color InitialValue=clAppWorkSpace }
5477{ OverrideProperty=TextColor InitialValue=clAppWorkSpace }
5478{ OverrideProperty=Client_Area_State InitialValue=False }
5479{ HelpTopic=MdiClientArea }
5480
5481{ OverrideProperty=Attach_Parent_State DesignTime=False }
5482//{ OverrideProperty=Auto_Locate_State DesignTime=False }
5483{ OverrideProperty=Block_Mouse_State DesignTime=False }
5484{ OverrideProperty=Caption_Bar DesignTime=False }
5485{ OverrideProperty=Client_Area_State DesignTime=False }
5486{ OverrideProperty=Focus_mode DesignTime=False }
5487{ OverrideProperty=FontItalics DesignTime=False }
5488{ OverrideProperty=FontSize DesignTime=False }
5489{ OverrideProperty=FontUnderline DesignTime=False }
5490{ OverrideProperty=FontWeight DesignTime=False }
5491{ OverrideProperty=Icon DesignTime=False }
5492//{ OverrideProperty=Locate_Mode DesignTime=False }
5493{ OverrideProperty=Location DesignTime=False }
5494{ OverrideProperty=Physical_FontSize DesignTime=False }
5495{ OverrideProperty=Minimize_Icon DesignTime=False }
5496{ OverrideProperty=Maximize_Icon DesignTime=False }
5497{ OverrideProperty=Mdi_State Designtime=False }
5498{ OverrideProperty=peAnchors DesignTime=False }
5499{ OverrideProperty=piMinSize DesignTime=False }
5500{ OverrideProperty=piMaxSize DesignTime=False }
5501{ OverrideProperty=Popup_State DesignTime=False }
5502{ OverrideProperty=OEM_Translate_State DesignTime=False }
5503{ OverrideProperty=Ring_State DesignTime=False }
5504{ OverrideProperty=Scope_State DesignTime=False }
5505{ OverrideProperty=Search_case DesignTime=False }
5506{ OverrideProperty=Size DesignTime=False }
5507{ OverrideProperty=Skip_state DesignTime=False }
5508{ OverrideProperty=Sysmenu_Icon DesignTime=False }
5509{ OverrideProperty=TextColor DesignTime=False }
5510{ OverrideProperty=Transparent_state DesignTime=False }
5511{ OverrideProperty=View_Mode DesignTime=False }
5512{ OverrideProperty=Visible_State DesignTime=False }
5513
5514Class MdiClientArea is a DfBaseMdiClient
5515
5516 Procedure Construct_Object
5517 Forward Send Construct_Object
5518 Send Define_RGB_Support_Temp_Mixin
5519 Set Scope_State To True
5520 Set Attach_Parent_State To True
5521 Set Caption_Bar To False
5522 Set Maximize_Icon To False
5523 Set Sysmenu_Icon To False
5524 Set Scroll_Bar_Visible_State To True
5525 Set Border_Style To BORDER_CLIENTEDGE
5526 Set Color to clAppWorkSpace
5527 Set TextColor to clAppWorkSpace
5528
5529 Set Client_Area_State to False
5530
5531 Send Define_Bitmap_Support_Mixin
5532 Send Define_Help_Mixin
5533 End_Procedure
5534
5535 Import_Class_Protocol RGB_Support_Temp_Mixin
5536 Import_Class_Protocol Bitmap_Support_Mixin
5537 Import_Class_Protocol Help_Mixin
5538
5539 { MethodType=Event Visibility=Private }
5540 Procedure Notify_Focus_Change Integer Fg
5541 //**Forward Send Notify_Focus_Change Fg
5542 if Fg Send OnSetFocus
5543 Else Send OnKillFocus
5544 End_Procedure // Notify_Focus_Change
5545
5546 { MethodType=Event }
5547 Procedure OnSetFocus
5548 end_Procedure
5549
5550 { MethodType=Event }
5551 Procedure OnKillFocus
5552 end_Procedure
5553
5554 // Private:
5555 // needed by navigation (next_object_id). See notes above.
5556 // This really should never get called but it needs to be understood (and not delegated)
5557 //
5558 { Visibility=Private }
5559 function ContainerFocusWillNotChange returns integer
5560 function_return false
5561 End_Function
5562
5563 // When skins are applied to views we want to maintain the client size. I theory we want to do this to all objects
5564 // with pbSizeToClientArea=T. Views are the most likely objects to need this which is what I've tested this with.
5565 { MethodType=Event }
5566 { Visibility=Private }
5567 Procedure OnPreApplySkin Boolean bReApply
5568 Broadcast Send OnPreApplySkin bReApply
5569 End_Procedure
5570
5571 { MethodType=Event }
5572 { Visibility=Private }
5573 Procedure OnPostApplySkin Boolean bReApply
5574 Broadcast Send OnPostApplySkin bReApply
5575 End_Procedure
5576
5577
5578End_Class
5579
5580
5581// Class: MdiDialog
5582//
5583// 1. Define standard MDI properties
5584// caption bar, sysmenu, minimize, no-maximize
5585// attach-prnt-st=T, Scope=T, Ring=T, Popup=T
5586// 2. Define Ctrl+F4 - Close_client (deactivate view)
5587// Ctrl+F6 - previous view
5588// Alt+F6 - next view
5589// 3. Define procedures for:
5590// Switch_next_View, Switch_Prior_View, Close_Client
5591// 4. redefine exit_appication to close_client so sysmenu works.
5592//
5593//
5594{ ClassType=Abstract }
5595{ DesignerClass=cDTView }
5596{ HelpTopic=MdiDialog }
5597{ OverrideProperty=Minimize_Icon InitialValue=True DesignTime=True }
5598{ OverrideProperty=Maximize_Icon InitialValue=False DesignTime=True }
5599{ OverrideProperty=Sysmenu_Icon InitialValue=True DesignTime=True }
5600{ OverrideProperty=Caption_Bar InitialValue=True DesignTime=True }
5601{ OverrideProperty=Label DesignTime=True }
5602{ OverrideProperty=Icon InitialValue="" DesignTime=True }
5603{ OverrideProperty=Attach_Parent_State InitialValue=True }
5604{ OverrideProperty=Scope_State InitialValue=True }
5605{ OverrideProperty=Ring_State InitialValue=True }
5606{ OverrideProperty=Popup_State InitialValue=True }
5607{ OverrideProperty=peNeighborHood InitialValue=nhPublic }
5608{ OverrideProperty=Modal_State InitialValue=False }
5609{ OverrideProperty=Modal_State DesignTime=False }
5610{ OverrideProperty=peAnchors DesignTime=False }
5611{ OverrideProperty=Skip_State DesignTime=False }
5612{ OverrideProperty=Transparent_State DesignTime=False }
5613{ OverrideProperty=Key_Path DesignTime=True }
5614{ OverrideProperty=Visible_State DesignTime=False }
5615{ OverrideProperty=Enabled_State DesignTime=False }
5616{ OverrideProperty=pbSizeToClientArea DesignTime=True InitialValue=True }
5617
5618Class MdiDialog is a Container3d
5619
5620 Procedure Construct_Object
5621 Forward Send Construct_Object
5622 Send Define_Panel_Mixin
5623 Set Mdi_State To True
5624 Set Minimize_Icon To True
5625 Set Maximize_Icon To False
5626 Set Sysmenu_Icon To True
5627 Set Caption_Bar To True
5628 Set Attach_Parent_State To True
5629 Set Scope_State To True
5630 Set Ring_State To True
5631 Set Popup_State To True
5632 Set peNeighborHood to DEFAULT_DIALOG_NeighborHood
5633 Set pbSizeToClientArea to True
5634
5635 On_Key Kclose_Panel Send Close_Panel
5636 On_Key Kswitch_Panel Send Switch_Next_View
5637 On_Key Kswitch_Panel_Back Send Switch_Prior_View
5638
5639 End_Procedure // Construct_Object
5640
5641 Import_Class_protocol Panel_Mixin
5642
5643 { MethodType=Event NoDoc=True }
5644 Procedure Exiting_Scope Integer Whereto Returns Integer
5645 Integer Rval Sbid
5646 Forward Get Msg_Exiting_Scope Whereto To Rval
5647 If Not Rval Begin
5648 Get Statusbar_Id To Sbid
5649 If Sbid Send Show_Status_Help To Sbid ''
5650 End
5651 End_Procedure
5652
5653 // added to 8.2, Centers view in client area. Should be used in place of auto-locate logic
5654 // which was never meant to be suupport in mdi dialogs.
5655 //
5656 Procedure DoCenterMdiDialog
5657 integer iClntSize iSize iRow iCol
5658 delegate get guisize to iClntSize
5659 Get GuiSize to iSize
5660 Move ( ((hi(iClntSize) - hi(iSize))/2) max 2) to iRow
5661 Move ( ((low(iClntSize) - low(iSize))/2) max 2) to iCol
5662 Set GuiLocation to iRow iCol
5663 Send Adjust_Logicals
5664 End_Procedure
5665End_Class
5666
5667Use Dftab_mx.pkg // tab dialog support
5668
5669{ OverrideProperty=Color InitialValue=clBtnFace }
5670{ OverrideProperty=TextColor InitialValue=clWindowText }
5671{ OverrideProperty=peNeighborHood InitialValue=nhNo }
5672{ OverrideProperty=Auto_Locate_State DesignTime=False }
5673{ ClassType=Abstract }
5674{ HelpTopic=TabDialog_ }
5675Class TabDialog_ Is A DfBaseTabDialog
5676 Procedure Construct_Object
5677 Forward Send Construct_Object
5678 // container mixin and tad dialog mixin cannot not be
5679 // mixed at the same level. (Next_object_id must be augmented)
5680 Send Define_Standard_Container_Mixin
5681 Set peNeighborHood to DEFAULT_CONTAINER_NeighborHood
5682 End_Procedure // Construct_Object
5683 Import_Class_Protocol Standard_Container_Mixin
5684End_Class
5685
5686{ CompositeClass=TabPage }
5687{ DesignerClass=cDTTabDialog }
5688{ HelpTopic=TabDialog }
5689
5690{ OverrideProperty=Attach_Parent_State DesignTime=False }
5691{ OverrideProperty=Auto_Top_Item_State DesignTime=False }
5692{ OverrideProperty=Aux_Value DesignTime=False }
5693{ OverrideProperty=Bitmap DesignTime=False }
5694{ OverrideProperty=Bitmap_Style DesignTime=False }
5695{ OverrideProperty=Block_Mouse_State DesignTime=False }
5696{ OverrideProperty=Border_Style DesignTime=False }
5697{ OverrideProperty=Checkbox_item_state DesignTime=False }
5698{ OverrideProperty=Client_Area_State DesignTime=False }
5699{ OverrideProperty=Entry_State DesignTime=False }
5700{ OverrideProperty=Form_Bitmap DesignTime=False }
5701{ OverrideProperty=Form_Border DesignTime=False }
5702{ OverrideProperty=Form_DataType DesignTime=False }
5703{ OverrideProperty=Form_FontHeight DesignTime=False }
5704{ OverrideProperty=Form_FontItalics DesignTime=False }
5705{ OverrideProperty=Form_FontUnderline DesignTime=False }
5706{ OverrideProperty=Form_FontWeight DesignTime=False }
5707{ OverrideProperty=Form_Width DesignTime=False }
5708{ OverrideProperty=Form_justification_Mode DesignTime=False }
5709{ OverrideProperty=Form_Margin DesignTime=False }
5710{ OverrideProperty=Form_Mask DesignTime=False }
5711{ OverrideProperty=Form_TypeFace DesignTime=False }
5712{ OverrideProperty=Label DesignTime=False }
5713{ OverrideProperty=Locate_Mode DesignTime=False }
5714{ OverrideProperty=Message DesignTime=False }
5715{ OverrideProperty=Password_State DesignTime=False }
5716{ OverrideProperty=Physical_FontSize DesignTime=False }
5717{ OverrideProperty=Popup_State DesignTime=False }
5718{ OverrideProperty=Ring_State DesignTime=False }
5719{ OverrideProperty=Scope_State DesignTime=False }
5720{ OverrideProperty=Search_Case DesignTime=False }
5721{ OverrideProperty=Search_Mode DesignTime=False }
5722{ OverrideProperty=Select_mode DesignTime=False }
5723{ OverrideProperty=Select_state DesignTime=False }
5724{ OverrideProperty=Transparent_State DesignTime=False }
5725{ OverrideProperty=Wrap_State DesignTime=False }
5726
5727Class TabDialog Is A TabDialog_
5728
5729 Procedure Construct_Object
5730 Forward Send Construct_Object
5731 Send Define_Tab_Dialog_Mixin
5732 End_Procedure // Construct_Object
5733
5734 Import_Class_Protocol Tab_Dialog_Mixin
5735
5736End_class
5737
5738// Class: TabPage
5739//
5740// 1. Import all tab page behaviors
5741// 2. Understand get/set Label (sets tab values)
5742//
5743{ DesignerClass=cDTTabPage }
5744{ HelpTopic=TabPage }
5745
5746{ OverrideProperty=Border_Style DesignTime=False }
5747{ OverrideProperty=Label DesignTime=True }
5748{ OverrideProperty=Location DesignTime=False }
5749{ OverrideProperty=peAnchors DesignTime=False }
5750{ OverrideProperty=piMinSize DesignTime=False }
5751{ OverrideProperty=piMaxSize DesignTime=False }
5752{ OverrideProperty=Size DesignTime=False }
5753{ OverrideProperty=Transparent_State DesignTime=False }
5754
5755Class TabPage is a Container3d
5756 Procedure Construct_Object
5757 forward send construct_object
5758 Send Define_Tab_Page_Mixin
5759 End_Procedure
5760
5761 Import_Class_Protocol Tab_Page_Mixin
5762
5763End_Class
5764
5765
5766//Use dfRadio.pkg // Radio controls and container support
5767Use DFRad_Mx.pkg // dfradio_group_mixin class
5768
5769
5770// Class: Radio
5771//
5772// Assumption:
5773// Object of this class is child of a "RadioGroup" or
5774// RadioContainer Object
5775//
5776// 1. Offers radio functionality in multiple one item radios.
5777//
5778{ HelpTopic=Radio }
5779Class Radio is a RadioButton
5780
5781 Procedure Construct_Object
5782 Forward Send Construct_Object
5783 Delegate Send Register_Radio_Object self
5784 On_Key kUpArrow Send Previous_Item
5785 On_Key kDownArrow Send Next_Item
5786 On_Key kLeftArrow Send Previous_Item
5787 On_Key kRightArrow Send Next_Item
5788 Set Use_Parent_Status_Help to True
5789 End_Procedure // Construct_Object
5790
5791 { NoDoc=True }
5792 Procedure Activate returns integer
5793 integer rVal
5794 If (In_Group_state(Parent(self))) Begin
5795 Forward Get MSG_Activate to rVal
5796 If (rval=0 AND Select_State(self,0)=0) Begin
5797 set select_state item 0 to true
5798 Delegate Set Changed_State to TRUE
5799 end
5800 end
5801 Else ;
5802 delegate Get msg_Activate to rVal
5803 Procedure_return rVal
5804 End_Procedure // Activate
5805
5806 { MethodType=Property }
5807 Procedure Set Select_State integer item# integer state
5808 Forward Set Select_State item item# to state
5809 If State ;
5810 Delegate Send Private.Notify_Select_state self 0
5811 End_Procedure // Set Select_State
5812
5813 { MethodType=Event Visibility=Private }
5814 Procedure Private.Notify_Select_State Integer ObjId Integer Item#
5815 End_Procedure // Private.Notify_Select_State
5816
5817 { Visibility=Private }
5818 Procedure Select_Toggling
5819 End_Procedure // Select_Toggling
5820
5821 Procedure Next_Item
5822 integer OldGrp
5823 Delegate Get In_Group_State to OldGrp
5824 Delegate Set In_Group_State to True
5825 Delegate Set Changed_State to TRUE
5826 Forward send Switch
5827 Delegate Set In_Group_State to OldGrp
5828 End_Procedure
5829
5830 Procedure Previous_Item
5831 integer OldGrp
5832 Delegate Get In_Group_State to OldGrp
5833 Delegate Set In_Group_State to True
5834 Delegate Set Changed_State to TRUE
5835 Forward send Switch_Back
5836 Delegate Set In_Group_State to OldGrp
5837 End_Procedure
5838
5839 { Visibility=Private }
5840 Procedure Switch
5841 Send Switch_Next_Group
5842 End_Procedure
5843
5844 { Visibility=Private }
5845 Procedure Switch_Back
5846 Send Switch_Prior_Group
5847 End_procedure
5848
5849 { MethodType=Event NoDoc=True }
5850 Procedure Mouse_Down integer i1 integer i2
5851 integer OldGrp
5852 Delegate Get In_Group_State to OldGrp
5853 Delegate Set In_Group_State to True
5854 Forward Send Mouse_Down i1 i2
5855 Delegate Set In_Group_State to OldGrp
5856 End_procedure
5857
5858 { MethodType=Event NoDoc=True }
5859 Procedure Mouse_Click integer i1 integer i2
5860 End_procedure
5861
5862 // augmented to trigger a radio group entering message, if the focus is
5863 // coming from outside of the radio group
5864 //
5865 { MethodType=Event NoDoc=True }
5866 procedure Entering returns integer
5867 integer iFail
5868 forward get msg_entering to iFail
5869 // we check if the focus is already a radio button, if it is not (-1)
5870 // then we know we are entering from outside of radio group
5871 If (iFail=0 and Radio_Object_Item(parent(self),focus(desktop))=-1) ;
5872 Delegate get OnRadioGroupEntering to iFail
5873 function_return iFail
5874 end_procedure
5875
5876 // augmented to trigger a radio group exiting message, if the focus is
5877 // moving outside of the radio group
5878 //
5879 { MethodType=Event NoDoc=True }
5880 Procedure Exiting Handle hoDestination Returns Integer
5881 integer iFail
5882 forward get msg_exiting to ifail
5883 // we check if the new focus is a radio button, if it is not (-1)
5884 // then we know we are exiting to some other object
5885 If (iFail=0 and Radio_Object_Item(parent(self),hoDestination)=-1) ;
5886 Delegate get OnRadioGroupExiting to iFail
5887 function_return iFail
5888 end_procedure
5889
5890
5891End_Class
5892
5893
5894
5895// Class: RadioGroup
5896//
5897// Assumption:
5898// Must be used together with one (or more) Radio child objects.
5899//
5900// 1. Offers radio functionality in multiple one item radios.
5901//
5902{ DesignerClass=cDTRadioGroup }
5903{ OverrideProperty=Client_Area_State InitialValue=False }
5904{ HelpTopic=RadioGroup }
5905Class RadioGroup is a Group
5906
5907 Procedure Construct_Object
5908 Forward Send Construct_Object
5909 Send Define_DFradio_group_Mixin
5910 End_Procedure
5911
5912 Import_Class_Protocol DfRadio_Group_Mixin
5913
5914End_Class
5915
5916// Class: RadioContainer
5917//
5918// Assumption:
5919// Must be used together with one (or more) Radio child objects.
5920//
5921// 1. Offers radio functionality in multiple one item radios.
5922//
5923{ HelpTopic=RadioContainer }
5924{ OverrideProperty=Bitmap DesignTime=False }
5925{ OverrideProperty=Bitmap_Style DesignTime=False }
5926{ OverrideProperty=Color DesignTime=False }
5927{ OverrideProperty=Focus_Mode DesignTime=False }
5928{ OverrideProperty=FontItalics DesignTime=False }
5929{ OverrideProperty=FontSize DesignTime=False }
5930{ OverrideProperty=FontUnderline DesignTime=False }
5931{ OverrideProperty=FontWeight DesignTime=False }
5932{ OverrideProperty=Label DesignTime=False }
5933{ OverrideProperty=Location DesignTime=False }
5934{ OverrideProperty=OEM_Translate_State DesignTime=False }
5935{ OverrideProperty=peAnchors DesignTime=False }
5936{ OverrideProperty=piMaxSize DesignTime=False }
5937{ OverrideProperty=piMinSize DesignTime=False }
5938{ OverrideProperty=Size DesignTime=False }
5939{ OverrideProperty=TextColor DesignTime=False }
5940{ OverrideProperty=Transparent_State DesignTime=False }
5941{ OverrideProperty=Visible_State DesignTime=False }
5942Class RadioContainer is a RadioGroup
5943 Import_Class_Protocol NonVisual_Container_Mixin
5944End_Class
5945
5946
5947//Use dfCmbfrm.pkg // Combo form and entry support
5948
5949use combo_mx.pkg
5950
5951{ DesignerClass=cDTComboForm }
5952//{ OverrideProperty=Border_Style InitialValue=Border_Normal }
5953{ HelpTopic=ComboForm }
5954
5955{ OverrideProperty=Attach_Parent_State DesignTime=False }
5956{ OverrideProperty=Auto_top_Item_State DesignTime=False }
5957{ OverrideProperty=Aux_Value DesignTime=False }
5958{ OverrideProperty=Bitmap DesignTime=False }
5959{ OverrideProperty=Bitmap_Style DesignTime=False }
5960{ OverrideProperty=Block_Mouse_State DesignTime=False }
5961{ OverrideProperty=Border_style DesignTime=False }
5962{ OverrideProperty=Checkbox_item_state DesignTime=False }
5963{ OverrideProperty=Client_Area_State DesignTime=False }
5964{ OverrideProperty=Form_Bitmap DesignTime=False }
5965{ OverrideProperty=Form_Border DesignTime=False }
5966{ OverrideProperty=Form_DataType DesignTime=False }
5967{ OverrideProperty=Form_FontHeight DesignTime=False }
5968{ OverrideProperty=Form_FontItalics DesignTime=False }
5969{ OverrideProperty=Form_FontUnderline DesignTime=False }
5970{ OverrideProperty=Form_FontWeight DesignTime=False }
5971{ OverrideProperty=Form_Justification_mode DesignTime=False }
5972{ OverrideProperty=Form_Margin DesignTime=False }
5973{ OverrideProperty=Form_Mask DesignTime=False }
5974{ OverrideProperty=Form_TypeFace DesignTime=False }
5975{ OverrideProperty=Form_Width DesignTime=False }
5976{ OverrideProperty=Message DesignTime=False }
5977{ OverrideProperty=Physical_FontSize DesignTime=False }
5978{ OverrideProperty=Popup_State DesignTime=False }
5979{ OverrideProperty=Ring_State DesignTime=False }
5980{ OverrideProperty=Scope_State DesignTime=False }
5981//{ OverrideProperty=Search_Mode DesignTime=False }
5982//{ OverrideProperty=Search_Case DesignTime=False }
5983{ OverrideProperty=Select_mode DesignTime=False }
5984{ OverrideProperty=Select_State DesignTime=False }
5985{ OverrideProperty=Transparent_State DesignTime=False }
5986{ OverrideProperty=Wrap_State DesignTime=False }
5987Class ComboForm is a DFBaseComboBox
5988
5989 Procedure Construct_Object
5990 Forward Send Construct_Object
5991 // setting this to zero forces current_item to be correct during object definition
5992 Set New_item to 0
5993
5994 Send define_standard_Form_Mixin
5995 Send Define_Combo_Mixin
5996 Send Define_ToolTip_Support_Mixin
5997 End_Procedure // Construct_Object
5998
5999 Import_Class_Protocol Standard_Form_Mixin // order matters here.
6000 Import_Class_Protocol Combo_Mixin // combo must be 2nd.
6001 Import_Class_Protocol ToolTip_Support_Mixin
6002
6003 // By default we will fill combo lists during activating. In some cases
6004 // the list may already be filled in which case nothing will happen.
6005 //
6006
6007 { MethodType=Event NoDoc=True }
6008 // as of 15.1 we changed all deactivating/activating signatures to not return values
6009 // We have not recommended using activating for return values and we don't want codesense and events to use the
6010 // get msg_activating syntax. We have not changed the actual code in unlikely case that some is successfully
6011 // using activating to return a value. This is a "if it ain't broke, don't fix it" kind of thing.
6012 // This usage is not recommended and should not be used as a sample.
6013 Procedure Activating // returns integer
6014 integer rVal
6015 Forward Get MSG_Activating to rVal
6016 if not rval Send Combo_initialize_list
6017 Procedure_Return rVal
6018 End_Procedure
6019
6020 Procedure End_Construct_Object
6021 Send End_Define_Combo_Mixin
6022 Forward Send End_Construct_Object
6023 End_Procedure // End_Construct_Object
6024
6025 { MethodType=Property }
6026 { InitialValue=False }
6027 { Category=Behavior }
6028 { PropertyType=Boolean }
6029 procedure Set Capslock_State Integer bState
6030 integer iOptions
6031 Get form_Options item 0 to iOptions
6032 if bState ;
6033 Move (AddBitValue(CAPSLOCK_BIT_VALUE, iOptions)) To iOptions
6034 else ;
6035 Move (RemoveBitValue(CAPSLOCK_BIT_VALUE, iOptions)) to iOptions
6036 set form_Options item 0 to iOptions
6037 End_procedure
6038
6039 { MethodType=Property }
6040 Function CapsLock_State returns Integer
6041 integer iOptions
6042 get form_Options item 0 to iOptions
6043 Function_Return ( (iOptions IAND CAPSLOCK_BIT_VALUE)<>0 )
6044 End_Function
6045
6046 // We need to do some capslock checking with form combos.
6047 // For some reason the runtime does not recognize the capslock bit
6048 // in the form_options (as it does in form).
6049 // note that comboForm and comboEntry each need their own Page method
6050 // and not a common mixin
6051 //
6052 { MethodType=Event Visibility=Private }
6053 Procedure Page integer mode#
6054 integer iStyle hWnd bState
6055 If Mode# ; // copied from mixin...
6056 Set Window_Style To CBS_SORT (Combo_Sort_State(Self))
6057 Forward Send Page mode#
6058 // This is required in form versions of combos because
6059 // setting capslock in form option does not work.
6060 If Mode# Begin
6061 get form_window_handle item 0 to hWnd
6062 if hWnd Begin
6063 Get Capslock_State to bState
6064 Move (GetWindowLong(hWnd, GWL_STYLE)) To iStyle
6065 if bState ;
6066 Move (AddBitValue(ES_UPPERCASE, iStyle)) To iStyle
6067 else ;
6068 Move (RemoveBitValue(ES_UPPERCASE, iStyle)) To iStyle
6069 Move (SetWindowLong(hWnd, GWL_STYLE, iStyle)) To iStyle
6070 end
6071 end
6072 If (Mode# =1) Begin
6073 Send DoSetListWidth
6074 Send DoSetSize
6075 End
6076 End_Procedure
6077
6078
6079 // Called by Page_Object. Handles tooltip creation. We use a dedicated
6080 // method to perform AddToolTip because it is often the case that Page_Object
6081 // is implemented in a mixin class.
6082 { Visibility=Private }
6083 Procedure RequestAddToolTip
6084 Send AddToolTip
6085 End_Procedure // RequestAddToolTip
6086
6087
6088 // Called by Page_Object. Handles tooltip removal.
6089 { Visibility=Private }
6090 Procedure RequestDeleteToolTip
6091 Send DeleteToolTip
6092 End_Procedure // RequestDeleteToolTip
6093
6094
6095 // Overridden to ensure that the combo form's Entry_State is taken into consideration.
6096 { Visibility=Private }
6097 Function pbUseFormWindowHandle Returns Boolean
6098 Boolean bEntry
6099 Get Entry_State to bEntry
6100 Function_Return (bEntry)
6101 End_Function
6102End_Class
6103
6104{ ClassType=Abstract }
6105{ DesignerClass=cDTComboForm }
6106//{ OverrideProperty=Border_Style InitialValue=Border_Normal }
6107{ HelpTopic=ComboEntry }
6108
6109{ OverrideProperty=Attach_Parent_State DesignTime=False }
6110{ OverrideProperty=Auto_top_Item_State DesignTime=False }
6111{ OverrideProperty=Aux_Value DesignTime=False }
6112{ OverrideProperty=Bitmap DesignTime=False }
6113{ OverrideProperty=Bitmap_Style DesignTime=False }
6114{ OverrideProperty=Block_Mouse_State DesignTime=False }
6115{ OverrideProperty=Border_style DesignTime=False }
6116{ OverrideProperty=Checkbox_item_state DesignTime=False }
6117{ OverrideProperty=Client_Area_State DesignTime=False }
6118{ OverrideProperty=Data_File DesignTime=False }
6119{ OverrideProperty=Data_Field DesignTime=False }
6120{ OverrideProperty=Form_Bitmap DesignTime=False }
6121{ OverrideProperty=Form_Border DesignTime=False }
6122{ OverrideProperty=Form_DataType DesignTime=False }
6123{ OverrideProperty=Form_FontHeight DesignTime=False }
6124{ OverrideProperty=Form_FontItalics DesignTime=False }
6125{ OverrideProperty=Form_FontUnderline DesignTime=False }
6126{ OverrideProperty=Form_FontWeight DesignTime=False }
6127{ OverrideProperty=Form_Justification_mode DesignTime=False }
6128{ OverrideProperty=Form_Margin DesignTime=False }
6129{ OverrideProperty=Form_Mask DesignTime=False }
6130{ OverrideProperty=Form_TypeFace DesignTime=False }
6131{ OverrideProperty=Form_Width DesignTime=False }
6132{ OverrideProperty=Message DesignTime=False }
6133{ OverrideProperty=Physical_FontSize DesignTime=False }
6134{ OverrideProperty=Popup_State DesignTime=False }
6135{ OverrideProperty=Ring_State DesignTime=False }
6136{ OverrideProperty=Scope_State DesignTime=False }
6137//{ OverrideProperty=Search_Mode DesignTime=False }
6138//{ OverrideProperty=Search_Case DesignTime=False }
6139{ OverrideProperty=Select_mode DesignTime=False }
6140{ OverrideProperty=Select_State DesignTime=False }
6141{ OverrideProperty=Transparent_State DesignTime=False }
6142{ OverrideProperty=Wrap_State DesignTime=False }
6143Class ComboEntry is a DFBaseComboBoxEntry
6144
6145 Procedure Construct_Object
6146 Forward Send Construct_Object
6147 Send define_standard_Form_Mixin
6148 Send Define_Combo_Mixin
6149 Send Define_ToolTip_Support_Mixin
6150 End_Procedure // Construct_Object
6151
6152 Import_Class_Protocol Standard_Form_Mixin
6153 Import_Class_Protocol Auto_Setup_Mixin
6154 Import_Class_Protocol DataFile_Help_Mixin
6155 Import_Class_Protocol Entry_Shadow_Mixin
6156 Import_Class_Protocol ToolTip_Support_Mixin
6157 Import_Class_Protocol Combo_Mixin // combo must be last
6158
6159 Procedure End_Construct_Object
6160 Send Define_Form_Margins
6161 Send End_Define_Combo_Mixin
6162 Forward Send End_construct_object
6163 End_Procedure // Construct_Object
6164
6165
6166 // By default we will fill combo lists during activating. In some cases
6167 // the list may already be filled in which case nothing will happen.
6168 //
6169 { MethodType=Event NoDoc=True }
6170 // as of 15.1 we changed all deactivating/activating signatures to not return values (see windows.pkg / ComboForm / Activating for more)
6171 Procedure Activating // returns integer
6172 integer rVal
6173 Forward Get MSG_Activating to rVal
6174 if not rval Send Combo_initialize_list
6175 Procedure_Return rVal
6176 End_Procedure
6177
6178 // With entry based objects we can set capslock by setting
6179 // the right bit in item_options AND form_Options. We use the
6180 // options message instead of the option message because form_
6181 // option doesn't seem to work right.
6182 //
6183 { MethodType=Property }
6184 { InitialValue=False }
6185 { Category=Behavior }
6186 { PropertyType=Boolean }
6187 Procedure Set Capslock_State Integer bState
6188 integer iOptions
6189 Get Item_Options item 0 to iOptions
6190 if bState ;
6191 Move (AddBitValue(CAPSLOCK_BIT_VALUE, iOptions)) To iOptions
6192 else ;
6193 Move (RemoveBitValue(CAPSLOCK_BIT_VALUE, iOptions)) to iOptions
6194 set Item_Options item 0 to iOptions
6195 set form_Options item 0 to iOptions
6196 End_procedure
6197
6198 // check capslock bit for capslock_state
6199 //
6200 { MethodType=Property }
6201 Function CapsLock_State returns Integer
6202 integer iOptions
6203 get Item_Options item 0 to iOptions
6204 Function_Return ( (iOptions IAND CAPSLOCK_BIT_VALUE)<>0 )
6205 End_Function // Wrap_State
6206
6207 // note that comboForm and comboEntry each need their own Page method
6208 // and not a common mixin
6209
6210 { MethodType=Event Visibility=Private }
6211 Procedure Page integer iState
6212 If iState ;
6213 Set Window_Style To CBS_SORT (Combo_Sort_State(self))
6214 Forward Send Page iState
6215 If (iState =1) Begin
6216 Send DoSetListWidth
6217 Send DoSetSize
6218 End
6219 End_Procedure
6220
6221
6222 // Called by Page_Object. Handles tooltip creation. We use a dedicated
6223 // method to perform AddToolTip because it is often the case that Page_Object
6224 // is implemented in a mixin class.
6225 { Visibility=Private }
6226 Procedure RequestAddToolTip
6227 Send AddToolTip
6228 End_Procedure // RequestAddToolTip
6229
6230
6231 // Called by Page_Object. Handles tooltip removal.
6232 { Visibility=Private }
6233 Procedure RequestDeleteToolTip
6234 Send DeleteToolTip
6235 End_Procedure // RequestDeleteToolTip
6236
6237
6238 // Overridden to ensure that the combo form's Entry_State is taken into consideration.
6239 { Visibility=Private }
6240 Function pbUseFormWindowHandle Returns Boolean
6241 Boolean bEntry
6242 Get Entry_State to bEntry
6243 Function_Return (bEntry)
6244 End_Function
6245End_Class
6246
6247Use cHttpTransfer.pkg // included here because in 7 it was always loaded.
6248