source: cprs/trunk/CPRS-Lib/ORCtrls.pas@ 1703

Last change on this file since 1703 was 1679, checked in by healthsevak, 10 years ago

Updating the working copy to CPRS version 28
File size: 225.8 KB
Line 
1unit ORCtrls; // Oct 26, 1997 @ 10:00am
2
3// To Do: eliminate topindex itemtip on mousedown (seen when choosing clinic pts)
4
5interface // --------------------------------------------------------------------------------
6
7uses Windows, Messages, SysUtils, Classes, Graphics, Controls, StdCtrls, Forms,
8 ComCtrls, Commctrl, Buttons, ExtCtrls, Grids, ImgList, Menus, CheckLst,
9 Variants, VAClasses, typinfo;
10
11const
12 UM_SHOWTIP = (WM_USER + 9436); // message id to display item tip **was 300
13 UM_GOTFOCUS = (WM_USER + 9437); // message to post when combo gets focus **was 301
14 MAX_TABS = 40; // maximum number of tab stops or pieces
15 LL_REVERSE = -1; // long list scrolling in reverse direction
16 LL_POSITION = 0; // long list thumb moved
17 LL_FORWARD = 1; // long list scrolling in forward direction
18 LLS_LINE = '^____________________________________________________________________________';
19 LLS_DASH = '^----------------------------------------------------------------------------';
20 LLS_SPACE = '^ ';
21
22type
23 IORBlackColorModeCompatible = interface(IInterface)
24 ['{3554985C-F524-45FA-8C27-4CDD8357DB08}']
25 procedure SetBlackColorMode(Value: boolean);
26 end;
27
28 TORComboBox = class; // forward declaration for FParentCombo
29
30 TTranslator = function(MString: string): string of object;
31
32 TORStrings = class(TStrings)
33 private
34 MList: TStringList;
35 FPlainText: TStrings;
36 FTranslator: TTranslator;
37 FVerification: boolean;
38 procedure Verify;
39 protected
40 function Get(index: integer): string; override;
41 function GetCount: integer; override;
42 function GetObject(index: integer): TObject; override;
43 procedure Put(Index: Integer; const S: string); override;
44 procedure PutObject(index: integer; Value: TObject); override;
45 procedure SetUpdateState(Value: boolean); override;
46 public
47 function Add(const S: string): integer; override;
48 constructor Create(PlainText: TStrings; Translator: TTranslator);
49 destructor Destroy; override;
50 procedure Clear; override;
51 procedure Delete(index: integer); override;
52 procedure Insert(Index: Integer; const S: string); override;
53 function IndexOf(const S: string): Integer; override;
54 property PlainText: TStrings read FPlainText;
55 property Translator: TTranslator read FTranslator;
56 property Verification: boolean read FVerification write FVerification;
57 end;
58
59 TORDirection = -1..1; // for compatibility, type is now integer
60 TORNeedDataEvent = procedure(Sender: TObject; const StartFrom: string;
61 Direction, InsertAt: Integer) of object;
62 TORBeforeDrawEvent = procedure(Sender: TObject; Index: Integer; Rect: TRect;
63 State: TOwnerDrawState) of object;
64 TORItemNotifyEvent = procedure(Sender: TObject; Index: integer) of object;
65 TORCheckComboTextEvent = procedure(Sender: TObject; NumChecked: integer; var Text: string) of object;
66 TORSynonymCheckEvent = procedure(Sender: TObject; const Text: string;
67 var IsSynonym: boolean) of object;
68
69 PItemRec = ^TItemRec;
70 TItemRec = record
71 Reference: Variant; // variant value associated with item
72 UserObject: TObject; // Objects[n] property of listbox item
73 CheckedState: TCheckBoxState; // Used to indicate check box values
74 end;
75
76 THintRecords = record
77 ObjectName: string;
78 ObjectHint: string;
79 end;
80
81 TORListBox = class(TListBox, IVADynamicProperty, IORBlackColorModeCompatible)
82 private
83 FFocusIndex: Integer; // item with focus when using navigation keys
84 FLargeChange: Integer; // visible items less one
85 FTipItem: Integer; // item currently displaying ItemTip
86 FItemTipActive: Boolean; // used to delay appearance of the ItemTip
87 FItemTipColor: TColor; // background color for ItemTip window
88 FItemTipEnable: Boolean; // allows display of ItemTips over items
89 FLastMouseX: Integer; // mouse X position on last MouseMove event
90 FLastMouseY: Integer; // mouse Y position on last MouseMove event
91 FLastItemIndex: Integer; // used for the OnChange event
92 FFromSelf: Boolean; // true if listbox message sent from this unit
93 FDelimiter: Char; // delimiter used by Pieces property
94 FWhiteSpace: Char; // may be space or tab (between pieces)
95 FTabPosInPixels: boolean; // determines if TabPosition is Pixels or Chars
96 FTabPos: array[0..MAX_TABS] of Integer; // character based positions of tab stops
97 FTabPix: array[0..MAX_TABS] of Integer; // pixel positions of tab stops
98 FPieces: array[0..MAX_TABS] of Integer; // pieces that should be displayed for item
99 FLongList: Boolean; // if true, enables special LongList properties
100 FScrollBar: TScrollBar; // scrollbar used when in LongList mode
101 FFirstLoad: Boolean; // true if NeedData has never been called
102 FFromNeedData: Boolean; // true means items added to LongList part
103 FDataAdded: Boolean; // true if items added during NeedData call
104 FCurrentTop: Integer; // TopIndex, changes when inserting to LongList
105 FWaterMark: Integer; // first LongList item after the short list
106 FDirection: Integer; // direction of the current NeedData call
107 FInsertAt: Integer; // insert point for the current NeedData call
108 FParentCombo: TORComboBox; // used when listbox is part of dropdown combo
109 FOnChange: TNotifyEvent; // event called when ItemIndex changes
110 FOnNeedData: TORNeedDataEvent; // event called when LongList needs more items
111 FHideSynonyms: boolean; // Hides Synonyms from the list
112 FSynonymChars: string; // Chars a string must contain to be considered a synonym
113 FOnSynonymCheck: TORSynonymCheckEvent; // Event that allows for custom synonym checking
114 FCreatingItem: boolean; // Used by Synonyms to prevent errors when adding new items
115 FCreatingText: string; // Used by Synonyms to prevent errors when adding new items
116 FOnBeforeDraw: TORBeforeDrawEvent; // event called prior to drawing an item
117 FRightClickSelect: boolean; // When true, a right click selects teh item
118 FCheckBoxes: boolean; // When true, list box contains check boxes
119 FFlatCheckBoxes: boolean; // When true, list box check boxes are flat
120 FCheckEntireLine: boolean; // When checked, clicking anywhere on the line checks the checkbox
121 FOnClickCheck: TORItemNotifyEvent; // Event notifying of checkbox change
122 FDontClose: boolean; // Used to keep drop down open when checkboxes
123 FItemsDestroyed: boolean; // Used to make sure items are not destroyed multiple times
124 FAllowGrayed: boolean;
125 FMItems: TORStrings; // Used to save corresponding M strings ("the pieces")
126 FCaption: TStaticText; // Used to supply a title to IAccessible interface
127 FCaseChanged: boolean; // If true, the names are stored in the database as all caps, but loaded and displayed in mixed-case
128 FLookupPiece: integer; // If zero, list look-up comes from display string; if non-zero, indicates which piece of the item needs to be used for list lookup
129 FIsPartOfComboBox: boolean;
130 FBlackColorMode: boolean;
131 FHideSelection: boolean;
132 procedure AdjustScrollBar;
133 procedure CreateScrollBar;
134 procedure FreeScrollBar;
135 function GetDisplayText(Index: Integer): string;
136 function GetItemID: Variant;
137 function GetItemIEN: Int64;
138 function GetPieces: string;
139 function GetReference(Index: Integer): Variant;
140 function GetTabPositions: string;
141 function GetStyle: TListBoxStyle;
142 procedure NeedData(Direction: Integer; StartFrom: string);
143 function PositionThumb: Integer;
144 procedure ResetItems;
145 procedure ScrollTo(Sender: TObject; ScrollCode: TScrollCode; var ScrollPos: Integer);
146 function GetStringIndex(const AString: string): Integer;
147 function SelectString(const AString: string): Integer;
148 procedure SetCheckBoxes(const Value: boolean);
149 procedure SetDelimiter(Value: Char);
150 procedure SetFlatCheckBoxes(const Value: boolean);
151 procedure SetFocusIndex(Value: Integer);
152 procedure SetLongList(Value: Boolean);
153 procedure SetPieces(const Value: string);
154 procedure SetReference(Index: Integer; AReference: Variant);
155 procedure SetTabPositions(const Value: string);
156 procedure SetTabPosInPixels(const Value: boolean);
157 procedure SetTabStops;
158 procedure SetHideSynonyms(Value: boolean);
159 procedure SetSynonymChars(Value: string);
160 procedure SetStyle(Value: TListBoxStyle);
161 function IsSynonym(const TestStr: string): boolean;
162 function TextToShow(S: string): string;
163 procedure LBGetText(var Message: TMessage); message LB_GETTEXT;
164 procedure LBGetTextLen(var Message: TMessage); message LB_GETTEXTLEN;
165 procedure LBGetItemData(var Message: TMessage); message LB_GETITEMDATA;
166 procedure LBSetItemData(var Message: TMessage); message LB_SETITEMDATA;
167 procedure LBAddString(var Message: TMessage); message LB_ADDSTRING;
168 procedure LBInsertString(var Message: TMessage); message LB_INSERTSTRING;
169 procedure LBDeleteString(var Message: TMessage); message LB_DELETESTRING;
170 procedure LBResetContent(var Message: TMessage); message LB_RESETCONTENT;
171 procedure LBSetCurSel(var Message: TMessage); message LB_SETCURSEL;
172 procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
173 procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;
174 procedure WMDestroy(var Message: TWMDestroy); message WM_DESTROY;
175 procedure WMKeyDown(var Message: TWMKeyDown); message WM_KEYDOWN;
176 procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
177 procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;
178 procedure WMRButtonUp(var Message: TWMRButtonUp); message WM_RBUTTONUP;
179 procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
180 procedure WMCancelMode(var Message: TMessage); message WM_CANCELMODE;
181 procedure WMMove(var Message: TWMMove); message WM_MOVE;
182 procedure WMSize(var Message: TWMSize); message WM_SIZE;
183 procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL;
184 procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW;
185 procedure UMShowTip(var Message: TMessage); message UM_SHOWTIP;
186 function GetChecked(Index: Integer): Boolean;
187 procedure SetChecked(Index: Integer; const Value: Boolean);
188 function GetMultiSelect: boolean;
189 function GetCheckedString: string;
190 procedure SetCheckedString(const Value: string);
191 function GetCheckedState(Index: Integer): TCheckBoxState;
192 procedure SetCheckedState(Index: Integer; const Value: TCheckBoxState);
193 function GetMItems: TStrings;
194 procedure SetMItems(Value: TStrings);
195 procedure SetCaption(const Value: string);
196 function GetCaption: string;
197 protected
198 procedure SetMultiSelect(Value: boolean); override;
199 procedure CreateParams(var Params: TCreateParams); override;
200 procedure CreateWnd; override;
201 procedure DestroyWnd; override;
202 procedure Click; override;
203 procedure DoChange; virtual;
204 procedure DoEnter; override;
205 procedure DoExit; override;
206 procedure DestroyItems;
207 procedure Loaded; override;
208 procedure ToggleCheckBox(idx: integer);
209 procedure KeyPress(var Key: Char); override;
210 procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
211 procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
212 procedure MeasureItem(Index: Integer; var Height: Integer); override;
213 procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override;
214 function GetIndexFromY(YPos: integer): integer;
215 property isPartOfComboBox: boolean read FIsPartOfComboBox write FIsPartOfComboBox default False;
216 property HideSynonyms: boolean read FHideSynonyms write SetHideSynonyms default FALSE;
217 property SynonymChars: string read FSynonymChars write SetSynonymChars;
218 public
219 constructor Create(AOwner: TComponent); override;
220 destructor Destroy; override;
221 procedure ClearTop;
222 function AddReference(const S: string; AReference: Variant): Integer;
223 procedure InsertReference(Index: Integer; const S: string; AReference: Variant);
224 function IndexOfReference(AReference: Variant): Integer;
225 procedure InsertSeparator;
226 procedure ForDataUse(Strings: TStrings);
227 procedure InitLongList(S: string);
228 function GetIEN(AnIndex: Integer): Int64;
229 function SelectByIEN(AnIEN: Int64): Integer;
230 function SelectByID(const AnID: string): Integer;
231 function SetExactByIEN(AnIEN: Int64; const AnItem: string): Integer;
232 procedure Clear; override;
233 property ItemID: Variant read GetItemID;
234 property ItemIEN: Int64 read GetItemIEN;
235 property FocusIndex: Integer read FFocusIndex write SetFocusIndex;
236 property DisplayText[Index: Integer]: string read GetDisplayText;
237 property References[Index: Integer]: Variant read GetReference write SetReference;
238 property ShortCount: Integer read FWaterMark;
239 property Checked[Index: Integer]: Boolean read GetChecked write SetChecked;
240 property CheckedString: string read GetCheckedString write SetCheckedString;
241 property CheckedState[Index: Integer]: TCheckBoxState read GetCheckedState write SetCheckedState;
242 property MItems: TStrings read GetMItems write SetMItems;
243 function VerifyUnique(SelectIndex: Integer; iText: string): integer;
244 procedure SetBlackColorMode(Value: boolean);
245 function SupportsDynamicProperty(PropertyID: integer): boolean;
246 function GetDynamicProperty(PropertyID: integer): string;
247 procedure SetHintProperties(Restore: Boolean; MainForm: TComponent);
248 property HideSelection: boolean read FHideSelection write FHideSelection;
249 published
250 property AllowGrayed: boolean read FAllowGrayed write FAllowGrayed default FALSE;
251 property Caption: string read GetCaption write SetCaption;
252 property CaseChanged: boolean read FCaseChanged write FCaseChanged default TRUE;
253 property Delimiter: Char read FDelimiter write SetDelimiter default '^';
254 property ItemTipColor: TColor read FItemTipColor write FItemTipColor;
255 property ItemTipEnable: Boolean read FItemTipEnable write FItemTipEnable default True;
256 property LongList: Boolean read FLongList write SetLongList;
257 property LookupPiece: integer read FLookupPiece write FLookupPiece default 0;
258 property Pieces: string read GetPieces write SetPieces;
259 property TabPosInPixels: boolean read FTabPosInPixels write SetTabPosInPixels default False; // MUST be before TabPositions!
260 property TabPositions: string read GetTabPositions write SetTabPositions;
261 property OnChange: TNotifyEvent read FOnChange write FOnChange;
262 property OnNeedData: TORNeedDataEvent read FOnNeedData write FOnNeedData;
263 property OnBeforeDraw: TORBeforeDrawEvent read FOnBeforeDraw write FOnBeforeDraw;
264 property RightClickSelect: boolean read FRightClickSelect write FRightClickSelect default FALSE;
265 property CheckBoxes: boolean read FCheckBoxes write SetCheckBoxes default FALSE;
266 property Style: TListBoxStyle read GetStyle write SetStyle default lbStandard;
267 property FlatCheckBoxes: boolean read FFlatCheckBoxes write SetFlatCheckBoxes default TRUE;
268 property CheckEntireLine: boolean read FCheckEntireLine write FCheckEntireLine default FALSE;
269 property OnClickCheck: TORItemNotifyEvent read FOnClickCheck write FOnClickCheck;
270 property MultiSelect: boolean read GetMultiSelect write SetMultiSelect default FALSE;
271 property Items: TStrings read GetMItems write SetMItems;
272 end;
273
274 TORDropPanel = class(TPanel)
275 private
276 FButtons: boolean;
277 procedure WMActivateApp(var Message: TMessage); message WM_ACTIVATEAPP;
278 protected
279 procedure CreateParams(var Params: TCreateParams); override;
280 procedure Resize; override;
281 procedure UpdateButtons;
282 function GetButton(OKBtn: boolean): TSpeedButton;
283 procedure ResetButtons;
284 procedure BtnClicked(Sender: TObject);
285 public
286 constructor Create(AOwner: TComponent); override;
287 end;
288
289 TORComboStyle = (orcsDropDown, orcsSimple);
290
291 TORComboPanelEdit = class(TPanel)
292 private
293 FFocused: boolean;
294 FCanvas: TControlCanvas;
295 protected
296 procedure Paint; override;
297 public
298 destructor Destroy; override;
299 end;
300
301 TORComboEdit = class(TEdit)
302 private
303 procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
304 procedure WMKillFocus(var Message: TWMKillFocus); message WM_KILLFOCUS;
305 protected
306 procedure CreateParams(var Params: TCreateParams); override;
307 end;
308
309 TORComboBox = class(TWinControl, IVADynamicProperty, IORBlackColorModeCompatible)
310 private
311 FItems: TStrings; // points to Items in FListBox
312 FMItems: TStrings; // points to MItems in FListBox
313 FListBox: TORListBox; // listbox control for the combobox
314 FEditBox: TORComboEdit; // edit control for the combobox
315 FEditPanel: TORComboPanelEdit; // Used to enable Multi-Select Combo Boxes
316 FDropBtn: TBitBtn; // drop down button for dropdown combo
317 FDropPanel: TORDropPanel; // panel for dropdown combo (parent=desktop)
318 FDroppedDown: Boolean; // true if the list part is dropped down
319 FStyle: TORComboStyle; // style is simple or dropdown for combo
320 FDropDownCount: Integer; // number of items to display when list appears
321 FFromSelf: Boolean; // prevents recursive calls to change event
322 FFromDropBtn: Boolean; // determines when to capture mouse on drop
323 FKeyTimerActive: Boolean; // true when timer running for OnKeyPause
324 FKeyIsDown: Boolean; // true between KeyDown & KeyUp events
325 FChangePending: Boolean;
326 FListItemsOnly: Boolean;
327 FLastFound: string;
328 FLastInput: string; // last thing the user typed into the edit box
329 FOnChange: TNotifyEvent; // maps to editbox change event
330 FOnClick: TNotifyEvent; // maps to listbox click event
331 FOnDblClick: TNotifyEvent; // maps to listbox double click event
332 FOnDropDown: TNotifyEvent; // event called when listbox appears
333 FOnDropDownClose: TNotifyEvent; // event called when listbox disappears
334 FOnKeyDown: TKeyEvent; // maps to editbox keydown event
335 FOnKeyPress: TKeyPressEvent; // maps to editbox keypress event
336 FOnKeyUp: TKeyEvent; // maps to editbox keyup event
337 FOnKeyPause: TNotifyEvent; // delayed change event when using keyboard
338 FOnMouseClick: TNotifyEvent; // called when click event triggered by mouse
339 FOnNeedData: TORNeedDataEvent; // called for longlist when more items needed
340 FCheckedState: string; // Used to refresh checkboxes when combo box cancel is pressed
341 FOnCheckedText: TORCheckComboTextEvent; // Used to modify the edit box display text when using checkboxes
342 FCheckBoxEditColor: TColor; // Edit Box color for Check Box Combo List, when not in Focus
343 FTemplateField: boolean;
344 FCharsNeedMatch: integer; // how many text need to be matched for auto selection
345 FUniqueAutoComplete: Boolean; // If true only perform autocomplete for unique list items.
346 FBlackColorMode: boolean;
347 FDisableHints: boolean; // true if hints have been disabled because drop down window was opened
348 FDropDownStatusChangedCount: integer; // prevents multiple calls to disabling hint window
349 fRpcCall: String;
350 procedure DropDownStatusChanged(opened: boolean);
351 procedure ClearDropDownStatus;
352 function EditControl: TWinControl;
353 procedure AdjustSizeOfSelf;
354 procedure DropButtonDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState;
355 X, Y: Integer);
356 procedure DropButtonUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState;
357 X, Y: Integer);
358 procedure FwdChange(Sender: TObject);
359 procedure FwdChangeDelayed;
360 procedure FwdClick(Sender: TObject);
361 procedure FwdDblClick(Sender: TObject);
362 procedure FwdKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
363 procedure FwdKeyPress(Sender: TObject; var Key: Char);
364 procedure FwdKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
365 procedure FwdMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState;
366 X, Y: Integer);
367 procedure FwdNeedData(Sender: TObject; const StartFrom: string;
368 Direction, InsertAt: Integer);
369 procedure SetNumForMatch(const NumberForMatch: integer);
370 function GetAutoSelect: Boolean;
371 function GetColor: TColor;
372 function GetDelimiter: Char;
373 function GetDisplayText(Index: Integer): string;
374 function GetItemHeight: Integer;
375 function GetItemID: Variant;
376 function GetItemIEN: Int64;
377 function GetItemIndex: Integer;
378 function GetItemTipEnable: Boolean;
379 function GetItemTipColor: TColor;
380 function GetLongList: Boolean;
381 function GetMaxLength: Integer;
382 function GetPieces: string;
383 function GetReference(Index: Integer): Variant;
384 function GetSelLength: Integer;
385 function GetSelStart: Integer;
386 function GetSelText: string;
387 function GetShortCount: Integer;
388 function GetSorted: Boolean;
389 function GetHideSynonyms: boolean;
390 function GetSynonymChars: string;
391 function GetTabPositions: string;
392 function GetTabPosInPixels: boolean;
393 function GetText: string;
394 procedure SetAutoSelect(Value: Boolean);
395 procedure SetColor(Value: TColor);
396 procedure SetDelimiter(Value: Char);
397 procedure SetDropDownCount(Value: Integer);
398 procedure SetDroppedDown(Value: Boolean);
399 procedure SetEditRect;
400 procedure SetEditText(const Value: string);
401 procedure SetItemIndex(Value: Integer);
402 procedure SetItemHeight(Value: Integer);
403 procedure SetItemTipEnable(Value: Boolean);
404 procedure SetItemTipColor(Value: TColor);
405 procedure SetLongList(Value: Boolean);
406 procedure SetMaxLength(Value: Integer);
407 procedure SetPieces(const Value: string);
408 procedure SetReference(Index: Integer; AReference: Variant);
409 procedure SetSelLength(Value: Integer);
410 procedure SetSelStart(Value: Integer);
411 procedure SetSelText(const Value: string);
412 procedure SetSorted(Value: Boolean);
413 procedure SetHideSynonyms(Value: boolean);
414 procedure SetSynonymChars(Value: string);
415 procedure SetStyle(Value: TORComboStyle);
416 procedure SetTabPositions(const Value: string);
417 procedure SetTabPosInPixels(const Value: boolean);
418 procedure SetText(const Value: string);
419 procedure SetItems(const Value: TStrings);
420 procedure StartKeyTimer;
421 procedure StopKeyTimer;
422 procedure WMDestroy(var Message: TWMDestroy); message WM_DESTROY;
423 procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
424 procedure WMMove(var Message: TWMMove); message WM_MOVE;
425 procedure WMSize(var Message: TWMSize); message WM_SIZE;
426 procedure WMTimer(var Message: TWMTimer); message WM_TIMER;
427 procedure UMGotFocus(var Message: TMessage); message UM_GOTFOCUS;
428 function GetCheckBoxes: boolean;
429 function GetChecked(Index: Integer): Boolean;
430 function GetCheckEntireLine: boolean;
431 function GetFlatCheckBoxes: boolean;
432 procedure SetCheckBoxes(const Value: boolean);
433 procedure SetChecked(Index: Integer; const Value: Boolean);
434 procedure SetCheckEntireLine(const Value: boolean);
435 procedure SetFlatCheckBoxes(const Value: boolean);
436 function GetCheckedString: string;
437 procedure SetCheckedString(const Value: string);
438 procedure SetCheckBoxEditColor(const Value: TColor);
439 procedure SetListItemsOnly(const Value: Boolean);
440 procedure SetOnCheckedText(const Value: TORCheckComboTextEvent);
441 procedure SetTemplateField(const Value: boolean);
442 function GetOnSynonymCheck: TORSynonymCheckEvent;
443 procedure SetOnSynonymCheck(const Value: TORSynonymCheckEvent);
444 function GetMItems: TStrings;
445 procedure SetCaption(const Value: string);
446 function GetCaption: string;
447 function GetCaseChanged: boolean;
448 procedure SetCaseChanged(const Value: boolean);
449 function GetLookupPiece: integer;
450 procedure SetLookupPiece(const Value: integer);
451 procedure SetUniqueAutoComplete(const Value: Boolean);
452 procedure LoadComboBoxImage;
453 protected
454 procedure DropPanelBtnPressed(OKBtn, AutoClose: boolean);
455 function GetEditBoxText(Index: Integer): string;
456 procedure CheckBoxSelected(Sender: TObject; Index: integer);
457 procedure UpdateCheckEditBoxText;
458 procedure DoEnter; override;
459 procedure DoExit; override;
460 procedure Loaded; override;
461 function GetEnabled: boolean; override;
462 procedure SetEnabled(Value: boolean); override;
463 public
464 constructor Create(AOwner: TComponent); override;
465 destructor Destroy; override;
466 function AddReference(const S: string; AReference: Variant): Integer;
467 procedure Clear;
468 procedure ClearTop;
469 procedure ForDataUse(Strings: TStrings);
470 procedure InitLongList(S: string);
471 procedure InsertSeparator;
472 procedure Invalidate; override;
473 procedure SetTextAutoComplete(TextToMatch: string);
474 function GetIEN(AnIndex: Integer): Int64;
475 function SelectByIEN(AnIEN: Int64): Integer;
476 function SelectByID(const AnID: string): Integer;
477 function SetExactByIEN(AnIEN: Int64; const AnItem: string): Integer;
478 function IndexOfReference(AReference: Variant): Integer;
479 procedure InsertReference(Index: Integer; const S: string; AReference: Variant);
480 procedure SelectAll;
481 procedure SetBlackColorMode(Value: boolean);
482 function SupportsDynamicProperty(PropertyID: integer): boolean;
483 function GetDynamicProperty(PropertyID: integer): string;
484 property DisplayText[Index: Integer]: string read GetDisplayText;
485 property DroppedDown: Boolean read FDroppedDown write SetDroppedDown;
486 property ItemID: Variant read GetItemID;
487 property ItemIEN: Int64 read GetItemIEN;
488 property ItemIndex: Integer read GetItemIndex write SetItemIndex;
489 property References[Index: Integer]: Variant read GetReference write SetReference;
490 property SelLength: Integer read GetSelLength write SetSelLength;
491 property SelStart: Integer read GetSelStart write SetSelStart;
492 property SelText: string read GetSelText write SetSelText;
493 property ShortCount: Integer read GetShortCount;
494 property Checked[Index: Integer]: Boolean read GetChecked write SetChecked;
495 property CheckedString: string read GetCheckedString write SetCheckedString;
496 property TemplateField: boolean read FTemplateField write SetTemplateField;
497 property MItems: TStrings read GetMItems;
498 published
499 Property RpcCall :String read fRpcCall write fRpcCall;
500 property Anchors;
501 property CaseChanged: boolean read GetCaseChanged write SetCaseChanged default TRUE;
502 property CheckBoxes: boolean read GetCheckBoxes write SetCheckBoxes default FALSE;
503 property Style: TORComboStyle read FStyle write SetStyle;
504 property Align;
505 property AutoSelect: Boolean read GetAutoSelect write SetAutoSelect;
506 property Caption: string read GetCaption write SetCaption;
507 property Color: TColor read GetColor write SetColor;
508 property Ctl3D;
509 property Delimiter: Char read GetDelimiter write SetDelimiter default '^';
510 property DropDownCount: Integer read FDropDownCount write SetDropDownCount;
511 property Enabled;
512 property Font;
513 property Items: TStrings read FItems write SetItems;
514 property ItemHeight: Integer read GetItemHeight write SetItemHeight;
515 property ItemTipColor: TColor read GetItemTipColor write SetItemTipColor;
516 property ItemTipEnable: Boolean read GetItemTipEnable write SetItemTipEnable;
517 property ListItemsOnly: Boolean read FListItemsOnly write SetListItemsOnly;
518 property LongList: Boolean read GetLongList write SetLongList;
519 property LookupPiece: Integer read GetLookupPiece write SetLookupPiece;
520 property MaxLength: Integer read GetMaxLength write SetMaxLength;
521 property ParentColor;
522 property ParentCtl3D;
523 property ParentFont;
524 property ParentShowHint;
525 property Pieces: string read GetPieces write SetPieces;
526 property PopupMenu;
527 property ShowHint;
528 property HideSynonyms: boolean read GetHideSynonyms write SetHideSynonyms default FALSE;
529 property Sorted: Boolean read GetSorted write SetSorted;
530 property SynonymChars: string read GetSynonymChars write SetSynonymChars;
531 property TabPosInPixels: boolean read GetTabPosInPixels write SetTabPosInPixels default False; // MUST be before TabPositions!
532 property TabPositions: string read GetTabPositions write SetTabPositions;
533 property TabOrder;
534 property TabStop;
535 property Text: string read GetText write SetText;
536 property Visible;
537 property FlatCheckBoxes: boolean read GetFlatCheckBoxes write SetFlatCheckBoxes default TRUE;
538 property CheckEntireLine: boolean read GetCheckEntireLine write SetCheckEntireLine default FALSE;
539 property CheckBoxEditColor: TColor read FCheckBoxEditColor write SetCheckBoxEditColor default clBtnFace;
540 property OnCheckedText: TORCheckComboTextEvent read FOnCheckedText write SetOnCheckedText;
541 property OnChange: TNotifyEvent read FOnChange write FOnChange;
542 property OnClick: TNotifyEvent read FOnClick write FOnClick;
543 property OnDblClick: TNotifyEvent read FOnDblClick write FOnDblClick;
544 property OnDragDrop;
545 property OnDragOver;
546 property OnDropDown: TNotifyEvent read FOnDropDown write FOnDropDown;
547 property OnDropDownClose: TNotifyEvent read FOnDropDownClose write FOnDropDownClose;
548 property OnEnter;
549 property OnExit;
550 property OnKeyDown: TKeyEvent read FOnKeyDown write FOnKeyDown;
551 property OnKeyPress: TKeyPressEvent read FOnKeyPress write FOnKeyPress;
552 property OnKeyUp: TKeyEvent read FOnKeyUp write FOnKeyUp;
553 property OnKeyPause: TNotifyEvent read FOnKeyPause write FOnKeyPause;
554 property OnMouseClick: TNotifyEvent read FOnMouseClick write FOnMouseClick;
555 property OnNeedData: TORNeedDataEvent read FOnNeedData write FOnNeedData;
556 property OnResize;
557 property OnSynonymCheck: TORSynonymCheckEvent read GetOnSynonymCheck write SetOnSynonymCheck;
558 property CharsNeedMatch: integer read FCharsNeedMatch write SetNumForMatch;
559{UniqueAutoComplete Was added as a result of the following defects:
560 7293 - PTM 85: Backspace and Dosage: Desired dosage does not populate if dosage is not in local dosage field
561 7337 - PTM 160 Meds: #8 IMO - Simple - Change Order in which Error generated if "Enter" is hit instead of "OK"
562 7278 - PTM 36 Meds: Select 40000 UNT/2ML and backspace to 4000 the dose selected remains 40000
563 7284 - Inconsistencies of pulling in a dose from the Possible Dose File }
564 property UniqueAutoComplete: Boolean read FUniqueAutoComplete write SetUniqueAutoComplete default False;
565 end;
566
567 TORAutoPanel = class(TPanel)
568 private
569 FSizes: TList;
570 procedure BuildSizes(Control: TWinControl);
571 procedure DoResize(Control: TWinControl; var CurrentIndex: Integer);
572 protected
573 procedure Loaded; override;
574 procedure Resize; override;
575 public
576 destructor Destroy; override;
577 end;
578
579 TOROffsetLabel = class(TGraphicControl) // see TCustomLabel in the VCL
580 private
581 FHorzOffset: Integer; // offset from left of label in pixels
582 FVertOffset: Integer; // offset from top of label in pixels
583 FWordWrap: Boolean; // true if word wrap should occur
584 function GetTransparent: Boolean;
585 procedure AdjustSizeOfSelf;
586 procedure DoDrawText(var Rect: TRect; Flags: Word);
587 procedure SetHorzOffset(Value: Integer);
588 procedure SetVertOffset(Value: Integer);
589 procedure SetTransparent(Value: Boolean);
590 procedure SetWordWrap(Value: Boolean);
591 procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
592 procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
593 protected
594 procedure Paint; override;
595 public
596 constructor Create(AOwner: TComponent); override;
597 published
598 property Align;
599 property Caption;
600 property Color;
601 property Enabled;
602 property Font;
603 property HorzOffset: Integer read FHorzOffset write SetHorzOffset;
604 property ParentColor;
605 property ParentFont;
606 property ParentShowHint;
607 property PopupMenu;
608 property ShowHint;
609 property Transparent: Boolean read GetTransparent write SetTransparent;
610 property VertOffset: Integer read FVertOffset write SetVertOffset;
611 property Visible;
612 property WordWrap: Boolean read FWordWrap write SetWordWrap;
613 property OnClick;
614 property OnDblClick;
615 property OnDragDrop;
616 property OnDragOver;
617 property OnEndDrag;
618 property OnMouseDown;
619 property OnMouseMove;
620 property OnMouseUp;
621 property OnStartDrag;
622 end;
623
624 TORAlignButton = class(TButton)
625 private
626 FAlignment: TAlignment;
627 FWordWrap: boolean;
628 FLayout: TTextLayout;
629 protected
630 procedure CreateParams(var Params: TCreateParams); override;
631 procedure SetAlignment(const Value: TAlignment);
632 procedure SetLayout(const Value: TTextLayout);
633 procedure SetWordWrap(const Value: boolean);
634 public
635 constructor Create(AOwner: TComponent); override;
636 published
637 property Align;
638 property Alignment: TAlignment read FAlignment write SetAlignment default taCenter;
639 property Layout: TTextLayout read FLayout write SetLayout default tlCenter;
640 property WordWrap: boolean read FWordWrap write SetWordWrap default FALSE;
641 end;
642
643{ TORAlignBitBtn = class(TBitBtn)
644 published
645 property Align;
646 end;}
647
648 TORAlignSpeedButton = class(TSpeedButton)
649 protected
650 procedure Paint; override;
651 public
652 property Canvas;
653 published
654 property Align;
655 property OnResize;
656 end;
657
658 TORAlignEdit = class(TEdit) //Depricated -- Use TCaptionEdit instead
659 published
660 property Align;
661 end;
662
663 TORDraggingEvent = procedure(Sender: TObject; Node: TTreeNode; var CanDrag: boolean) of object;
664
665
666 TCaptionTreeView = class(TTreeView, IVADynamicProperty)
667 private
668 procedure SetCaption(const Value: string);
669 function GetCaption: string;
670 protected
671 FCaptionComponent: TStaticText;
672 public
673 function SupportsDynamicProperty(PropertyID: integer): boolean;
674 function GetDynamicProperty(PropertyID: integer): string;
675 published
676 property Align;
677 property Caption: string read GetCaption write SetCaption;
678 end;
679
680 TORTreeView = class;
681
682 TORTreeNode = class(TTreeNode)
683 private
684 FTag: integer;
685 FStringData: string;
686 FCaption: string;
687 function GetParent: TORTreeNode;
688 procedure SetCaption(const Value: string);
689 protected
690 function GetText: string;
691 procedure SetText(const Value: string);
692 procedure UpdateText(const Value: string; UpdateData: boolean = TRUE);
693 function GetBold: boolean;
694 procedure SetBold(const Value: boolean);
695 procedure SetStringData(const Value: string);
696 function GetORTreeView: TORTreeView;
697 public
698 procedure SetPiece(PieceNum: Integer; const NewPiece: string);
699 procedure EnsureVisible;
700 property Bold: boolean read GetBold write SetBold;
701 property Tag: integer read FTag write FTag;
702 property StringData: string read FStringData write SetStringData;
703 property TreeView: TORTreeView read GetORTreeView;
704 property Text: string read GetText write SetText;
705 property Parent: TORTreeNode read GetParent;
706 property Caption: string read FCaption write SetCaption;
707 end;
708
709 TNodeCaptioningEvent = procedure(Sender: TObject; var Caption: string) of object;
710
711 TORTreeView = class(TCaptionTreeView)
712 private
713 FOnDragging: TORDraggingEvent;
714 FDelim: Char;
715 FPiece: integer;
716 FOnAddition: TTVExpandedEvent;
717 FShortNodeCaptions: boolean;
718 FOnNodeCaptioning: TNodeCaptioningEvent;
719 procedure SetShortNodeCaptions(const Value: boolean);
720 protected
721 procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
722 function CreateNode: TTreeNode; override;
723 function GetHorzScrollPos: integer;
724 procedure SetHorzScrollPos(Value: integer);
725 function GetVertScrollPos: integer;
726 procedure SetVertScrollPos(Value: integer);
727 procedure SetNodeDelim(const Value: Char);
728 procedure SetNodePiece(const Value: integer);
729 public
730 constructor Create(AOwner: TComponent); override;
731 function FindPieceNode(Value: string;
732 ParentDelim: Char = #0; StartNode: TTreeNode = nil): TORTreeNode; overload;
733 function FindPieceNode(Value: string; APiece: integer;
734 ParentDelim: Char = #0; StartNode: TTreeNode = nil): TORTreeNode; overload;
735 procedure RenameNodes;
736 function GetExpandedIDStr(APiece: integer; ParentDelim: char = #0): string;
737 procedure SetExpandedIDStr(APiece: integer; const Value: string); overload;
738 procedure SetExpandedIDStr(APiece: integer; ParentDelim: char;
739 const Value: string); overload;
740 function GetNodeID(Node: TORTreeNode; ParentDelim: Char = #0): string; overload;
741 function GetNodeID(Node: TORTreeNode; APiece: integer; ParentDelim: Char = #0): string; overload;
742 published
743 property Caption;
744 property NodeDelim: Char read FDelim write SetNodeDelim default '^';
745 property NodePiece: integer read FPiece write SetNodePiece;
746 property OnAddition: TTVExpandedEvent read FOnAddition write FOnAddition;
747 property OnDragging: TORDraggingEvent read FOnDragging write FOnDragging;
748 property HorzScrollPos: integer read GetHorzScrollPos write SetHorzScrollPos default 0;
749 property VertScrollPos: integer read GetVertScrollPos write SetVertScrollPos default 0;
750 property ShortNodeCaptions: boolean read FShortNodeCaptions write SetShortNodeCaptions default False;
751 property OnNodeCaptioning: TNodeCaptioningEvent read FOnNodeCaptioning write FOnNodeCaptioning;
752 end;
753
754 TORCBImageIndexes = class(TComponent)
755 private
756 FImages: TCustomImageList;
757 FImageChangeLink: TChangeLink;
758 FCheckedEnabledIndex: integer;
759 FGrayedEnabledIndex: integer;
760 FUncheckedEnabledIndex: integer;
761 FCheckedDisabledIndex: integer;
762 FGrayedDisabledIndex: integer;
763 FUncheckedDisabledIndex: integer;
764 protected
765 procedure SetCheckedDisabledIndex(const Value: integer);
766 procedure SetCheckedEnabledIndex(const Value: integer);
767 procedure SetGrayedDisabledIndex(const Value: integer);
768 procedure SetGrayedEnabledIndex(const Value: integer);
769 procedure SetUncheckedDisabledIndex(const Value: integer);
770 procedure SetUncheckedEnabledIndex(const Value: integer);
771 procedure ImageListChanged(Sender: TObject);
772 procedure Notification(AComponent: TComponent; Operation: TOperation); override;
773 function IdxString: string;
774 procedure SetIdxString(Value: string);
775 procedure SetImages(const Value: TCustomImageList);
776 public
777 constructor Create(AOwner: TComponent); override;
778 destructor Destroy; override;
779 published
780 property CheckedEnabledIndex: integer read FCheckedEnabledIndex write SetCheckedEnabledIndex;
781 property CheckedDisabledIndex: integer read FCheckedDisabledIndex write SetCheckedDisabledIndex;
782 property GrayedEnabledIndex: integer read FGrayedEnabledIndex write SetGrayedEnabledIndex;
783 property GrayedDisabledIndex: integer read FGrayedDisabledIndex write SetGrayedDisabledIndex;
784 property UncheckedEnabledIndex: integer read FUncheckedEnabledIndex write SetUncheckedEnabledIndex;
785 property UncheckedDisabledIndex: integer read FUncheckedDisabledIndex write SetUncheckedDisabledIndex;
786 end;
787
788 TGrayedStyle = (gsNormal, gsQuestionMark, gsBlueQuestionMark);
789
790 TORCheckBox = class(TCheckBox, IORBlackColorModeCompatible)
791 private
792 FStringData: string;
793 FCanvas: TCanvas;
794 FGrayedToChecked: boolean;
795 FCustomImagesOwned: boolean;
796 FCustomImages: TORCBImageIndexes;
797 FGrayedStyle: TGrayedStyle;
798 FWordWrap: boolean;
799 FAutoSize: boolean;
800 FSingleLine: boolean;
801 FSizable: boolean;
802 FGroupIndex: integer;
803 FAllowAllUnchecked: boolean;
804 FRadioStyle: boolean;
805 FAssociate: TControl;
806 FFocusOnBox: boolean;
807 FBlackColorMode: boolean;
808 procedure SetFocusOnBox(value: boolean);
809 procedure CNMeasureItem(var Message: TWMMeasureItem); message CN_MEASUREITEM;
810 procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;
811 procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
812 procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
813 procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
814 procedure WMSize(var Message: TWMSize); message WM_SIZE;
815 procedure BMSetCheck(var Message: TMessage); message BM_SETCHECK;
816 procedure BMGetCheck(var Message: TMessage); message BM_GETCHECK;
817 procedure BMGetState(var Message: TMessage); message BM_GETSTATE;
818 function GetImageList: TCustomImageList;
819 function GetImageIndexes: string;
820 procedure SetImageIndexes(const Value: string);
821 procedure SetImageList(const Value: TCustomImageList);
822 procedure SetWordWrap(const Value: boolean);
823 function GetCaption: TCaption;
824 procedure SetCaption(const Value: TCaption);
825 procedure SyncAllowAllUnchecked;
826 procedure SetAllowAllUnchecked(const Value: boolean);
827 procedure SetGroupIndex(const Value: integer);
828 procedure SetRadioStyle(const Value: boolean);
829 procedure SetAssociate(const Value: TControl);
830 protected
831 procedure SetAutoSize(Value: boolean); override;
832 procedure GetDrawData(CanvasHandle: HDC; var Bitmap: TBitmap;
833 var FocRect, Rect: TRect;
834 var DrawOptions: UINT;
835 var TempBitMap: boolean);
836 procedure DrawItem(const DrawItemStruct: TDrawItemStruct); dynamic;
837 procedure Toggle; override;
838 procedure CreateParams(var Params: TCreateParams); override;
839 procedure SetGrayedStyle(Value: TGrayedStyle);
840 constructor ListViewCreate(AOwner: TComponent; ACustomImages: TORCBImageIndexes);
841 procedure CreateCommon(AOwner: TComponent);
842 property CustomImages: TORCBImageIndexes read FCustomImages;
843 procedure SetParent(AParent: TWinControl); override;
844 procedure UpdateAssociate;
845 procedure Notification(AComponent: TComponent; Operation: TOperation); override;
846 public
847 constructor Create(AOwner: TComponent); override;
848 destructor Destroy; override;
849 procedure AutoAdjustSize;
850 procedure SetBlackColorMode(Value: boolean);
851 property SingleLine: boolean read FSingleLine;
852 property StringData: string read FStringData write FStringData;
853 published
854 property FocusOnBox: boolean read FFocusOnBox write SetFocusOnBox default false;
855 property GrayedStyle: TGrayedStyle read FGrayedStyle write SetGrayedStyle default gsNormal;
856 property GrayedToChecked: boolean read FGrayedToChecked write FGrayedToChecked default TRUE;
857 property ImageIndexes: string read GetImageIndexes write SetImageIndexes;
858 property ImageList: TCustomImageList read GetImageList write SetImageList;
859 property WordWrap: boolean read FWordWrap write SetWordWrap default FALSE;
860 property AutoSize: boolean read FAutoSize write SetAutoSize default FALSE;
861 property Caption: TCaption read GetCaption write SetCaption;
862 property AllowAllUnchecked: boolean read FAllowAllUnchecked write SetAllowAllUnchecked default TRUE;
863 property GroupIndex: integer read FGroupIndex write SetGroupIndex default 0;
864 property RadioStyle: boolean read FRadioStyle write SetRadioStyle default FALSE;
865 property Associate: TControl read FAssociate write SetAssociate;
866 property OnEnter;
867 property OnExit;
868 end;
869
870 TORListView = class(TListView)
871 private
872 protected
873 procedure WMNotify(var Message: TWMNotify); message WM_NOTIFY;
874 procedure LVMSetColumn(var Message: TMessage); message LVM_SETCOLUMN;
875 procedure LVMSetColumnWidth(var Message: TMessage); message LVM_SETCOLUMNWIDTH;
876 end;
877
878 { TORPopupMenu and TORMenuItem are not available at design time, since they
879 would offer little value there. They are currently used for dynamic menu
880 creation }
881 TORPopupMenu = class(TPopupMenu)
882 private
883 FData: string;
884 public
885 property Data: string read FData write FData;
886 end;
887
888 TORMenuItem = class(TMenuItem)
889 private
890 FData: string;
891 public
892 property Data: string read FData write FData;
893 end;
894
895 (*
896 TORCalendar = class(TCalendar)
897 protected
898 procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); override;
899 end;
900 *)
901
902 TKeyClickPanel = class(TPanel)
903 protected
904 procedure KeyDown(var Key: Word; Shift: TShiftState); override;
905 end;
906
907 TKeyClickRadioGroup = class(TRadioGroup)
908 protected
909 procedure KeyDown(var Key: Word; Shift: TShiftState); override;
910 procedure Click; override;
911 public
912 constructor Create(AOwner: TComponent); override;
913 end;
914
915 TCaptionListBox = class(TListBox, IVADynamicProperty)
916 private
917 FHoverItemPos: integer;
918 FRightClickSelect: boolean; // When true, a right click selects teh item
919 FHintOnItem: boolean;
920 procedure SetCaption(const Value: string);
921 function GetCaption: string;
922 procedure WMRButtonUp(var Message: TWMRButtonUp); message WM_RBUTTONUP;
923 procedure WMMouseMove(var Message: TWMMouseMove); message WM_MOUSEMOVE;
924 procedure WMKeyDown(var Message: TWMKeyDown); message WM_KEYDOWN;
925 procedure MoveFocusDown;
926 procedure MoveFocusUp;
927 protected
928 FCaptionComponent: TStaticText;
929 procedure DoEnter; override;
930 public
931 function SupportsDynamicProperty(PropertyID: integer): boolean;
932 function GetDynamicProperty(PropertyID: integer): string;
933 published
934 property RightClickSelect: boolean read FRightClickSelect write FRightClickSelect default FALSE;
935 property Caption: string read GetCaption write SetCaption;
936 //Make the ListBox's hint contain the contents of the listbox Item the mouse is currently over.
937 property HintOnItem: boolean read FHintOnItem write FHintOnItem default FALSE;
938 end;
939
940 TCaptionCheckListBox = class(TCheckListBox, IVADynamicProperty)
941 private
942 procedure SetCaption(const Value: string);
943 function GetCaption: string;
944 protected
945 FCaptionComponent: TStaticText;
946 public
947 function SupportsDynamicProperty(PropertyID: integer): boolean;
948 function GetDynamicProperty(PropertyID: integer): string;
949 published
950 property Caption: string read GetCaption write SetCaption;
951 Property CheckWidth: integer Read GetCheckWidth;
952 end;
953
954 TCaptionMemo = class(TMemo, IVADynamicProperty)
955 private
956 procedure SetCaption(const Value: string);
957 function GetCaption: string;
958 protected
959 FCaptionComponent: TStaticText;
960 public
961 function SupportsDynamicProperty(PropertyID: integer): boolean;
962 function GetDynamicProperty(PropertyID: integer): string;
963 published
964 property Caption: string read GetCaption write SetCaption;
965 end;
966
967 TCaptionEdit = class(TEdit, IVADynamicProperty)
968 private
969 procedure SetCaption(const Value: string);
970 function GetCaption: string;
971 protected
972 FCaptionComponent: TStaticText;
973 public
974 function SupportsDynamicProperty(PropertyID: integer): boolean;
975 function GetDynamicProperty(PropertyID: integer): string;
976 published
977 property Align;
978 property Caption: string read GetCaption write SetCaption;
979 end;
980
981 TCaptionRichEdit = class(TRichEdit, IVADynamicProperty)
982 private
983 protected
984 FCaption: string;
985 public
986 function SupportsDynamicProperty(PropertyID: integer): boolean;
987 function GetDynamicProperty(PropertyID: integer): string;
988 published
989 property Align;
990 property Caption: string read FCaption write FCaption;
991 end;
992
993 TCaptionComboBox = class(TComboBox, IVADynamicProperty)
994 private
995 procedure SetCaption(const Value: string);
996 function GetCaption: string;
997 protected
998 FCaptionComponent: TStaticText;
999 public
1000 function SupportsDynamicProperty(PropertyID: integer): boolean;
1001 function GetDynamicProperty(PropertyID: integer): string;
1002 published
1003 property Caption: string read GetCaption write SetCaption;
1004 end;
1005
1006 TCaptionListView = class(TListView, IVADynamicProperty)
1007 public
1008 function SupportsDynamicProperty(PropertyID: integer): boolean;
1009 function GetDynamicProperty(PropertyID: integer): string;
1010 published
1011 property Caption;
1012 end;
1013
1014 TCaptionStringGrid = class(TStringGrid, IVADynamicProperty)
1015 private
1016 FJustToTab: boolean;
1017 FCaption: string;
1018 protected
1019 procedure KeyUp(var Key: Word; Shift: TShiftState); override;
1020 public
1021 procedure IndexToColRow(index: integer; var Col: integer; var Row: integer);
1022 function ColRowToIndex(Col: integer; Row: Integer): integer;
1023 function SupportsDynamicProperty(PropertyID: integer): boolean;
1024 function GetDynamicProperty(PropertyID: integer): string;
1025 published
1026 property Caption: string read FCaption write FCaption;
1027 property JustToTab: boolean read FJustToTab write FJustToTab default FALSE;
1028 end;
1029
1030function FontWidthPixel(FontHandle: THandle): Integer;
1031function FontHeightPixel(FontHandle: THandle): Integer;
1032function ItemTipKeyHook(Code: Integer; wParam: WPARAM; lParam: LPARAM): LRESULT; StdCall;
1033
1034{I may have messed up my Windows.pas file, but mine defines NotifyWinEvent without a stdcall.}
1035procedure GoodNotifyWinEvent(event: DWORD; hwnd: HWND; idObject, idChild: Longint); stdcall;
1036
1037function CalcShortName(LongName: string; PrevLongName: string): string;
1038
1039{Returns True if any one of 3 mouse buttons are down left, right, or middle}
1040function IsAMouseButtonDown: boolean;
1041
1042implementation // ---------------------------------------------------------------------------
1043
1044{$R ORCTRLS}
1045
1046uses
1047 VAUtils;
1048
1049const
1050 ALPHA_DISTRIBUTION: array[0..100] of string[3] = ('', ' ', 'ACE', 'ADG', 'ALA', 'AMI', 'ANA', 'ANT',
1051 'ARE', 'ASU', 'AZO', 'BCP', 'BIC', 'BOO', 'BST', 'CAF', 'CAR', 'CD6', 'CHE', 'CHO', 'CMC', 'CON', 'CPD',
1052 'CVI', 'DAA', 'DEF', 'DEP', 'DIA', 'DIH', 'DIP', 'DP ', 'EAR', 'EM ', 'EPI', 'ETH', 'F2G', 'FIB', 'FML',
1053 'FUM', 'GEL', 'GLU', 'GPQ', 'HAL', 'HEM', 'HIS', 'HUN', 'HYL', 'IDS', 'IND', 'INT', 'ISO', 'KEX', 'LAN',
1054 'LEV', 'LOY', 'MAG', 'MAX', 'MER', 'MET', 'MIC', 'MON', 'MUD', 'NAI', 'NEU', 'NIT', 'NUC', 'OMP', 'OTH',
1055 'P42', 'PAR', 'PEN', 'PHA', 'PHO', 'PLA', 'POL', 'PRA', 'PRO', 'PSE', 'PYR', 'RAN', 'REP', 'RIB', 'SAA',
1056 'SCL', 'SFL', 'SMO', 'SPO', 'STR', 'SUL', 'TAG', 'TET', 'THI', 'TOL', 'TRI', 'TRY', 'UNC', 'VAR', 'VIT',
1057 'WRO', 'ZYM', #127#127#127);
1058
1059 CBO_CYMARGIN = 8; // vertical whitespace in the edit portion of combobox
1060 CBO_CXBTN = 13; // width of drop down button in combobox
1061 CBO_CXFRAME = 5; // offset to account for frame around the edit part of combobox
1062
1063 NOREDRAW = 0; // suspend screen updates
1064 DOREDRAW = 1; // allow screen updates
1065
1066 KEY_TIMER_DELAY = 500; // 500 ms delay after key up before OnKeyPause called
1067 KEY_TIMER_ID = 5800; // arbitrary, use high number in case TListBox uses timers
1068
1069 { use high word to pass positioning flags since listbox is limited to 32767 items }
1070 //SFI_TOP = $80000000; // top of listbox (decimal value: -2147483648)
1071 //SFI_END = $90000000; // end of listbox (decimal value: -1879048192)
1072 SFI_TOP = -2147483646; // top of listbox (hex value: $80000001)
1073 SFI_END = -1879048192; // end of listbox (hex value: $90000000)
1074
1075 CheckWidth = 15; // CheckBox Width space to reserve for TORListBox
1076 CheckComboBtnHeight = 21;
1077 MaxNeedDataLen = 64;
1078
1079type
1080 TItemTip = class(TCustomControl)
1081 private
1082 FShowing: Boolean; // true when itemtip is visible
1083 FListBox: TORListBox; // current listbox displaying itemtips
1084 FListItem: integer;
1085 FPoint: TPoint;
1086 FSelected: boolean;
1087 FTabs: array[0..MAX_TABS] of Integer; // Holds the pixel offsets for tabs
1088 procedure GetTabSettings;
1089 protected
1090 constructor Create(AOwner: TComponent); override;
1091 destructor Destroy; override;
1092 procedure CreateParams(var Params: TCreateParams); override;
1093 procedure Paint; override;
1094 procedure Hide;
1095 procedure UpdateText(CatchMouse: Boolean);
1096 procedure Show(AListBox: TORListBox; AnItem: Integer; APoint: TPoint; CatchMouse: Boolean);
1097 end;
1098
1099 TSizeRatio = class // relative sizes and positions for resizing
1100 CLeft: Extended;
1101 CTop: Extended;
1102 CWidth: Extended;
1103 CHeight: Extended;
1104 constructor Create(ALeft, ATop, AWidth, AHeight: Extended);
1105 end;
1106
1107var
1108 uKeyHookHandle: HHOOK; // handle to capture key events & hide ItemTip window
1109 uItemTip: TItemTip; // ItemTip window
1110 uItemTipCount: Integer; // number of ItemTip clients
1111 uNewStyle: Boolean; // True if using Windows 95 interface
1112 HintArray: array of THintRecords;
1113{ General functions and procedures --------------------------------------------------------- }
1114
1115function ClientWidthOfList(AListBox: TORListBox): Integer;
1116begin
1117 with AListBox do
1118 begin
1119 Result := Width;
1120 if BorderStyle = bsSingle then
1121 begin
1122 Dec(Result, 1);
1123 if Ctl3D then Dec(Result, 1);
1124 end;
1125 end;
1126 Dec(Result, GetSystemMetrics(SM_CXVSCROLL));
1127end;
1128
1129function FontWidthPixel(FontHandle: THandle): Integer;
1130{ return in pixels the average character width of the font passed in FontHandle }
1131var
1132 DC: HDC;
1133 SaveFont: HFont;
1134 Extent: TSize;
1135begin
1136 DC := GetDC(0);
1137 try
1138 SaveFont := SelectObject(DC, FontHandle);
1139 try
1140 GetTextExtentPoint32(DC, 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz', 52, Extent);
1141 //Find the average of the width then round up
1142 Result := Trunc(Extent.cx / 52 ) + 1;
1143 finally
1144 SelectObject(DC, SaveFont);
1145 end;
1146 finally
1147 ReleaseDC(0, DC);
1148 end;
1149end;
1150
1151function FontHeightPixel(FontHandle: THandle): Integer;
1152{ return in pixels the height of the font passed in FontHandle }
1153var
1154 DC: HDC;
1155 SaveFont: HFont;
1156 FontMetrics: TTextMetric;
1157begin
1158 DC := GetDC(0);
1159 SaveFont := SelectObject(DC, FontHandle);
1160 GetTextMetrics(DC, FontMetrics);
1161 Result := FontMetrics.tmHeight;
1162 SelectObject(DC, SaveFont);
1163 ReleaseDC(0, DC);
1164end;
1165
1166function HigherOf(i, j: Integer): Integer;
1167{ returns the greater of two integers }
1168begin
1169 Result := i;
1170 if j > i then Result := j;
1171end;
1172
1173function LowerOf(i, j: Integer): Integer;
1174{ returns the lesser of two integers }
1175begin
1176 Result := i;
1177 if j < i then Result := j;
1178end;
1179
1180function Piece(const S: string; Delim: char; PieceNum: Integer): string;
1181{ returns the Nth piece (PieceNum) of a string delimited by Delim }
1182var
1183 i: Integer;
1184 Strt, Next: PChar;
1185begin
1186 i := 1;
1187 Strt := PChar(S);
1188 Next := StrScan(Strt, Delim);
1189 while (i < PieceNum) and (Next <> nil) do
1190 begin
1191 Inc(i);
1192 Strt := Next + 1;
1193 Next := StrScan(Strt, Delim);
1194 end;
1195 if Next = nil then Next := StrEnd(Strt);
1196 if i < PieceNum then Result := '' else SetString(Result, Strt, Next - Strt);
1197end;
1198
1199procedure SetPiece(var x: string; Delim: Char; PieceNum: Integer; const NewPiece: string);
1200{ sets the Nth piece (PieceNum) of a string to NewPiece, adding delimiters as necessary }
1201var
1202 i: Integer;
1203 Strt, Next: PChar;
1204begin
1205 i := 1;
1206 Strt := PChar(x);
1207 Next := StrScan(Strt, Delim);
1208 while (i < PieceNum) and (Next <> nil) do
1209 begin
1210 Inc(i);
1211 Strt := Next + 1;
1212 Next := StrScan(Strt, Delim);
1213 end;
1214 if Next = nil then Next := StrEnd(Strt);
1215 if i < PieceNum
1216 then x := x + StringOfChar(Delim, PieceNum - i) + NewPiece
1217 else x := Copy(x, 1, Strt - PChar(x)) + NewPiece + StrPas(Next);
1218end;
1219
1220function IntArrayToString(const IntArray: array of Integer): string;
1221{ converts an array of integers to a comma delimited string, 0 element assumed to be count }
1222var
1223 i: Integer;
1224begin
1225 Result := '';
1226 for i := 1 to IntArray[0] do Result := Result + IntToStr(IntArray[i]) + ',';
1227 if Length(Result) > 0 then Delete(Result, Length(Result), 1);
1228end;
1229
1230procedure StringToIntArray(AString: string; var IntArray: array of Integer; AllowNeg: boolean = FALSE);
1231{ converts a string to an array of positive integers, count is kept in 0 element }
1232var
1233 ANum: Integer;
1234 APiece: string;
1235begin
1236 FillChar(IntArray, SizeOf(IntArray), 0);
1237 repeat
1238 if Pos(',', AString) > 0 then
1239 begin
1240 APiece := Copy(AString, 1, Pos(',', AString) - 1);
1241 Delete(AString, 1, Pos(',', AString));
1242 end else
1243 begin
1244 APiece := AString;
1245 AString := EmptyStr;
1246 end;
1247 ANum := StrToIntDef(Trim(APiece), 0);
1248 if (ANum > 0) or (AllowNeg and (ANum < 0)) then
1249 begin
1250 Inc(IntArray[0]);
1251 IntArray[IntArray[0]] := ANum;
1252 end;
1253 until (Length(AString) = 0) or (IntArray[0] = High(IntArray));
1254end;
1255
1256function StringBetween(const x, First, Last: string): Boolean;
1257{ returns true if x collates between the strings First and Last, not case sensitive }
1258begin
1259 Result := True;
1260 if (CompareText(x, First) < 0) or (CompareText(x, Last) > 0) then Result := False;
1261end;
1262
1263{ ItemTip callback ------------------------------------------------------------------------- }
1264
1265function ItemTipKeyHook(Code: Integer; wParam: WPARAM; lParam: LPARAM): LRESULT;
1266{ callback used to hide the item tip window whenever a key is pressed }
1267begin
1268 if lParam shr 31 = 0 then uItemTip.Hide; // hide only on key down
1269 Result := CallNextHookEx(uKeyHookHandle, Code, wParam, lParam);
1270end;
1271
1272{ TItemTip --------------------------------------------------------------------------------- }
1273
1274procedure AddItemTipRef; // kcm
1275begin
1276 if uItemTipCount = 0 then uItemTip := TItemTip.Create(Application); // all listboxes share a single ItemTip window
1277 Inc(uItemTipCount);
1278end;
1279
1280procedure RemoveItemTipRef; // kcm
1281begin
1282 Dec(uItemTipCount);
1283 if (uItemTipCount = 0) and (uItemTip <> nil) then uItemTip.Free;
1284end;
1285
1286constructor TItemTip.Create(AOwner: TComponent);
1287{ the windows hook allows the item tip window to be hidden whenever a key is pressed }
1288begin
1289 inherited Create(AOwner);
1290 uKeyHookHandle := SetWindowsHookEx(WH_KEYBOARD, ItemTipKeyHook, 0, GetCurrentThreadID);
1291end;
1292
1293destructor TItemTip.Destroy;
1294{ disconnects the windows hook (callback) for keyboard events }
1295begin
1296 UnhookWindowsHookEx(uKeyHookHandle);
1297 inherited Destroy;
1298 uItemTip := nil;
1299end;
1300
1301procedure TItemTip.CreateParams(var Params: TCreateParams);
1302{ makes the window so that is can be viewed but not activated (can't get events) }
1303begin
1304 inherited CreateParams(Params);
1305 Params.Style := WS_POPUP or WS_DISABLED or WS_BORDER;
1306 if uNewStyle then Params.ExStyle := WS_EX_TOOLWINDOW;
1307 Params.ExStyle := Params.ExStyle or WS_EX_TOPMOST; // - test this!!
1308end;
1309
1310procedure TItemTip.Paint;
1311{ displays the caption property for the window within the window }
1312var
1313 AString: string;
1314 y: integer;
1315
1316begin
1317 AString := Caption;
1318 with Canvas do
1319 begin
1320 SetBkMode(Handle, TRANSPARENT);
1321 FillRect(ClientRect);
1322 y := ((ClientRect.Bottom - ClientRect.Top) - FontHeightPixel(Canvas.Font.Handle)) div 2;
1323 //TextOut(ClientRect.Left + 1, ClientRect.Top - 1, AString);
1324// WARNING - Do NOT change the X pos or the tab starting pos - this will cause a missmatch
1325// between the hint window and what the control displayes
1326 TabbedTextOut(Handle, 0, y, PChar(AString), Length(AString), MAX_TABS + 1, FTabs[0], 0);
1327 end;
1328end;
1329
1330procedure TItemTip.Hide;
1331{ hides the tip window and makes sure the listbox isn't still capturing the mouse }
1332begin
1333 if FShowing then
1334 begin
1335 { The listbox should retain mousecapture if the left mouse button is still down or it
1336 is the dropdown list for a combobox. Otherwise, click events don't get triggered. }
1337 with FListBox do if not (csLButtonDown in ControlState) and (FParentCombo = nil)
1338 then MouseCapture := False;
1339 ShowWindow(Handle, SW_HIDE);
1340 FShowing := False;
1341 end;
1342end;
1343
1344procedure TItemTip.GetTabSettings;
1345var
1346 DX, X, i, count: integer;
1347
1348begin
1349 Count := FListBox.FTabPix[0];
1350 FTabs[0] := 1; // Set first tab stop to location 1 for display purposes
1351 if (Count = 1) then
1352 begin
1353 DX := FListBox.FTabPix[1];
1354 X := (DX * 2) - 1;
1355 end
1356 else
1357 begin
1358 DX := FontWidthPixel(FListBox.Font.Handle) * 8; // windows tab default is 8 chars
1359 X := FListBox.FTabPix[Count];
1360 X := Trunc(X / DX) + 1;
1361 X := (X * DX) - 1; // get the next tab position after that which is specified
1362 end;
1363 for i := 1 to MAX_TABS do
1364 begin
1365 if (i <= Count) then
1366 FTabs[i] := FListBox.FTabPix[i] - 1
1367 else
1368 begin
1369 FTabs[i] := X;
1370 inc(X, DX);
1371 end;
1372 end;
1373end;
1374
1375procedure TItemTip.UpdateText(CatchMouse: Boolean);
1376var
1377 AWidth, ListClientWidth, X: Integer;
1378 sr: TRect;
1379
1380begin
1381 Cursor := FListBox.Cursor;
1382 Canvas.Font := FListBox.Font;
1383 if FSelected then
1384 begin
1385 Canvas.Brush.Color := clHighlight;
1386 Canvas.Font.Color := clHighlightText;
1387 end else // the item is not selected
1388 begin
1389 Canvas.Brush.Color := FListBox.ItemTipColor;
1390 Canvas.Font.Color := clWindowText;
1391 end;
1392 Caption := #9 + FListBox.DisplayText[FListItem];
1393 if Copy(Caption, 1, 2) = '__' then Caption := ' '; // so separators don't extend past window
1394
1395 GetTabSettings;
1396
1397 AWidth := LOWORD(GetTabbedTextExtent(Canvas.Handle, PChar(Caption), Length(Caption),
1398 MAX_TABS + 1, FTabs[0]));
1399 // inherent scrollbar may not always be visible in a long list
1400 if FListBox.LongList
1401 then ListClientWidth := ClientWidthOfList(FListBox)
1402 else ListClientWidth := FListBox.ClientWidth;
1403 X := FPoint.X;
1404 if (FListBox.FCheckBoxes) then
1405 begin
1406 dec(ListClientWidth, CheckWidth);
1407 inc(X, CheckWidth);
1408 end;
1409 if AWidth > ListClientWidth then
1410 Inc(AWidth, 4)
1411 else
1412 AWidth := ListClientWidth;
1413 if SystemParametersInfo(SPI_GETWORKAREA, 0, @sr, 0) then
1414 begin
1415 if AWidth < (sr.Right - sr.Left) then
1416 begin
1417 if (X + AWidth) > sr.Right then
1418 X := sr.Right - AWidth;
1419 end
1420 else
1421 X := sr.Left;
1422 end;
1423 FShowing := True;
1424 if (GetCaptureControl = nil) and CatchMouse then FListBox.MouseCapture := True;
1425 SetWindowPos(Handle, HWND_TOP, X, FPoint.Y, AWidth, FListBox.ItemHeight,
1426 SWP_SHOWWINDOW or SWP_NOACTIVATE);
1427 Invalidate;
1428end;
1429
1430procedure TItemTip.Show(AListBox: TORListBox; AnItem: Integer; APoint: TPoint;
1431 CatchMouse: Boolean);
1432{ sets the canvas properties and window size and text depending on the item in the listbox }
1433begin
1434 if not AListBox.Visible then Exit; // added to support DropDown lists
1435 FListBox := AListBox;
1436 FListItem := AnItem;
1437 FPoint := APoint;
1438 FSelected := (FListBox.Perform(LB_GETSEL, FListItem, 0) > 0);
1439 UpdateText(CatchMouse);
1440end;
1441
1442type
1443 TORCBImgIdx = (iiUnchecked, iiChecked, iiGrayed, iiQMark, iiBlueQMark,
1444 iiDisUnchecked, iiDisChecked, iiDisGrayed, iiDisQMark,
1445 iiFlatUnChecked, iiFlatChecked, iiFlatGrayed,
1446 iiRadioUnchecked, iiRadioChecked, iiRadioDisUnchecked, iiRadioDisChecked);
1447
1448const
1449 CheckBoxImageResNames: array[TORCBImgIdx] of PChar = (
1450 'ORCB_UNCHECKED', 'ORCB_CHECKED', 'ORCB_GRAYED', 'ORCB_QUESTIONMARK',
1451 'ORCB_BLUEQUESTIONMARK', 'ORCB_DISABLED_UNCHECKED', 'ORCB_DISABLED_CHECKED',
1452 'ORCB_DISABLED_GRAYED', 'ORCB_DISABLED_QUESTIONMARK',
1453 'ORLB_FLAT_UNCHECKED', 'ORLB_FLAT_CHECKED', 'ORLB_FLAT_GRAYED',
1454 'ORCB_RADIO_UNCHECKED', 'ORCB_RADIO_CHECKED',
1455 'ORCB_RADIO_DISABLED_UNCHECKED', 'ORCB_RADIO_DISABLED_CHECKED');
1456
1457 BlackCheckBoxImageResNames: array[TORCBImgIdx] of PChar = (
1458 'BLACK_ORLB_FLAT_UNCHECKED', 'BLACK_ORLB_FLAT_CHECKED', 'BLACK_ORLB_FLAT_GRAYED',
1459 'BLACK_ORCB_QUESTIONMARK', 'BLACK_ORCB_BLUEQUESTIONMARK',
1460 'BLACK_ORCB_DISABLED_UNCHECKED', 'BLACK_ORCB_DISABLED_CHECKED',
1461 'BLACK_ORCB_DISABLED_GRAYED', 'BLACK_ORCB_DISABLED_QUESTIONMARK',
1462 'BLACK_ORLB_FLAT_UNCHECKED', 'BLACK_ORLB_FLAT_CHECKED', 'BLACK_ORLB_FLAT_GRAYED',
1463 'BLACK_ORCB_RADIO_UNCHECKED', 'BLACK_ORCB_RADIO_CHECKED',
1464 'BLACK_ORCB_RADIO_DISABLED_UNCHECKED', 'BLACK_ORCB_RADIO_DISABLED_CHECKED');
1465
1466var
1467 ORCBImages: array[TORCBImgIdx, Boolean] of TBitMap;
1468
1469function GetORCBBitmap(Idx: TORCBImgIdx; BlackMode: boolean): TBitmap;
1470var
1471 ResName: string;
1472begin
1473 if (not assigned(ORCBImages[Idx, BlackMode])) then
1474 begin
1475 ORCBImages[Idx, BlackMode] := TBitMap.Create;
1476 if BlackMode then
1477 ResName := BlackCheckBoxImageResNames[Idx]
1478 else
1479 ResName := CheckBoxImageResNames[Idx];
1480 ORCBImages[Idx, BlackMode].LoadFromResourceName(HInstance, ResName);
1481 end;
1482 Result := ORCBImages[Idx, BlackMode];
1483end;
1484
1485procedure DestroyORCBBitmaps; far;
1486var
1487 i: TORCBImgIdx;
1488 mode: boolean;
1489
1490begin
1491 for i := low(TORCBImgIdx) to high(TORCBImgIdx) do
1492 begin
1493 for Mode := false to true do
1494 begin
1495 if (assigned(ORCBImages[i, Mode])) then
1496 ORCBImages[i, Mode].Free;
1497 end;
1498 end;
1499end;
1500
1501{ TORStrings }
1502
1503function TORStrings.Add(const S: string): integer;
1504var
1505 RealVerification: Boolean;
1506begin
1507 RealVerification := Verification;
1508 Verification := False; //Disable verification while lists are not matched
1509 result := FPlainText.Add(Translator(S));
1510 Verification := RealVerification;
1511 MList.Insert(result, S); //Don't need to here because MList never gets custom handlers
1512end;
1513
1514procedure TORStrings.Clear;
1515var
1516 RealVerification: Boolean;
1517begin
1518 Verify;
1519 MList.Clear;
1520 RealVerification := Verification;
1521 Verification := False;
1522 FPlainText.Clear;
1523 Verification := RealVerification;
1524end;
1525
1526constructor TORStrings.Create(PlainText: TStrings; Translator: TTranslator);
1527begin
1528 MList := TStringList.Create;
1529 FPlainText := PlainText;
1530 FTranslator := Translator;
1531 FVerification := False;
1532end;
1533
1534procedure TORStrings.Delete(index: integer);
1535var
1536 RealVerification: Boolean;
1537begin
1538 Verify;
1539 MList.Delete(index);
1540 RealVerification := Verification;
1541 Verification := False;
1542 FPlainText.Delete(index);
1543 Verification := RealVerification;
1544end;
1545
1546destructor TORStrings.Destroy;
1547begin
1548 MList.Free;
1549 inherited;
1550end;
1551
1552function TORStrings.Get(index: integer): string;
1553begin
1554 Verify;
1555 result := MList[index];
1556end;
1557
1558function TORStrings.GetCount: integer;
1559begin
1560 Verify;
1561 result := MList.Count;
1562end;
1563
1564function TORStrings.GetObject(index: integer): TObject;
1565begin
1566 Verify;
1567 result := FPlainText.Objects[index];
1568end;
1569
1570function TORStrings.IndexOf(const S: string): Integer;
1571begin
1572 Verify;
1573 Result := FPlainText.IndexOf(S);
1574end;
1575
1576procedure TORStrings.Insert(Index: Integer; const S: string);
1577var
1578 RealVerification: Boolean;
1579begin
1580 Verify;
1581 MList.Insert(index, S);
1582 RealVerification := Verification;
1583 Verification := False;
1584 FPlainText.Insert(index, Translator(S));
1585 Verification := RealVerification;
1586end;
1587
1588
1589procedure TORStrings.Put(Index: Integer; const S: string);
1590var
1591 RealVerification: Boolean;
1592begin //If this method weren't overridden, the listbox would forget which item was selected.
1593 MList[Index] := S;
1594 RealVerification := Verification;
1595 Verification := False; //Disable verification while lists are not matched
1596 FPlainText[Index] := Translator(S);
1597 Verification := RealVerification;
1598end;
1599
1600procedure TORStrings.PutObject(index: integer; Value: TObject);
1601begin
1602 FPlainText.Objects[index] := Value;
1603end;
1604
1605procedure TORStrings.SetUpdateState(Value: boolean);
1606begin
1607 if Value then
1608 FPlainText.BeginUpdate
1609 else
1610 FPlainText.EndUpdate;
1611end;
1612
1613procedure TORStrings.Verify;
1614var
1615 Errors: TStringList;
1616 i: integer;
1617 M: string;
1618 Plain: string;
1619 TotalCount: integer;
1620begin
1621 if Verification then begin
1622 if not Assigned(FPlainText) then
1623 raise Exception.Create('ORStrings is missing PlainText property.');
1624 if not Assigned(FTranslator) then
1625 raise Exception.Create('ORStrings is missing Translator property.');
1626 Errors := TStringList.Create;
1627 try
1628 TotalCount := MList.Count;
1629 if MList.Count <> PlainText.Count then begin
1630 Errors.Add('M string count:' + IntToStr(MList.Count));
1631 Errors.Add('Plain string count:' + IntToStr(PlainText.Count));
1632 if PlainText.Count > TotalCount then
1633 TotalCount := PlainText.Count;
1634 end;
1635 for i := 0 to TotalCount - 1 do begin
1636 if i >= MList.Count then
1637 Errors.Add('PlainText[' + IntToStr(i) + ']: ' + PlainText[i])
1638 else if i >= PlainText.Count then
1639 Errors.Add('ORStrings[' + IntToStr(i) + ']: ' + Translator(MList[i]))
1640 else begin
1641 M := Translator(MList[i]);
1642 Plain := PlainText[i];
1643 if M <> Plain then begin
1644 if UpperCase(M) = UpperCase(Plain) then //Listboxes don't always sort cases right, so we give them a little help here.
1645 begin
1646 PlainText[i] := M;
1647 end
1648 else
1649 begin
1650 Errors.Add('PlainText[' + IntToStr(i) + ']: ' + Plain);
1651 Errors.Add('ORStrings[' + IntToStr(i) + ']: ' + M);
1652 end;
1653 end;
1654 end;
1655 end;
1656 if Errors.Count > 0 then begin
1657 Errors.Insert(0, 'OR strings are out of sync with plain text strings :');
1658 raise Exception.Create(Errors.Text);
1659 end;
1660 finally
1661 Errors.Free;
1662 end;
1663 end;
1664end;
1665
1666{ TORListBox ------------------------------------------------------------------------------- }
1667
1668constructor TORListBox.Create(AOwner: TComponent);
1669{ sets initial values for fields used by added properties (ItemTip, Reference, Tab, LongList) }
1670begin
1671 inherited Create(AOwner);
1672 AddItemTipRef; // kcm
1673 FTipItem := -1;
1674 FItemTipColor := clWindow;
1675 FItemTipEnable := True;
1676 FLastItemIndex := -1;
1677 FFromSelf := False;
1678 FDelimiter := '^';
1679 FWhiteSpace := ' ';
1680 FLongList := False;
1681 FFromNeedData := False;
1682 FFirstLoad := True;
1683 FCurrentTop := -1;
1684 FFocusIndex := -1;
1685 ShowHint := True;
1686 FHideSynonyms := FALSE;
1687 FSynonymChars := '<>';
1688 FTabPosInPixels := False;
1689 FRightClickSelect := FALSE;
1690 FCheckBoxes := FALSE;
1691 FFlatCheckBoxes := TRUE;
1692 FCaseChanged := TRUE;
1693 FLookupPiece := 0;
1694 FIsPartOfComboBox := False;
1695end;
1696
1697destructor TORListBox.Destroy;
1698{ ensures that the special records associated with each listbox item are disposed }
1699begin
1700 FMItems.Free;
1701 if uItemTip <> nil then uItemTip.Hide;
1702 DestroyItems;
1703 RemoveItemTipRef; //kcm
1704 inherited Destroy;
1705end;
1706
1707procedure TORListBox.CreateParams(var Params: TCreateParams);
1708{ ensures that the listbox can support tab stops }
1709begin
1710 inherited CreateParams(Params);
1711 with Params do Style := Style or LBS_USETABSTOPS;
1712end;
1713
1714procedure TORListBox.CreateWnd;
1715{ makes sure that actual (rather than 'intercepted') values are restored from FSaveItems
1716 (FSaveItems is part of TCustomListBox), necessary if window is recreated by property change
1717 also gets the first bolus of data in the case of a LongList }
1718var
1719 RealVerification: Boolean;
1720begin
1721 FFromSelf := True;
1722 RealVerification := True;
1723 if Assigned(FMItems) then
1724 begin
1725 RealVerification := FMItems.Verification;
1726 FMItems.Verification := False;
1727 end;
1728 inherited CreateWnd;
1729 if Assigned(FMItems) then
1730 begin
1731 FMItems.Verification := RealVerification;
1732 FMItems.Verify;
1733 end;
1734 FFromSelf := False;
1735 if FTabPos[0] > 0 then SetTabStops;
1736end;
1737
1738procedure TORListBox.Loaded;
1739{ after the properties are loaded, get the first data bolus for a LongList }
1740begin
1741 inherited;
1742 if FLongList then FWaterMark := Items.Count;
1743 SetTabStops;
1744end;
1745
1746procedure TORListBox.DestroyWnd;
1747{ makes sure that actual (rather than 'intercepted') values are saved to FSaveItems
1748 (FSaveItems is part of TCustomListBox), necessary if window is recreated by property change }
1749begin
1750 FFromSelf := True;
1751 inherited DestroyWnd;
1752 FFromSelf := False;
1753end;
1754
1755function TORListBox.TextToShow(S: string): string;
1756{ returns the text that will be displayed based on the Pieces and TabPosition properties }
1757var
1758 i: Integer;
1759begin
1760 if FPieces[0] > 0 then
1761 begin
1762 Result := '';
1763 for i := 1 to FPieces[0] do
1764 Result := Result + Piece(S, FDelimiter, FPieces[i]) + FWhiteSpace;
1765 Result := TrimRight(Result);
1766 end
1767 else
1768 begin
1769 SetString(Result, PChar(S), Length(S));
1770 end;
1771end;
1772
1773function TORListBox.IsSynonym(const TestStr: string): boolean;
1774var
1775 i, cnt, len: integer;
1776
1777begin
1778 Result := FALSE;
1779 if ((FHideSynonyms) and (FSynonymChars <> '')) then
1780 begin
1781 len := length(FSynonymChars);
1782 cnt := 0;
1783 for i := 1 to len do
1784 if (pos(FSynonymChars[i], TestStr) > 0) then inc(cnt);
1785 if (cnt = len) then Result := TRUE;
1786 if assigned(FOnSynonymCheck) then
1787 FOnSynonymCheck(Self, TestStr, Result);
1788 end;
1789end;
1790
1791function TORListBox.GetDisplayText(Index: Integer): string;
1792{ get the item string actually displayed by the listbox rather than what is in Items[n] }
1793var
1794 Len: Integer;
1795 Buf: array[0..4095] of Char;
1796begin
1797 Result := '';
1798 FFromSelf := True;
1799 Len := SendMessage(Handle, LB_GETTEXT, Index, Integer(@Buf));
1800 FFromSelf := False;
1801 if Len > 0 then
1802 begin
1803 SetString(Result, Buf, Len);
1804 end;
1805end;
1806
1807function TORListBox.GetDynamicProperty(PropertyID: integer): string;
1808begin
1809 if PropertyID = DynaPropAccesibilityCaption then
1810 Result := GetCaption
1811 else
1812 Result := '';
1813end;
1814
1815// The following 7 message handling procedures essentially reimplement the TListBoxStrings
1816// object found in StdCtrls. They do this by intercepting the messages sent by the
1817// TListBoxStrings object and modifying the contents of WParam, LParam, and Result.
1818// This allows TORListBox to use the ItemData pointer that is part of each listbox item
1819// to store its own information yet let the application still use the Objects property
1820// of standard Delphi listboxes. It also makes it possible to implement the Pieces and
1821// TabPosition properties without forcing the listbox to be owner drawn.
1822
1823procedure TORListBox.LBGetItemData(var Message: TMessage);
1824{ intercept LB_GETITEMDATA and repoint to UserObject rather than internal value in ItemData }
1825var
1826 ItemRec: PItemRec;
1827begin
1828 inherited;
1829 if not FFromSelf then with Message do
1830 begin
1831 ItemRec := PItemRec(Result);
1832 if (assigned(ItemRec)) then
1833 Result := Integer(ItemRec^.UserObject)
1834 else
1835 Result := 0;
1836 end;
1837end;
1838
1839procedure TORListBox.LBSetItemData(var Message: TMessage);
1840{ intercept LB_SETITEMDATA as save object in UserObject since ItemData is used interally }
1841var
1842 ItemRec: PItemRec;
1843begin
1844 if not FFromSelf then with Message do
1845 begin
1846 FFromSelf := True;
1847 ItemRec := PItemRec(SendMessage(Handle, LB_GETITEMDATA, WParam, 0)); // WParam: list index
1848 FFromSelf := False;
1849 if (assigned(ItemRec)) then
1850 ItemRec^.UserObject := TObject(LParam);
1851 LParam := Integer(ItemRec);
1852 if uItemTip.FShowing and (uItemTip.FListBox = Self) and (uItemTip.FListItem = WParam) then
1853 uItemTip.UpdateText(FALSE);
1854 end;
1855 inherited;
1856end;
1857
1858procedure TORListBox.LBGetText(var Message: TMessage);
1859{ intercept LB_GETTEXT and repoint to full item string rather than what's visible in listbox }
1860var
1861 ItemRec: PItemRec;
1862 Text: string;
1863begin
1864 inherited;
1865 if (not FFromSelf) and (Message.Result <> LB_ERR) then with Message do
1866 begin
1867 FFromSelf := True;
1868 ItemRec := PItemRec(SendMessage(Handle, LB_GETITEMDATA, WParam, 0)); // WParam: list index
1869 FFromSelf := False;
1870 if (assigned(ItemRec)) then
1871 begin
1872 FFromSelf := True;
1873 Text := TListBox(self).Items[WParam];
1874 StrCopy(PChar(LParam), PChar(Text)); // LParam: points string buffer
1875 Result := Length(Text); // Result: length of string
1876 FFromSelf := False;
1877 end
1878 else
1879 begin
1880 StrPCopy(PChar(LParam), '');
1881 Result := 0;
1882 end;
1883 end;
1884end;
1885
1886procedure TORListBox.LBGetTextLen(var Message: TMessage);
1887{ intercept LB_GETTEXTLEN and return true length of ItemRec^.FullText }
1888{ -- in response to HOU-0299-70576, Thanks to Stephen Kirby for this fix! }
1889var
1890 ItemRec: PItemRec;
1891begin
1892 inherited;
1893 if (not FFromSelf) and (Message.Result <> LB_ERR) then with Message do
1894 begin
1895 FFromSelf := True;
1896 ItemRec := PItemRec(SendMessage(Handle, LB_GETITEMDATA, WParam, 0));
1897 if (assigned(ItemRec)) then
1898 Result := Length(TListBox(self).Items[WParam]) // Result:length of string
1899 else
1900 Result := 0;
1901 FFromSelf := False;
1902 end;
1903end;
1904
1905procedure TORListBox.LBAddString(var Message: TMessage);
1906{ intercept LB_ADDSTRING and save full string in separate record. Then rebuild a string that
1907 has what's visible (based on Pieces, TabPosition properties) and substitute that in LParam }
1908var
1909 ItemRec: PItemRec;
1910begin
1911 if not FFromSelf then
1912 begin
1913 if FLongList then // -- special long list processing - begin
1914 begin
1915 if FFromNeedData then FDataAdded := True else with Message do
1916 begin
1917 WParam := FWaterMark;
1918 Result := Perform(LB_INSERTSTRING, WParam, LParam); // always insert into short list
1919 Exit;
1920 end;
1921 end; // -- special long list processing - end
1922 New(ItemRec);
1923 with ItemRec^, Message do
1924 begin
1925 UserObject := nil;
1926 CheckedState := cbUnchecked;
1927 FCreatingText := PChar(LParam);
1928 end;
1929 FCreatingItem := TRUE;
1930 inherited;
1931 FCreatingItem := FALSE;
1932 // insert into list AFTER calling inherited in case the listbox is sorted
1933 DoChange;
1934 with Message do if Result <> LB_ERR then
1935 begin
1936 FFromSelf := True;
1937 SendMessage(Handle, LB_SETITEMDATA, Result, Integer(ItemRec)); // Result: new item index
1938 FFromSelf := False;
1939 end
1940 else Dispose(ItemRec);
1941 end
1942 else inherited;
1943end;
1944
1945procedure TORListBox.LBInsertString(var Message: TMessage);
1946{ intercepts LB_INSERTSTRING, similar to LBAddString except for special long list processing }
1947var
1948 ItemRec: PItemRec;
1949begin
1950 if not FFromSelf then
1951 begin
1952 if FLongList then // -- special long list processing - begin
1953 begin
1954 if FFromNeedData then
1955 begin
1956 FDataAdded := True;
1957 Inc(FCurrentTop);
1958 end
1959 else with Message do
1960 begin
1961 if WParam > FWaterMark then
1962 begin // make sure insert above watermark
1963 FMItems.MList.Move(WParam, FWaterMark);
1964 WParam := FWaterMark;
1965 end;
1966 Inc(FWaterMark);
1967 end;
1968 end; // -- special long list processing - end
1969 New(ItemRec);
1970 with ItemRec^, Message do
1971 begin
1972 UserObject := nil;
1973 CheckedState := cbUnchecked;
1974 FCreatingText := PChar(LParam);
1975 end;
1976 FCreatingItem := TRUE;
1977 inherited;
1978 FCreatingItem := FALSE;
1979 DoChange;
1980 with Message do if Result <> LB_ERR then
1981 begin
1982 FFromSelf := True;
1983 SendMessage(Handle, LB_SETITEMDATA, Result, Integer(ItemRec)); // Result: new item index
1984 FFromSelf := False;
1985 end
1986 else Dispose(ItemRec);
1987 end
1988 else inherited;
1989end;
1990
1991procedure TORListBox.LBDeleteString(var Message: TMessage);
1992{ intercept LB_DELETESTRING and dispose the record associated with the item being deleted }
1993var
1994 ItemRec: PItemRec;
1995begin
1996 with Message do
1997 begin
1998 FFromSelf := True;
1999 ItemRec := PItemRec(SendMessage(Handle, LB_GETITEMDATA, WParam, 0)); // WParam: list index
2000 FFromSelf := False;
2001 if (assigned(ItemRec)) then
2002 begin
2003 if FLongList and not FFromNeedData then
2004 Dec(FWaterMark);
2005 Dispose(ItemRec);
2006 end;
2007 end;
2008 FFromSelf := True; // FFromSelf is set here because, under NT, LBResetContent is called
2009 inherited; // when deleting the last string from the listbox. Since ItemRec is
2010 FFromSelf := False; // already disposed, it shouldn't be disposed again.
2011 DoChange;
2012end;
2013
2014procedure TORListBox.LBResetContent(var Message: TMessage);
2015{ intercept LB_RESETCONTENT (list is being cleared) and dispose all records }
2016var
2017 ItemCount, i: Integer;
2018 ItemRec: PItemRec;
2019begin
2020 if not FFromSelf then
2021 begin
2022 ItemCount := Perform(LB_GETCOUNT, 0, 0);
2023 for i := 0 to ItemCount - 1 do
2024 begin
2025 FFromSelf := True;
2026 ItemRec := PItemRec(SendMessage(Handle, LB_GETITEMDATA, i, 0));
2027 FFromSelf := False;
2028 Dispose(ItemRec);
2029 end;
2030 Perform(LB_SETCOUNT, 0, 0);
2031 end;
2032 // This was casuing pain for ResetItems when FWaterMark was being cleared for short lists
2033 if FLongList then
2034 FWaterMark := 0;
2035 inherited;
2036end;
2037
2038procedure TORListBox.LBSetCurSel(var Message: TMessage);
2039{ call DoChange, which calls OnChange event whenever ItemIndex changes }
2040begin
2041 inherited;
2042 DoChange;
2043end;
2044
2045procedure TORListBox.CMFontChanged(var Message: TMessage);
2046{ make sure itemtip and tabs respond to characteristics of the new font }
2047begin
2048 inherited;
2049 FLargeChange := (Height div ItemHeight) - 1;
2050 SetTabStops;
2051end;
2052
2053procedure TORListBox.WMKeyDown(var Message: TWMKeyDown);
2054{ intercept the keydown messages so that the listbox can be navigated by using the arrow
2055 keys and shifting the focus rectangle rather than generating Click for each keypress }
2056var
2057 IsSelected: LongBool;
2058begin
2059 //if Message.CharCode in [VK_RETURN, VK_ESCAPE] then inherited; // ignore other keys
2060 case Message.CharCode of
2061 VK_LBUTTON, VK_RETURN, VK_SPACE:
2062 begin
2063 if (FocusIndex < 0) and (CheckBoxes or MultiSelect) and (Count > 0) then // JNM - 508 compliance
2064 SetFocusIndex(0);
2065 if FocusIndex > -1 then
2066 begin
2067 if MultiSelect then
2068 begin
2069 IsSelected := LongBool(Perform(LB_GETSEL, FocusIndex, 0));
2070 Perform(LB_SETSEL, Longint(not IsSelected), FocusIndex);
2071 end
2072 else Perform(LB_SETCURSEL, FocusIndex, 0);
2073 // Send WM_COMMAND here because LBN_SELCHANGE not triggered by LB_SETSEL
2074 // and LBN_SELCHANGE is what eventually triggers the Click event.
2075 // The LBN_SELCHANGE documentation implies we should send the control id, which is
2076 // 32 bits long, in the high word of WPARAM (16 bits). Since that won't work - we'll
2077 // try sending the item index instead.
2078 //PostMessage() not SendMessage() is Required here for checkboxes, SendMessage() doesn't
2079 //Allow the Checkbox state on the control to be updated
2080 if CheckBoxes then
2081 PostMessage(Parent.Handle, WM_COMMAND, MAKELONG(FocusIndex, LBN_SELCHANGE), LPARAM(Handle))
2082 else
2083 SendMessage(Parent.Handle, WM_COMMAND, MAKELONG(FocusIndex, LBN_SELCHANGE), LPARAM(Handle));
2084 end;
2085 end;
2086 VK_PRIOR: SetFocusIndex(FocusIndex - FLargeChange);
2087 VK_NEXT: SetFocusIndex(FocusIndex + FLargeChange);
2088 VK_END: SetFocusIndex(SFI_END);
2089 VK_HOME: SetFocusIndex(SFI_TOP);
2090 VK_LEFT, VK_UP: SetFocusIndex(FocusIndex - 1);
2091 VK_RIGHT, VK_DOWN: SetFocusIndex(FocusIndex + 1);
2092 else inherited;
2093 end;
2094 Message.Result := 0;
2095end;
2096
2097procedure TORListBox.WMLButtonDown(var Message: TWMLButtonDown);
2098{ work around for a very ugly problem when the listbox is used with a dropdown combobox
2099 when the listbox is used this way (parent=desktop) the click events seem to be ignored }
2100var
2101 AnItem: Integer;
2102 ScrollRect, ListRect: TRect;
2103 ScreenPoint: TSmallPoint;
2104 TmpRect: TRect;
2105begin
2106 if FParentCombo <> nil then with Message do
2107 begin
2108 FDontClose := FALSE;
2109 ListRect := ClientRect; //+
2110 if FLongList then ListRect.Right := ListRect.Left + ClientWidthOfList(Self); //+
2111 // if the mouse was clicked in the client area set ItemIndex ourselves
2112 if PtInRect(ListRect, Point(XPos, YPos)) then //~
2113 begin
2114 AnItem := GetIndexFromY(YPos);
2115 if AnItem < Items.Count then ItemIndex := AnItem;
2116 FParentCombo.FwdClick(FParentCombo);
2117 FDontClose := TRUE;
2118 end;
2119 // if the mouse was clicked on the scrollbar, send a message to make the scrolling happen
2120 // this is done with WM_NCLBUTTONDOWN, which is ignored if mousecapture is on, so we have
2121 // to turn mousecapture off, then back on since it's needed to hide the listbox
2122 with ListRect do ScrollRect := Rect(Right + 1, Top, Self.Width - 2, Bottom); //~
2123 if {(Items.Count > (FLargeChange + 1)) and} PtInRect(ScrollRect, Point(XPos, YPos)) then //~
2124 begin
2125 if FLongList then // for long lists
2126 begin
2127 ScreenPoint := PointToSmallPoint(FScrollBar.ScreenToClient(
2128 Self.ClientToScreen(Point(XPos, YPos))));
2129 MouseCapture := False;
2130 SendMessage(FScrollBar.Handle, WM_LBUTTONDOWN, Message.Keys,
2131 MakeLParam(ScreenPoint.X, ScreenPoint.Y));
2132 MouseCapture := True;
2133 end else // for normal lists
2134 begin
2135 ScreenPoint := PointToSmallPoint(Self.ClientToScreen(Point(XPos, YPos)));
2136 MouseCapture := False;
2137 SendMessage(Self.Handle, WM_NCLBUTTONDOWN, HTVSCROLL,
2138 MakeLParam(ScreenPoint.X, ScreenPoint.Y));
2139 MouseCapture := True;
2140 end;
2141 end
2142 else
2143 if (FCheckBoxes) then
2144 begin
2145 TmpRect := ListRect;
2146 TmpRect.Top := TmpRect.Bottom;
2147 TmpRect.Right := TmpRect.Left + Width;
2148 inc(TmpRect.Bottom, CheckComboBtnHeight);
2149 if PtInRect(TmpRect, Point(XPos, YPos)) then
2150 begin
2151 inc(TmpRect.Left, (TmpRect.right - TmpRect.Left) div 2);
2152 FParentCombo.DropPanelBtnPressed(XPos <= TmpRect.Left, FALSE);
2153 end;
2154 end;
2155 end;
2156 inherited;
2157end;
2158
2159procedure TORListBox.WMLButtonUp(var Message: TWMLButtonUp);
2160{ If the listbox is being used with a dropdown combo, hide the listbox whenever something is
2161 clicked. The mouse is captured at this point - this isn't called if clicking scrollbar. }
2162begin
2163 if (FParentCombo <> nil) and ((not FDontClose) or (not FCheckBoxes)) then FParentCombo.DroppedDown := False;
2164 FDontClose := FALSE;
2165 inherited;
2166end;
2167
2168procedure TORListBox.WMRButtonUp(var Message: TWMRButtonUp);
2169{ When the RightClickSelect property is true, this routine is used to select an item }
2170var
2171 AnItem: Integer;
2172 ListRect: TRect;
2173
2174begin
2175 if (FRightClickSelect and (FParentCombo = nil)) then with Message do // List Boxes only, not Combo Boxes
2176 begin
2177 ListRect := ClientRect; //+
2178 if FLongList then ListRect.Right := ListRect.Left + ClientWidthOfList(Self); //+
2179 // if the mouse was clicked in the client area set ItemIndex ourselves
2180 if PtInRect(ListRect, Point(XPos, YPos)) then //~
2181 begin
2182 AnItem := GetIndexFromY(YPos);
2183 if AnItem >= Items.Count then AnItem := -1;
2184 end
2185 else
2186 AnItem := -1;
2187 ItemIndex := AnItem;
2188 end;
2189 inherited;
2190end;
2191
2192procedure TORListBox.WMLButtonDblClk(var Message: TWMLButtonDblClk);
2193{ treat a doubleclick in the scroll region as if it were a single click - see WMLButtonDown }
2194var
2195 ScrollRect: TRect;
2196 ScreenPoint: TSmallPoint;
2197begin
2198 if FParentCombo <> nil then with Message do
2199 begin
2200 if (FCheckBoxes) then FDontClose := TRUE;
2201 // if the mouse was clicked on the scrollbar, send a message to make the scrolling happen
2202 // this is done with WM_NCLBUTTONDOWN, which is ignored if mousecapture is on, so we have
2203 // to turn mousecapture off, then back on since it's needed to hide the listbox
2204 with ClientRect do ScrollRect := Rect(Right + 1, Top, Self.Width - 2, Bottom);
2205 if (Items.Count > (FLargeChange + 1)) and PtInRect(ScrollRect, Point(XPos, YPos)) then
2206 begin
2207 if FLongList then // for long lists
2208 begin
2209 ScreenPoint := PointToSmallPoint(FScrollBar.ScreenToClient(
2210 Self.ClientToScreen(Point(XPos, YPos))));
2211 MouseCapture := False;
2212 SendMessage(FScrollBar.Handle, WM_LBUTTONDOWN, Message.Keys,
2213 MakeLParam(ScreenPoint.X, ScreenPoint.Y));
2214 MouseCapture := True;
2215 end else // for normal lists
2216 begin
2217 ScreenPoint := PointToSmallPoint(Self.ClientToScreen(Point(XPos, YPos)));
2218 MouseCapture := False;
2219 SendMessage(Self.Handle, WM_NCLBUTTONDOWN, HTVSCROLL,
2220 MakeLParam(ScreenPoint.X, ScreenPoint.Y));
2221 MouseCapture := True;
2222 end; {if FLongList}
2223 end; {if (Items.Count)}
2224 end; {if FParentCombo}
2225 inherited;
2226end;
2227
2228procedure TORListBox.WMCancelMode(var Message: TMessage);
2229{ This message is sent when focus shifts to another window - need to hide the listbox at this
2230 point if it is being used with a dropdown combobox. }
2231begin
2232 uItemTip.Hide;
2233 if FParentCombo <> nil then FParentCombo.DroppedDown := False;
2234 inherited;
2235end;
2236
2237procedure TORListBox.WMMove(var Message: TWMMove);
2238{ whenever in LongList mode we need to move the scrollbar along with the listbox }
2239begin
2240 inherited;
2241 if FScrollBar <> nil then AdjustScrollBar;
2242end;
2243
2244procedure TORListBox.WMSize(var Message: TWMSize);
2245{ calculate the number of visible items in the listbox whenever it is resized
2246 if in LongList mode, size the scrollbar to match the listbox }
2247begin
2248 inherited;
2249 FLargeChange := (Message.Height div ItemHeight) - 1;
2250 if FScrollBar <> nil then AdjustScrollBar;
2251end;
2252
2253procedure TORListBox.WMVScroll(var Message: TWMVScroll);
2254{ makes sure the itemtip is hidden whenever the listbox is scrolled }
2255// it would be better if this was done right away (before endscroll, but it seems to mess
2256// up mouse capture (SaveCaptureControl, HideItemTip, RestoreCaptureControl?)
2257begin
2258 inherited;
2259 if Message.ScrollCode = SB_ENDSCROLL then uItemTip.Hide;
2260end;
2261
2262procedure TORListBox.CMHintShow(var Message: TMessage);
2263{ if ShowHint is used to delay showing tip, starts showing ItemTip when hint timer expires }
2264var
2265 APoint: TPoint;
2266begin
2267 inherited;
2268 FItemTipActive := True;
2269 GetCursorPos(APoint);
2270 APoint := ScreenToClient(APoint);
2271 MouseMove([], APoint.X, APoint.Y); // assume nothing in ShiftState for now
2272end;
2273
2274procedure TORListBox.Click;
2275begin
2276 inherited Click;
2277 DoChange;
2278end;
2279
2280procedure TORListBox.DoChange;
2281{ call the OnChange Event if ItemIndex is changed }
2282begin
2283 if ItemIndex <> FLastItemIndex then
2284 begin
2285 FLastItemIndex := ItemIndex;
2286 if (not isPartOfComboBox) and (ItemIndex <> -1) then
2287 SetFocusIndex(ItemIndex);
2288 if Assigned(FOnChange) then FOnChange(Self);
2289 end;
2290end;
2291
2292procedure TORListBox.DoEnter;
2293{ display the item tip window when the listbox gets keyboard focus - if itemtip enabled }
2294begin
2295 //if Items.Count > 0 then SetFocusIndex(TopIndex); // this seems to cause problems
2296 //Fix For ClearQuest: HDS00001576
2297 //This fix has been commented out, becuase it causes problems
2298{ if (Items.Count > 0) and (Not IsAMouseButtonDown()) and (ItemIndex = -1) then
2299 SetFocusIndex(TopIndex);//ItemIndex := TopIndex; }
2300 if FHideSelection and (ItemIndex < 0) and (FFocusIndex >= 0) then
2301 ItemIndex := FFocusIndex;
2302 inherited DoEnter;
2303end;
2304
2305procedure TORListBox.DoExit;
2306var
2307 SaveIndex: integer;
2308{ make sure item tip is hidden for this listbox when focus shifts to something else }
2309begin
2310 if FHideSelection then
2311 begin
2312 SaveIndex := ItemIndex;
2313 ItemIndex := -1;
2314 FFocusIndex := SaveIndex;
2315 end;
2316
2317 uItemTip.Hide;
2318 FItemTipActive := False;
2319 inherited DoExit;
2320end;
2321
2322procedure TORListBox.DestroyItems;
2323var
2324 ItemCount, i: Integer;
2325 ItemRec: PItemRec;
2326
2327begin
2328 if (not FItemsDestroyed) then
2329 begin
2330 ItemCount := Perform(LB_GETCOUNT, 0, 0);
2331 for i := 0 to ItemCount - 1 do
2332 begin
2333 FFromSelf := True;
2334 ItemRec := PItemRec(SendMessage(Handle, LB_GETITEMDATA, i, 0));
2335 FFromSelf := False;
2336 if Assigned(ItemRec) then
2337 Dispose(ItemRec);
2338 end;
2339 FItemsDestroyed := TRUE;
2340
2341 end;
2342end;
2343
2344procedure TORListBox.ToggleCheckBox(idx: integer);
2345var
2346 ItemRec: PItemRec;
2347 OldFromSelf: boolean;
2348 Rect: TRect;
2349
2350begin
2351 if (not FCheckBoxes) or (idx < 0) or (idx >= Items.Count) then exit;
2352 OldFromSelf := FFromSelf;
2353 FFromSelf := True;
2354 ItemRec := PItemRec(SendMessage(Handle, LB_GETITEMDATA, idx, 0));
2355 FFromSelf := OldFromSelf;
2356 if (assigned(ItemRec)) then
2357 begin
2358 if (FAllowGrayed) then
2359 begin
2360 case ItemRec^.CheckedState of
2361 cbUnchecked: ItemRec^.CheckedState := cbGrayed;
2362 cbGrayed: ItemRec^.CheckedState := cbChecked;
2363 cbChecked: ItemRec^.CheckedState := cbUnchecked;
2364 end;
2365 end
2366 else
2367 begin
2368 if (ItemRec^.CheckedState = cbUnchecked) then
2369 ItemRec^.CheckedState := cbChecked
2370 else
2371 ItemRec^.CheckedState := cbUnChecked;
2372 end;
2373 end;
2374 Rect := ItemRect(Idx);
2375 InvalidateRect(Handle, @Rect, FALSE);
2376 if (assigned(FOnClickCheck)) then
2377 FOnClickCheck(Self, idx);
2378 if (assigned(FParentCombo)) then
2379 FParentCombo.UpdateCheckEditBoxText;
2380end;
2381
2382procedure TORListBox.KeyPress(var Key: Char);
2383begin
2384 {inherited KeyPress is changing the ' ' into #0, had to move conditional before inherited.}
2385 if (Key = ' ') then begin
2386 ToggleCheckBox(ItemIndex);
2387 {The space bar causes the focus to jump to an item in the list that starts with
2388 a space. Disable that function.}
2389 Key := #0;
2390 end;
2391 inherited;
2392end;
2393
2394procedure TORListBox.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
2395{ hide the item tip window whenever an item is clicked - ignored if itemtip not enabled}
2396var
2397 idx: integer;
2398
2399begin
2400 uItemTip.Hide;
2401 inherited MouseDown(Button, Shift, X, Y);
2402 if (FCheckBoxes) and (X >= 0) and (X <= Width) and (Y >= 0) and (Y <= Height) then
2403 begin
2404 idx := GetIndexFromY(Y);
2405 if (idx >= 0) then
2406 begin
2407 if (FCheckEntireLine) then
2408 ToggleCheckBox(idx)
2409 else
2410 if (X < CheckWidth) then ToggleCheckBox(idx);
2411 end;
2412 end;
2413end;
2414
2415procedure TORListBox.SetHintProperties(Restore: Boolean; MainForm: TComponent);
2416var
2417 i, x: integer;
2418 Component: TComponent;
2419begin
2420 //Clear the array if we are not restoring it
2421 if not restore then SetLength(HintArray, 0);
2422
2423 //Loop through all the components on the form
2424 for i := 0 to TForm(MainForm).ComponentCount - 1 do begin
2425 Component := TForm(MainForm).Components[i];
2426 if (Component is TControl) then begin
2427 if not restore then begin
2428 //Increase our array and set our record
2429 SetLength(HintArray, Length(HintArray) + 1);
2430 HintArray[high(HintArray)].ObjectName := Component.Name;
2431 HintArray[high(HintArray)].ObjectHint := GetStrProp(Component, 'Hint');
2432 //Now clear out the component's hint
2433 SetStrProp(Component, 'Hint', '');
2434 end else begin
2435 //Loop through the array and find this component's hint
2436 for x := Low(HintArray) to High(HintArray) do begin
2437 if Component.Name = HintArray[x].ObjectName then begin
2438 //Once found reset the hint and break out of the loop
2439 SetStrProp(Component, 'Hint', HintArray[x].ObjectHint);
2440 break;
2441 end;
2442 end;
2443 end;
2444 end;
2445 end;
2446
2447 //Now deal with the form itself
2448 if not restore then begin
2449 //Increase our array and set our record
2450 SetLength(HintArray, Length(HintArray) + 1);
2451 HintArray[high(HintArray)].ObjectName := TForm(MainForm).Name;
2452 HintArray[high(HintArray)].ObjectHint := TForm(MainForm).Hint;
2453 //Now clear out the Forms's hint
2454 TForm(MainForm).Hint := '';
2455 end else begin
2456 //Loop through the array and find this Forms's hint
2457 for x := Low(HintArray) to High(HintArray) do begin
2458 if TForm(MainForm).Name = HintArray[x].ObjectName then begin
2459 //Once found reset the hint and break out of the loop
2460 TForm(MainForm).Hint := HintArray[x].ObjectHint;
2461 break;
2462 end;
2463 end;
2464 //Now clear the arrau since we are done using it
2465 SetLength(HintArray, 0);
2466 end;
2467end;
2468
2469procedure TORListBox.MouseMove(Shift: TShiftState; X, Y: Integer);
2470{ hide and show the appropriate item tip window as the mouse moves through the listbox }
2471const
2472 CATCH_MOUSE = True;
2473var
2474 AnItem: Integer;
2475 TrueOffset: integer;
2476 TipPos: TPoint;
2477begin
2478 inherited MouseMove(Shift, X, Y);
2479
2480 //If the drop down is visible and the hint hasn't been changed then clear the hint and save the original hint
2481 if assigned(FParentCombo) then begin
2482 //agp change
2483 //if (FParentCombo.FDropPanel.Visible) and (TForm(self.Owner.Owner).Hint <> '') then begin
2484 if (FParentCombo.FDropPanel.Visible) and ((GetParentForm(self) <> nil) and (Length(HintArray) = 0)) then begin
2485 SetHintProperties(False, GetParentForm(Self));
2486 end;
2487 end;
2488
2489
2490 if (not FItemTipEnable) or (not Application.Active) then Exit;
2491 { Make sure mouse really moved before continuing. For some reason, MouseMove gets called
2492 every time a navigation key is pressed. If FItemTipActive is true, mouse is pausing
2493 over the list.}
2494 if (not FItemTipActive) and (X = FLastMouseX) and (Y = FLastMouseY) then Exit;
2495 FLastMouseX := X;
2496 FLastMouseY := Y;
2497 // when captured mouse moving outside listbox
2498 if not PtInRect(ClientRect, Point(X, Y)) then
2499 begin
2500 If FParentCombo = nil then MouseCapture := False;
2501 uItemTip.Hide;
2502 FItemTipActive := False;
2503 FTipItem := -1;
2504 Exit;
2505 end;
2506 // borrow hint timer to delay first ItemTip
2507 if ShowHint and not FItemTipActive then Exit;
2508 // when mouse moving within listbox
2509 AnItem := GetIndexFromY(Y);
2510 TrueOffset := (Y div ItemHeight) + TopIndex;
2511 if AnItem <> FTipItem then
2512 begin
2513 if (AnItem < Items.Count) and ((TrueOffset - TopIndex + 1) * ItemHeight < Height) then
2514 begin
2515 TipPos := ClientToScreen(Point(0, (TrueOffset - TopIndex) * ItemHeight));
2516 uItemTip.Show(Self, AnItem, TipPos, CATCH_MOUSE);
2517 FTipItem := AnItem;
2518 end else
2519 begin
2520 uItemTip.Hide;
2521 FTipItem := -1;
2522 end;
2523 end;
2524end;
2525
2526procedure TORListBox.MeasureItem(Index: Integer; var Height: Integer);
2527var
2528 Txt: string;
2529
2530begin
2531 if (FHideSynonyms) and (fSynonymChars <> '') then
2532 begin
2533 if (FCreatingItem) then
2534 Txt := FCreatingText
2535 else
2536 Txt := Items[Index];
2537 if (IsSynonym(Txt)) then Height := 0;
2538 end;
2539 inherited MeasureItem(Index, Height);
2540end;
2541
2542procedure TORListBox.WMDestroy(var Message: TWMDestroy);
2543begin
2544 if (assigned(Owner)) and (csDestroying in Owner.ComponentState) then
2545 DestroyItems;
2546 inherited;
2547end;
2548
2549procedure TORListBox.CNDrawItem(var Message: TWMDrawItem);
2550begin
2551 if (FCheckBoxes) then
2552 with Message.DrawItemStruct^ do
2553 inc(rcItem.Left, CheckWidth);
2554 inherited;
2555end;
2556
2557procedure TORListBox.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);
2558var
2559 Flags: Longint;
2560 ItemRec: PItemRec;
2561 OldFromSelf: boolean;
2562 BMap: TBitMap;
2563 i, DY: integer;
2564 TmpR: TRect;
2565 Neg: boolean;
2566 ShowText: string;
2567begin
2568 if (assigned(FOnBeforeDraw)) then
2569 FOnBeforeDraw(Self, Index, Rect, State);
2570 if Assigned(OnDrawItem) then OnDrawItem(Self, Index, Rect, State)
2571 else
2572 begin
2573 Canvas.FillRect(Rect);
2574 if Index < Items.Count then
2575 begin
2576 Flags := DrawTextBiDiModeFlags(DT_SINGLELINE or DT_VCENTER);
2577 if not UseRightToLeftAlignment then
2578 Inc(Rect.Left, 2)
2579 else
2580 Dec(Rect.Right, 2);
2581 OldFromSelf := FFromSelf;
2582 FFromSelf := True;
2583 ItemRec := PItemRec(SendMessage(Handle, LB_GETITEMDATA, Index, 0)); // WParam: list index
2584 FFromSelf := OldFromSelf;
2585
2586 if (FCheckBoxes) then
2587 begin
2588 if (assigned(ItemRec)) then
2589 begin
2590 case ItemRec^.CheckedState of
2591 cbUnchecked:
2592 begin
2593 if (FFlatCheckBoxes) then
2594 BMap := GetORCBBitmap(iiFlatUnChecked, FBlackColorMode)
2595 else
2596 BMap := GetORCBBitmap(iiUnchecked, FBlackColorMode);
2597 end;
2598 cbChecked:
2599 begin
2600 if (FFlatCheckBoxes) then
2601 BMap := GetORCBBitmap(iiFlatChecked, FBlackColorMode)
2602 else
2603 BMap := GetORCBBitmap(iiChecked, FBlackColorMode);
2604 end;
2605 else // cbGrayed:
2606 begin
2607 if (FFlatCheckBoxes) then
2608 BMap := GetORCBBitmap(iiFlatGrayed, FBlackColorMode)
2609 else
2610 BMap := GetORCBBitmap(iiGrayed, FBlackColorMode);
2611 end;
2612 end;
2613 end
2614 else
2615 begin
2616 if (FFlatCheckBoxes) then
2617 BMap := GetORCBBitmap(iiFlatGrayed, FBlackColorMode)
2618 else
2619 BMap := GetORCBBitmap(iiGrayed, FBlackColorMode);
2620 end;
2621 TmpR := Rect;
2622 TmpR.Right := TmpR.Left;
2623 dec(TmpR.Left, CheckWidth + 1);
2624 DY := ((TmpR.Bottom - TmpR.Top) - BMap.Height) div 2;
2625 Canvas.Draw(TmpR.Left, TmpR.Top + DY, BMap);
2626 end;
2627
2628 if (FTabPos[0] > 0) then
2629 Flags := (FTabPos[1] * 256) or Flags or DT_TABSTOP or DT_EXPANDTABS;
2630
2631 ShowText := GetDisplayText(Index);
2632 if (Style <> lbStandard) and (FTabPos[0] > 0) then
2633 begin
2634 for i := 1 to FTabPix[0] do
2635 begin
2636 Neg := (FTabPix[i] < 0);
2637 if Neg then FTabPix[i] := -FTabPix[i];
2638 inc(FTabPix[i], Rect.Left - 1);
2639 if Neg then FTabPix[i] := -FTabPix[i];
2640 end;
2641 TabbedTextOut(Canvas.Handle, Rect.Left, Rect.Top + 1, PChar(ShowText), Length(ShowText),
2642 FTabPix[0], FTabPix[1], -1);
2643 for i := 1 to FTabPix[0] do
2644 begin
2645 Neg := (FTabPix[i] < 0);
2646 if Neg then FTabPix[i] := -FTabPix[i];
2647 dec(FTabPix[i], Rect.Left - 1);
2648 if Neg then FTabPix[i] := -FTabPix[i];
2649 end;
2650 end
2651 else
2652 DrawText(Canvas.Handle, PChar(ShowText), Length(ShowText), Rect, Flags);
2653 end;
2654 end;
2655end;
2656
2657function TORListBox.GetIndexFromY(YPos: integer): integer;
2658begin
2659 if (FHideSynonyms) then
2660 begin
2661 Result := TopIndex - 1;
2662 repeat
2663 inc(Result);
2664 if (Perform(LB_GETITEMHEIGHT, Result, 0) > 0) then
2665 dec(YPos, ItemHeight);
2666 until ((YPos < 0) or (Result >= Items.Count));
2667 end
2668 else
2669 Result := (YPos div ItemHeight) + TopIndex;
2670end;
2671
2672procedure TORListBox.SetFocusIndex(Value: Integer);
2673{ move the focus rectangle to an item and show the item tip window if enabled
2674 in the case of a LongList, scroll the list so that new items are loaded appropriately }
2675const
2676 CATCH_MOUSE = True;
2677 NO_CATCH_MOUSE = False;
2678var
2679 ScrollCount, ScrollPos, InitialTop, i: Integer;
2680begin
2681 if FLongList then // -- special long list processing - begin
2682 begin
2683 if (Value = SFI_TOP) or (Value = SFI_END) then // scroll to top or bottom
2684 begin
2685 if Value = SFI_TOP then ScrollPos := 0 else ScrollPos := 100;
2686 ScrollTo(Self, scPosition, ScrollPos); // ScrollTo is scrollbar event
2687 FScrollBar.Position := ScrollPos;
2688 if ScrollPos = 0 then Value := FFocusIndex else Value := FFocusIndex + FLargeChange;
2689 end else
2690 begin
2691 InitialTop := TopIndex;
2692 ScrollCount := Value - InitialTop;
2693 ScrollPos := 50; // arbitrary, can be anything from 1-99
2694 if ScrollCount < 0 then // scroll backwards
2695 begin
2696 if ScrollCount = -FLargeChange then ScrollTo(Self, scPageUp, ScrollPos) else
2697 for i := 1 to Abs(ScrollCount) do ScrollTo(Self, scLineUp, ScrollPos);
2698 FScrollBar.Position := ScrollPos;
2699 Value := Value + (FCurrentTop - InitialTop);
2700 end;
2701 if ScrollCount > FLargeChange then // scroll forwards
2702 begin
2703 if ScrollCount = (FLargeChange * 2) then ScrollTo(Self, scPageDown, ScrollPos) else
2704 for i := FLargeChange + 1 to ScrollCount do ScrollTo(Self, scLineDown, ScrollPos);
2705 FScrollBar.Position := ScrollPos;
2706 end;
2707 if (FHideSynonyms) then
2708 begin
2709 while ((Perform(LB_GETITEMHEIGHT, Value, 0) = 0) and (Value >= 0) and (value < Items.Count)) do
2710 begin
2711 if (Value < FFocusIndex) then
2712 dec(Value)
2713 else
2714 inc(Value);
2715 end;
2716 end;
2717 end;
2718 end; // -- special long list processing - end
2719 if (Value = SFI_END) or (not (Value < Items.Count)) then Value := Items.Count - 1;
2720 if (Value = SFI_TOP) or (Value < 0) then Value := 0;
2721 FFocusIndex := Value;
2722 if Focused or (not FHideSelection) then
2723 ItemIndex := Value;
2724 if MultiSelect then Perform(LB_SETCARETINDEX, FFocusIndex, 0) // LPARAM=0, scrolls into view
2725 else
2726 begin
2727 // LB_SETCARETINDEX doesn't scroll with single select so we have to do it ourselves
2728 // ( a LongList should always come through here - it should never be MultiSelect )
2729 if FocusIndex < TopIndex
2730 then TopIndex := FocusIndex
2731 else if FocusIndex > (TopIndex + FLargeChange)
2732 then TopIndex := HigherOf(FocusIndex - FLargeChange, 0);
2733 end;
2734 // need to have a way to move the focus rectangle for single select listboxs w/o itemtips
2735 // if FItemTipEnable or not MultiSelect then ... Show: if not ItemTipEnable then AWidth := 0?
2736 //
2737 // can't show the item tip from keyboard input for dropdown combo without causing problems
2738 // with mouse capture, post the message to allow the selected attribute to be posted
2739 if FItemTipEnable {and (FParentCombo = nil)}
2740 then PostMessage(Self.Handle, UM_SHOWTIP, Value, 0);
2741end;
2742
2743procedure TORListBox.UMShowTip(var Message: TMessage);
2744{ show item tip, Tip Position in parameters: wParam=X and lParam=Y }
2745const
2746 NO_CATCH_MOUSE = False;
2747var
2748 TipPos: TPoint;
2749 TrueOffset: integer;
2750 TmpIdx: integer;
2751begin
2752 // if listbox is dropdown combo but control is not focused -
2753 if (Parent is TORComboBox) and (FParentCombo <> nil) and (Screen.ActiveControl <> Parent)
2754 then Exit;
2755 // if listbox is dropdown combo and list is not dropped down -
2756 if (FParentCombo <> nil) and (FParentCombo.DroppedDown = False) then Exit;
2757 // if control is not focused -
2758 if (Screen.ActiveControl <> Self) and (Screen.ActiveControl <> Parent) then Exit;
2759 if (FHideSynonyms) then
2760 begin
2761 TrueOffset := TopIndex;
2762 TmpIdx := TopIndex;
2763 while ((TmpIdx < Message.wParam) and (TmpIdx < Items.Count)) do
2764 begin
2765 if (Perform(LB_GETITEMHEIGHT, TmpIdx, 0) > 0) then
2766 inc(TrueOffset);
2767 inc(TmpIdx);
2768 end;
2769 end
2770 else
2771 TrueOffset := Message.wParam;
2772 TipPos := ClientToScreen(Point(0, (TrueOffset - TopIndex) * ItemHeight));
2773 //uItemTip.Show(Self, FFocusIndex, TipPos, NO_CATCH_MOUSE);
2774 uItemTip.Show(Self, FFocusIndex, TipPos, FParentCombo = nil); // if DropDown, no mousecapture
2775end;
2776
2777function TORListBox.GetIEN(AnIndex: Integer): Int64;
2778{ return as an integer the first piece of the Item identified by AnIndex }
2779begin
2780 if (AnIndex < Items.Count) and (AnIndex > -1)
2781 then Result := StrToInt64Def(Piece(Items[AnIndex], FDelimiter, 1), 0)
2782 else Result := 0;
2783end;
2784
2785function TORListBox.GetItemIEN: Int64;
2786{ return as an integer the first piece of the currently selected item }
2787begin
2788 if ItemIndex > -1
2789 then Result := StrToInt64Def(Piece(Items[ItemIndex], FDelimiter, 1), 0)
2790 else Result := 0;
2791end;
2792
2793function TORListBox.SelectByIEN(AnIEN: Int64): Integer;
2794{ cause the item where the first piece = AnIEN to be selected (sets ItemIndex) }
2795var
2796 i: Integer;
2797begin
2798 Result := -1;
2799 for i := 0 to Items.Count - 1 do
2800 if GetIEN(i) = AnIEN then
2801 begin
2802 ItemIndex := i;
2803 Result := i;
2804 break;
2805 end;
2806end;
2807
2808function TORListBox.SetExactByIEN(AnIEN: Int64; const AnItem: string): Integer;
2809{ finds an exact entry (matches IEN) in a list or a long list and returns ItemIndex }
2810var
2811 ItemFound: Boolean;
2812 i, ListEnd: Integer;
2813begin
2814 ItemFound := False;
2815 Result := -1;
2816 if FLongList then ListEnd := FWaterMark - 1 else ListEnd := Items.Count - 1;
2817 for i := 0 to ListEnd do if (GetIEN(i) = AnIEN) and (GetDisplayText(i) = AnItem) then
2818 begin
2819 ItemIndex := i;
2820 Result := i;
2821 ItemFound := True;
2822 break;
2823 end;
2824 if FLongList and not ItemFound then
2825 begin
2826 InitLongList(AnItem);
2827 Result := SelectByIEN(AnIEN);
2828 end;
2829end;
2830
2831function TORListBox.GetItemID: Variant;
2832{ return as a variant the first piece of the currently selected item }
2833begin
2834 if ItemIndex > -1 then Result := Piece(Items[ItemIndex], FDelimiter, 1) else Result := '';
2835end;
2836
2837function TORListBox.SelectByID(const AnID: string): Integer;
2838{ cause the item where the first piece = AnID to be selected (sets ItemIndex) }
2839var
2840 i: Integer;
2841begin
2842 Result := -1;
2843 for i := 0 to Items.Count - 1 do
2844 if Piece(Items[i], FDelimiter, 1) = AnID then
2845 begin
2846 ItemIndex := i;
2847 Result := i;
2848 break;
2849 end;
2850end;
2851
2852function TORListBox.GetReference(Index: Integer): Variant;
2853{ retrieves a variant value that is associated with an item in a listbox }
2854var
2855 ItemRec: PItemRec;
2856begin
2857 if (Index < 0) or (Index >= Items.Count) then
2858 raise Exception.Create('List Index Out of Bounds');
2859 FFromSelf := True;
2860 ItemRec := PItemRec(SendMessage(Handle, LB_GETITEMDATA, Index, 0));
2861 FFromSelf := False;
2862 if (assigned(ItemRec)) then
2863 Result := ItemRec^.Reference
2864 else
2865 Result := Null;
2866end;
2867
2868procedure TORListBox.SetReference(Index: Integer; AReference: Variant);
2869{ stores a variant value that is associated with an item in a listbox }
2870var
2871 ItemRec: PItemRec;
2872begin
2873 if (Index < 0) or (Index >= Items.Count) then
2874 raise Exception.Create('List Index Out of Bounds');
2875 FFromSelf := True;
2876 ItemRec := PItemRec(SendMessage(Handle, LB_GETITEMDATA, Index, 0));
2877 FFromSelf := False;
2878 if (assigned(ItemRec)) then
2879 ItemRec^.Reference := AReference;
2880end;
2881
2882function TORListBox.AddReference(const S: string; AReference: Variant): Integer;
2883{ adds a string to a listbox, along with a variant value to be associated with the string }
2884begin
2885 Result := Items.Add(S);
2886 SetReference(Result, AReference);
2887end;
2888
2889procedure TORListBox.InsertReference(Index: Integer; const S: string; AReference: Variant);
2890{ inserts a string at a position into a listbox, along with its associated variant value }
2891begin
2892 Items.Insert(Index, S);
2893 SetReference(Index, AReference);
2894end;
2895
2896function TORListBox.IndexOfReference(AReference: Variant): Integer;
2897{ looks through the list of References (variants) and returns the index of the first match }
2898var
2899 i: Integer;
2900begin
2901 Result := -1;
2902 for i := 0 to Items.Count - 1 do
2903 if GetReference(i) = AReference then
2904 begin
2905 Result := i;
2906 Break;
2907 end;
2908end;
2909
2910function TORListBox.GetTabPositions: string;
2911{ returns the character based tab stops that are currently set, if any }
2912begin
2913 if (FTabPosInPixels) then
2914 Result := IntArrayToString(FTabPix)
2915 else
2916 Result := IntArrayToString(FTabPos);
2917end;
2918
2919procedure TORListBox.SetTabPositions(const Value: string);
2920{ converts a string of character position tab stops to an array of integer & sets now tabs }
2921var
2922 TabTmp: array[0..MAX_TABS] of Integer;
2923 i: Integer;
2924begin
2925 StringToIntArray(Value, TabTmp, TRUE);
2926 for i := 2 to TabTmp[0] do
2927 if (abs(TabTmp[i]) < abs(TabTmp[i - 1])) or
2928 (TabTmp[i] = TabTmp[i - 1]) then
2929 raise Exception.Create('Tab positions must be in ascending order');
2930 if (FTabPosInPixels) then
2931 begin
2932 for i := 0 to TabTmp[0] do FTabPix[i] := TabTmp[i];
2933 end
2934 else
2935 begin
2936 for i := 0 to TabTmp[0] do FTabPos[i] := TabTmp[i];
2937 end;
2938 SetTabStops;
2939 if FTabPos[0] > 0 then FWhiteSpace := #9 else FWhiteSpace := ' ';
2940 ResetItems;
2941end;
2942
2943procedure TORListBox.SetTabPosInPixels(const Value: boolean);
2944begin
2945 if (FTabPosInPixels <> Value) then
2946 begin
2947 FTabPosInPixels := Value;
2948 SetTabStops;
2949 end;
2950end;
2951
2952procedure TORListBox.SetTabStops;
2953{ sets new tabs stops based on dialog units, FTabPix array also used by ItemTip }
2954var
2955 TabDlg: array[0..MAX_TABS] of Integer;
2956 i, AveWidth: Integer;
2957begin
2958 FillChar(TabDlg, SizeOf(TabDlg), 0);
2959 AveWidth := FontWidthPixel(Self.Font.Handle);
2960 if (FTabPosInPixels) then
2961 begin
2962 FillChar(FTabPos, SizeOf(FTabPos), 0);
2963 FTabPos[0] := FTabPix[0];
2964 for i := 1 to FTabPix[0] do
2965 begin
2966 FTabPos[i] := FTabPix[i] div AveWidth;
2967 TabDlg[i] := (FTabPix[i] * 4) div AveWidth;
2968 end;
2969 end
2970 else
2971 begin
2972 FillChar(FTabPix, SizeOf(FTabPix), 0);
2973 FTabPix[0] := FTabPos[0];
2974 for i := 1 to FTabPos[0] do
2975 begin
2976 // do dialog units first so that pixels gets the same rounding error
2977 TabDlg[i] := FTabPos[i] * 4; // 4 dialog units per character
2978 FTabPix[i] := (TabDlg[i] * AveWidth) div 4;
2979 end;
2980 end;
2981 TabDlg[0] := FTabPos[0];
2982 Perform(LB_SETTABSTOPS, TabDlg[0], Integer(@TabDlg[1]));
2983 Refresh;
2984end;
2985
2986function TORListBox.SupportsDynamicProperty(PropertyID: integer): boolean;
2987begin
2988 Result := (PropertyID = DynaPropAccesibilityCaption);
2989end;
2990
2991procedure TORListBox.SetHideSynonyms(Value: boolean);
2992var
2993 TmpIH: integer;
2994
2995begin
2996 if (FHideSynonyms <> Value) then
2997 begin
2998 if ((Value) and (not FLongList)) then
2999 raise Exception.Create('Hide Synonyms only allowed on Long Lists');
3000 FHideSynonyms := Value;
3001 if (not FHideSynonyms) then
3002 begin
3003 Style := lbStandard;
3004 end
3005 else
3006 begin
3007 if (FSynonymChars = '') then
3008 FSynonymChars := '<>';
3009 TmpIH := ItemHeight;
3010 Style := lbOwnerDrawVariable;
3011 ItemHeight := TmpIH;
3012 end;
3013 end;
3014end;
3015
3016procedure TORListBox.SetSynonymChars(Value: string);
3017begin
3018 if (FSynonymChars <> Value) then
3019 begin
3020 FSynonymChars := Value;
3021 if ((Value = '') and (FHideSynonyms)) then
3022 SetHideSynonyms(FALSE);
3023 if (FHideSynonyms) then
3024 begin
3025 SetHideSynonyms(FALSE);
3026 SetHideSynonyms(TRUE);
3027 end;
3028 end;
3029end;
3030
3031function TORListBox.GetStyle: TListBoxStyle;
3032begin
3033 Result := inherited Style;
3034end;
3035
3036procedure TORListBox.SetStyle(Value: TListBoxStyle);
3037begin
3038 if (Value <> lbOwnerDrawVariable) and (FHideSynonyms) then
3039 FHideSynonyms := FALSE;
3040 if (FCheckBoxes) and (Value = lbStandard) then
3041 FCheckBoxes := FALSE;
3042 inherited Style := Value;
3043end;
3044
3045procedure TORListBox.SetDelimiter(Value: Char);
3046{ change the delimiter used in conjunction with the pieces property (default = '^') }
3047begin
3048 FDelimiter := Value;
3049 ResetItems;
3050end;
3051
3052function TORListBox.GetPieces: string;
3053{ returns the pieces of an item currently selected for display }
3054begin
3055 Result := IntArrayToString(FPieces);
3056end;
3057
3058procedure TORListBox.SetPieces(const Value: string);
3059{ converts a string of comma-delimited integers into an array of string pieces to display }
3060begin
3061 StringToIntArray(Value, FPieces);
3062 ResetItems;
3063end;
3064
3065procedure TORListBox.ResetItems;
3066{ saves listbox objects then rebuilds listbox including references and user objects }
3067var
3068 SaveItems: TList;
3069 Strings: TStringList;
3070 i, Pos: Integer;
3071 ItemRec, ItemRec2: PItemRec;
3072 SaveListMode: Boolean;
3073 RealVerify: Boolean;
3074begin
3075 SaveListMode := False;
3076 Strings := nil;
3077 SaveItems := nil;
3078 RealVerify := TORStrings(Items).Verification;
3079 try
3080 TORStrings(Items).Verification := False;
3081 HandleNeeded; // ensures that Items is valid if in the middle of RecreateWnd
3082 SaveListMode := FLongList;
3083 Strings := TStringList.Create;
3084 SaveItems := TList.Create;
3085 FLongList := False; // so don't have to track WaterMark
3086 FFromSelf := True;
3087 for i := 0 to Items.Count - 1 do // put pointers to TItemRec in SaveItems
3088 begin
3089 ItemRec := PItemRec(SendMessage(Handle, LB_GETITEMDATA, i, 0));
3090 SaveItems.Add(ItemRec);
3091 end;
3092 Strings.Assign(Items);
3093 Items.Clear; // still FromSelf so don't dispose recs
3094 FFromSelf := False;
3095 for i := 0 to SaveItems.Count - 1 do // use saved ItemRecs to rebuild listbox
3096 begin
3097 ItemRec := SaveItems[i];
3098 if (assigned(ItemRec)) then
3099 begin
3100 Pos := Items.AddObject(Strings[i], ItemRec^.UserObject);
3101 // CQ 11491 - Changing TabPositions, etc. was wiping out check box status.
3102 FFromSelf := True;
3103 ItemRec2 := PItemRec(SendMessage(Handle, LB_GETITEMDATA, Pos, 0));
3104 FFromSelf := False;
3105 if (assigned(ItemRec2)) then
3106 begin
3107 ItemRec2^.Reference := ItemRec^.Reference;
3108 ItemRec2^.CheckedState := ItemRec^.CheckedState;
3109 end;
3110 end;
3111 end;
3112 finally
3113 SaveItems.Free;
3114 Strings.Free;
3115 TORStrings(Items).Verification := RealVerify;
3116 FLongList := SaveListMode;
3117 end;
3118end;
3119
3120procedure TORListBox.SetLongList(Value: Boolean);
3121{ changes the list box so that it runs in LongList mode (calls OnNeedData) }
3122begin
3123 if Value <> FLongList then
3124 begin
3125 if Value = True then
3126 CreateScrollBar
3127 else
3128 begin
3129 FreeScrollBar;
3130 if (FHideSynonyms) then
3131 SetHideSynonyms(FALSE);
3132 end;
3133 end;
3134end;
3135
3136procedure TORListBox.AdjustScrollBar;
3137{ ensures that the scrollbar used for a long list is placed properly within the listbox }
3138var
3139 L, T, W, H, OffsetLT, OffsetWH: Integer;
3140begin
3141 if uNewStyle then begin OffsetLT := 2; OffsetWH := 4; end // Win95
3142 else begin OffsetLT := 0; OffsetWH := 0; end; // Win3.1
3143 W := GetSystemMetrics(SM_CXVSCROLL);
3144 L := Left + Width - W - OffsetLT;
3145 T := Top + OffsetLT;
3146 H := Height - OffsetWH;
3147 FScrollBar.SetBounds(L, T, W, H);
3148 FScrollBar.Invalidate;
3149end;
3150
3151procedure TORListBox.CreateScrollBar;
3152{ a long list uses it's own scrollbar (mapped to APLHA_DISTRIBUTION, rather than the listbox's }
3153begin
3154 FLongList := True;
3155 if MultiSelect then MultiSelect := False; // LongLists do not support multiple selections
3156 FScrollBar := TScrollBar.Create(Self);
3157 FScrollBar.Kind := sbVertical;
3158 FScrollBar.TabStop := False;
3159 FScrollBar.ControlStyle := FScrollBar.ControlStyle - [csCaptureMouse];
3160 AdjustScrollBar;
3161 FScrollBar.OnScroll := ScrollTo;
3162 if FParentCombo = nil
3163 then FScrollBar.Parent := Parent
3164 else FScrollBar.Parent := FParentCombo.FDropPanel;
3165end;
3166
3167procedure TORListBox.FreeScrollBar;
3168{ frees the scrollbar for a longlist (called when LongList property becomes false) }
3169begin
3170 FLongList := False;
3171 FScrollBar.Free; // don't call from destroy because scrollbar may already be free
3172 FScrollBar := nil;
3173end;
3174
3175procedure TORListBox.ForDataUse(Strings: TStrings);
3176{ adds or inserts items into a list box after determining the proper collating sequence }
3177var
3178 Ascend: Boolean;
3179 FirstItem, LastItem: string;
3180 i: Integer;
3181begin
3182 if Strings.Count = 0 then Exit;
3183 { To prevent the problem where the initial list item(s) are returned repeatedly because the
3184 DisplayText is longer than the subscript in a cross-reference, compare the last item
3185 returned with the first item in the long list. If they are the same, assume the long
3186 list is already scrolled to the first item. }
3187 if (FDirection = LL_REVERSE) and (FWaterMark < Items.Count) and
3188 (CompareText(Strings[Strings.Count - 1], Items[FWaterMark]) = 0) then Exit;
3189
3190 FirstItem := TextToShow(Strings[0]);
3191 LastItem := TextToShow(Strings[Strings.Count - 1]);
3192 Ascend := True;
3193 case FDirection of
3194 LL_REVERSE: if CompareText(FirstItem, LastItem) < 0 then Ascend := False;
3195 LL_FORWARD: if CompareText(FirstItem, LastItem) > 0 then Ascend := False;
3196 end;
3197 case Ascend of // should call AddObject & InsertObject instead?
3198 False: case FDirection of
3199 LL_REVERSE: for i := Strings.Count - 1 downto 0 do Items.Insert(FInsertAt, Strings[i]);
3200 LL_FORWARD: for i := Strings.Count - 1 downto 0 do Items.Add(Strings[i]);
3201 end;
3202 True: case FDirection of
3203 LL_REVERSE: for i := 0 to Strings.Count - 1 do Items.Insert(FInsertAt, Strings[i]);
3204 LL_FORWARD: for i := 0 to Strings.Count - 1 do Items.Add(Strings[i]);
3205 end;
3206 end;
3207end;
3208
3209procedure TORListBox.InitLongList(S: string);
3210{ clears the listbox starting at FWaterMark and makes the initial NeedData call }
3211var
3212 index: integer;
3213begin
3214 if FLongList then
3215 begin
3216 if LookUpPiece <> 0 then
3217 begin
3218 index := GetStringIndex(S);
3219 if index > -1 then
3220 S := Piece(Items[index], Delimiter, LookUpPiece);
3221 end;
3222 if CaseChanged then
3223 S := UpperCase(S);
3224 // decrement last char & concat '~' for $ORDER
3225 if Length(S) > 0 then S := Copy(S, 1, Length(S) - 1) + Pred(S[Length(S)]) + '~';
3226 NeedData(LL_POSITION, S);
3227 if S = '' then TopIndex := 0 else TopIndex := FWaterMark;
3228 FScrollBar.Position := PositionThumb;
3229 end;
3230end;
3231
3232procedure TORListBox.InsertSeparator;
3233begin
3234 if FWaterMark > 0 then
3235 begin
3236 Items.Insert(FWaterMark, LLS_LINE);
3237 Items.Insert(FWaterMark, LLS_SPACE);
3238 end;
3239end;
3240
3241procedure TORListBox.ClearTop;
3242{ clears a long listbox up to FWaterMark (doesn't clear long list) }
3243var
3244 i: Integer;
3245begin
3246 SendMessage(Handle, WM_SETREDRAW, NOREDRAW, 0);
3247 for i := FWaterMark - 1 downto 0 do Items.Delete(i);
3248 SendMessage(Handle, WM_SETREDRAW, DOREDRAW, 0);
3249 Invalidate;
3250end;
3251
3252procedure TORListBox.NeedData(Direction: Integer; StartFrom: string);
3253{ called whenever the longlist needs more data inserted at a certain point into the listbox }
3254var
3255 CtrlPos, CharPos, index: Integer;
3256
3257 procedure ClearLong;
3258 { clears a portion or all of the longlist to conserve the memory it occupies }
3259 var
3260 i: Integer;
3261 begin
3262 case FDirection of
3263 LL_REVERSE: for i := Items.Count - 1 downto
3264 HigherOf(FCurrentTop + FLargeChange, FWaterMark) do Items.Delete(i);
3265 LL_POSITION: for i := Items.Count - 1 downto FWaterMark do Items.Delete(i);
3266 LL_FORWARD: for i := FCurrentTop - 1 downto FWaterMark do Items.Delete(i);
3267 end;
3268 end;
3269
3270begin {NeedData}
3271 FFromNeedData := True;
3272 FFirstLoad := False;
3273 FDataAdded := False;
3274 FDirection := Direction;
3275 SendMessage(Handle, WM_SETREDRAW, NOREDRAW, 0);
3276 if Items.Count > 1000 then ClearLong;
3277 case FDirection of
3278 LL_REVERSE: if FWaterMark < Items.Count then StartFrom := DisplayText[FWaterMark];
3279 LL_POSITION: begin
3280 ClearLong;
3281 if StartFrom = #127#127#127 then
3282 begin
3283 FDirection := LL_REVERSE;
3284 StartFrom := '';
3285 end
3286 else FDirection := LL_FORWARD;
3287 end;
3288 LL_FORWARD: if (FWaterMark < Items.Count) and (Items.Count > 0)
3289 then StartFrom := DisplayText[Items.Count - 1];
3290 end;
3291 if LookupPiece <> 0 then
3292 begin
3293 index := GetStringIndex(StartFrom);
3294 if index > -1 then
3295 StartFrom := Piece(Items[index], Delimiter, LookUpPiece);
3296 end;
3297 if CaseChanged then
3298 StartFrom := Uppercase(StartFrom);
3299 StartFrom := Copy(StartFrom, 1, 128); // limit length to 128 characters
3300 CtrlPos := 0; // make sure no ctrl characters
3301 for CharPos := 1 to Length(StartFrom) do if StartFrom[CharPos] in [#0..#31] then
3302 begin
3303 CtrlPos := CharPos;
3304 break;
3305 end;
3306 if CtrlPos > 0 then StartFrom := Copy(StartFrom, 1, CtrlPos - 1);
3307 if FDirection = LL_FORWARD then FInsertAt := Items.Count else FInsertAt := FWaterMark;
3308 if Assigned(FOnNeedData) then FOnNeedData(Self, copy(StartFrom, 1, MaxNeedDataLen), FDirection, FInsertAt);
3309 SendMessage(Handle, WM_SETREDRAW, DOREDRAW, 0);
3310 FFromNeedData := False;
3311 Invalidate;
3312end;
3313
3314function TORListBox.PositionThumb: Integer;
3315{ returns the proper thumb position for the TopIndex item relative to ALPHA_DISTRIBUTION }
3316var
3317 x: string;
3318begin
3319 Result := 1;
3320 x := DisplayText[TopIndex];
3321 if (FWaterMark > 0) and (TopIndex < FWaterMark)
3322 then Result := 0 // short list visible
3323 else while (CompareText(ALPHA_DISTRIBUTION[Result], x) < 0) and (Result < 100) do
3324 Inc(Result); // only long list visible
3325end;
3326
3327procedure TORListBox.ScrollTo(Sender: TObject; ScrollCode: TScrollCode; var ScrollPos: Integer);
3328{ event code for the longlist scrollbar, adjusts TopIndex & calls OnNeedData as necessary }
3329var
3330 Count, Goal, Dir: integer;
3331 Done: boolean;
3332 DropDownPanel: TORListBox;
3333begin
3334 If Length(HintArray) > 0 then begin
3335 DropDownPanel := TORListBox.Create(nil);
3336 try
3337 DropDownPanel.SetHintProperties(True, GetParentForm(Self));
3338 finally
3339 DropDownPanel.Free;
3340 end;
3341 end;
3342 uItemTip.Hide;
3343 FCurrentTop := TopIndex;
3344 if (ScrollCode = scPosition) then
3345 begin
3346 NeedData(LL_POSITION, ALPHA_DISTRIBUTION[ScrollPos]);
3347 case ScrollPos of
3348 0: TopIndex := 0;
3349 1..99: TopIndex := FWaterMark;
3350 100: TopIndex := HigherOf(Items.Count - FLargeChange, 0);
3351 end;
3352 FFocusIndex := TopIndex;
3353 end
3354 else
3355 if (HideSynonyms) then
3356 begin
3357 Count := 0;
3358 case ScrollCode of
3359 scLineUp: begin Dir := -1; Goal := 1; end;
3360 scLineDown: begin Dir := 1; Goal := 1; end;
3361 scPageUp: begin Dir := -1; Goal := FLargeChange; end;
3362 scPageDown: begin Dir := 1; Goal := FLargeChange; end;
3363 else
3364 exit;
3365 end;
3366 repeat
3367 Done := FALSE;
3368 if (Dir > 0) then
3369 begin
3370 if (FCurrentTop + (FLargeChange * 2)) > (Items.Count - 1) then
3371 NeedData(LL_FORWARD, '');
3372 if (FCurrentTop >= Items.Count - 1) then
3373 begin
3374 FCurrentTop := Items.Count - 1;
3375 Done := TRUE;
3376 end;
3377 end
3378 else
3379 begin
3380 if (FCurrentTop - FLargeChange) < FWaterMark then NeedData(LL_REVERSE, '');
3381 if (FCurrentTop <= 0) then
3382 begin
3383 FCurrentTop := 0;
3384 Done := TRUE;
3385 end;
3386 end;
3387 if (not Done) then
3388 begin
3389 FCurrentTop := FCurrentTop + Dir;
3390 if (Perform(LB_GETITEMHEIGHT, FCurrentTop, 0) > 0) then
3391 begin
3392 inc(Count);
3393 Done := (Count >= Goal);
3394 end;
3395 end;
3396 until Done;
3397 TopIndex := FCurrentTop;
3398 end
3399 else
3400 begin
3401 case ScrollCode of
3402 scLineUp: begin
3403 if (FCurrentTop - FLargeChange) < FWaterMark then NeedData(LL_REVERSE, '');
3404 TopIndex := HigherOf(FCurrentTop - 1, 0);
3405 end;
3406 scLineDown: begin
3407 if (FCurrentTop + (FLargeChange * 2)) > (Items.Count - 1)
3408 then NeedData(LL_FORWARD, '');
3409 TopIndex := LowerOf(FCurrentTop + 1, Items.Count - 1);
3410 end;
3411 scPageUp: begin
3412 if (FCurrentTop - FLargeChange) < FWaterMark then NeedData(LL_REVERSE, '');
3413 TopIndex := HigherOf(FCurrentTop - FLargeChange, 0);
3414 end;
3415 scPageDown: begin
3416 if (FCurrentTop + (FLargeChange * 2)) > (Items.Count - 1)
3417 then NeedData(LL_FORWARD, '');
3418 TopIndex := LowerOf(FCurrentTop + FLargeChange, Items.Count - 1);
3419 end;
3420 end;
3421 end;
3422 if (ScrollPos > 0) and (ScrollPos < 100) then ScrollPos := PositionThumb;
3423end;
3424
3425function TORListBox.GetStringIndex(const AString: string): Integer;
3426{returns the index of the first string that partially matches AString}
3427var
3428 i: Integer;
3429begin
3430 Result := -1;
3431 if Length(AString) > 0 then {*KCM*}
3432 begin
3433 if not FLongList then // Normal List
3434 begin
3435 Result := SendMessage(Handle, LB_FINDSTRING, -1, Longint(PChar(AString)));
3436 if Result = LB_ERR then Result := -1;
3437 end else // Long List
3438 begin
3439 if FScrollBar.Position = 0 then for i := 0 to FWatermark - 1 do
3440 begin
3441 if CompareText(AString, Copy(DisplayText[i], 1, Length(AString))) = 0 then
3442 begin
3443 Result := i;
3444 break;
3445 end;
3446 end;
3447 if Result < 0 then
3448 begin
3449 Result := SendMessage(Handle, LB_FINDSTRING, FWaterMark - 1, Longint(PChar(AString)));
3450 if Result < FWaterMark then Result := -1;
3451 end; {if Result}
3452 end; {if not FLongList}
3453 end; {if Length(AString)}
3454end;
3455
3456function TORListBox.SelectString(const AString: string): Integer;
3457{ causes the first string that partially matches AString to be selected & returns the index }
3458var
3459 x: string;
3460 i: Integer;
3461 index: integer;
3462begin
3463 Result := -1;
3464 if Length(AString) > 0 then {*KCM*}
3465 begin
3466 if not FLongList then // Normal List
3467 begin
3468 Result := SendMessage(Handle, LB_FINDSTRING, -1, Longint(PChar(AString)));
3469 if Result = LB_ERR then Result := -1;
3470 // use FFocusIndex instead of FocusIndex to reduce flashing
3471 FFocusIndex := Result;
3472 end else // Long List
3473 begin
3474 if FScrollBar.Position = 0 then for i := 0 to FWatermark - 1 do
3475 begin
3476 if CompareText(AString, Copy(DisplayText[i], 1, Length(AString))) = 0 then
3477 begin
3478 Result := i;
3479 break;
3480 end;
3481 end;
3482 if not StringBetween(AString, DisplayText[FWaterMark], DisplayText[Items.Count - 1]) then
3483 begin
3484 x := AString;
3485 if LookupPiece <> 0 then
3486 begin
3487 index := GetStringIndex(x);
3488 if index > -1 then
3489 x := Piece(Items[index], Delimiter, LookUpPiece);
3490 end;
3491 if CaseChanged then
3492 x := UpperCase(x);
3493 // decrement last char & concat '~' for $ORDER
3494 if Length(x) > 0 then x := Copy(x, 1, Length(x) - 1) + Pred(x[Length(x)]) + '~';
3495 NeedData(LL_POSITION, x);
3496 end;
3497 if Result < 0 then
3498 begin
3499 Result := SendMessage(Handle, LB_FINDSTRING, FWaterMark - 1, Longint(PChar(AString)));
3500 if Result < FWaterMark then Result := -1;
3501 if Result >= FWatermark then FocusIndex := Result;
3502 uItemTip.Hide;
3503 end; {if Result}
3504 end; {if not FLongList}
3505 end; {if Length(AString)}
3506 ItemIndex := Result;
3507 FFocusIndex := Result;
3508 if Result > -1 then TopIndex := Result; // will scroll item into view
3509 if FLongList then FScrollBar.Position := PositionThumb; // done after topindex set
3510end;
3511
3512procedure TORListBox.SetCheckBoxes(const Value: boolean);
3513begin
3514 if (FCheckBoxes <> Value) then
3515 begin
3516 FCheckBoxes := Value;
3517 if (Value) then
3518 begin
3519 if (GetStyle = lbStandard) then
3520 SetStyle(lbOwnerDrawFixed);
3521 if (inherited MultiSelect) then
3522 SetMultiSelect(FALSE);
3523 end;
3524 invalidate;
3525 end;
3526end;
3527
3528procedure TORListBox.SetFlatCheckBoxes(const Value: boolean);
3529begin
3530 if (FFlatCheckBoxes <> Value) then
3531 begin
3532 FFlatCheckBoxes := Value;
3533 invalidate;
3534 end;
3535end;
3536
3537function TORListBox.GetChecked(Index: Integer): Boolean;
3538var
3539 ItemRec: PItemRec;
3540
3541begin
3542 Result := False;
3543 if Index < 0 then exit;
3544 FFromSelf := True;
3545 ItemRec := PItemRec(SendMessage(Handle, LB_GETITEMDATA, Index, 0));
3546 FFromSelf := FALSE;
3547 if (assigned(ItemRec)) then
3548 Result := (ItemRec^.CheckedState = cbChecked)
3549 else
3550 Result := False;
3551end;
3552
3553procedure TORListBox.SetChecked(Index: Integer; const Value: Boolean);
3554var
3555 ItemRec: PItemRec;
3556 Rect: TRect;
3557
3558begin
3559 FFromSelf := True;
3560 ItemRec := PItemRec(SendMessage(Handle, LB_GETITEMDATA, Index, 0));
3561 FFromSelf := False;
3562 if (assigned(ItemRec)) and (Value <> (ItemRec^.CheckedState = cbChecked)) then
3563 begin
3564 if (Value) then
3565 ItemRec^.CheckedState := cbChecked
3566 else
3567 ItemRec^.CheckedState := cbUnChecked;
3568 Rect := ItemRect(Index);
3569 InvalidateRect(Handle, @Rect, FALSE);
3570 if (assigned(FOnClickCheck)) then
3571 FOnClickCheck(Self, Index);
3572 end;
3573end;
3574
3575function TORListBox.GetCheckedState(Index: Integer): TCheckBoxState;
3576var
3577 ItemRec: PItemRec;
3578
3579begin
3580 FFromSelf := True;
3581 ItemRec := PItemRec(SendMessage(Handle, LB_GETITEMDATA, Index, 0));
3582 FFromSelf := FALSE;
3583 if (assigned(ItemRec)) then
3584 Result := ItemRec^.CheckedState
3585 else
3586 Result := cbGrayed;
3587end;
3588
3589procedure TORListBox.SetCheckedState(Index: Integer;
3590 const Value: TCheckBoxState);
3591var
3592 ItemRec: PItemRec;
3593 Rect: TRect;
3594
3595begin
3596 FFromSelf := True;
3597 ItemRec := PItemRec(SendMessage(Handle, LB_GETITEMDATA, Index, 0));
3598 FFromSelf := False;
3599 if (assigned(ItemRec)) and (Value <> ItemRec^.CheckedState) then
3600 begin
3601 ItemRec^.CheckedState := Value;
3602 Rect := ItemRect(Index);
3603 InvalidateRect(Handle, @Rect, FALSE);
3604 if (assigned(FOnClickCheck)) then
3605 FOnClickCheck(Self, Index);
3606 end;
3607end;
3608
3609function TORListBox.GetMultiSelect: boolean;
3610begin
3611 result := inherited MultiSelect;
3612end;
3613
3614procedure TORListBox.SetMultiSelect(Value: boolean);
3615begin
3616 inherited SetMultiSelect(Value);
3617 if (Value) then SetCheckBoxes(FALSE);
3618end;
3619
3620function TORListBox.GetCheckedString: string;
3621var
3622 i: integer;
3623
3624begin
3625 Result := '';
3626 if (FCheckBoxes) then
3627 begin
3628 for i := 0 to Items.Count - 1 do
3629 Result := Result + Char(ord('0') + Ord(GetCheckedState(i)));
3630 end;
3631end;
3632
3633procedure TORListBox.SetCheckedString(const Value: string);
3634var
3635 i: integer;
3636
3637begin
3638 for i := 0 to Items.Count - 1 do
3639 SetCheckedState(i, TCheckBoxState(StrToIntDef(copy(Value, i + 1, 1), 0)));
3640end;
3641
3642function TORListBox.GetMItems: TStrings;
3643begin
3644 if not Assigned(FMItems) then
3645 FMItems := TORStrings.Create(Tlistbox(Self).Items, TextToShow);
3646 result := FMItems;
3647end;
3648
3649procedure TORListBox.SetMItems(Value: TStrings);
3650begin
3651 if not Assigned(FMItems) then
3652 FMItems := TORStrings.Create(Tlistbox(Self).Items, TextToShow);
3653 FMItems.Assign(Value);
3654end;
3655
3656procedure TORListBox.Clear;
3657begin
3658 Items.Clear;
3659 inherited;
3660end;
3661
3662procedure TORListBox.SetBlackColorMode(Value: boolean);
3663begin
3664 FBlackColorMode := Value;
3665end;
3666
3667procedure TORListBox.SetCaption(const Value: string);
3668begin
3669 if not Assigned(FCaption) then begin
3670 FCaption := TStaticText.Create(self);
3671 FCaption.AutoSize := False;
3672 FCaption.Height := 0;
3673 FCaption.Width := 0;
3674 FCaption.Visible := True;
3675 if Assigned(FParentCombo) then
3676 FCaption.Parent := FParentCombo
3677 else
3678 FCaption.Parent := Parent;
3679 FCaption.BringToFront;
3680 end;
3681 FCaption.Caption := Value;
3682end;
3683
3684function TORListBox.GetCaption: string;
3685begin
3686 result := FCaption.Caption;
3687end;
3688
3689// In Delphi 2006, hint windows will cause the TORComboBox drop down list to
3690// move behind a Stay on Top form. Hints are also problematic with item tips in
3691// the drop down list, so we disable them when ever a drop down list is open,
3692// on all forms, not just stay on top forms.
3693var
3694 uDropPanelOpenCount: integer = 0;
3695 uOldShowHintsSetting: boolean;
3696
3697procedure DropDownPanelOpened;
3698begin
3699 if uDropPanelOpenCount = 0 then
3700 uOldShowHintsSetting := Application.ShowHint;
3701 // Application.ShowHint := FALSE;
3702 inc(uDropPanelOpenCount);
3703end;
3704
3705procedure DropDownPanelClosed;
3706begin
3707 dec(uDropPanelOpenCount);
3708 if uDropPanelOpenCount <= 0 then
3709 begin
3710 uDropPanelOpenCount := 0;
3711 if not Application.ShowHint then
3712 // Application.ShowHint := uOldShowHintsSetting
3713 end;
3714end;
3715
3716{ TORDropPanel ----------------------------------------------------------------------------- }
3717const
3718 OKBtnTag = 1;
3719 CancelBtnTag = 2;
3720
3721procedure TORDropPanel.BtnClicked(Sender: TObject);
3722begin
3723 (Owner as TORComboBox).DropPanelBtnPressed((Sender as TSpeedButton).Tag = OKBtnTag, TRUE);
3724end;
3725
3726constructor TORDropPanel.Create(AOwner: TComponent);
3727{ Creates a panel the contains the listbox portion of a combobox when the combobox style is
3728 orcsDropDown. This is necessary for the combobox to scroll the list properly. The panel
3729 acts as the parent for the list, which recieves the scroll events. If the panel is not
3730 used, the scroll events to the the Desktop and are not received by the application }
3731begin
3732 inherited Create(AOwner);
3733 BevelInner := bvNone;
3734 BevelOuter := bvNone;
3735 BorderStyle := bsNone;
3736 Caption := '';
3737 Ctl3D := False;
3738 Visible := False;
3739 UpdateButtons;
3740end;
3741
3742procedure TORDropPanel.CreateParams(var Params: TCreateParams);
3743{ changes parent of panel to desktop so when list is dropped it can overlap other windows }
3744begin
3745 inherited CreateParams(Params);
3746 if not (csDesigning in ComponentState) then with Params do
3747 begin
3748 if uNewStyle then Params.ExStyle := Params.ExStyle or WS_EX_TOOLWINDOW;
3749 Params.ExStyle := Params.ExStyle or WS_EX_TOPMOST; // - incompatible with ItemTip
3750 WindowClass.Style := WindowClass.Style or CS_SAVEBITS;
3751 WndParent := GetDesktopWindow;
3752 end;
3753end;
3754
3755function TORDropPanel.GetButton(OKBtn: boolean): TSpeedButton;
3756var
3757 i: integer;
3758
3759begin
3760 Result := nil;
3761 if (FButtons) then
3762 begin
3763 for i := 0 to ControlCount - 1 do
3764 if (Controls[i] is TSpeedButton) then
3765 begin
3766 if ((OKBtn and ((Controls[i] as TSpeedButton).Tag = OKBtnTag)) or
3767 ((not OKBtn) and ((Controls[i] as TSpeedButton).Tag = CancelBtnTag))) then
3768 begin
3769 Result := TSpeedButton(Controls[i]);
3770 break;
3771 end;
3772 end;
3773 end;
3774end;
3775
3776procedure TORDropPanel.ResetButtons;
3777var
3778 sb: TSpeedButton;
3779
3780begin
3781 sb := GetButton(TRUE);
3782 if (assigned(sb)) then sb.Down := FALSE;
3783 sb := GetButton(FALSE);
3784 if (assigned(sb)) then sb.Down := FALSE;
3785end;
3786
3787procedure TORDropPanel.Resize;
3788var
3789 half: integer;
3790 btn: TSpeedButton;
3791
3792begin
3793 inherited;
3794 if (FButtons) then
3795 begin
3796 btn := GetButton(TRUE);
3797 if (assigned(btn)) then
3798 begin
3799 half := width div 2;
3800 btn.Left := 0;
3801 btn.Width := Half;
3802 btn.Top := Height - btn.Height;
3803 btn := GetButton(FALSE);
3804 btn.Left := Half;
3805 btn.Width := Width - Half;
3806 btn.Top := Height - btn.Height;
3807 end;
3808 end;
3809end;
3810
3811procedure TORDropPanel.UpdateButtons;
3812var
3813 btn: TSpeedButton;
3814 cbo: TORComboBox;
3815 i: integer;
3816
3817begin
3818 cbo := (Owner as TORComboBox);
3819 if (cbo.FListBox.FCheckBoxes) then
3820 begin
3821 if (not FButtons) then
3822 begin
3823 btn := TSpeedButton.Create(Self);
3824 btn.Parent := Self;
3825 btn.Caption := 'OK';
3826 btn.Height := CheckComboBtnHeight;
3827 btn.Tag := OKBtnTag;
3828 btn.AllowAllUp := TRUE;
3829 btn.GroupIndex := 1;
3830 btn.OnClick := BtnClicked;
3831 btn := TSpeedButton.Create(Self);
3832 btn.Parent := Self;
3833 btn.Caption := 'Cancel';
3834 btn.Height := CheckComboBtnHeight;
3835 btn.Tag := CancelBtnTag;
3836 btn.AllowAllUp := TRUE;
3837 btn.GroupIndex := 1;
3838 btn.OnClick := BtnClicked;
3839 FButtons := TRUE;
3840 Resize;
3841 end;
3842 end
3843 else
3844 if (FButtons) then
3845 begin
3846 for i := ControlCount - 1 downto 0 do
3847 if (Controls[i] is TButton) then
3848 Controls[i].Free;
3849 FButtons := FALSE;
3850 Resize;
3851 end;
3852end;
3853
3854procedure TORDropPanel.WMActivateApp(var Message: TMessage);
3855{ causes drop down list to be hidden when another application is activated (i.e., Alt-Tab) }
3856begin
3857 if BOOL(Message.wParam) = False then with Owner as TORComboBox do DroppedDown := False;
3858end;
3859
3860{ TORComboEdit ----------------------------------------------------------------------------- }
3861const
3862 ComboBoxImages: array[boolean] of string = ('BMP_CBODOWN_DISABLED', 'BMP_CBODOWN');
3863 BlackComboBoxImages: array[boolean] of string = ('BLACK_BMP_CBODOWN_DISABLED', 'BLACK_BMP_CBODOWN');
3864
3865procedure TORComboEdit.CreateParams(var Params: TCreateParams);
3866{ sets a one line edit box to multiline style so the editing rectangle can be changed }
3867begin
3868 inherited CreateParams(Params);
3869// JM - removed multi-line - broke lookup when MaxLength is set, besides, it didn't really
3870// seem to have an effect on the editing rectangle anyway.
3871// agp change cause tab characters to show on meds and lab order dialogs
3872// Params.Style := Params.Style {or ES_MULTILINE} or WS_CLIPCHILDREN;
3873 if TForm(self.Owner.Owner) <> nil then Params.Style := Params.Style or ES_MULTILINE or WS_CLIPCHILDREN
3874 else Params.Style := Params.Style {or ES_MULTILINE} or WS_CLIPCHILDREN;
3875
3876end;
3877
3878procedure TORComboEdit.WMKillFocus(var Message: TWMKillFocus);
3879begin
3880 inherited;
3881 with (Owner as TORComboBox) do
3882 begin
3883 if (FListBox.FCheckBoxes) and assigned(FEditPanel) and
3884 (Message.FocusedWnd <> FListBox.Handle) and
3885 ((not assigned(FDropBtn)) or (Message.FocusedWnd <> FDropBtn.Handle)) then
3886 begin
3887 FEditPanel.FFocused := FALSE;
3888 FEditPanel.Invalidate;
3889 end;
3890 end;
3891end;
3892
3893procedure TORComboEdit.WMSetFocus(var Message: TWMSetFocus);
3894begin
3895 inherited;
3896 with (Owner as TORComboBox) do
3897 begin
3898 if FListBox.FCheckBoxes and assigned(FEditPanel) then
3899 begin
3900 HideCaret(Self.Handle);
3901 FEditPanel.FFocused := TRUE;
3902 FEditPanel.Invalidate;
3903 end;
3904 end;
3905end;
3906
3907{ TORComboBox ------------------------------------------------------------------------------ }
3908
3909constructor TORComboBox.Create(AOwner: TComponent);
3910{ create the editbox and listbox used for the combobox - the default style is Simple }
3911begin
3912 inherited Create(AOwner);
3913 Width := 121;
3914 Height := 97;
3915 FLastInput := '';
3916 FDropDownCount := 8;
3917 FStyle := orcsSimple;
3918 FCheckBoxEditColor := clBtnFace;
3919 FListBox := TORListBox.Create(Self);
3920 FListBox.isPartOfComboBox := True;
3921 FListBox.Parent := Self;
3922 FListBox.TabStop := False;
3923 FListBox.OnClick := FwdClick;
3924 FListBox.OnDblClick := FwdDblClick;
3925 FListBox.OnMouseUp := FwdMouseUp;
3926 FListBox.OnNeedData := FwdNeedData;
3927 FListBox.OnClickCheck := CheckBoxSelected;
3928 FListBox.Visible := True;
3929 FItems := FListBox.Items;
3930 FMItems := FListBox.MItems;
3931 FEditBox := TORComboEdit.Create(Self);
3932 FEditBox.Parent := Self;
3933 FEditBox.OnChange := FwdChange;
3934 FEditBox.OnKeyDown := FwdKeyDown;
3935 FEditBox.OnKeyPress := FwdKeyPress;
3936 FEditBox.OnKeyUp := FwdKeyUp;
3937 FEditBox.Visible := True;
3938 fCharsNeedMatch := 1;
3939end;
3940
3941procedure TORComboBox.WMDestroy(var Message: TWMDestroy);
3942begin
3943 if (assigned(Owner)) and (csDestroying in Owner.ComponentState) then
3944 FListBox.DestroyItems;
3945 inherited;
3946end;
3947
3948procedure TORComboBox.CMFontChanged(var Message: TMessage);
3949{ resize the edit portion of the combobox to match the font }
3950begin
3951 inherited;
3952 AdjustSizeOfSelf;
3953end;
3954
3955procedure TORComboBox.WMMove(var Message: TWMMove);
3956{ for DropDown style, need to hide listbox whenever control moves (since listbox isn't child) }
3957begin
3958 inherited;
3959 DroppedDown := False;
3960end;
3961
3962procedure TORComboBox.WMSize(var Message: TWMSize);
3963{ whenever control is resized, adjust the components (edit, list, button) within it }
3964begin
3965 inherited;
3966 AdjustSizeOfSelf;
3967end;
3968
3969procedure TORComboBox.WMTimer(var Message: TWMTimer);
3970begin
3971 inherited;
3972 if (Message.TimerID = KEY_TIMER_ID) then
3973 begin
3974 StopKeyTimer;
3975 if FListBox.LongList and FChangePending then FwdChangeDelayed;
3976 if Assigned(FOnKeyPause) then FOnKeyPause(Self);
3977 end;
3978end;
3979
3980function TORComboBox.EditControl: TWinControl;
3981begin
3982 if (assigned(FEditPanel)) then
3983 Result := FEditPanel
3984 else
3985 Result := FEditBox;
3986end;
3987
3988procedure TORComboBox.AdjustSizeOfSelf;
3989{ adjusts the components of the combobox to fit within the control boundaries }
3990var
3991 FontHeight: Integer;
3992 cboBtnX, cboBtnY: integer;
3993 cboYMargin: integer;
3994
3995begin
3996 DroppedDown := False;
3997 FontHeight := FontHeightPixel(Self.Font.Handle);
3998 if FTemplateField then
3999 begin
4000 cboYMargin := 0;
4001 cboBtnX := 1;
4002 cboBtnY := 1;
4003 end
4004 else
4005 begin
4006 cboYMargin := CBO_CYMARGIN;
4007 cboBtnX := CBO_CXFRAME;
4008 cboBtnY := CBO_CXFRAME;
4009 end;
4010 Height := HigherOf(FontHeight + cboYMargin, Height); // must be at least as high as text
4011 EditControl.SetBounds(0, 0, Width, FontHeight + cboYMargin);
4012 if (assigned(FEditPanel)) then
4013 FEditBox.SetBounds(2, 3, FEditPanel.Width - 4, FEditPanel.Height - 5);
4014 if FStyle = orcsDropDown then
4015 begin
4016 Height := FontHeight + cboYMargin; // DropDown can only be text height
4017 FDropBtn.SetBounds(EditControl.Width - CBO_CXBTN - cboBtnX, 0,
4018 CBO_CXBTN, EditControl.Height - cboBtnY);
4019 end else
4020 begin
4021 FListBox.SetBounds(0, FontHeight + CBO_CYMARGIN,
4022 Width, Height - FontHeight - CBO_CYMARGIN);
4023 end;
4024 SetEditRect;
4025end;
4026
4027procedure TORComboBox.DropButtonDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState;
4028 X, Y: Integer);
4029{ display the listbox for a DropDown style combobox whenever the drop down button is pressed }
4030begin
4031 if (Button = mbLeft) then
4032 begin
4033 FFromDropBtn := True;
4034 DroppedDown := not FDroppedDown;
4035 FFromDropBtn := False;
4036 end;
4037end;
4038
4039procedure TORComboBox.DropButtonUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState;
4040 X, Y: Integer);
4041{ shift the focus back to the editbox so the focus rectangle doesn't clutter the button }
4042begin
4043 if FDroppedDown then FListBox.MouseCapture := True; // do here so 1st buttonup not captured
4044 FEditBox.SetFocus;
4045end;
4046
4047procedure TORComboBox.DropDownStatusChanged(opened: boolean);
4048var
4049 DropDownPanel: TORListBox;
4050begin
4051 DropDownPanel := TORListBox.Create(nil);
4052 try
4053 if opened then
4054 begin
4055 if not FDropPanel.Visible then
4056 begin
4057 if FDropDownStatusChangedCount = 0 then
4058 begin
4059 FDisableHints := TRUE;
4060 DropDownPanelOpened;
4061 end;
4062 inc(FDropDownStatusChangedCount);
4063 end;
4064 end
4065 else
4066 begin
4067 dec(FDropDownStatusChangedCount);
4068 if FDropDownStatusChangedCount <= 0 then
4069 begin
4070 //agp change
4071 //if FDisableHints then
4072 if (FDisableHints) and (Self.Owner <> nil) then
4073 begin
4074 DropDownPanelClosed;
4075 FDisableHints := FALSE;
4076 If (GetParentForm(Self) <> nil) then
4077 DropDownPanel.SetHintProperties(True, GetParentForm(Self));
4078 end;
4079 FDropDownStatusChangedCount := 0;
4080 end;
4081 end;
4082 finally
4083 DropDownPanel.Free;
4084 end;
4085end;
4086
4087procedure TORComboBox.ClearDropDownStatus;
4088begin
4089 FDropDownStatusChangedCount := 1;
4090 DropDownStatusChanged(FALSE);
4091end;
4092
4093destructor TORComboBox.Destroy;
4094begin
4095 ClearDropDownStatus;
4096 inherited;
4097end;
4098
4099procedure TORComboBox.DoEnter;
4100{var
4101 key : word;}
4102{ select all the text in the editbox when recieve focus - done first so OnEnter can deselect }
4103begin
4104 //FEditBox.SelectAll;
4105 //Fix For ClearQuest: HDS00001576
4106 //This fix has been commented out, becuase it causes problems
4107{ with FListBox do
4108 if (Items.Count > 0) and (Not IsAMouseButtonDown()) and (ItemIndex = -1) then
4109 begin
4110 key := VK_UP;
4111 FwdKeyDown(Self,key,[]);
4112 //Calling keyUp after key down creates a better mimic of a Keystroke.
4113 FwdKeyUp(Self,key,[]); //fixes clearquest: HDS00001418
4114 end; }
4115 inherited DoEnter;
4116 PostMessage(Handle, UM_GOTFOCUS, 0, 0)
4117end;
4118
4119procedure TORComboBox.UMGotFocus(var Message: TMessage);
4120begin
4121 FEditBox.SetFocus;
4122 if AutoSelect then FEditBox.SelectAll;
4123end;
4124
4125procedure TORComboBox.DoExit;
4126{ make sure DropDown list is raised when losing focus }
4127begin
4128 DroppedDown := False;
4129 if FKeyTimerActive then
4130 begin
4131 StopKeyTimer;
4132 if FListBox.LongList and FChangePending then FwdChangeDelayed;
4133 end;
4134 inherited DoExit;
4135end;
4136
4137procedure TORComboBox.LoadComboBoxImage;
4138var
4139 imageName: string;
4140begin
4141 if assigned(FDropBtn) then
4142 begin
4143 if FBlackColorMode then
4144 imageName := BlackComboBoxImages[inherited Enabled]
4145 else
4146 imageName := ComboBoxImages[inherited Enabled];
4147 FDropBtn.Glyph.LoadFromResourceName(hInstance, imageName);
4148 end;
4149end;
4150
4151procedure TORComboBox.Loaded;
4152{ we need to call the loaded method for the listbox child (it's not called automatically) }
4153begin
4154 inherited Loaded;
4155 FListBox.Loaded;
4156end;
4157
4158procedure TORComboBox.FwdChange(Sender: TObject);
4159{ allow timer to call FwdChangeDelayed if long list, otherwise call directly }
4160begin
4161 if FFromSelf then Exit;
4162 FChangePending := True;
4163 if FListBox.LongList and FKeyIsDown then Exit;
4164 FwdChangeDelayed;
4165end;
4166
4167procedure TORComboBox.FwdChangeDelayed;
4168{ when user types in the editbox, find a partial match in the listbox & set into editbox }
4169var
4170 SelectIndex: Integer;
4171 x: string;
4172begin
4173 FChangePending := False;
4174 if (not FListItemsOnly) and (Length(FEditBox.Text) > 0) and (FEditBox.SelStart = 0) then Exit; // **KCM** test this!
4175 with FEditBox do x := Copy(Text, 1, SelStart);
4176 FLastInput := x;
4177 SelectIndex := -1;
4178 if Length(x) >= CharsNeedMatch then
4179 SelectIndex := FListBox.SelectString(x);
4180 if (Length(x) < CharsNeedMatch) and (FListBox.ItemIndex > -1) then
4181 SelectIndex := FListBox.SelectString(x);
4182 if UniqueAutoComplete then
4183 SelectIndex := FListBox.VerifyUnique(SelectIndex, x);
4184 if FListItemsOnly and (SelectIndex < 0) and (x <> '') then
4185 begin
4186 FFromSelf := True;
4187 x := FLastFound;
4188 SelectIndex := FListBox.SelectString(x);
4189 FEditBox.Text := GetEditBoxText(SelectIndex);
4190 if (not FListBox.FCheckBoxes) then
4191 SendMessage(FEditBox.Handle, EM_SETSEL, Length(FEditBox.Text), Length(x));
4192 FFromSelf := False;
4193 Exit; // OnChange not called in this case
4194 end;
4195 FFromSelf := True;
4196 if SelectIndex > -1 then
4197 begin
4198 FEditBox.Text := GetEditBoxText(SelectIndex);
4199 FLastFound := x;
4200 if (not FListBox.FCheckBoxes) then
4201 SendMessage(FEditBox.Handle, EM_SETSEL, Length(FEditBox.Text), Length(x));
4202 end else
4203 begin
4204 if (FListBox.CheckBoxes) then
4205 FEditBox.Text := GetEditBoxText(SelectIndex)
4206 else
4207 FEditBox.Text := x; // no match, so don't set FLastFound
4208 FEditBox.SelStart := Length(x);
4209 end;
4210 FFromSelf := False;
4211 if (not FListBox.FCheckBoxes) then
4212 if Assigned(FOnChange) then FOnChange(Self);
4213end;
4214
4215(*
4216procedure TORComboBox.FwdChangeDelayed;
4217{ when user types in the editbox, find a partial match in the listbox & set into editbox }
4218var
4219 SelectIndex: Integer;
4220 x: string;
4221begin
4222 FChangePending := False;
4223 with FEditBox do x := Copy(Text, 1, SelStart);
4224 if x = FLastInput then Exit; // this change event is just removing the selected text
4225 FLastInput := x;
4226 SelectIndex := FListBox.SelectString(x);
4227 FFromSelf := True;
4228 if SelectIndex > -1 then
4229 begin
4230 FEditBox.Text := GetEditBoxText(SelectIndex);
4231 if(not FListBox.FCheckBoxes) then
4232 SendMessage(FEditBox.Handle, EM_SETSEL, Length(FEditBox.Text), Length(x));
4233 end else
4234 begin
4235 FEditBox.Text := x;
4236 FEditBox.SelStart := Length(x);
4237 end;
4238 FFromSelf := False;
4239 if(not FListBox.FCheckBoxes) then
4240 if Assigned(FOnChange) then FOnChange(Self);
4241end;
4242*)
4243
4244procedure TORComboBox.FwdClick(Sender: TObject);
4245{ places the text of the item that was selected from the listbox into the editbox }
4246begin
4247 if FListBox.ItemIndex > -1 then
4248 begin
4249 FFromSelf := True;
4250 FListBox.FFocusIndex := FListBox.ItemIndex; // FFocusIndex used so ItemTip doesn't flash
4251 FEditBox.Text := GetEditBoxText(FListBox.ItemIndex);
4252 FLastFound := FEditBox.Text;
4253 FFromSelf := False;
4254 // not sure why this must be posted (put at the back of the message queue), but for some
4255 // reason FEditBox.SelectAll selects successfully then deselects on exiting this procedure
4256 if (not FListBox.FCheckBoxes) then
4257 PostMessage(FEditBox.Handle, EM_SETSEL, 0, Length(FEditBox.Text));
4258 FEditBox.SetFocus;
4259 end;
4260 if Assigned(FOnClick) then FOnClick(Self);
4261 if (not FListBox.FCheckBoxes) then
4262 if Assigned(FOnChange) then FOnChange(Self); // click causes both click & change events
4263end;
4264
4265procedure TORComboBox.FwdDblClick(Sender: TObject);
4266{ surfaces the double click event from the listbox so it is available as a combobox property }
4267begin
4268 if Assigned(FOnDblClick) then FOnDblClick(Self);
4269end;
4270
4271procedure TORComboBox.FwdKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
4272{ passed selected navigation keys to listbox, applies special handling to backspace and F4 }
4273var
4274 i, iPos: Integer;
4275 x, AString: string;
4276begin
4277 // special case: when default action taken (RETURN) make sure FwdChangeDelayed is called first
4278 if (Key = VK_RETURN) and FListBox.LongList and FChangePending then FwdChangeDelayed;
4279 StopKeyTimer; // stop timer after control keys so in case an exit event is triggered
4280 if Assigned(FOnKeyDown) then FOnKeyDown(Self, Key, Shift);
4281 if Key in [VK_PRIOR, VK_NEXT, VK_UP, VK_DOWN] then // navigation
4282 begin
4283 if (FStyle = orcsDropDown) and not DroppedDown then DroppedDown := True;
4284 // handle special case of FocusIndex, WM_KEYDOWN will increment from -1 to 0
4285 if FListBox.ItemIndex = -1 then
4286 begin
4287 FListBox.FFocusIndex := -1;
4288 //Move to correct position when Unique AutoComplete is on.
4289 if UniqueAutoComplete then
4290 begin
4291 AString := Copy(FEditBox.Text, 1, SelStart);
4292 iPos := SendMessage(FListBox.Handle, LB_FINDSTRING, -1, Longint(PChar(AString)));
4293 if iPos = LB_ERR then iPos := -1;
4294 if iPos > -1 then
4295 begin
4296 FListBox.FFocusIndex := iPos - 1;
4297 FListBox.ItemIndex := FListBox.FFocusIndex;
4298 end;
4299 end;
4300 end;
4301 FListBox.Perform(WM_KEYDOWN, Key, 1);
4302 end;
4303 if Key in [VK_LBUTTON, VK_RETURN, VK_PRIOR, VK_NEXT, VK_UP, VK_DOWN] then // select item
4304 begin
4305 FListBox.Perform(WM_KEYDOWN, VK_LBUTTON, 1);
4306 FFromSelf := True;
4307 if FListBox.ItemIndex > -1 then
4308 begin
4309 FEditBox.Text := GetEditBoxText(FListBox.ItemIndex);
4310 FLastFound := FEditBox.Text; //kcm
4311 end;
4312 FFromSelf := False;
4313 end;
4314 // tell parent about RETURN, ESCAPE so that the default action is taken
4315 if Key in [VK_RETURN, VK_ESCAPE, VK_TAB] then SendMessage(Parent.Handle, CN_KEYDOWN, Key, 0);
4316 if Key = VK_BACK then // backspace
4317 begin
4318 FFromSelf := True;
4319 x := FEditBox.Text;
4320 i := FEditBox.SelStart;
4321 Delete(x, i + 1, Length(x));
4322 if (FListBox.FCheckBoxes) then
4323 FEditBox.Text := GetEditBoxText(ItemIndex)
4324 else
4325 FEditBox.Text := x;
4326 FLastFound := x;
4327 FEditBox.SelStart := i;
4328 FFromSelf := False;
4329 end;
4330 if (FStyle = orcsDropDown) and (Key = VK_F4) then DroppedDown := not DroppedDown; // drop
4331
4332 if (Key = VK_SPACE) and (FListBox.FCheckBoxes) and (FListBox.ItemIndex > -1) then
4333 FListBox.ToggleCheckBox(FListBox.ItemIndex);
4334
4335 if (FStyle = orcsDropDown) and (FListBox.FCheckBoxes) then
4336 begin
4337 if Key = VK_RETURN then DropPanelBtnPressed(TRUE, TRUE);
4338 if Key = VK_ESCAPE then DropPanelBtnPressed(FALSE, TRUE);
4339 end;
4340
4341 FKeyIsDown := True;
4342end;
4343
4344procedure TORComboBox.FwdKeyPress(Sender: TObject; var Key: Char);
4345var
4346 KeyCode: integer;
4347{ prevents return from being used by editbox (otherwise sends a newline & text vanishes) }
4348begin
4349 KeyCode := ord(Key);
4350 if (KeyCode = VK_RETURN) and (Style = orcsDropDown) and DroppedDown then
4351 begin
4352 DroppedDown := FALSE;
4353 Key := #0;
4354 end
4355 else
4356 begin
4357 // may want to make the tab beep if tab key (#9) - can't tab until list raised
4358 if (KeyCode = VK_RETURN) or (KeyCode = VK_TAB) or (FListBox.FCheckBoxes and (KeyCode = VK_SPACE)) then
4359 begin
4360 Key := #0;
4361 Exit;
4362 end;
4363 if Assigned(FOnKeyPress) then FOnKeyPress(Self, Key);
4364 end;
4365end;
4366
4367procedure TORComboBox.FwdKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
4368{ surfaces the key up event from the editbox so it is available as a combobox property }
4369begin
4370 FKeyIsDown := False;
4371 // tell parent about RETURN, ESCAPE so that the default action is taken
4372 if Key in [VK_RETURN, VK_ESCAPE, VK_TAB] then SendMessage(Parent.Handle, CN_KEYUP, Key, 0);
4373 if Assigned(FOnKeyUp) then FOnKeyUp(Self, Key, Shift);
4374 StartKeyTimer;
4375end;
4376
4377procedure TORComboBox.FwdMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState;
4378 X, Y: Integer);
4379begin
4380 if Assigned(FOnMouseClick) then FOnMouseClick(Self);
4381end;
4382
4383procedure TORComboBox.FwdNeedData(Sender: TObject; const StartFrom: string;
4384 Direction, InsertAt: Integer);
4385{ surfaces the need data event from the (long) listbox so it is available as a property }
4386begin
4387 if Assigned(FOnNeedData) then FOnNeedData(Self, copy(StartFrom, 1, MaxNeedDataLen), Direction, InsertAt);
4388end;
4389
4390procedure TORComboBox.SetDropDownCount(Value: Integer);
4391{ when the listbox is dropped, it's sized according to Value (ItemHeight * DropDownCount) }
4392begin
4393 if Value > 0 then FDropDownCount := Value;
4394end;
4395
4396procedure TORComboBox.SetDroppedDown(Value: Boolean);
4397{ for DropDown combo, display the listbox at the appropriate full screen coordinates }
4398const
4399 MIN_ITEMS = 3; // minimum visible items for long list
4400var
4401 ScreenPoint: TPoint;
4402 DropDownCnt: Integer;
4403 PnlHeight: integer;
4404begin
4405 if (Value = FDroppedDown) or (FStyle <> orcsDropDown) then Exit;
4406 FDroppedDown := Value;
4407 if FDroppedDown = True then
4408 begin
4409 if Assigned(FOnDropDown) then FOnDropDown(Self);
4410 if FListBox.LongList
4411 then DropDownCnt := HigherOf(FDropDownCount, MIN_ITEMS)
4412 else DropDownCnt := LowerOf(FDropDownCount, FListBox.Items.Count);
4413 FListBox.SetBounds(0, 0, Width, (FListBox.ItemHeight * DropDownCnt) + CBO_CXFRAME);
4414 // need to make this smart enough to drop the list UP when necessary ***
4415 ScreenPoint := Self.ClientToScreen(Point(0, EditControl.Height));
4416
4417 PnlHeight := FListBox.Height;
4418 if (FListBox.FCheckBoxes) then
4419 inc(PnlHeight, CheckComboBtnHeight);
4420 FDropPanel.SetBounds(ScreenPoint.X, ScreenPoint.Y, FListBox.Width, PnlHeight);
4421 if (FListBox.FCheckBoxes) then
4422 begin
4423 FDropPanel.ResetButtons;
4424 FCheckedState := FListBox.GetCheckedString;
4425 end;
4426 DropDownStatusChanged(TRUE);
4427 FDropPanel.Visible := True;
4428 FDropPanel.BringToFront;
4429 if FListBox.FScrollBar <> nil then FListBox.FScrollBar.BringToFront;
4430 if not FFromDropBtn then FListBox.MouseCapture := True; // otherwise ButtonUp captures
4431 end else
4432 begin
4433 if Assigned(FOnDropDownClose) then FOnDropDownClose(Self);
4434 FListBox.MouseCapture := False;
4435 uItemTip.Hide;
4436 FDropPanel.Hide;
4437 DropDownStatusChanged(FALSE);
4438 if (FListBox.FCheckBoxes) and (assigned(FOnChange)) and
4439 (FCheckedState <> FListBox.GetCheckedString) then
4440 FOnChange(Self);
4441 end;
4442end;
4443
4444procedure TORComboBox.SetEditRect;
4445{ change the edit rectangle to not hide the dropdown button - taken from SPIN.PAS sample }
4446var
4447 Loc: TRect;
4448begin
4449 SendMessage(FEditBox.Handle, EM_GETRECT, 0, LongInt(@Loc));
4450 Loc.Bottom := ClientHeight + 1; // +1 is workaround for windows paint bug
4451 if FStyle = orcsDropDown then
4452 begin
4453 Loc.Right := ClientWidth - FDropBtn.Width - CBO_CXFRAME; // edit up to button
4454 if (FTemplateField) then
4455 inc(Loc.Right, 3);
4456 end
4457 else
4458 Loc.Right := ClientWidth - CBO_CXFRAME; // edit in full edit box
4459 Loc.Top := 0;
4460 if (FTemplateField) then
4461 Loc.Left := 2
4462 else
4463 Loc.Left := 0;
4464 SendMessage(FEditBox.Handle, EM_SETRECTNP, 0, LongInt(@Loc));
4465end;
4466
4467procedure TORComboBox.SetEditText(const Value: string);
4468{ allows the text to change when ItemIndex is changed without triggering a change event }
4469begin
4470 FFromSelf := True;
4471 FEditBox.Text := Value;
4472 FLastFound := FEditBox.Text;
4473 FFromSelf := False;
4474 PostMessage(FEditBox.Handle, EM_SETSEL, 0, Length(FEditBox.Text));
4475end;
4476
4477procedure TORComboBox.SetItemIndex(Value: Integer);
4478{ set the ItemIndex in the listbox and update the editbox to show the DisplayText }
4479begin
4480 with FListBox do
4481 begin
4482 ItemIndex := Value;
4483 { should Value = -1 be handled in the SetFocusIndex procedure itself? or should it be
4484 handled by the setting of the ItemIndex property? }
4485 if Value = -1 then FFocusIndex := -1 else FocusIndex := Value;
4486 uItemTip.Hide;
4487 if (FListBox.CheckBoxes) then
4488 SetEditText(GetEditBoxText(ItemIndex))
4489 else
4490 begin
4491 if ItemIndex > -1 then SetEditText(GetEditBoxText(ItemIndex)) else SetEditText('');
4492 end;
4493 end;
4494end;
4495
4496function TORComboBox.SelectByIEN(AnIEN: Int64): Integer;
4497begin
4498 Result := FListBox.SelectByIEN(AnIEN);
4499 SetItemIndex(Result);
4500end;
4501
4502function TORComboBox.SelectByID(const AnID: string): Integer;
4503begin
4504 Result := FListBox.SelectByID(AnID);
4505 SetItemIndex(Result);
4506end;
4507
4508function TORComboBox.SetExactByIEN(AnIEN: Int64; const AnItem: string): Integer;
4509begin
4510 Result := FListBox.SetExactByIEN(AnIEN, AnItem);
4511 SetItemIndex(Result);
4512end;
4513
4514procedure TORComboBox.SetStyle(Value: TORComboStyle);
4515{ Simple: get rid of dropdown button & panel, make combobox parent of listbox
4516 DropDown: create dropdown button & panel, transfer listbox parent to dropdown panel
4517 this allows the dropped list to overlap other windows }
4518begin
4519 if Value <> FStyle then
4520 begin
4521 FStyle := Value;
4522 if FStyle = orcsSimple then
4523 begin
4524 if FDropBtn <> nil then FDropBtn.Free;
4525 if FDropPanel <> nil then
4526 begin
4527 ClearDropDownStatus;
4528 FDropPanel.Free;
4529 end;
4530 FDropBtn := nil;
4531 FDropPanel := nil;
4532 FListBox.FParentCombo := nil;
4533 FListBox.Parent := Self;
4534 if FListBox.FScrollBar <> nil then FListBox.FScrollBar.Parent := Self; // if long
4535 FListBox.Visible := True;
4536 end else
4537 begin
4538 FDropBtn := TBitBtn.Create(Self);
4539 if (assigned(FEditPanel) and (csDesigning in ComponentState)) then
4540 FEditPanel.ControlStyle := FEditPanel.ControlStyle + [csAcceptsControls];
4541 FDropBtn.Parent := FEditBox;
4542 if (assigned(FEditPanel) and (csDesigning in ComponentState)) then
4543 FEditPanel.ControlStyle := FEditPanel.ControlStyle - [csAcceptsControls];
4544 LoadComboBoxImage;
4545// FDropBtn.Glyph.LoadFromResourceName(hInstance, ComboBoxImages[inherited Enabled]);
4546 FDropBtn.OnMouseDown := DropButtonDown;
4547 FDropBtn.OnMouseUp := DropButtonUp;
4548 FDropBtn.TabStop := False;
4549 FDropBtn.Visible := True;
4550 FDropBtn.BringToFront;
4551 if not (csDesigning in ComponentState) then
4552 begin
4553 FDropPanel := TORDropPanel.Create(Self);
4554 FDropPanel.Parent := Self; // parent is really the desktop - see CreateParams
4555 FListBox.FParentCombo := Self;
4556 FListBox.Parent := FDropPanel;
4557 ClearDropDownStatus;
4558 if FListBox.FScrollBar <> nil then FListBox.FScrollBar.Parent := FDropPanel; // if long
4559 end else
4560 begin
4561 FListBox.Visible := False;
4562 end;
4563 Height := EditControl.Height;
4564 end;
4565 AdjustSizeOfSelf;
4566 end;
4567end;
4568
4569procedure TORComboBox.StartKeyTimer;
4570{ start (or restart) a timer (done on keyup to delay before calling OnKeyPause) }
4571var
4572 ATimerID: Integer;
4573begin
4574 if FListBox.LongList or Assigned(FOnKeyPause) then
4575 begin
4576 StopKeyTimer;
4577 ATimerID := SetTimer(Handle, KEY_TIMER_ID, KEY_TIMER_DELAY, nil);
4578 FKeyTimerActive := ATimerID > 0;
4579 // if can't get a timer, just call the OnKeyPause event immediately
4580 if not FKeyTimerActive then Perform(WM_TIMER, KEY_TIMER_ID, 0);
4581 end;
4582end;
4583
4584procedure TORComboBox.StopKeyTimer;
4585{ stop the timer (done whenever a key is pressed or the combobox no longer has focus) }
4586begin
4587 if FKeyTimerActive then
4588 begin
4589 KillTimer(Handle, KEY_TIMER_ID);
4590 FKeyTimerActive := False;
4591 end;
4592end;
4593
4594function TORComboBox.SupportsDynamicProperty(PropertyID: integer): boolean;
4595begin
4596 Result := (PropertyID = DynaPropAccesibilityCaption);
4597end;
4598
4599// Since TORComboBox is composed of several controls (FEditBox, FListBox, FDropBtn), the
4600// following functions and procedures map public and published properties to their related
4601// subcomponents.
4602
4603function TORComboBox.AddReference(const S: string; AReference: Variant): Integer;
4604begin
4605 Result := FListBox.AddReference(S, AReference);
4606end;
4607
4608procedure TORComboBox.Clear;
4609begin
4610 FListBox.Clear;
4611 FEditBox.Clear;
4612end;
4613
4614procedure TORComboBox.ClearTop;
4615begin
4616 FListBox.ClearTop;
4617end;
4618
4619procedure TORComboBox.ForDataUse(Strings: TStrings);
4620begin
4621 FListBox.ForDataUse(Strings);
4622end;
4623
4624procedure TORComboBox.InitLongList(S: string);
4625begin
4626 FListBox.InitLongList(S);
4627end;
4628
4629function TORComboBox.IndexOfReference(AReference: Variant): Integer;
4630begin
4631 Result := FListBox.IndexOfReference(AReference);
4632end;
4633
4634procedure TORComboBox.InsertReference(Index: Integer; const S: string; AReference: Variant);
4635begin
4636 FListBox.InsertReference(Index, S, AReference);
4637end;
4638
4639procedure TORComboBox.InsertSeparator;
4640begin
4641 FListBox.InsertSeparator;
4642end;
4643
4644procedure TORComboBox.Invalidate;
4645begin
4646 inherited;
4647 FEditBox.Invalidate;
4648 FListBox.Invalidate;
4649 if assigned(FEditPanel) then
4650 FEditPanel.Invalidate;
4651 if assigned(FDropBtn) then
4652 FDropBtn.Invalidate;
4653 if assigned(FDropPanel) then
4654 FDropPanel.Invalidate;
4655end;
4656
4657function TORComboBox.GetAutoSelect: Boolean;
4658begin
4659 Result := FEditBox.AutoSelect;
4660end;
4661
4662function TORComboBox.GetColor: TColor;
4663begin
4664 Result := FListBox.Color;
4665end;
4666
4667function TORComboBox.GetDelimiter: Char;
4668begin
4669 Result := FListBox.Delimiter;
4670end;
4671
4672function TORComboBox.GetDisplayText(Index: Integer): string;
4673begin
4674 Result := FListBox.DisplayText[Index];
4675end;
4676
4677function TORComboBox.GetDynamicProperty(PropertyID: integer): string;
4678begin
4679 if PropertyID = DynaPropAccesibilityCaption then
4680 Result := GetCaption
4681 else
4682 Result := '';
4683end;
4684
4685function TORComboBox.GetItemHeight: Integer;
4686begin
4687 Result := FListBox.ItemHeight;
4688end;
4689
4690function TORComboBox.GetIEN(AnIndex: Integer): Int64;
4691begin
4692 Result := FListBox.GetIEN(AnIndex);
4693end;
4694
4695function TORComboBox.GetItemID: Variant;
4696begin
4697 Result := FListBox.ItemID;
4698end;
4699
4700function TORComboBox.GetItemIEN: Int64;
4701begin
4702 Result := FListBox.ItemIEN;
4703end;
4704
4705function TORComboBox.GetItemIndex: Integer;
4706begin
4707 Result := FListBox.ItemIndex;
4708end;
4709
4710function TORComboBox.GetItemTipEnable: Boolean;
4711begin
4712 Result := FListBox.ItemTipEnable;
4713end;
4714
4715function TORComboBox.GetItemTipColor: TColor;
4716begin
4717 Result := FListBox.ItemTipColor;
4718end;
4719
4720function TORComboBox.GetLongList: Boolean;
4721begin
4722 Result := FListBox.LongList;
4723end;
4724
4725function TORComboBox.GetMaxLength: Integer;
4726begin
4727 Result := FEditBox.MaxLength;
4728end;
4729
4730function TORComboBox.GetPieces: string;
4731begin
4732 Result := FListBox.Pieces;
4733end;
4734
4735function TORComboBox.GetReference(Index: Integer): Variant;
4736begin
4737 Result := FListBox.References[Index];
4738end;
4739
4740function TORComboBox.GetSelLength: Integer;
4741begin
4742 Result := FEditBox.SelLength;
4743end;
4744
4745function TORComboBox.GetSelStart: Integer;
4746begin
4747 Result := FEditBox.SelStart;
4748end;
4749
4750function TORComboBox.GetSelText: string;
4751begin
4752 Result := FEditBox.SelText;
4753end;
4754
4755function TORComboBox.GetShortCount: Integer;
4756begin
4757 Result := FListBox.ShortCount;
4758end;
4759
4760function TORComboBox.GetSorted: Boolean;
4761begin
4762 Result := FListBox.Sorted;
4763end;
4764
4765function TORComboBox.GetHideSynonyms: boolean;
4766begin
4767 Result := FListBox.HideSynonyms;
4768end;
4769
4770function TORComboBox.GetSynonymChars: string;
4771begin
4772 result := FListBox.SynonymChars;
4773end;
4774
4775procedure TORComboBox.SetHideSynonyms(Value: boolean);
4776begin
4777 FListBox.HideSynonyms := Value;
4778end;
4779
4780procedure TORComboBox.SetSynonymChars(Value: string);
4781begin
4782 FListBox.SynonymChars := Value;
4783end;
4784
4785function TORComboBox.GetTabPositions: string;
4786begin
4787 Result := FListBox.TabPositions;
4788end;
4789
4790function TORComboBox.GetTabPosInPixels: boolean;
4791begin
4792 Result := FListBox.TabPosInPixels;
4793end;
4794
4795function TORComboBox.GetText: string;
4796begin
4797 Result := FEditBox.Text;
4798end;
4799
4800procedure TORComboBox.SelectAll;
4801begin
4802 FEditBox.SelectAll;
4803end;
4804
4805procedure TORComboBox.SetAutoSelect(Value: Boolean);
4806begin
4807 FEditBox.AutoSelect := Value;
4808end;
4809
4810procedure TORComboBox.SetBlackColorMode(Value: boolean);
4811begin
4812 if FBlackColorMode <> Value then
4813 begin
4814 FBlackColorMode := Value;
4815 FListBox.SetBlackColorMode(Value);
4816 LoadComboBoxImage;
4817 end;
4818end;
4819
4820procedure TORComboBox.SetColor(Value: TColor);
4821begin
4822 if (not FListBox.CheckBoxes) then
4823 FEditBox.Color := Value;
4824 FListBox.Color := Value;
4825end;
4826
4827procedure TORComboBox.SetDelimiter(Value: Char);
4828begin
4829 FListBox.Delimiter := Value;
4830end;
4831
4832procedure TORComboBox.SetItemHeight(Value: Integer);
4833begin
4834 FListBox.ItemHeight := Value;
4835end;
4836
4837procedure TORComboBox.SetItemTipEnable(Value: Boolean);
4838begin
4839 FListBox.ItemTipEnable := Value;
4840end;
4841
4842procedure TORComboBox.SetItemTipColor(Value: TColor);
4843begin
4844 FListBox.ItemTipColor := Value;
4845end;
4846
4847procedure TORComboBox.SetLongList(Value: Boolean);
4848begin
4849 FListBox.LongList := Value;
4850end;
4851
4852procedure TORComboBox.SetMaxLength(Value: Integer);
4853begin
4854 FEditBox.MaxLength := Value;
4855end;
4856
4857procedure TORComboBox.SetPieces(const Value: string);
4858begin
4859 FListBox.Pieces := Value;
4860end;
4861
4862procedure TORComboBox.SetReference(Index: Integer; AReference: Variant);
4863begin
4864 FListBox.References[Index] := AReference;
4865end;
4866
4867procedure TORComboBox.SetSelLength(Value: Integer);
4868begin
4869 FEditBox.SelLength := Value;
4870end;
4871
4872procedure TORComboBox.SetSelStart(Value: Integer);
4873begin
4874 FEditBox.SelStart := Value;
4875end;
4876
4877procedure TORComboBox.SetSelText(const Value: string);
4878begin
4879 FEditBox.SelText := Value;
4880end;
4881
4882procedure TORComboBox.SetSorted(Value: Boolean);
4883begin
4884 FListBox.Sorted := Value;
4885end;
4886
4887procedure TORComboBox.SetTabPositions(const Value: string);
4888begin
4889 FListBox.TabPositions := Value;
4890end;
4891
4892procedure TORComboBox.SetTabPosInPixels(const Value: boolean);
4893begin
4894 FListBox.TabPosInPixels := Value;
4895end;
4896
4897procedure TORComboBox.SetText(const Value: string);
4898begin
4899 FEditBox.Text := Value; // kcm ???
4900end;
4901
4902procedure TORComboBox.SetItems(const Value: TStrings);
4903begin
4904 FItems.Assign(Value);
4905end;
4906
4907function TORComboBox.GetCheckBoxes: boolean;
4908begin
4909 Result := FListBox.FCheckBoxes;
4910end;
4911
4912function TORComboBox.GetChecked(Index: Integer): Boolean;
4913begin
4914 Result := FListBox.GetChecked(Index);
4915end;
4916
4917function TORComboBox.GetCheckEntireLine: boolean;
4918begin
4919 Result := FListBox.FCheckEntireLine;
4920end;
4921
4922function TORComboBox.GetFlatCheckBoxes: boolean;
4923begin
4924 Result := FListBox.FFlatCheckBoxes;
4925end;
4926
4927procedure TORComboBox.SetCheckBoxes(const Value: boolean);
4928begin
4929 if (FListBox.FCheckBoxes <> Value) then
4930 begin
4931 FListBox.SetCheckBoxes(Value);
4932 if (assigned(FDropPanel)) then
4933 FDropPanel.UpdateButtons;
4934 FEditBox.Visible := FALSE;
4935 try
4936 if (Value) then
4937 begin
4938 SetListItemsOnly(TRUE);
4939 SetAutoSelect(FALSE);
4940 FEditBox.Color := FCheckBoxEditColor;
4941 FEditBox.Text := GetEditBoxText(-1);
4942 FEditBox.BorderStyle := bsNone;
4943 FEditPanel := TORComboPanelEdit.Create(Self);
4944 FEditPanel.Parent := Self;
4945 FEditPanel.BevelOuter := bvRaised;
4946 FEditPanel.BorderWidth := 1;
4947 FEditBox.Parent := FEditPanel;
4948 if (csDesigning in ComponentState) then
4949 FEditPanel.ControlStyle := FEditPanel.ControlStyle - [csAcceptsControls];
4950 end
4951 else
4952 begin
4953 FEditBox.Parent := Self;
4954 FEditBox.Color := FListBox.Color;
4955 FEditBox.BorderStyle := bsSingle;
4956 FEditPanel.Free;
4957 FEditPanel := nil;
4958 end;
4959 finally
4960 FEditBox.Visible := TRUE;
4961 end;
4962 AdjustSizeOfSelf;
4963 end;
4964end;
4965
4966procedure TORComboBox.SetChecked(Index: Integer; const Value: Boolean);
4967begin
4968 FListBox.SetChecked(Index, Value);
4969 if (assigned(FDropPanel)) then
4970 FDropPanel.UpdateButtons;
4971 if (Value) then
4972 SetListItemsOnly(TRUE);
4973end;
4974
4975procedure TORComboBox.SetCheckEntireLine(const Value: boolean);
4976begin
4977 FListBox.FCheckEntireLine := Value;
4978end;
4979
4980procedure TORComboBox.SetFlatCheckBoxes(const Value: boolean);
4981begin
4982 FListBox.SetFlatCheckBoxes(Value);
4983end;
4984
4985procedure TORComboBox.DropPanelBtnPressed(OKBtn, AutoClose: boolean);
4986var
4987 btn: TSpeedButton;
4988
4989begin
4990 if (assigned(FDropPanel)) then
4991 begin
4992 btn := FDropPanel.GetButton(OKBtn);
4993 if (assigned(Btn)) then
4994 Btn.Down := TRUE;
4995 end;
4996 if (not OKBtn) then FListBox.SetCheckedString(FCheckedState);
4997 if (AutoClose) then
4998 begin
4999 FListBox.FDontClose := FALSE;
5000 DroppedDown := False;
5001 end;
5002 UpdateCheckEditBoxText;
5003end;
5004
5005function TORComboBox.GetCheckedString: string;
5006begin
5007 Result := FListBox.GetCheckedString;
5008end;
5009
5010procedure TORComboBox.SetCheckedString(const Value: string);
5011begin
5012 FListBox.SetCheckedString(Value);
5013end;
5014
5015procedure TORComboBox.SetCheckBoxEditColor(const Value: TColor);
5016begin
5017 if (FCheckBoxEditColor <> Value) then
5018 begin
5019 FCheckBoxEditColor := Value;
5020 if (FListBox.FCheckBoxes) then
5021 FEditBox.Color := FCheckBoxEditColor;
5022 end;
5023end;
5024
5025procedure TORComboBox.SetListItemsOnly(const Value: Boolean);
5026begin
5027 if (FListItemsOnly <> Value) then
5028 begin
5029 FListItemsOnly := Value;
5030 if (not Value) then
5031 SetCheckBoxes(FALSE);
5032 end;
5033end;
5034
5035procedure TORComboBox.SetOnCheckedText(const Value: TORCheckComboTextEvent);
5036begin
5037 FOnCheckedText := Value;
5038 FEditBox.Text := GetEditBoxText(-1);
5039end;
5040
5041procedure TORComboBox.SetTemplateField(const Value: boolean);
5042begin
5043 if (FTemplateField <> Value) then
5044 begin
5045 FTemplateField := Value;
5046 if (Value) then
5047 begin
5048 SetStyle(orcsDropDown);
5049 FEditBox.BorderStyle := bsNone
5050 end
5051 else
5052 FEditBox.BorderStyle := bsSingle;
5053 AdjustSizeOfSelf;
5054 end;
5055end;
5056
5057function TORComboBox.GetOnSynonymCheck: TORSynonymCheckEvent;
5058begin
5059 Result := FListBox.FOnSynonymCheck;
5060end;
5061
5062procedure TORComboBox.SetOnSynonymCheck(const Value: TORSynonymCheckEvent);
5063begin
5064 FListBox.FOnSynonymCheck := Value;
5065end;
5066
5067function TORComboBox.GetEnabled: boolean;
5068begin
5069 Result := inherited GetEnabled;
5070end;
5071
5072procedure TORComboBox.SetEnabled(Value: boolean);
5073begin
5074 if (inherited GetEnabled <> Value) then
5075 begin
5076 DroppedDown := FALSE;
5077 inherited SetEnabled(Value);
5078 if assigned(FDropBtn) then
5079 LoadComboBoxImage;
5080// FDropBtn.Glyph.LoadFromResourceName(hInstance, ComboBoxImages[Value]);
5081 end;
5082end;
5083
5084function TORComboBox.GetEditBoxText(Index: Integer): string;
5085var
5086 i, cnt: integer;
5087
5088begin
5089 if (FListBox.FCheckBoxes) then
5090 begin
5091 Result := '';
5092 cnt := 0;
5093 for i := 0 to FListBox.Items.Count - 1 do
5094 begin
5095 if (FListBox.Checked[i]) then
5096 begin
5097 inc(cnt);
5098 if (Result <> '') then
5099 Result := Result + ', ';
5100 Result := Result + FListBox.GetDisplayText(i);
5101 end;
5102 end;
5103 if (assigned(FOnCheckedText)) then
5104 FOnCheckedText(FListBox, cnt, Result);
5105 end
5106 else
5107 Result := FListBox.GetDisplayText(Index);
5108end;
5109
5110procedure TORComboBox.UpdateCheckEditBoxText;
5111begin
5112 if (FListBox.FCheckBoxes) then
5113 begin
5114 FFromSelf := TRUE;
5115 FEditBox.Text := GetEditBoxText(-1);
5116 FEditBox.SelLength := 0;
5117 FFromSelf := FALSE;
5118 end;
5119end;
5120
5121procedure TORComboBox.CheckBoxSelected(Sender: TObject; Index: integer);
5122begin
5123 UpdateCheckEditBoxText;
5124 if (FStyle <> orcsDropDown) and (assigned(FOnChange)) then
5125 FOnChange(Self);
5126end;
5127
5128function TORComboBox.GetMItems: TStrings;
5129begin
5130 result := FMItems;
5131end;
5132
5133procedure TORComboBox.SetCaption(const Value: string);
5134begin
5135 FListBox.Caption := Value;
5136end;
5137
5138function TORComboBox.GetCaption: string;
5139begin
5140 result := FListBox.Caption;
5141end;
5142
5143function TORComboBox.GetCaseChanged: boolean;
5144begin
5145 result := FListBox.CaseChanged;
5146end;
5147
5148procedure TORComboBox.SetCaseChanged(const Value: boolean);
5149begin
5150 FListBox.CaseChanged := Value;
5151end;
5152
5153function TORComboBox.GetLookupPiece: integer;
5154begin
5155 result := FListBox.LookupPiece;
5156end;
5157
5158procedure TORComboBox.SetLookupPiece(const Value: integer);
5159begin
5160 FListBox.LookupPiece := Value;
5161end;
5162
5163{ TSizeRatio methods }
5164
5165constructor TSizeRatio.Create(ALeft, ATop, AWidth, AHeight: Extended);
5166{ creates an object that records the initial relative size & position of a control }
5167begin
5168 CLeft := ALeft; CTop := ATop; CWidth := AWidth; CHeight := AHeight;
5169end;
5170
5171{ TORAutoPanel ----------------------------------------------------------------------------- }
5172
5173destructor TORAutoPanel.Destroy;
5174{ destroy objects used to record size and position information for controls }
5175var
5176 SizeRatio: TSizeRatio;
5177 i: Integer;
5178begin
5179 if FSizes <> nil then with FSizes do for i := 0 to Count - 1 do
5180 begin
5181 SizeRatio := Items[i];
5182 SizeRatio.Free;
5183 end;
5184 FSizes.Free;
5185 inherited Destroy;
5186end;
5187
5188procedure TORAutoPanel.BuildSizes(Control: TWinControl);
5189var
5190 i, H, W: Integer;
5191 SizeRatio: TSizeRatio;
5192 Child: TControl;
5193begin
5194 H := ClientHeight;
5195 W := ClientWidth;
5196 if (H = 0) or (W = 0) then exit;
5197 for i := 0 to Control.ControlCount - 1 do
5198 begin
5199 Child := Control.Controls[i];
5200 with Child do
5201 SizeRatio := TSizeRatio.Create(Left / W, Top / H, Width / W, Height / H);
5202 FSizes.Add(SizeRatio); //FSizes is in tree traversal order.
5203 //TGroupBox is currently the only type of container that is having these
5204 //resize problems
5205 if Child is TGroupBox then
5206 BuildSizes(TWinControl(Child));
5207 end;
5208end;
5209
5210procedure TORAutoPanel.Loaded;
5211{ record initial size & position info for resizing logic }
5212begin
5213 inherited Loaded;
5214 if csDesigning in ComponentState then Exit; // only want auto-resizing at run time
5215 FSizes := TList.Create;
5216 BuildSizes(Self);
5217end;
5218
5219procedure TORAutoPanel.DoResize(Control: TWinControl; var CurrentIndex: Integer);
5220var
5221 i, H, W: Integer;
5222 SizeRatio: TSizeRatio;
5223 Child: TControl;
5224begin
5225 H := ClientHeight;
5226 W := ClientWidth;
5227 for i := 0 to Control.ControlCount - 1 do
5228 begin
5229 Child := Control.Controls[i];
5230 if CurrentIndex = FSizes.Count then break;
5231// raise Exception.Create('Error while Sizing Auto-Size Panel');
5232 SizeRatio := FSizes[CurrentIndex];
5233 inc(CurrentIndex);
5234 with SizeRatio do begin
5235 if (Child is TLabel) or (Child is TStaticText) then
5236 Child.SetBounds(Round(CLeft * W), Round(CTop * H), Child.Width, Child.Height)
5237 else
5238 Child.SetBounds(Round(CLeft * W), Round(CTop * H), Round(CWidth * W), Round(CHeight * H));
5239 end;
5240 if Child is TGroupBox then
5241 DoResize(TwinControl(Child), CurrentIndex);
5242 end;
5243end;
5244
5245procedure TORAutoPanel.Resize;
5246{ resize child controls using their design time proportions }
5247var
5248 i: Integer;
5249begin
5250 inherited Resize;
5251 if csDesigning in ComponentState then Exit; // only want auto-resizing at run time
5252 i := 0;
5253 DoResize(Self, i);
5254end;
5255
5256{ TOROffsetLabel --------------------------------------------------------------------------- }
5257
5258constructor TOROffsetLabel.Create(AOwner: TComponent);
5259{ create the label with the default of Transparent = False and Offset = 2}
5260begin
5261 inherited Create(AOwner);
5262 ControlStyle := ControlStyle + [csOpaque];
5263 FHorzOffset := 2;
5264 FVertOffset := 2;
5265end;
5266
5267procedure TOROffsetLabel.CMTextChanged(var Message: TMessage);
5268{ resize whenever the label caption changes }
5269begin
5270 inherited;
5271 AdjustSizeOfSelf;
5272end;
5273
5274procedure TOROffsetLabel.CMFontChanged(var Message: TMessage);
5275{ resize whenever the label font changes }
5276begin
5277 inherited;
5278 AdjustSizeOfSelf;
5279end;
5280
5281procedure TOROffsetLabel.AdjustSizeOfSelf;
5282{ using the current font, call DrawText to calculate the rectangle size for the label }
5283var
5284 DC: HDC;
5285 Flags: Word;
5286 ARect: TRect;
5287begin
5288 if not (csReading in ComponentState) then
5289 begin
5290 DC := GetDC(0);
5291 Canvas.Handle := DC;
5292 ARect := ClientRect;
5293 Flags := DT_EXPANDTABS or DT_CALCRECT;
5294 if FWordWrap then Flags := Flags or DT_WORDBREAK;
5295 DoDrawText(ARect, Flags); // returns size of text rect
5296 Canvas.Handle := 0;
5297 ReleaseDC(0, DC);
5298 // add alignment property later?
5299 SetBounds(Left, Top, ARect.Right + FHorzOffset, ARect.Bottom + FVertOffset); // add offsets
5300 end;
5301end;
5302
5303procedure TOROffsetLabel.DoDrawText(var Rect: TRect; Flags: Word);
5304{ call drawtext to paint or calculate the size of the text in the caption property }
5305var
5306 Text: string;
5307begin
5308 Text := Caption;
5309 Canvas.Font := Font;
5310 if not Enabled then Canvas.Font.Color := clGrayText;
5311 DrawText(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags);
5312end;
5313
5314procedure TOROffsetLabel.Paint;
5315{ set the background characterictics, add the offsets, and paint the text }
5316var
5317 ARect: TRect;
5318 Flags: Word;
5319begin
5320 with Canvas do
5321 begin
5322 if not Transparent then
5323 begin
5324 Brush.Color := Self.Color;
5325 Brush.Style := bsSolid;
5326 FillRect(ClientRect);
5327 end;
5328 Brush.Style := bsClear;
5329 ARect := ClientRect;
5330 Inc(ARect.Left, FHorzOffset);
5331 Inc(ARect.Top, FVertOffset);
5332 Flags := DT_EXPANDTABS or DT_NOPREFIX or DT_LEFT;
5333 if FWordWrap then Flags := Flags or DT_WORDBREAK;
5334 DoDrawText(ARect, Flags);
5335 end;
5336end;
5337
5338function TOROffsetLabel.GetTransparent: Boolean;
5339{ returns true if the control style is not opaque }
5340begin
5341 if csOpaque in ControlStyle then Result := False else Result := True;
5342end;
5343
5344procedure TOROffsetLabel.SetTransparent(Value: Boolean);
5345{ if true, removes Opaque from the control style }
5346begin
5347 if Value <> Transparent then
5348 begin
5349 if Value
5350 then ControlStyle := ControlStyle - [csOpaque] // transparent = true
5351 else ControlStyle := ControlStyle + [csOpaque]; // transparent = false
5352 Invalidate;
5353 end;
5354end;
5355
5356procedure TOROffsetLabel.SetVertOffset(Value: Integer);
5357{ adjusts the size of the label whenever the vertical offset of the label changes }
5358begin
5359 FVertOffset := Value;
5360 AdjustSizeOfSelf;
5361end;
5362
5363procedure TOROffsetLabel.SetHorzOffset(Value: Integer);
5364{ adjusts the size of the label whenever the horizontal offset of the label changes }
5365begin
5366 FHorzOffset := Value;
5367 AdjustSizeOfSelf;
5368end;
5369
5370procedure TOROffsetLabel.SetWordWrap(Value: Boolean);
5371{ adjusts the size of the label whenever the word wrap property changes }
5372begin
5373 if FWordWrap <> Value then
5374 begin
5375 FWordWrap := Value;
5376 AdjustSizeOfSelf;
5377 end;
5378end;
5379
5380(*
5381{ TORCalendar }
5382
5383procedure TORCalendar.DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState);
5384{ uses the Calendar that is part of Samples and highlights the current date }
5385var
5386 TheText: string;
5387 CurMonth, CurYear, CurDay: Word;
5388begin
5389 TheText := CellText[ACol, ARow];
5390 with ARect, Canvas do
5391 begin
5392 DecodeDate(Date, CurYear, CurMonth, CurDay);
5393 if (CurYear = Year) and (CurMonth = Month) and (IntToStr(CurDay) = TheText) then
5394 begin
5395 TheText := '[' + TheText + ']';
5396 Font.Style := [fsBold];
5397 end;
5398 TextRect(ARect, Left + (Right - Left - TextWidth(TheText)) div 2,
5399 Top + (Bottom - Top - TextHeight(TheText)) div 2, TheText);
5400 end;
5401end;
5402*)
5403
5404{ TORAlignButton }
5405
5406constructor TORAlignButton.Create(AOwner: TComponent);
5407begin
5408 inherited;
5409 FAlignment := taCenter;
5410 FLayout := tlCenter;
5411 FWordWrap := FALSE;
5412end;
5413
5414procedure TORAlignButton.CreateParams(var Params: TCreateParams);
5415const
5416 ButtonAlignment: array[TAlignment] of DWORD = (BS_LEFT, BS_RIGHT, BS_CENTER);
5417 ButtonWordWrap: array[boolean] of DWORD = (0, BS_MULTILINE);
5418 ButtonLayout: array[TTextLayout] of DWORD = (BS_TOP, BS_VCENTER, BS_BOTTOM);
5419begin
5420 inherited CreateParams(Params);
5421 Params.Style := Params.Style or ButtonAlignment[FAlignment] or
5422 ButtonLayout[FLayout] or
5423 ButtonWordWrap[FWordWrap];
5424end;
5425
5426procedure TORAlignButton.SetAlignment(const Value: TAlignment);
5427begin
5428 if (FAlignment <> Value) then
5429 begin
5430 FAlignment := Value;
5431 RecreateWnd;
5432 end;
5433end;
5434
5435procedure TORAlignButton.SetLayout(const Value: TTextLayout);
5436begin
5437 if (FLayout <> Value) then
5438 begin
5439 FLayout := Value;
5440 RecreateWnd;
5441 end;
5442end;
5443
5444procedure TORAlignButton.SetWordWrap(const Value: boolean);
5445begin
5446 if (FWordWrap <> Value) then
5447 begin
5448 FWordWrap := Value;
5449 RecreateWnd;
5450 end;
5451end;
5452
5453{ TORTreeNode }
5454
5455procedure TORTreeNode.EnsureVisible;
5456var
5457 R: TRect;
5458 DY, LH: integer;
5459
5460begin
5461 MakeVisible;
5462 R := DisplayRect(FALSE);
5463 if (R.Top < 0) then
5464 TreeView.TopItem := Self
5465 else
5466 if (R.Bottom > TreeView.ClientHeight) then
5467 begin
5468 DY := R.Bottom - TreeView.ClientHeight;
5469 LH := R.Bottom - R.Top + 1;
5470 DY := (DY div LH) + 1;
5471 GetORTreeView.SetVertScrollPos(GetORTreeView.GetVertScrollPos + DY);
5472 end;
5473end;
5474
5475function TORTreeNode.GetBold: boolean;
5476var
5477 Item: TTVItem;
5478begin
5479 Result := False;
5480 with Item do
5481 begin
5482 mask := TVIF_STATE;
5483 hItem := ItemId;
5484 if TreeView_GetItem(Handle, Item) then
5485 Result := (state and TVIS_BOLD) <> 0;
5486 end;
5487end;
5488
5489function TORTreeNode.GetORTreeView: TORTreeView;
5490begin
5491 Result := ((inherited TreeView) as TORTreeView);
5492end;
5493
5494function TORTreeNode.GetParent: TORTreeNode;
5495begin
5496 Result := ((inherited Parent) as TORTreeNode);
5497end;
5498
5499function TORTreeNode.GetText: string;
5500begin
5501 Result := inherited Text;
5502end;
5503
5504procedure TORTreeNode.SetBold(const Value: boolean);
5505var
5506 Item: TTVItem;
5507 Template: DWORD;
5508
5509begin
5510 if Value then Template := DWORD(-1)
5511 else Template := 0;
5512 with Item do
5513 begin
5514 mask := TVIF_STATE;
5515 hItem := ItemId;
5516 stateMask := TVIS_BOLD;
5517 state := stateMask and Template;
5518 end;
5519 TreeView_SetItem(Handle, Item);
5520end;
5521
5522procedure TORTreeNode.SetPiece(PieceNum: Integer; const NewPiece: string);
5523begin
5524 with GetORTreeView do
5525 begin
5526 ORCtrls.SetPiece(FStringData, FDelim, PieceNum, NewPiece);
5527 if (PieceNum = FPiece) then
5528 Text := NewPiece;
5529 end;
5530end;
5531
5532procedure TORTreeNode.SetStringData(const Value: string);
5533begin
5534 if (FStringData <> Value) then
5535 begin
5536 FStringData := Value;
5537 with GetORTreeView do
5538 if (FDelim <> #0) and (FPiece > 0) then
5539 inherited Text := Piece(FStringData, FDelim, FPiece);
5540 end;
5541 Caption := Text;
5542end;
5543
5544procedure TORTreeNode.SetText(const Value: string);
5545begin
5546 UpdateText(Value, TRUE);
5547end;
5548
5549procedure TORTreeNode.UpdateText(const Value: string; UpdateData: boolean);
5550begin
5551 inherited Text := Value;
5552 Caption := Text;
5553 if (UpdateData) then
5554 with GetORTreeView do
5555 begin
5556 if (FDelim <> #0) and (FPiece > 0) then
5557 ORCtrls.SetPiece(FStringData, FDelim, FPiece, Value);
5558 end;
5559end;
5560
5561function CalcShortName(LongName: string; PrevLongName: string): string;
5562var
5563 WordBorder: integer;
5564 j: integer;
5565begin
5566 WordBorder := 1;
5567 for j := 1 to Length(LongName) do
5568 begin
5569 if (LongName[j] = ' ') or ((j > 1) and (LongName[j - 1] = ' ')) or
5570 ((j = Length(LongName)) and (j = Length(PrevLongName)) and (LongName[j] = PrevLongName[j])) then
5571 WordBorder := j;
5572 if (j > Length(PrevLongName)) or (LongName[j] <> PrevLongName[j]) then
5573 break;
5574 end;
5575 if WordBorder = 1 then
5576 result := LongName
5577 else if WordBorder = Length(LongName) then
5578 result := 'Same as above (' + LongName + ')'
5579 else
5580 result := Copy(LongName, WordBorder, Length(LongName)) + ' (' + Trim(Copy(LongName, 1, WordBorder - 1)) + ')';
5581end;
5582
5583procedure TORTreeNode.SetCaption(const Value: string);
5584var
5585 TheCaption: string;
5586begin
5587 TheCaption := Value;
5588 with GetORTreeView do
5589 begin
5590 if assigned(OnNodeCaptioning) then
5591 OnNodeCaptioning(self, TheCaption);
5592 if ShortNodeCaptions and (Self.GetPrevSibling <> nil) then
5593 TheCaption := CalcShortName(TheCaption, Self.GetPrevSibling.Text);
5594 end;
5595 FCaption := TheCaption;
5596end;
5597
5598{ TORTreeView }
5599
5600procedure TORTreeView.CNNotify(var Message: TWMNotify);
5601var
5602 DNode: TTreeNode;
5603 DoInh: boolean;
5604
5605begin
5606 DoInh := TRUE;
5607 if (assigned(FOnDragging)) then
5608 begin
5609 with Message do
5610 begin
5611 case NMHdr^.code of
5612 TVN_BEGINDRAG:
5613 begin
5614 with PNMTreeView(Message.NMHdr)^.ItemNew do
5615 begin
5616 if (state and TVIF_PARAM) <> 0 then DNode := Pointer(lParam)
5617 else DNode := Items.GetNode(hItem);
5618 end;
5619 FOnDragging(Self, DNode, DoInh);
5620 if (not DoInh) then
5621 begin
5622 Message.Result := 1;
5623 Selected := DNode;
5624 end;
5625 end;
5626 end;
5627 end;
5628 end;
5629 if (DoInh) then inherited;
5630end;
5631
5632constructor TORTreeView.Create(AOwner: TComponent);
5633begin
5634 inherited;
5635 FDelim := '^';
5636end;
5637
5638function TORTreeView.CreateNode: TTreeNode;
5639begin
5640 Result := TORTreeNode.Create(Items);
5641 if Assigned(OnAddition) then
5642 OnAddition(self, Result);
5643end;
5644
5645function TORTreeView.FindPieceNode(Value: string;
5646 ParentDelim: Char = #0; StartNode: TTreeNode = nil): TORTreeNode;
5647begin
5648 Result := FindPieceNode(Value, FPiece, ParentDelim, StartNode);
5649end;
5650
5651function TORTreeView.FindPieceNode(Value: string; APiece: integer;
5652 ParentDelim: Char = #0; StartNode: TTreeNode = nil): TORTreeNode;
5653var
5654 StartIdx, i: integer;
5655 Node: TORTreeNode;
5656
5657begin
5658 if assigned(StartNode) then
5659 StartIdx := StartNode.AbsoluteIndex + 1
5660 else
5661 StartIdx := 0;
5662 Result := nil;
5663 for i := StartIdx to Items.Count - 1 do
5664 begin
5665 Node := (Items[i] as TORTreeNode);
5666 if (GetNodeID(Node, APiece, ParentDelim) = Value) then
5667 begin
5668 Result := Node;
5669 break;
5670 end;
5671 end;
5672end;
5673
5674function TORTreeView.GetExpandedIDStr(APiece: integer; ParentDelim: char = #0): string;
5675var
5676 i: integer;
5677
5678begin
5679 Result := '';
5680 for i := 0 to Items.Count - 1 do
5681 begin
5682 with (Items[i] as TORTreeNode) do
5683 begin
5684 if (Expanded) then
5685 begin
5686 if (Result <> '') then
5687 Result := Result + FDelim;
5688 Result := Result + GetNodeID(TORTreeNode(Items[i]), APiece, ParentDelim);
5689 end;
5690 end;
5691 end;
5692end;
5693
5694procedure TORTreeView.SetExpandedIDStr(APiece: integer; const Value: string);
5695begin
5696 SetExpandedIDStr(APiece, #0, Value);
5697end;
5698
5699procedure TORTreeView.SetExpandedIDStr(APiece: integer; ParentDelim: char;
5700 const Value: string);
5701var
5702 i: integer;
5703 Top, Sel: TTreeNode;
5704 Node: TORTreeNode;
5705 NList: string;
5706 Srch: string;
5707
5708begin
5709 Items.BeginUpdate;
5710 try
5711 Top := TopItem;
5712 Sel := Selected;
5713 FullCollapse;
5714 Selected := Sel;
5715 NList := Value;
5716 repeat
5717 i := pos(FDelim, NList);
5718 if (i = 0) then i := length(NList) + 1;
5719 Srch := copy(NList, 1, i - 1);
5720 Node := FindPieceNode(Srch, APiece, ParentDelim);
5721 if (assigned(Node)) then
5722 Node.Expand(FALSE);
5723 Nlist := copy(NList, i + 1, MaxInt);
5724 until (NList = '');
5725 TopItem := Top;
5726 Selected := Sel;
5727 finally
5728 Items.EndUpdate;
5729 end;
5730end;
5731
5732function TORTreeView.GetHorzScrollPos: integer;
5733begin
5734 Result := GetScrollPos(Handle, SB_HORZ);
5735end;
5736
5737function TORTreeView.GetVertScrollPos: integer;
5738begin
5739 Result := GetScrollPos(Handle, SB_VERT);
5740end;
5741
5742procedure TORTreeView.RenameNodes;
5743var
5744 i: integer;
5745
5746begin
5747 if (FDelim <> #0) and (FPiece > 0) then
5748 begin
5749 for i := 0 to Items.Count - 1 do
5750 with (Items[i] as TORTreeNode) do
5751 UpdateText(Piece(FStringData, FDelim, FPiece), FALSE);
5752 end;
5753end;
5754
5755procedure TORTreeView.SetNodeDelim(const Value: Char);
5756begin
5757 if (FDelim <> Value) then
5758 begin
5759 FDelim := Value;
5760 RenameNodes;
5761 end;
5762end;
5763
5764procedure TORTreeView.SetHorzScrollPos(Value: integer);
5765begin
5766 if (Value < 0) then Value := 0;
5767 Perform(WM_HSCROLL, MakeWParam(SB_THUMBPOSITION, Value), 0);
5768end;
5769
5770procedure TORTreeView.SetNodePiece(const Value: integer);
5771begin
5772 if (FPiece <> Value) then
5773 begin
5774 FPiece := Value;
5775 RenameNodes;
5776 end;
5777end;
5778
5779procedure TORTreeView.SetVertScrollPos(Value: integer);
5780begin
5781 if (Value < 0) then Value := 0;
5782 Perform(WM_VSCROLL, MakeWParam(SB_THUMBPOSITION, Value), 0);
5783end;
5784
5785function TORTreeView.GetNodeID(Node: TORTreeNode;
5786 ParentDelim: Char): string;
5787begin
5788 Result := GetNodeID(Node, FPiece, ParentDelim);
5789end;
5790
5791function TORTreeView.GetNodeID(Node: TORTreeNode; APiece: integer;
5792 ParentDelim: Char): string;
5793begin
5794 if (assigned(Node)) then
5795 begin
5796 Result := Piece(Node.FStringData, FDelim, APiece);
5797 if ((ParentDelim <> #0) and (ParentDelim <> FDelim) and (assigned(Node.Parent))) then
5798 Result := Result + ParentDelim + GetNodeID(Node.Parent, APiece, ParentDelim);
5799 end
5800 else
5801 Result := '';
5802end;
5803
5804procedure TORTreeView.SetShortNodeCaptions(const Value: boolean);
5805begin
5806 FShortNodeCaptions := Value;
5807 RenameNodes;
5808end;
5809
5810{ TORCBImageIndexes }
5811
5812constructor TORCBImageIndexes.Create(AOwner: TComponent);
5813begin
5814 inherited;
5815 FCheckedEnabledIndex := -1;
5816 FCheckedDisabledIndex := -1;
5817 FGrayedEnabledIndex := -1;
5818 FGrayedDisabledIndex := -1;
5819 FUncheckedEnabledIndex := -1;
5820 FUncheckedDisabledIndex := -1;
5821 FImageChangeLink := TChangeLink.Create;
5822 FImageChangeLink.OnChange := ImageListChanged;
5823end;
5824
5825destructor TORCBImageIndexes.Destroy;
5826begin
5827 FImageChangeLink.Free;
5828 inherited;
5829end;
5830
5831procedure TORCBImageIndexes.SetImages(const Value: TCustomImageList);
5832begin
5833 if FImages <> nil then FImages.UnRegisterChanges(FImageChangeLink);
5834 FImages := Value;
5835 if FImages <> nil then
5836 begin
5837 FImages.RegisterChanges(FImageChangeLink);
5838 FImages.FreeNotification(Self);
5839 end;
5840 ImageListChanged(Self);
5841end;
5842
5843function TORCBImageIndexes.IdxString: string;
5844 function RStr(Value: integer): string;
5845 begin
5846 if (Value <> -1) then
5847 Result := IntToStr(Value)
5848 else
5849 Result := '';
5850 Result := Result + ',';
5851 end;
5852
5853begin
5854 Result := RStr(FCheckedEnabledIndex) +
5855 RStr(FGrayedEnabledIndex) +
5856 RStr(FUncheckedEnabledIndex) +
5857 RStr(FCheckedDisabledIndex) +
5858 RStr(FGrayedDisabledIndex) +
5859 RStr(FUncheckedDisabledIndex);
5860 delete(Result, length(Result), 1);
5861 if (Result = ',,,,,') then Result := '';
5862end;
5863
5864procedure TORCBImageIndexes.SetIdxString(Value: string);
5865var
5866 i, j, v: integer;
5867 Sub: string;
5868
5869begin
5870 if (Value = '') then
5871 begin
5872 FCheckedEnabledIndex := -1;
5873 FGrayedEnabledIndex := -1;
5874 FUncheckedEnabledIndex := -1;
5875 FCheckedDisabledIndex := -1;
5876 FGrayedDisabledIndex := -1;
5877 FUncheckedDisabledIndex := -1;
5878 end
5879 else
5880 begin
5881 i := 0;
5882 Sub := Value;
5883 repeat
5884 j := pos(',', Sub);
5885 if (j = 0) then j := length(Sub) + 1;
5886 v := StrToIntDef(copy(Sub, 1, j - 1), -1);
5887 case i of
5888 0: FCheckedEnabledIndex := v;
5889 1: FGrayedEnabledIndex := v;
5890 2: FUncheckedEnabledIndex := v;
5891 3: FCheckedDisabledIndex := v;
5892 4: FGrayedDisabledIndex := v;
5893 5: FUncheckedDisabledIndex := v;
5894 end;
5895 inc(i);
5896 Sub := copy(Sub, j + 1, MaxInt);
5897 until (Sub = '');
5898 end;
5899end;
5900
5901procedure TORCBImageIndexes.ImageListChanged(Sender: TObject);
5902begin
5903 if (Owner is TWinControl) then
5904 (Owner as TWinControl).Invalidate;
5905end;
5906
5907procedure TORCBImageIndexes.Notification(AComponent: TComponent; Operation: TOperation);
5908begin
5909 inherited Notification(AComponent, Operation);
5910 if (AComponent = FImages) and (Operation = opRemove) then SetImages(nil);
5911end;
5912
5913procedure TORCBImageIndexes.SetCheckedDisabledIndex(const Value: integer);
5914begin
5915 if (FCheckedDisabledIndex <> Value) then
5916 begin
5917 FCheckedDisabledIndex := Value;
5918 ImageListChanged(Self);
5919 end;
5920end;
5921
5922procedure TORCBImageIndexes.SetCheckedEnabledIndex(const Value: integer);
5923begin
5924 if (FCheckedEnabledIndex <> Value) then
5925 begin
5926 FCheckedEnabledIndex := Value;
5927 ImageListChanged(Self);
5928 end;
5929end;
5930
5931procedure TORCBImageIndexes.SetGrayedDisabledIndex(const Value: integer);
5932begin
5933 if (FGrayedDisabledIndex <> Value) then
5934 begin
5935 FGrayedDisabledIndex := Value;
5936 ImageListChanged(Self);
5937 end;
5938end;
5939
5940procedure TORCBImageIndexes.SetGrayedEnabledIndex(const Value: integer);
5941begin
5942 if (FGrayedEnabledIndex <> Value) then
5943 begin
5944 FGrayedEnabledIndex := Value;
5945 ImageListChanged(Self);
5946 end;
5947end;
5948
5949procedure TORCBImageIndexes.SetUncheckedDisabledIndex(const Value: integer);
5950begin
5951 if (FUncheckedDisabledIndex <> Value) then
5952 begin
5953 FUncheckedDisabledIndex := Value;
5954 ImageListChanged(Self);
5955 end;
5956end;
5957
5958procedure TORCBImageIndexes.SetUncheckedEnabledIndex(const Value: integer);
5959begin
5960 if (FUncheckedEnabledIndex <> Value) then
5961 begin
5962 FUncheckedEnabledIndex := Value;
5963 ImageListChanged(Self);
5964 end;
5965end;
5966
5967{ TORCheckBox }
5968
5969constructor TORCheckBox.Create(AOwner: TComponent);
5970begin
5971 CreateCommon(AOwner);
5972 FCustomImages := TORCBImageIndexes.Create(Self);
5973 FCustomImagesOwned := TRUE;
5974 FAllowAllUnchecked := TRUE;
5975end;
5976
5977constructor TORCheckBox.ListViewCreate(AOwner: TComponent; ACustomImages: TORCBImageIndexes);
5978begin
5979 CreateCommon(AOwner);
5980 FCustomImages := ACustomImages;
5981 FCustomImagesOwned := FALSE;
5982end;
5983
5984procedure TORCheckBox.CreateCommon(AOwner: TComponent);
5985begin
5986 inherited Create(AOwner);
5987 FGrayedToChecked := TRUE;
5988 FCanvas := TCanvas.Create;
5989end;
5990
5991destructor TORCheckBox.Destroy;
5992begin
5993 if (FCustomImagesOwned) then FCustomImages.Free;
5994 FCanvas.Free;
5995 inherited;
5996end;
5997
5998
5999function TORCheckBox.GetImageIndexes: string;
6000begin
6001 Result := FCustomImages.IdxString;
6002end;
6003
6004function TORCheckBox.GetImageList: TCustomImageList;
6005begin
6006 Result := FCustomImages.FImages;
6007end;
6008
6009procedure TORCheckBox.SetImageIndexes(const Value: string);
6010begin
6011 FCustomImages.SetIdxString(Value);
6012end;
6013
6014procedure TORCheckBox.SetImageList(const Value: TCustomImageList);
6015begin
6016 FCustomImages.SetImages(Value);
6017end;
6018
6019procedure TORCheckBox.Toggle;
6020begin
6021 if (FGrayedToChecked) then
6022 begin
6023 case State of
6024 cbUnchecked:
6025 if AllowGrayed then State := cbGrayed else State := cbChecked;
6026 cbChecked: State := cbUnchecked;
6027 cbGrayed: State := cbChecked;
6028 end;
6029 end
6030 else
6031 begin
6032 case State of
6033 cbUnchecked: State := cbChecked;
6034 cbChecked: if AllowGrayed then State := cbGrayed else State := cbUnchecked;
6035 cbGrayed: State := cbUnchecked;
6036 end;
6037 end;
6038end;
6039
6040procedure TORCheckBox.CreateParams(var Params: TCreateParams);
6041begin
6042 inherited CreateParams(Params);
6043 Params.Style := (Params.Style and (not BS_3STATE)) or BS_OWNERDRAW;
6044end;
6045
6046procedure TORCheckBox.CMEnabledChanged(var Message: TMessage);
6047begin
6048 inherited;
6049 Invalidate;
6050end;
6051
6052procedure TORCheckBox.CMFontChanged(var Message: TMessage);
6053begin
6054 inherited;
6055 Invalidate;
6056end;
6057
6058procedure TORCheckBox.CNDrawItem(var Message: TWMDrawItem);
6059begin
6060 DrawItem(Message.DrawItemStruct^);
6061end;
6062
6063procedure TORCheckBox.CNMeasureItem(var Message: TWMMeasureItem);
6064begin
6065 with Message.MeasureItemStruct^ do
6066 begin
6067 itemWidth := Width;
6068 itemHeight := Height;
6069 end;
6070end;
6071
6072procedure TORCheckBox.GetDrawData(CanvasHandle: HDC; var Bitmap: TBitmap;
6073 var FocRect, Rect: TRect;
6074 var DrawOptions: UINT;
6075 var TempBitMap: boolean);
6076var
6077 i, l, TxtHeight, TxtWidth, AWidth: Integer;
6078 ImgIdx: TORCBImgIdx;
6079 CustomImgIdx: integer;
6080
6081begin
6082 BitMap := nil;
6083 TempBitMap := FALSE;
6084 DrawOptions := DT_LEFT;
6085 FSingleLine := TRUE;
6086
6087 if (not (csDestroying in ComponentState)) then
6088 begin
6089 with FCustomImages do
6090 begin
6091 FCanvas.Handle := CanvasHandle;
6092 try
6093 Rect := ClientRect;
6094 with FCanvas do
6095 begin
6096 CustomImgIdx := -1;
6097 if (assigned(FImages)) then
6098 begin
6099 if (Enabled or (csDesigning in ComponentState)) then
6100 begin
6101 case State of
6102 cbChecked: CustomImgIdx := FCheckedEnabledIndex;
6103 cbUnChecked: CustomImgIdx := FUncheckedEnabledIndex;
6104 cbGrayed: CustomImgIdx := FGrayedEnabledIndex;
6105 end;
6106 end
6107 else
6108 begin
6109 case State of
6110 cbChecked: CustomImgIdx := FCheckedDisabledIndex;
6111 cbUnChecked: CustomImgIdx := FUncheckedDisabledIndex;
6112 cbGrayed: CustomImgIdx := FGrayedDisabledIndex;
6113 end;
6114 end;
6115 if ((CustomImgIdx < 0) or (CustomImgIdx >= FImages.Count)) then
6116 CustomImgIdx := -1;
6117 end;
6118 if (CustomImgIdx < 0) then
6119 begin
6120 ImgIdx := iiChecked;
6121 if (Enabled or (csDesigning in ComponentState)) then
6122 begin
6123 if (FRadioStyle) then
6124 begin
6125 if State = cbChecked then
6126 ImgIdx := iiRadioChecked
6127 else
6128 ImgIdx := iiRadioUnchecked;
6129 end
6130 else
6131 begin
6132 case State of
6133 cbChecked: ImgIdx := iiChecked;
6134 cbUnChecked: ImgIdx := iiUnchecked;
6135 cbGrayed:
6136 begin
6137 case FGrayedStyle of
6138 gsNormal: ImgIdx := iiGrayed;
6139 gsQuestionMark: ImgIdx := iiQMark;
6140 gsBlueQuestionMark: ImgIdx := iiBlueQMark;
6141 end;
6142 end;
6143 end;
6144 end;
6145 end
6146 else
6147 begin
6148 if (FRadioStyle) then
6149 begin
6150 if State = cbChecked then
6151 ImgIdx := iiRadioDisChecked
6152 else
6153 ImgIdx := iiRadioDisUnchecked;
6154 end
6155 else
6156 begin
6157 case State of
6158 cbChecked: ImgIdx := iiDisChecked;
6159 cbUnChecked: ImgIdx := iiDisUnchecked;
6160 cbGrayed:
6161 begin
6162 if (FGrayedStyle = gsNormal) then
6163 ImgIdx := iiDisGrayed
6164 else
6165 ImgIdx := iiDisQMark;
6166 end;
6167 end;
6168 end;
6169 end;
6170 Bitmap := GetORCBBitmap(ImgIdx, FBlackColorMode);
6171 end
6172 else
6173 begin
6174 Bitmap := TBitmap.Create;
6175 FImages.GetBitmap(CustomImgIdx, Bitmap);
6176 TempBitMap := TRUE;
6177 end;
6178 Brush.Style := bsClear;
6179 Font := Self.Font;
6180
6181 if Alignment = taLeftJustify then
6182 Rect.Left := 2
6183 else
6184 Rect.Left := Bitmap.Width + 5;
6185
6186 if (FWordWrap) then
6187 DrawOptions := DrawOptions or DT_WORDBREAK
6188 else
6189 DrawOptions := DrawOptions or DT_VCENTER or DT_SINGLELINE;
6190
6191 if (FWordWrap) then
6192 begin
6193 if Alignment = taLeftJustify then
6194 Rect.Right := Width - Bitmap.Width - 3
6195 else
6196 Rect.Right := Width;
6197 Rect.Top := 1;
6198 Rect.Bottom := Height + 1;
6199 dec(Rect.Right);
6200 FocRect := Rect;
6201 TxtHeight := DrawText(Handle, PChar(Caption), Length(Caption), FocRect,
6202 DrawOptions or DT_CALCRECT);
6203 FSingleLine := (TxtHeight = TextHeight(Caption));
6204 Rect.Bottom := Rect.Top + TxtHeight + 1;
6205 FocRect := Rect;
6206 end
6207 else
6208 begin
6209 TxtWidth := TextWidth(Caption);
6210 //Get rid of ampersands that turn into underlines
6211 i := 0;
6212 l := length(Caption);
6213 AWidth := TextWidth('&');
6214 while (i < l) do
6215 begin
6216 inc(i);
6217 // '&&' is an escape char that should display one '&' wide.
6218 // This next part preserves the first '&' but drops all the others
6219 if (Copy(Caption, i, 2) <> '&&') and (Copy(Caption, i, 1) = '&') then
6220 dec(TxtWidth, AWidth);
6221 end;
6222 Rect.Right := Rect.Left + TxtWidth;
6223 TxtHeight := TextHeight(Caption);
6224 if (TxtHeight < Bitmap.Height) then
6225 TxtHeight := Bitmap.Height;
6226 Rect.Top := ((((ClientHeight - TxtHeight) * 5) - 5) div 10);
6227 Rect.Bottom := Rect.Top + TxtHeight + 1;
6228 IntersectRect(FocRect, Rect, ClientRect);
6229 end;
6230 end;
6231 finally
6232 FCanvas.Handle := 0;
6233 end;
6234 end;
6235 end;
6236end;
6237
6238procedure TORCheckBox.DrawItem(const DrawItemStruct: TDrawItemStruct);
6239var
6240 R, FocusRect, TempRect: TRect;
6241 Bitmap: TBitmap;
6242 OldColor: TColor;
6243 DrawOptions: UINT;
6244 TempBitMap: boolean;
6245
6246begin
6247 if (not (csDestroying in ComponentState)) then
6248 begin
6249 GetDrawData(DrawItemStruct.hDC, Bitmap, FocusRect, R, DrawOptions, TempBitMap);
6250 try
6251 FCanvas.Handle := DrawItemStruct.hDC;
6252 try
6253 with FCanvas do
6254 begin
6255 Brush.Color := Self.Color;
6256 Brush.Style := bsSolid;
6257 InflateRect(R, 1, 1);
6258 FillRect(R);
6259 InflateRect(R, -1, -1);
6260
6261 Brush.Style := bsClear;
6262 Font := Self.Font;
6263
6264 if (Enabled or (csDesigning in ComponentState)) then
6265 begin
6266 DrawText(Handle, PChar(Caption), Length(Caption), FocusRect, DrawOptions);
6267 end
6268 else
6269 begin
6270 OldColor := Font.Color;
6271 try
6272 if Ctl3D then
6273 begin
6274 OffsetRect(FocusRect, 1, 1);
6275 Font.Color := clBtnHighlight;
6276 DrawText(Handle, PChar(Caption), Length(Caption), FocusRect, DrawOptions);
6277 OffsetRect(FocusRect, -1, -1);
6278 end;
6279 Font.Color := clGrayText;
6280 DrawText(Handle, PChar(Caption), Length(Caption), FocusRect, DrawOptions);
6281 finally
6282 Font.Color := OldColor;
6283 end;
6284
6285 Brush.Color := Self.Color;
6286 Brush.Style := bsSolid;
6287 end;
6288
6289 if ((DrawItemStruct.itemState and ODS_FOCUS) <> 0) then
6290 begin
6291 InflateRect(FocusRect, 1, 1);
6292 if (FFocusOnBox) then
6293 //TempRect := Rect(0, 0, CheckWidth - 1, CheckWidth - 1)
6294 TempRect := Rect(0, 0, CheckWidth + 2, CheckWidth + 5)
6295 else
6296 TempRect := FocusRect;
6297 //UnionRect(Temp2Rect,ClipRect,TempRect);
6298 //ClipRect := Temp2Rect;
6299 Pen.Color := clWindowFrame;
6300 Brush.Color := clBtnFace;
6301 DrawFocusRect(TempRect);
6302 InflateRect(FocusRect, -1, -1);
6303 end;
6304
6305 if Alignment = taLeftJustify then
6306 R.Left := ClientWidth - Bitmap.Width
6307 else
6308 R.Left := 0;
6309 if (FWordWrap) then
6310 R.Top := FocusRect.Top
6311 else
6312 begin
6313 R.Top := ((ClientHeight - Bitmap.Height + 1) div 2) - 1;
6314 if R.Top < 0 then R.Top := 0
6315 end;
6316 Draw(R.Left, R.Top, Bitmap);
6317 end;
6318 finally
6319 FCanvas.Handle := 0;
6320 end;
6321 finally
6322 if (TempBitMap) then
6323 Bitmap.Free;
6324 end;
6325 end;
6326end;
6327
6328procedure TORCheckBox.SetGrayedStyle(Value: TGrayedStyle);
6329begin
6330 if (FGrayedStyle <> Value) then
6331 begin
6332 FGrayedStyle := Value;
6333 if (State = cbGrayed) then Invalidate;
6334 end;
6335end;
6336
6337procedure TORCheckBox.WMLButtonDblClk(var Message: TWMLButtonDblClk);
6338begin
6339 Perform(WM_LBUTTONDOWN, Message.Keys, Longint(Message.Pos));
6340end;
6341
6342procedure TORCheckBox.WMSize(var Message: TWMSize);
6343begin
6344 inherited;
6345 if (FSizable) and (csDesigning in ComponentState) then
6346 AutoAdjustSize;
6347end;
6348
6349procedure TORCheckBox.BMSETCHECK(var Message: TMessage);
6350var
6351 cnt, i: integer;
6352 cb: TORCheckBox;
6353 Chk: boolean;
6354
6355begin
6356 Message.Result := 0;
6357
6358 if (assigned(Parent) and (FGroupIndex <> 0)) then
6359 begin
6360 Chk := Checked;
6361 if (Chk or (not FAllowAllUnchecked)) then
6362 begin
6363 cnt := 0;
6364 for i := 0 to Parent.ControlCount - 1 do
6365 begin
6366 if (Parent.Controls[i] is TORCheckBox) then
6367 begin
6368 cb := TORCheckBox(Parent.Controls[i]);
6369 if (cb <> Self) then
6370 begin
6371 if (cb.Checked and (cb.FGroupIndex = FGroupIndex)) then
6372 begin
6373 if Chk then
6374 cb.Checked := FALSE
6375 else
6376 inc(cnt);
6377 end;
6378 end;
6379 end;
6380 end;
6381 if (not Chk) and (Cnt = 0) then
6382 Checked := TRUE;
6383 end;
6384 end;
6385 UpdateAssociate;
6386 Invalidate;
6387end;
6388
6389procedure TORCheckBox.SetWordWrap(const Value: boolean);
6390begin
6391 if (FWordWrap <> Value) then
6392 begin
6393 FWordWrap := Value;
6394 AutoAdjustSize;
6395 invalidate;
6396 end;
6397end;
6398
6399procedure TORCheckBox.SetAutoSize(Value: boolean);
6400begin
6401 if (FAutoSize <> Value) then
6402 begin
6403 FAutoSize := Value;
6404 AutoAdjustSize;
6405 invalidate;
6406 end;
6407end;
6408
6409procedure TORCheckBox.SetBlackColorMode(Value: boolean);
6410begin
6411 if FBlackColorMode <> Value then
6412 begin
6413 FBlackColorMode := Value;
6414 Invalidate;
6415 end;
6416end;
6417
6418procedure TORCheckBox.AutoAdjustSize;
6419var
6420 R, FocusRect: TRect;
6421 Bitmap: TBitmap;
6422 DrawOptions: UINT;
6423 TempBitMap: boolean;
6424 DC: HDC;
6425 SaveFont: HFont;
6426
6427begin
6428 if (FAutoSize and (([csDestroying, csLoading] * ComponentState) = [])) then
6429 begin
6430 FSizable := TRUE;
6431 DC := GetDC(0);
6432 try
6433 SaveFont := SelectObject(DC, Font.Handle);
6434 try
6435 GetDrawData(DC, Bitmap, FocusRect, R, DrawOptions, TempBitMap);
6436 finally
6437 SelectObject(DC, SaveFont);
6438 end;
6439 finally
6440 ReleaseDC(0, DC);
6441 end;
6442 if (FocusRect.Left <> R.Left) or
6443 (FocusRect.Right <> R.Right) or
6444 (FocusRect.Top <> R.Top) or
6445 (FocusRect.Bottom <> R.Bottom) or
6446 (R.Right <> ClientRect.Right) or
6447 (R.Bottom <> ClientRect.Bottom) then
6448 begin
6449 FocusRect := R;
6450 if Alignment = taLeftJustify then
6451 begin
6452 dec(R.Left, 2);
6453 inc(R.Right, Bitmap.Width + 3);
6454 end
6455 else
6456 dec(R.Left, Bitmap.Width + 5);
6457 Width := R.Right - R.Left + 1;
6458 Height := R.Bottom - R.Top + 2;
6459 end;
6460 end;
6461end;
6462
6463function TORCheckBox.GetCaption: TCaption;
6464begin
6465 Result := inherited Caption;
6466end;
6467
6468procedure TORCheckBox.SetCaption(const Value: TCaption);
6469begin
6470 if (inherited Caption <> Value) then
6471 begin
6472 inherited Caption := Value;
6473 AutoAdjustSize;
6474 invalidate;
6475 end;
6476end;
6477
6478procedure TORCheckBox.SetAllowAllUnchecked(const Value: boolean);
6479begin
6480 FAllowAllUnchecked := Value;
6481 SyncAllowAllUnchecked;
6482end;
6483
6484procedure TORCheckBox.SetGroupIndex(const Value: integer);
6485begin
6486 FGroupIndex := Value;
6487 if (Value <> 0) and (csDesigning in ComponentState) and (not (csLoading in ComponentState)) then
6488 SetRadioStyle(TRUE);
6489 SyncAllowAllUnchecked;
6490end;
6491
6492procedure TORCheckBox.SyncAllowAllUnchecked;
6493var
6494 i: integer;
6495 cb: TORCheckBox;
6496
6497begin
6498 if (assigned(Parent) and (FGroupIndex <> 0)) then
6499 begin
6500 for i := 0 to Parent.ControlCount - 1 do
6501 begin
6502 if (Parent.Controls[i] is TORCheckBox) then
6503 begin
6504 cb := TORCheckBox(Parent.Controls[i]);
6505 if ((cb <> Self) and (cb.FGroupIndex = FGroupIndex)) then
6506 cb.FAllowAllUnchecked := FAllowAllUnchecked;
6507 end;
6508 end;
6509 end;
6510end;
6511
6512procedure TORCheckBox.SetParent(AParent: TWinControl);
6513begin
6514 inherited;
6515 SyncAllowAllUnchecked;
6516end;
6517
6518procedure TORCheckBox.SetRadioStyle(const Value: boolean);
6519begin
6520 FRadioStyle := Value;
6521 Invalidate;
6522end;
6523
6524procedure TORCheckBox.SetAssociate(const Value: TControl);
6525begin
6526 if (FAssociate <> Value) then
6527 begin
6528 if (assigned(FAssociate)) then
6529 FAssociate.RemoveFreeNotification(Self);
6530 FAssociate := Value;
6531 if (assigned(FAssociate)) then
6532 begin
6533 FAssociate.FreeNotification(Self);
6534 UpdateAssociate;
6535 end;
6536 end;
6537end;
6538
6539procedure TORCheckBox.UpdateAssociate;
6540
6541 procedure EnableCtrl(Ctrl: TControl; DoCtrl: boolean);
6542 var
6543 i: integer;
6544 DoIt: boolean;
6545
6546 begin
6547 if DoCtrl then
6548 Ctrl.Enabled := Checked;
6549
6550 // added (csAcceptsControls in Ctrl.ControlStyle) below to prevent disabling of
6551 // child sub controls, like the TBitBtn in the TORComboBox. If the combo box is
6552 // already disabled, we don't want to disable the button as well - when we do, we
6553 // lose the disabled glyph that is stored on that button for the combo box.
6554
6555 if (Ctrl is TWinControl) and (csAcceptsControls in Ctrl.ControlStyle) then
6556 begin
6557 for i := 0 to TWinControl(Ctrl).ControlCount - 1 do
6558 begin
6559 if DoCtrl then
6560 DoIt := TRUE
6561 else
6562 DoIt := (TWinControl(Ctrl).Controls[i] is TWinControl);
6563 if DoIt then
6564 EnableCtrl(TWinControl(Ctrl).Controls[i], TRUE);
6565 end;
6566 end;
6567 end;
6568
6569begin
6570 if (assigned(FAssociate)) then
6571 EnableCtrl(FAssociate, FALSE);
6572end;
6573
6574procedure TORCheckBox.Notification(AComponent: TComponent;
6575 Operation: TOperation);
6576begin
6577 inherited;
6578 if (AComponent = FAssociate) and (Operation = opRemove) then
6579 FAssociate := nil;
6580end;
6581
6582procedure TORCheckBox.SetFocusOnBox(value: boolean);
6583begin
6584 FFocusOnBox := value;
6585 invalidate;
6586end;
6587
6588procedure TORCheckBox.BMGetCheck(var Message: TMessage);
6589begin
6590 {This Allows JAWS to report the state when tabbed into or using the read object
6591 keys (Ins+Tab)}
6592 {if Self.GrayedStyle = gsBlueQuestionMark then
6593 Message.Result := BST_INDETERMINATE
6594 else}
6595 if Self.Checked then
6596 Message.Result := BST_CHECKED
6597 else
6598 Message.Result := BST_UNCHECKED;
6599end;
6600
6601procedure TORCheckBox.BMGetState(var Message: TMessage);
6602begin
6603 //This gives JAWS ability to read state when spacebar is pressed.
6604 //Commented out because JAWS reads states, but inversly. Working with freedom...
6605{ if Self.Checked then
6606 Message.Result := BST_CHECKED
6607 else
6608 Message.Result := BST_UNCHECKED;}
6609end;
6610
6611{ TORListView }
6612
6613procedure TORListView.WMNotify(var Message: TWMNotify);
6614begin
6615 inherited;
6616 with Message.NMHdr^ do
6617 case code of
6618 HDN_BEGINTRACK, HDN_TRACK, HDN_ENDTRACK:
6619 with PHDNotify(Pointer(Message.NMHdr))^, PItem^ do
6620 if (Mask and HDI_WIDTH) <> 0 then
6621 begin
6622 if (Column[Item].MinWidth > 0) and (cxy < Column[Item].MinWidth) then
6623 cxy := Column[Item].MinWidth;
6624 if (Column[Item].MaxWidth > 0) and (cxy > Column[Item].MaxWidth) then
6625 cxy := Column[Item].MaxWidth;
6626 Column[Item].Width := cxy;
6627 end;
6628 end;
6629end;
6630
6631procedure TORListView.LVMSetColumn(var Message: TMessage);
6632var
6633 Changed: boolean;
6634 NewW, idx: integer;
6635
6636begin
6637 Changed := FALSE;
6638 NewW := 0;
6639 idx := 0;
6640 with Message, TLVColumn(pointer(LParam)^) do
6641 begin
6642 if (cx < Column[WParam].MinWidth) then
6643 begin
6644 NewW := Column[WParam].MinWidth;
6645 Changed := TRUE;
6646 idx := WParam;
6647 end;
6648 if (cx > Column[WParam].MaxWidth) then
6649 begin
6650 NewW := Column[WParam].MaxWidth;
6651 Changed := TRUE;
6652 idx := WParam;
6653 end;
6654 end;
6655 inherited;
6656 if (Changed) then
6657 Column[idx].Width := NewW;
6658end;
6659
6660procedure TORListView.LVMSetColumnWidth(var Message: TMessage);
6661var
6662 Changed: boolean;
6663 NewW, idx: integer;
6664
6665begin
6666 Changed := FALSE;
6667 NewW := 0;
6668 idx := 0;
6669 with Message do
6670 begin
6671 if (LParam < Column[WParam].MinWidth) then
6672 begin
6673 LParam := Column[WParam].MinWidth;
6674 Changed := TRUE;
6675 NewW := LParam;
6676 idx := WParam;
6677 end;
6678 if (LParam > Column[WParam].MaxWidth) then
6679 begin
6680 LParam := Column[WParam].MaxWidth;
6681 Changed := TRUE;
6682 NewW := LParam;
6683 idx := WParam;
6684 end;
6685 end;
6686 inherited;
6687 if (Changed) then
6688 Column[idx].Width := NewW;
6689end;
6690
6691{ TORComboPanelEdit }
6692
6693destructor TORComboPanelEdit.Destroy;
6694begin
6695 if (assigned(FCanvas)) then
6696 FCanvas.Free;
6697 inherited;
6698end;
6699
6700procedure TORComboPanelEdit.Paint;
6701var
6702 DC: HDC;
6703 R: TRect;
6704
6705begin
6706 inherited;
6707 if (FFocused) then
6708 begin
6709 if (not assigned(FCanvas)) then
6710 FCanvas := TControlCanvas.Create;
6711 DC := GetWindowDC(Handle);
6712 try
6713 FCanvas.Handle := DC;
6714 R := ClientRect;
6715 InflateRect(R, -1, -1);
6716 FCanvas.DrawFocusRect(R);
6717 finally
6718 ReleaseDC(Handle, DC);
6719 end;
6720 end;
6721end;
6722
6723{ TKeyClickPanel ----------------------------------------------------------------------------- }
6724
6725procedure TKeyClickPanel.KeyDown(var Key: Word; Shift: TShiftState);
6726begin
6727 case Key of
6728 VK_LBUTTON, VK_RETURN, VK_SPACE:
6729 Click;
6730 end;
6731end;
6732
6733{ TKeyClickRadioGroup }
6734
6735procedure TKeyClickRadioGroup.Click;
6736begin
6737 inherited;
6738 TabStop := Enabled and Visible and (ItemIndex = -1);
6739end;
6740
6741constructor TKeyClickRadioGroup.Create(AOwner: TComponent);
6742begin
6743 inherited;
6744 TabStop := Enabled and Visible and (ItemIndex = -1);
6745end;
6746
6747procedure TKeyClickRadioGroup.KeyDown(var Key: Word; Shift: TShiftState);
6748begin
6749 inherited;
6750 case Key of
6751 VK_RETURN, VK_SPACE:
6752 if ItemIndex = -1 then begin
6753 ItemIndex := 0;
6754 Click;
6755 if ControlCount > 0 then begin
6756 TWinControl(Controls[0]).SetFocus;
6757 end;
6758 Key := 0;
6759 end;
6760 end;
6761end;
6762
6763{ TCaptionListBox }
6764
6765procedure TCaptionListBox.DoEnter;
6766begin
6767 inherited;
6768 if HintOnItem then
6769 FHoverItemPos := -1; //CQ: 7178 & 9911 - used as last item index for ListBox
6770end;
6771
6772function TCaptionListBox.GetCaption: string;
6773begin
6774 if not Assigned(FCaptionComponent) then
6775 result := ''
6776 else
6777 result := FCaptionComponent.Caption;
6778end;
6779
6780function TCaptionListBox.GetDynamicProperty(PropertyID: integer): string;
6781begin
6782 if PropertyID = DynaPropAccesibilityCaption then
6783 Result := GetCaption
6784 else
6785 Result := '';
6786end;
6787
6788
6789procedure TCaptionListBox.MoveFocusUp;
6790begin
6791 if ItemIndex > 0 then
6792 Perform(LB_SETCARETINDEX, ItemIndex - 1, 0);
6793end;
6794
6795procedure TCaptionListBox.MoveFocusDown;
6796begin
6797 if ItemIndex < (Items.Count - 1) then
6798 Perform(LB_SETCARETINDEX, ItemIndex + 1, 0);
6799end;
6800
6801procedure TCaptionListBox.SetCaption(const Value: string);
6802begin
6803 if not Assigned(FCaptionComponent) then begin
6804 FCaptionComponent := TStaticText.Create(self);
6805 FCaptionComponent.AutoSize := False;
6806 FCaptionComponent.Height := 0;
6807 FCaptionComponent.Width := 0;
6808 FCaptionComponent.Visible := True;
6809 FCaptionComponent.Parent := Parent;
6810 FCaptionComponent.BringToFront;
6811 end;
6812 FCaptionComponent.Caption := Value;
6813end;
6814
6815function TCaptionListBox.SupportsDynamicProperty(PropertyID: integer): boolean;
6816begin
6817 Result := (PropertyID = DynaPropAccesibilityCaption);
6818end;
6819
6820procedure TCaptionListBox.WMKeyDown(var Message: TWMKeyDown);
6821var
6822 IsSelected: LongBool;
6823begin
6824 if Boolean(Hi(GetKeyState(VK_CONTROL))) and MultiSelect then
6825 case Message.CharCode of
6826 VK_SPACE:
6827 begin
6828 IsSelected := LongBool(Perform(LB_GETSEL, ItemIndex, 0));
6829 Perform(LB_SETSEL, Longint(not IsSelected), ItemIndex);
6830 end;
6831 VK_LEFT, VK_UP: MoveFocusUp;
6832 VK_RIGHT, VK_DOWN: MoveFocusDown;
6833 else inherited;
6834 end
6835 else inherited;
6836end;
6837
6838procedure TCaptionListBox.WMMouseMove(var Message: TWMMouseMove);
6839var
6840 i: integer;
6841begin
6842 inherited;
6843 //CQ: 7178 & 9911 - FHoverItemPos should be set to -1 in OnEnter
6844 //Make the TListBox's hint contain the contents of the listbox Item the mouse is currently over
6845 if HintOnItem then
6846 begin
6847 i := ItemAtPos(Point(Message.XPos, Message.YPos), true);
6848 if i <> FHoverItemPos then
6849 Application.CancelHint;
6850 if i = -1 then
6851 Hint := ''
6852 else
6853 Hint := Items[i];
6854 FHoverItemPos := i;
6855 end;
6856end;
6857
6858procedure TCaptionListBox.WMRButtonUp(var Message: TWMRButtonUp);
6859{ When the RightClickSelect property is true, this routine is used to select an item }
6860var
6861 APoint: TPoint;
6862 i: integer;
6863begin
6864 if FRightClickSelect then with Message do
6865 begin
6866 APoint := Point(XPos, YPos);
6867 // if the mouse was clicked in the client area set ItemIndex...
6868 if PtInRect(ClientRect, APoint) then
6869 begin
6870 ItemIndex := ItemAtPos(APoint, True);
6871 // ...but not if its just going to deselect the current item
6872 if ItemIndex > -1 then
6873 begin
6874 Items.BeginUpdate;
6875 try
6876 if not Selected[ItemIndex] then
6877 for i := 0 to Items.Count - 1 do
6878 Selected[i] := False;
6879 Selected[ItemIndex] := True;
6880 finally
6881 Items.EndUpdate;
6882 end;
6883 end;
6884 end;
6885 end;
6886 inherited;
6887end;
6888
6889{ TCaptionCheckListBox }
6890
6891function TCaptionCheckListBox.GetCaption: string;
6892begin
6893 if not Assigned(FCaptionComponent) then
6894 result := ''
6895 else
6896 result := FCaptionComponent.Caption;
6897end;
6898
6899function TCaptionCheckListBox.GetDynamicProperty(PropertyID: integer): string;
6900begin
6901 if PropertyID = DynaPropAccesibilityCaption then
6902 Result := GetCaption
6903 else
6904 Result := '';
6905end;
6906
6907procedure TCaptionCheckListBox.SetCaption(const Value: string);
6908begin
6909 if not Assigned(FCaptionComponent) then begin
6910 FCaptionComponent := TStaticText.Create(self);
6911 FCaptionComponent.AutoSize := False;
6912 FCaptionComponent.Height := 0;
6913 FCaptionComponent.Width := 0;
6914 FCaptionComponent.Visible := True;
6915 FCaptionComponent.Parent := Parent;
6916 FCaptionComponent.BringToFront;
6917 end;
6918 FCaptionComponent.Caption := Value;
6919end;
6920
6921function TCaptionCheckListBox.SupportsDynamicProperty(
6922 PropertyID: integer): boolean;
6923begin
6924 Result := (PropertyID = DynaPropAccesibilityCaption);
6925end;
6926
6927{ TCaptionMemo }
6928
6929function TCaptionMemo.GetCaption: string;
6930begin
6931 if not Assigned(FCaptionComponent) then
6932 result := ''
6933 else
6934 result := FCaptionComponent.Caption;
6935end;
6936
6937function TCaptionMemo.GetDynamicProperty(PropertyID: integer): string;
6938begin
6939 if PropertyID = DynaPropAccesibilityCaption then
6940 Result := GetCaption
6941 else
6942 Result := '';
6943end;
6944
6945procedure TCaptionMemo.SetCaption(const Value: string);
6946begin
6947 if not Assigned(FCaptionComponent) then begin
6948 FCaptionComponent := TStaticText.Create(self);
6949 FCaptionComponent.AutoSize := False;
6950 FCaptionComponent.Height := 0;
6951 FCaptionComponent.Width := 0;
6952 FCaptionComponent.Visible := True;
6953 FCaptionComponent.Parent := Parent;
6954 FCaptionComponent.BringToFront;
6955 end;
6956 FCaptionComponent.Caption := Value;
6957end;
6958
6959function TCaptionMemo.SupportsDynamicProperty(PropertyID: integer): boolean;
6960begin
6961 Result := (PropertyID = DynaPropAccesibilityCaption);
6962end;
6963
6964{ TCaptionEdit }
6965
6966function TCaptionEdit.GetCaption: string;
6967begin
6968 if not Assigned(FCaptionComponent) then
6969 result := ''
6970 else
6971 result := FCaptionComponent.Caption;
6972end;
6973
6974function TCaptionEdit.GetDynamicProperty(PropertyID: integer): string;
6975begin
6976 if PropertyID = DynaPropAccesibilityCaption then
6977 Result := GetCaption
6978 else
6979 Result := '';
6980end;
6981
6982procedure TCaptionEdit.SetCaption(const Value: string);
6983begin
6984 if not Assigned(FCaptionComponent) then begin
6985 FCaptionComponent := TStaticText.Create(self);
6986 FCaptionComponent.AutoSize := False;
6987 FCaptionComponent.Height := 0;
6988 FCaptionComponent.Width := 0;
6989 FCaptionComponent.Visible := True;
6990 FCaptionComponent.Parent := Parent;
6991 FCaptionComponent.BringToFront;
6992 end;
6993 FCaptionComponent.Caption := Value;
6994end;
6995
6996function TCaptionEdit.SupportsDynamicProperty(PropertyID: integer): boolean;
6997begin
6998 Result := (PropertyID = DynaPropAccesibilityCaption);
6999end;
7000
7001{ TCaptionRichEdit }
7002
7003function TCaptionRichEdit.GetDynamicProperty(PropertyID: integer): string;
7004begin
7005 if PropertyID = DynaPropAccesibilityCaption then
7006 Result := FCaption
7007 else
7008 Result := '';
7009end;
7010
7011
7012function TCaptionRichEdit.SupportsDynamicProperty(PropertyID: integer): boolean;
7013begin
7014 Result := (PropertyID = DynaPropAccesibilityCaption);
7015end;
7016
7017{ TCaptionTreeView}
7018
7019function TCaptionTreeView.GetCaption: string;
7020begin
7021 result := inherited Caption;
7022end;
7023
7024function TCaptionTreeView.GetDynamicProperty(PropertyID: integer): string;
7025begin
7026 if PropertyID = DynaPropAccesibilityCaption then
7027 Result := GetCaption
7028 else
7029 Result := '';
7030end;
7031
7032procedure TCaptionTreeView.SetCaption(const Value: string);
7033begin
7034 if not Assigned(FCaptionComponent) then begin
7035 FCaptionComponent := TStaticText.Create(self);
7036 FCaptionComponent.AutoSize := False;
7037 FCaptionComponent.Height := 0;
7038 FCaptionComponent.Width := 0;
7039 FCaptionComponent.Visible := True;
7040 FCaptionComponent.Parent := Parent;
7041 FCaptionComponent.BringToFront;
7042 end;
7043 FCaptionComponent.Caption := Value;
7044 inherited Caption := Value;
7045end;
7046
7047function TCaptionTreeView.SupportsDynamicProperty(PropertyID: integer): boolean;
7048begin
7049 Result := (PropertyID = DynaPropAccesibilityCaption);
7050end;
7051
7052{ TCaptionComboBox }
7053
7054function TCaptionComboBox.GetCaption: string;
7055begin
7056 if not Assigned(FCaptionComponent) then
7057 result := ''
7058 else
7059 result := FCaptionComponent.Caption;
7060end;
7061
7062function TCaptionComboBox.GetDynamicProperty(PropertyID: integer): string;
7063begin
7064 if PropertyID = DynaPropAccesibilityCaption then
7065 Result := GetCaption
7066 else
7067 Result := '';
7068end;
7069
7070procedure TCaptionComboBox.SetCaption(const Value: string);
7071begin
7072 if not Assigned(FCaptionComponent) then begin
7073 FCaptionComponent := TStaticText.Create(self);
7074 FCaptionComponent.AutoSize := False;
7075 FCaptionComponent.Height := 0;
7076 FCaptionComponent.Width := 0;
7077 FCaptionComponent.Visible := True;
7078 FCaptionComponent.Parent := Parent;
7079 FCaptionComponent.BringToFront;
7080 end;
7081 FCaptionComponent.Caption := Value;
7082end;
7083
7084function TCaptionComboBox.SupportsDynamicProperty(PropertyID: integer): boolean;
7085begin
7086 Result := (PropertyID = DynaPropAccesibilityCaption);
7087end;
7088
7089{ TORAlignSpeedButton }
7090
7091procedure TORAlignSpeedButton.Paint;
7092var
7093 Rect: TRect;
7094begin
7095 inherited;
7096 if (Parent <> nil) and (Parent is TKeyClickPanel) and TKeyClickPanel(Parent).Focused then
7097 begin
7098 Rect := ClientRect;
7099 InflateRect(Rect, -3, -3);
7100 Canvas.Brush.Color := Color;
7101 Canvas.DrawFocusRect(Rect);
7102 end;
7103end;
7104
7105{ TCaptionStringGrid }
7106
7107{I may have messed up my Windows.pas file, but mine defines NotifyWinEvent without a stdcall.}
7108procedure GoodNotifyWinEvent; external user32 name 'NotifyWinEvent';
7109
7110function TCaptionStringGrid.ColRowToIndex(Col, Row: Integer): integer;
7111begin
7112 result := (ColCount - FixedCols) * (Row - FixedRows) +
7113 (Col - FixedCols) + 1;
7114end;
7115
7116function TCaptionStringGrid.GetDynamicProperty(PropertyID: integer): string;
7117begin
7118 if PropertyID = DynaPropAccesibilityCaption then
7119 Result := FCaption
7120 else
7121 Result := '';
7122end;
7123
7124procedure TCaptionStringGrid.IndexToColRow(index: integer; var Col,
7125 Row: integer);
7126begin
7127 Row := (index - 1) div (ColCount - FixedCols) + FixedRows;
7128 Col := (index - 1) mod (ColCount - FixedCols) + FixedCols;
7129end;
7130
7131procedure TCaptionStringGrid.KeyUp(var Key: Word; Shift: TShiftState);
7132begin
7133 inherited;
7134 {Look for all of the grid navigation keys}
7135 if (Key in [VK_LEFT, VK_RIGHT, VK_UP, VK_DOWN]) and (Shift = []) or
7136 (Key = VK_TAB) and (Shift <= [ssShift]) then
7137 GoodNotifyWinEvent(EVENT_OBJECT_FOCUS, Handle, integer(OBJID_CLIENT),
7138 ColRowToIndex(Col, Row));
7139end;
7140
7141
7142function TCaptionStringGrid.SupportsDynamicProperty(
7143 PropertyID: integer): boolean;
7144begin
7145 Result := (PropertyID = DynaPropAccesibilityCaption);
7146end;
7147
7148function IsAMouseButtonDown: boolean;
7149begin
7150 if Boolean(Hi(GetKeyState(VK_MBUTTON))) or
7151 Boolean(Hi(GetKeyState(VK_LBUTTON))) or
7152 Boolean(Hi(GetKeyState(VK_RBUTTON))) then
7153 Result := true
7154 else
7155 Result := false;
7156end;
7157
7158procedure TORComboBox.SetNumForMatch(const NumberForMatch: integer);
7159begin
7160 if NumberForMatch < 1 then
7161 FCharsNeedMatch := 1
7162 else if NumberForMatch > 15 then
7163 FCharsNeedMatch := 15
7164 else
7165 FCharsNeedMatch := NumberForMatch;
7166end;
7167
7168procedure TORComboBox.SetUniqueAutoComplete(const Value: Boolean);
7169begin
7170 FUniqueAutoComplete := Value;
7171end;
7172
7173function TORListBox.VerifyUnique(SelectIndex: Integer; iText: string): integer;
7174var
7175 i: integer;
7176 counter: integer;
7177begin
7178 Result := SelectIndex;
7179 if LongList then
7180 begin
7181 //Implemented for CQ: 10092, PSI-04-057
7182 //asume long lists are alphabetically ordered...
7183 if CompareText(iText, Copy(DisplayText[SelectIndex + 1], 1, Length(iText))) = 0 then
7184 Result := -1;
7185 end
7186 else //Not a LongList
7187 begin
7188 counter := 0;
7189 for i := 0 to Items.Count - 1 do
7190 if CompareText(iText, Copy(DisplayText[i], 1, Length(iText))) = 0 then
7191 Inc(counter);
7192 if counter > 1 then
7193 Result := -1;
7194 end;
7195 FFocusIndex := Result;
7196 ItemIndex := Result;
7197end;
7198
7199//This procedure sets the Text property equal to the TextToMatch parameter, then calls
7200//FwdChangeDelayed which will perform an auto-completion on the text.
7201
7202procedure TORComboBox.SetTextAutoComplete(TextToMatch: string);
7203begin
7204 Text := TextToMatch;
7205 SelStart := Length(Text);
7206 FwdChangeDelayed;
7207end;
7208
7209{ TCaptionListView }
7210
7211function TCaptionListView.GetDynamicProperty(PropertyID: integer): string;
7212begin
7213 if PropertyID = DynaPropAccesibilityCaption then
7214 Result := Caption
7215 else
7216 Result := '';
7217end;
7218
7219function TCaptionListView.SupportsDynamicProperty(PropertyID: integer): boolean;
7220begin
7221 Result := (PropertyID = DynaPropAccesibilityCaption);
7222end;
7223
7224initialization
7225 //uItemTip := TItemTip.Create(Application); // all listboxes share a single ItemTip window
7226 uItemTipCount := 0;
7227 uNewStyle := Lo(GetVersion) >= 4; // True = Win95 interface, otherwise old interface
7228 FillChar(ORCBImages, SizeOf(ORCBImages), 0);
7229
7230finalization
7231 //uItemTip.Free; // don't seem to need this - called by Application
7232 DestroyORCBBitmaps;
7233
7234end.
7235
Note: See TracBrowser for help on using the repository browser.