diff --git a/components/orpheus/ORBLUEDOT.bmp b/components/orpheus/ORBLUEDOT.bmp new file mode 100644 index 000000000..60a689de9 Binary files /dev/null and b/components/orpheus/ORBLUEDOT.bmp differ diff --git a/components/orpheus/ORBTNCLC.bmp b/components/orpheus/ORBTNCLC.bmp new file mode 100644 index 000000000..1629a542d Binary files /dev/null and b/components/orpheus/ORBTNCLC.bmp differ diff --git a/components/orpheus/ORCOLUMNMOVECURSOR.cur b/components/orpheus/ORCOLUMNMOVECURSOR.cur new file mode 100644 index 000000000..643454de8 Binary files /dev/null and b/components/orpheus/ORCOLUMNMOVECURSOR.cur differ diff --git a/components/orpheus/ORREDDOT.bmp b/components/orpheus/ORREDDOT.bmp new file mode 100644 index 000000000..324afd19e Binary files /dev/null and b/components/orpheus/ORREDDOT.bmp differ diff --git a/components/orpheus/ORROWMOVECURSOR.cur b/components/orpheus/ORROWMOVECURSOR.cur new file mode 100644 index 000000000..e8ea822d9 Binary files /dev/null and b/components/orpheus/ORROWMOVECURSOR.cur differ diff --git a/components/orpheus/ORTCCHECKGLYPHS.bmp b/components/orpheus/ORTCCHECKGLYPHS.bmp new file mode 100644 index 000000000..ac2b13173 Binary files /dev/null and b/components/orpheus/ORTCCHECKGLYPHS.bmp differ diff --git a/components/orpheus/ORTCCOMBOARROW.bmp b/components/orpheus/ORTCCOMBOARROW.bmp new file mode 100644 index 000000000..7e71afc69 Binary files /dev/null and b/components/orpheus/ORTCCOMBOARROW.bmp differ diff --git a/components/orpheus/OrphStatus.html b/components/orpheus/OrphStatus.html new file mode 100644 index 000000000..d2147be6b --- /dev/null +++ b/components/orpheus/OrphStatus.html @@ -0,0 +1,570 @@ + + + + + + +Status of Orpheus Port + + + + + + +
+

Status of Orpheus Port

+
+ +
+

Contents

+What's New
+Introduction
+Installation
+Platforms Tested
+Examples
+Porting Philosophy
+Usage Notes
+Limitations
+Status of Individual Controls
+To Do
+Other Resources

+ +

+

What's New

+ + + +
+

Introduction

+ +These notes describe the status of the OrphPort Project, an attempt to +port a subset of TurboPower's Orpheus controls to Lazarus +and Free Pascal. At this time, +several enhanced label controls and most of the table (grid) controls +have been ported. Some of the controls +work quite well on multiple platforms; others need more work or +await better support by the Lazarus LCL or by specific widgetsets before +they are fully functional. The table below gives the status of individual +controls. You are encouraged to work on improving these controls +(see To Do list). Please send your bug reports, suggestions +and patches to:

+ +  MacPgmr (at) fastermac (dot) net

+ +Note: You can also post to the "Ported from Delphi/Kylix" section of the Lazarus +forum if you want your bug reports and suggestions to be seen by the entire +Lazarus community.

+ +The ported source code is here: http://web.fastermac.net/~MacPgmr/OrphPort/downloads

+ +The original Orpheus 4.06 source code that this port was based on is here: + +http://sourceforge.net/projects/tporpheus +(although you don't need this for Lazarus)

+ +TurboPower's 1,392-page Orpheus User's Manual is also available from the Source Forge site.

+ +Note that the ported source remains under the original MPL 1.1 license. + +

+

Installation

+ +
    +
  1. Unzip the ported source files into their own folder. +
  2. Start Lazarus. +
  3. Optionally, choose File | New | Application to make sure Lazarus doesn't +mess up the currently open project. +
  4. Choose Component | Open package file and select orpheus.lpk. +
  5. Click Compile to make sure your version of Lazarus can compile the +Orpheus units. +
  6. Click Install and click Yes when prompted to rebuild the Lazarus IDE. +
  7. After rebuilding is finished, restart Lazarus if it didn't restart +automatically. The installed Orpheus controls will be on the Orpheus tab +of the component palette. +
+ +Important! If you don't have write access to the folder where Lazarus +is installed, you may have problems rebuilding the Lazarus IDE with older +versions of Lazarus. However, if you have a relatively new version of Lazarus, +it will compile itself to the ~/.lazarus/bin folder if you don't have write +access to the Lazarus install folder. After rebuilding, be sure to start +~/.lazarus/bin/lazarus, not the installed Lazarus.

+ +

+

Platforms Tested

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
PlatformOS VersionLibrary VersionsWidgetsets TestedLazarus Version Tested
WindowsXP SP2 win3220070105 snapshot of 0.9.21 with FPC 2.1.1
OS X10.3.9 (Panther) on PowerPCgtk: 1.2.0.9.1
qt: 4.1.4		gtk, carbon, qt20070105 snapshot of 0.9.21 with FPC 2.0.4
LinuxSUSE 10.1gtk: 1.2.10-907gtkStable 0.9.20 with FPC 2.0.4

+ +
+

Examples

+ +The source for several small test applications is included which demonstrates +most of the ported controls. Open each test app's .lpi file and compile it once +Orpheus has been installed in Lazarus. Folders for the test apps are located +in the tests folder in your Orpheus folder, as follows: + + +To see the TOvcSpinner control in action, try out the table's Rows and Columns +property editors with the TestTable app.

+ +Note: The TestTable app uses the included .bmp files to demo the +TOvcTCBitMap control. These bitmap files are not needed to rebuild the Lazarus +IDE since they're in the ovcreg.lrs resource file, but they are +included for completeness.

+ +Tip: The necessary files for compiling the test apps with Delphi are +also included (.dof, .dfm, .bdsproj). If you have Delphi you can compile +the apps to see exactly how the Orpheus controls are supposed to look and +behave. Note that with the free Turbo Delphi Explorer you can't install +Orpheus (a limitation of the free version). However, you can still compile +the test apps, as follows: +

+ +
+

Porting Philosophy

+ + + +
+

Usage Notes

+ +
    +
  1. When you first add an Orpheus control to a form, Lazarus will add +the Orpheus unit to the uses section of your main source file (.lpr). +This pulls in a great deal of code that you don't need. Delete the Orpheus unit +from the uses section to reduce the size of your executable file.

    +

  2. Several of the ported controls are not supported by the GTK widgetset +(see table below). Don't use these controls in cross-platform applications. +Just opening a form that has a TOvcSimpleField or TOvcTCSimpleField control +on it will likely crash the Lazarus IDE with GTK. Use the +TO32FlexEdit and TO32TCFlexEdit controls in place of TOvcSimpleField and +TOvcTCSimpleField controls in cross-platform applications.

    +

  3. To display the TOvcLabel's Style Manager property editor in the Lazarus +IDE, right-click on the TOvcLabel control (Apple key+click on Mac). You can +also change Style Manager properties via the CustomSettings in the +Object Inspector. Also, with GTK, the default clNone Color displays a black +background, so be sure to set ParentColor to True or select a different +Color.

    +

  4. An added benefit of the Orpheus TOvcSpinner control is that it is +available for Delphi too, unlike the LCL TSpinEdit, which has no equivalent +in the Delphi VCL. +
+ +
+

Limitations

+ +
    +
  1. The TO32FlexEdit and TO32TCFlexEdit controls include code for displaying +an optional button within the text editing area. However, this TBitBtn-within- +a-TEdit is not supported by the LCL, so the code has been IFDEF'd out for now. +If this is ever supported by the LCL, defining ButtonOkay in o32flxed.pas +is all that's needed to enable the button code.

    +

  2. Widgetsets generally implement LCL controls by creating native controls +that correspond to the LCL controls (text edit, check box, etc.). However, +Orpheus builds its TOvcSimpleField control from TCustomControl, rather than +descending from an existing edit control such as TCustomEdit. This sort of +edit control does not appear to be supported by the GTK widgetset.

    +

  3. The GTK and Carbon widgetsets do not support TOvcRotatedLabel, apparently +because the GetTextMetrics function is not fully implemented on those +widgetsets. +
+ +
+

Status of Individual Controls

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
ControlVCL / LCL ancestorDescriptionIssues / To-dowin32gtkcarbonqt
TOvcRotatedLabel
TGraphicControlRotated textgtk and carbon don't supportWorkingNot workingNot workingWorking
TOvcLabel
TGraphicControlFancy shading, color and highlightingProperty editor still needs workWorkingWorkingNot workingCrashes
TOvcURL
TCustomLabelLooks and acts like HTML hyperlinkNo TLabel yet on carbonWorkingWorkingNot workingPartial
TOvcSpinner
TCustomControlCan associate with a TEdit; 8 different styles WorkingWorkingCrashesCrashes
TOvcVirtualListBox
TCustomControlTabs, header, huge number of rowsScrolling problemsPartialPartial?Not working
TOvcSimpleField
TCustomControlEdit control with validationgtk doesn't supportWorkingCrashes?Crashes
TO32FlexEdit
TCustomEditEdit control with validationSee "To Do" listWorkingWorkingCrashesWorking
TOvcTable
TCustomControlFull-featured grid controlSee "To Do" listWorkingWorking??
TOvcTCColHead
TComponentTable column headings WorkingWorking??
TOvcTCRowHead
TComponentTable row headings WorkingWorking??
TOvcTCString
TComponent
(edits with TEdit)		Table cell for editing strings WorkingWorking??
TOvcTCSimpleField
TComponent
(edits with TOvcSimpleField)		Table cell for editing strings, with validationgtk doesn't supportWorkingCrashes??
TOvcTCMemo
TComponent
(edits with TMemo)		Table cell for editing memo text WorkingWorking??
TOvcTCCheckBox
TComponent
(edits with TCustomControl)		Table cell for check box WorkingWorking??
TOvcTCComboBox
TComponent
(edits with TComboBox)		Table cell for combo boxDropdown problem w/o XP manifestWorkingWorking??
TOvcTCBitmap
TComponentTable cell for displaying bitmap WorkingWorking??
TOvcTCGlyph
TComponentTable cell for cycling thru glyphs Working?Working???
TOvcTCIcon
TComponentTable cell for displaying icon Working?Working???
TO32TCFlexEdit
TComponent
(edits with TO32FlexEdit)		Table cell for editing strings, with validation WorkingWorking??
TOvcController
TComponentKey-to-command translatorProperty editor uses TTabSet????
+
+ +Notes:
+(1) "Working" means control is basically functional. "Partial" means +control compiles, installs in IDE and displays at run-time, but doesn't function +correctly. "Not working" means control compiles and installs in IDE but +doesn't display correctly. "Widgetset doesn't support" means the widgetset +currently does not provide the support needed for the control.
+(2) TOvcSimpleField and TOvcTable require a TOvcController on form. +However, TO32FlexEdit doesn't need TOvcController.

+ +

+

To Do

+ + +
+

Other Resources

+ +Qt widgetset status:

+http://wiki.lazarus.freepascal.org/Qt_Interface

+ +Carbon widgetset status:

+http://wiki.lazarus.freepascal.org/Carbon_Interface

+ +OS X tips for Lazarus:

+http://wiki.lazarus.freepascal.org/OS_X_Programming_Tips

+ +

+

+Last updated: Jan. 07, 2007 +

+ + + + diff --git a/components/orpheus/README.txt b/components/orpheus/README.txt new file mode 100644 index 000000000..5bce555ad --- /dev/null +++ b/components/orpheus/README.txt @@ -0,0 +1,5 @@ + +This is the Lazarus port of a subset of Orpheus controls. + +See OrphStatus.html for more information. + diff --git a/components/orpheus/TO32FLEXEDIT.bmp b/components/orpheus/TO32FLEXEDIT.bmp new file mode 100644 index 000000000..e8f077945 Binary files /dev/null and b/components/orpheus/TO32FLEXEDIT.bmp differ diff --git a/components/orpheus/TO32TCFLEXEDIT.bmp b/components/orpheus/TO32TCFLEXEDIT.bmp new file mode 100644 index 000000000..47eb1a620 Binary files /dev/null and b/components/orpheus/TO32TCFLEXEDIT.bmp differ diff --git a/components/orpheus/TOVCCONTROLLER.bmp b/components/orpheus/TOVCCONTROLLER.bmp new file mode 100644 index 000000000..779c273a9 Binary files /dev/null and b/components/orpheus/TOVCCONTROLLER.bmp differ diff --git a/components/orpheus/TOVCLABEL.bmp b/components/orpheus/TOVCLABEL.bmp new file mode 100644 index 000000000..20f540dd6 Binary files /dev/null and b/components/orpheus/TOVCLABEL.bmp differ diff --git a/components/orpheus/TOVCROTATEDLABEL.bmp b/components/orpheus/TOVCROTATEDLABEL.bmp new file mode 100644 index 000000000..b2f3865cb Binary files /dev/null and b/components/orpheus/TOVCROTATEDLABEL.bmp differ diff --git a/components/orpheus/TOVCSIMPLEFIELD.bmp b/components/orpheus/TOVCSIMPLEFIELD.bmp new file mode 100644 index 000000000..30eb14423 Binary files /dev/null and b/components/orpheus/TOVCSIMPLEFIELD.bmp differ diff --git a/components/orpheus/TOVCSPINNER.bmp b/components/orpheus/TOVCSPINNER.bmp new file mode 100644 index 000000000..63dd1eda0 Binary files /dev/null and b/components/orpheus/TOVCSPINNER.bmp differ diff --git a/components/orpheus/TOVCTABLE.bmp b/components/orpheus/TOVCTABLE.bmp new file mode 100644 index 000000000..4635858f3 Binary files /dev/null and b/components/orpheus/TOVCTABLE.bmp differ diff --git a/components/orpheus/TOVCTCBITMAP.bmp b/components/orpheus/TOVCTCBITMAP.bmp new file mode 100644 index 000000000..67a4e63ed Binary files /dev/null and b/components/orpheus/TOVCTCBITMAP.bmp differ diff --git a/components/orpheus/TOVCTCCHECKBOX.bmp b/components/orpheus/TOVCTCCHECKBOX.bmp new file mode 100644 index 000000000..054e81e7a Binary files /dev/null and b/components/orpheus/TOVCTCCHECKBOX.bmp differ diff --git a/components/orpheus/TOVCTCCOLHEAD.bmp b/components/orpheus/TOVCTCCOLHEAD.bmp new file mode 100644 index 000000000..87a270b9c Binary files /dev/null and b/components/orpheus/TOVCTCCOLHEAD.bmp differ diff --git a/components/orpheus/TOVCTCCOMBOBOX.bmp b/components/orpheus/TOVCTCCOMBOBOX.bmp new file mode 100644 index 000000000..6b48011e6 Binary files /dev/null and b/components/orpheus/TOVCTCCOMBOBOX.bmp differ diff --git a/components/orpheus/TOVCTCGLYPH.bmp b/components/orpheus/TOVCTCGLYPH.bmp new file mode 100644 index 000000000..85f1c5714 Binary files /dev/null and b/components/orpheus/TOVCTCGLYPH.bmp differ diff --git a/components/orpheus/TOVCTCICON.bmp b/components/orpheus/TOVCTCICON.bmp new file mode 100644 index 000000000..8131baf7e Binary files /dev/null and b/components/orpheus/TOVCTCICON.bmp differ diff --git a/components/orpheus/TOVCTCMEMO.bmp b/components/orpheus/TOVCTCMEMO.bmp new file mode 100644 index 000000000..7bc7e8807 Binary files /dev/null and b/components/orpheus/TOVCTCMEMO.bmp differ diff --git a/components/orpheus/TOVCTCROWHEAD.bmp b/components/orpheus/TOVCTCROWHEAD.bmp new file mode 100644 index 000000000..1f0720654 Binary files /dev/null and b/components/orpheus/TOVCTCROWHEAD.bmp differ diff --git a/components/orpheus/TOVCTCSIMPLEFIELD.bmp b/components/orpheus/TOVCTCSIMPLEFIELD.bmp new file mode 100644 index 000000000..cf5d9c516 Binary files /dev/null and b/components/orpheus/TOVCTCSIMPLEFIELD.bmp differ diff --git a/components/orpheus/TOVCTCSTRING.bmp b/components/orpheus/TOVCTCSTRING.bmp new file mode 100644 index 000000000..2add159e2 Binary files /dev/null and b/components/orpheus/TOVCTCSTRING.bmp differ diff --git a/components/orpheus/TOVCURL.bmp b/components/orpheus/TOVCURL.bmp new file mode 100644 index 000000000..d397374d9 Binary files /dev/null and b/components/orpheus/TOVCURL.bmp differ diff --git a/components/orpheus/TOVCVIRTUALLISTBOX.bmp b/components/orpheus/TOVCVIRTUALLISTBOX.bmp new file mode 100644 index 000000000..5d3b35637 Binary files /dev/null and b/components/orpheus/TOVCVIRTUALLISTBOX.bmp differ diff --git a/components/orpheus/mymin.pas b/components/orpheus/mymin.pas new file mode 100644 index 000000000..b40bc941d --- /dev/null +++ b/components/orpheus/mymin.pas @@ -0,0 +1,36 @@ +unit MyMin; + + {Minimum uses to compile all ported runtime and property + editor (design) units. + + Note: Doesn't compile orpheus.pas.} + +interface + +uses + ovctcsim, + ovctcedt, + ovctccbx, + ovctcbox, + ovctcico, + ovctable, + o32tcflx, + o32vpool, + ovcrlbl, + ovcurl, + ovclabel, + ovcsc, + ovcvlb, + ovcclrcb +{$IFDEF FPC}, {These already installed in Delphi} + ovcabot0, + ovclbl0, + ovclbl1, + myovctbpe1, + myovctbpe2, + myovcreg +{$ENDIF}; + +implementation + +end. diff --git a/components/orpheus/mymisc.pas b/components/orpheus/mymisc.pas new file mode 100644 index 000000000..e9aae8c9c --- /dev/null +++ b/components/orpheus/mymisc.pas @@ -0,0 +1,917 @@ +{*********************************************************} +{* mymisc.pas *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is Orpheus for Lazarus Additional Units. *} +{* *} +{* The Initial Developer of the Original Code is Phil Hess. *} +{* *} +{* Portions created by Phil Hess are Copyright (C) 2006 Phil Hess. *} +{* All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +unit MyMisc; + +{ + This unit provides types, constants, and functions that fill + in some gaps in the Lazarus LCL for compiling the ported + Orpheus controls. + + Declarations that have been commented out in the interface + section are no longer needed. It is expected that over time + more of these can be eliminated as the LCL evolves. + + Several of these functions are only used by Orpheus units + that have not yet been ported to Lazarus. For now, these + functions are just stubs on non-Windows platforms, as + indicated in the function comments. +} + +{$I ovc.inc} + +interface + +uses + {$IFDEF MSWINDOWS} Windows, {$ELSE} Types, {$ENDIF} + LclIntf, LMessages, LclType, + {$IFDEF LINUX} FileUtil, {$ENDIF} + GraphType, Graphics, Controls, SysUtils; + +type + TButtonStyle = (bsAutoDetect, bsWin31, bsNew); + + TWMMouse = TLMMouse; + TWMKeyDown = TLMKeyDown; + TWMNCHitTest = TLMNCHitTest; + TWMSetText = TLMSetText; + TCMDesignHitTest = TWMMouse; + TWMChar = TLMChar; + TWMClear = TLMNoParams; + TWMCopy = TLMNoParams; + TWMCut = TLMNoParams; + TWMLButtonDblClk = TLMLButtonDblClk; + TWMLButtonDown = TLMLButtonDown; + TWMLButtonUp = TLMLButtonUp; + TWMRButtonDown = TLMRButtonDown; + TWMSysKeyDown = TLMSysKeyDown; + TWMMouseActivate = packed record + Msg: Cardinal; + TopLevel: HWND; + HitTestCode: Word; + MouseMsg: Word; + Result: Longint; + end; + TWMMouseMove = TLMMouseMove; + TWMPaste = TLMNoParams; + TMessage = TLMessage; + TWMEraseBkgnd = TLMEraseBkgnd; + TWMGetText = TLMGetText; + TWMGetTextLength = TLMGetTextLength; + TWMKillFocus = TLMKillFocus; + TWMSetCursor = packed record + Msg: Cardinal; + CursorWnd: HWND; + HitTest: Word; + MouseMsg: Word; + Result: Longint; + end; + TWMSetFocus = TLMSetFocus; + TWMGetDlgCode = TLMNoParams; + TWMSize = TLMSize; + TWMSetFont = packed record + Msg: Cardinal; + Font: HFONT; + Redraw: WordBool; + Unused: Word; + Result: Longint; + end; + TWMCommand = TLMCommand; + TWMDrawItem = TLMDrawItems; + LPDWORD = PDWORD; + TFNWndEnumProc = TFarProc; + TNonClientMetrics = packed record + cbSize: UINT; + iBorderWidth: Integer; + iScrollWidth: Integer; + iScrollHeight: Integer; + iCaptionWidth: Integer; + iCaptionHeight: Integer; + lfCaptionFont: TLogFontA; + iSmCaptionWidth: Integer; + iSmCaptionHeight: Integer; + lfSmCaptionFont: TLogFontA; + iMenuWidth: Integer; + iMenuHeight: Integer; + lfMenuFont: TLogFontA; + lfStatusFont: TLogFontA; + lfMessageFont: TLogFontA; + end; + TWMKey = TLMKey; + TWMScroll = TLMScroll; + TWMNoParams = TLMNoParams; + TWMPaint = TLMPaint; + TWMNCPaint = packed record + Msg: Cardinal; + RGN: HRGN; + Unused: Longint; + Result: Longint; + end; + TWMHScroll = TLMHScroll; + TWMVScroll = TLMVScroll; + +const + WM_WININICHANGE = CM_WININICHANGE; + WM_CANCELMODE = LM_CANCELMODE; + WM_ERASEBKGND = LM_ERASEBKGND; + WM_GETTEXTLENGTH = LM_GETTEXTLENGTH; + WM_KEYDOWN = LM_KEYDOWN; + WM_KILLFOCUS = LM_KILLFOCUS; + WM_LBUTTONDOWN = LM_LBUTTONDOWN; + WM_LBUTTONUP = LM_LBUTTONUP; + WM_MOUSEMOVE = LM_MOUSEMOVE; + WM_NCHITTEST = LM_NCHITTEST; + WM_SETCURSOR = LM_SETCURSOR; + WM_SETTEXT = $000C; + WM_GETTEXT = $000D; + WM_SETFOCUS = LM_SETFOCUS; + WM_CHAR = LM_CHAR; + WM_CLEAR = LM_CLEARSEL; + WM_COPY = LM_COPYTOCLIP; + WM_CUT = LM_CUTTOCLIP; + WM_PASTE = LM_PASTEFROMCLIP; + WM_GETDLGCODE = LM_GETDLGCODE; + WM_SIZE = LM_SIZE; + WM_SETFONT = LM_SETFONT; + WM_SYSKEYDOWN = LM_SYSKEYDOWN; + WM_RBUTTONUP = LM_RBUTTONUP; + WM_MOUSEACTIVATE = $0021; + WM_LBUTTONDBLCLK = LM_LBUTTONDBLCLK; + WM_SETREDRAW = $000B; + WM_NEXTDLGCTL = $0028; + WM_MOUSEWHEEL = LM_MOUSEWHEEL; + WM_PAINT = LM_PAINT; + WM_VSCROLL = LM_VSCROLL; + WM_HSCROLL = LM_HSCROLL; + WM_NCPAINT = LM_NCPAINT; + WM_MEASUREITEM = LM_MEASUREITEM; + + EM_GETMODIFY = $00B8; + EM_SETMODIFY = $00B9; + EM_GETSEL = $00B0; + EM_SETSEL = $00B1; + EM_GETLINECOUNT = $00BA; + EM_LINELENGTH = $00C1; + EM_LINEINDEX = $00BB; + EM_GETLINE = $00C4; + EM_REPLACESEL = $00C2; + + CS_SAVEBITS = $800; + CS_DBLCLKS = 8; + SPI_GETWORKAREA = 48; + SPI_GETNONCLIENTMETRICS = 41; + DLGC_STATIC = $100; + GW_HWNDLAST = 1; + GW_HWNDNEXT = 2; + GW_HWNDPREV = 3; + GW_CHILD = 5; + DT_EXPANDTABS = $40; + DT_END_ELLIPSIS = $8000; + DT_MODIFYSTRING = $10000; + GHND = 66; + TMPF_TRUETYPE = 4; + SWP_HIDEWINDOW = $80; + SWP_SHOWWINDOW = $40; + RDW_INVALIDATE = 1; + RDW_UPDATENOW = $100; + RDW_FRAME = $400; + LANG_JAPANESE = $11; + ES_PASSWORD = $20; + ES_LEFT = 0; + ES_RIGHT = 2; + ES_CENTER = 1; + ES_AUTOHSCROLL = $80; + ES_MULTILINE = 4; + ODS_COMBOBOXEDIT = $1000; + CB_FINDSTRING = $014C; + CB_SETITEMHEIGHT = $0153; + CB_FINDSTRINGEXACT = $0158; + CB_SETDROPPEDWIDTH = 352; + CBS_DROPDOWN = 2; + CBS_DROPDOWNLIST = 3; + CBS_OWNERDRAWVARIABLE = $20; + CBS_AUTOHSCROLL = $40; + CBS_HASSTRINGS = $200; + WHEEL_DELTA = 120; + LB_GETCARETINDEX = $019F; + LB_GETCOUNT = $018B; + LB_GETCURSEL = $0188; + LB_GETITEMHEIGHT = $01A1; + LB_GETITEMRECT = $0198; + LB_GETSEL = $0187; + LB_GETTOPINDEX = $018E; + LB_RESETCONTENT = $0184; + LB_SELITEMRANGE = $019B; + LB_SETCURSEL = $0186; + LB_SETSEL = $0185; + LB_SETTABSTOPS = $0192; + LB_SETTOPINDEX = $0197; + LB_ERR = -1; + MA_ACTIVATE = 1; + MA_NOACTIVATEANDEAT = 4; + + + {These belong in LclIntf unit} +function IsCharAlpha(c : Char) : Boolean; +function DefWindowProc(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; +function GetProfileInt(lpAppName, lpKeyName: PChar; nDefault: Integer): UINT; +function GetProfileString(lpAppName, lpKeyName, lpDefault: PChar; + lpReturnedString: PChar; nSize: DWORD): DWORD; +function GetTickCount : DWORD; +//function SetTimer(hWnd: HWND; nIDEvent, uElapse: UINT; +// lpTimerFunc: TFNTimerProc): UINT; +//function KillTimer(hWnd: HWND; uIDEvent: UINT): BOOL; +function GetCaretBlinkTime: UINT; +function SetCaretBlinkTime(uMSeconds: UINT): BOOL; +//function DestroyCaret: BOOL; +function MessageBeep(uType: UINT): BOOL; +function SystemParametersInfo(uiAction, uiParam: UINT; + pvParam: Pointer; fWinIni: UINT): BOOL; +{$IFNDEF MSWINDOWS} +function GetSystemMetrics(nIndex: Integer): Integer; +{$ENDIF} +function MoveWindow(hWnd: HWND; X, Y, nWidth, nHeight: Integer; bRepaint: BOOL): BOOL; +function SetWindowPos(hWnd: HWND; hWndInsertAfter: HWND; + X, Y, cx, cy: Integer; uFlags: UINT): BOOL; +function ValidateRect(hWnd: HWND; lpRect: PRect): BOOL; +function InvalidateRect(hWnd: HWND; lpRect: PRect; bErase: BOOL): BOOL; +function InvalidateRgn(hWnd: HWND; hRgn: HRGN; bErase: BOOL): BOOL; +function GetRgnBox(RGN : HRGN; lpRect : PRect) : Longint; +function PtInRegion(RGN: HRGN; X, Y: Integer) : Boolean; +function SetWindowText(hWnd: HWND; lpString: PChar): BOOL; +function GetBkColor(hDC: HDC): COLORREF; +function GetBkMode(hDC: HDC): Integer; +function GetWindow(hWnd: HWND; uCmd: UINT): HWND; +function GetNextWindow(hWnd: HWND; uCmd: UINT): HWND; +function RedrawWindow(hWnd: HWND; lprcUpdate: PRect; hrgnUpdate: HRGN; flags: UINT): BOOL; +function GetWindowDC(hWnd: HWND): HDC; +function ScrollDC(DC: HDC; DX, DY: Integer; var Scroll, Clip: TRect; Rgn: HRGN; + Update: PRect): BOOL; +function SetScrollRange(hWnd: HWND; nBar, nMinPos, nMaxPos: Integer; bRedraw: BOOL): BOOL; +function GetTabbedTextExtent(hDC: HDC; lpString: PChar; + nCount, nTabPositions: Integer; + var lpnTabStopPositions): DWORD; +function TabbedTextOut(hDC: HDC; X, Y: Integer; lpString: PChar; + nCount, nTabPositions: Integer; + var lpnTabStopPositions; nTabOrigin: Integer): Longint; +//function LoadBitmap(hInstance: HINST; lpBitmapName: PAnsiChar): HBITMAP; +function LoadCursor(hInstance: HINST; lpCursorName: PAnsiChar): HCURSOR; +function EnumThreadWindows(dwThreadId: DWORD; lpfn: TFNWndEnumProc; lParam: LPARAM): BOOL; +procedure OutputDebugString(lpOutputString: PChar); +function SetViewportOrgEx(DC: HDC; X, Y: Integer; Point: PPoint): BOOL; +function GlobalAlloc(uFlags: UINT; dwBytes: DWORD): HGLOBAL; +function GlobalLock(hMem: HGLOBAL): Pointer; +function GlobalUnlock(hMem: HGLOBAL): BOOL; +//function DestroyCursor(hCursor: HICON): BOOL; +{$IFDEF MSWINDOWS} //Shouldn't be needed with GTK widgetset. +function PostMessage(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): BOOL; +function SendMessage(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; +{$ENDIF} +procedure RecreateWnd(const AWinControl:TWinControl); + + {These belong in Classes unit} +//function MakeObjectInstance(Method: TWndMethod): Pointer; +//procedure FreeObjectInstance(ObjectInstance: Pointer); +//function AllocateHWnd(Method: TWndMethod): HWND; +//procedure DeallocateHWnd(Wnd: HWND); + + {This belongs in System unit} +function FindClassHInstance(ClassType: TClass): LongWord; + + {This belongs in ExtCtrls unit} +procedure Frame3D(Canvas: TCanvas; var Rect: TRect; + TopColor, BottomColor: TColor; Width: Integer); + + {This should be a TCanvas method} +procedure BrushCopy(DestCanvas: TCanvas; const Dest: TRect; Bitmap: TBitmap; + const Source: TRect; Color: TColor); + + {This belongs in Buttons unit} +function DrawButtonFace(Canvas: TCanvas; const Client: TRect; + BevelWidth: Integer; Style: TButtonStyle; + IsRounded, IsDown, IsFocused: Boolean): TRect; + + {Additional routines} +{$IFDEF LINUX} +function GetBrowserPath : string; +{$ENDIF} + + +implementation + + {These functions belong in LclIntf unit} + +function IsCharAlpha(c : Char) : Boolean; +// Doesn't handle upper-ANSI chars, but then LCL IsCharAlphaNumeric +// function doesn't either. +begin + Result := ((Ord(c) >= 65) and (Ord(c) <= 90)) or + ((Ord(c) >= 97) and (Ord(c) <= 122)); +end; + +function DefWindowProc(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; +// DefWindowProc is a Win API function for handling any window message +// that the application doesn't handle. +// Can't find equivalent in LCL. +begin +{$IFDEF MSWINDOWS} + Result := Windows.DefWindowProc(hWnd, Msg, wParam, lParam); +{$ELSE} + Result := 0; +{$ENDIF} +end; + +function GetProfileInt(lpAppName, lpKeyName: PChar; nDefault: Integer): UINT; +// Return the integer value for the key name in the lpAppName section +// of the WIN.INI file, which on Win32 maps to the corresponding +// section of the Windows registry. +begin +{$IFDEF MSWINDOWS} + Result := Windows.GetProfileInt(lpAppName, lpKeyName, nDefault); +{$ELSE} //Just return default for now. + Result := nDefault; +{$ENDIF} +end; + +function GetProfileString(lpAppName, lpKeyName, lpDefault: PChar; + lpReturnedString: PChar; nSize: DWORD): DWORD; +// Return the string value for the key name in the lpAppName section +// of the WIN.INI file, which on Win32 maps to the corresponding +// section of the Windows registry. +begin +{$IFDEF MSWINDOWS} + Result := Windows.GetProfileString(lpAppName, lpKeyName, lpDefault, + lpReturnedString, nSize); +{$ELSE} //Just return default for now. + StrLCopy(lpReturnedString, lpDefault, Pred(nSize)); +{$ENDIF} +end; + +function GetTickCount : DWORD; + {On Windows, this is number of milliseconds since Windows was + started. On non-Windows platforms, LCL returns number of + milliseconds since Dec. 30, 1899, wrapped by size of DWORD. + This value can overflow LongInt variable when checks turned on, + so "wrap" value here so it fits within LongInt. + Also, since same thing could happen with Windows that has been + running for at least approx. 25 days, override it too.} +begin +{$IFDEF MSWINDOWS} + Result := Windows.GetTickCount mod High(LongInt); +{$ELSE} + Result := LclIntf.GetTickCount mod High(LongInt); +{$ENDIF} +end; + +function SetTimer(hWnd: HWND; nIDEvent, uElapse: UINT; + lpTimerFunc: TFNTimerProc): UINT; +begin +{$IFDEF MSWINDOWS} + Result := {Windows.}SetTimer(hWnd, nIDEvent, uElapse, lpTimerFunc); +{$ENDIF} +end; + +function KillTimer(hWnd: HWND; uIDEvent: UINT): BOOL; +begin +{$IFDEF MSWINDOWS} + Result := Windows.KillTimer(hWnd, UIDEvent); +{$ENDIF} +end; + +function GetCaretBlinkTime: UINT; +// This function and SetCaretBlinkTime are only used in OvcCaret unit's +// TOvcSingleCaret.SetLinked, which is used to write Linked property. +begin +{$IFDEF MSWINDOWS} + Result := Windows.GetCaretBlinkTime; +{$ELSE} + Result := 530; //Default on Win XP, so use as reasonable value +{$ENDIF} +end; + +function SetCaretBlinkTime(uMSeconds: UINT): BOOL; +begin +{$IFDEF MSWINDOWS} + Result := Windows.SetCaretBlinkTime(uMSeconds); +{$ENDIF} +end; + +function DestroyCaret: BOOL; +begin +{$IFDEF MSWINDOWS} + Result := Windows.DestroyCaret; +{$ENDIF} +end; + +function MessageBeep(uType: UINT): BOOL; +begin +{$IFDEF MSWINDOWS} + Result := Windows.MessageBeep(uType); +{$ELSE} + Beep; //Most calls pass 0 as uType (MB_OK), which is system default sound} +{$ENDIF} +end; + +function SystemParametersInfo(uiAction, uiParam: UINT; + pvParam: Pointer; fWinIni: UINT): BOOL; +// Only used in: +// OvcMisc: PathEllipsis, which is only used in ovcmru (not yet ported). +// OvcEdClc: TOvcCustomNumberEdit.PopupOpen. +// OvcEdCal: TOvcCustomDateEdit.PopupOpen. +// OvcEdSld (not yet ported). +begin +{$IFDEF MSWINDOWS} + Result := Windows.SystemParametersInfo(uiAction, uiParam, pvParam, + fWinIni); +{$ENDIF} +end; + +{$IFNDEF MSWINDOWS} +function GetSystemMetrics(nIndex: Integer): Integer; +// SM_CYBORDER, etc. not implemented yet in GTK widgetset. +begin + if nIndex = SM_SWAPBUTTON then + Result := 0 {Not implemented on GTK, so assume buttons not swapped} + else + begin + if nIndex = SM_CYBORDER then + nIndex := SM_CYEDGE; //Substitute for now so returned value is valid. + Result := LclIntf.GetSystemMetrics(nIndex); + end; +end; +{$ENDIF} + +function MoveWindow(hWnd: HWND; X, Y, nWidth, nHeight: Integer; bRepaint: BOOL): BOOL; +// Only used in: +// OvcEdClc: TOvcCustomNumberEdit.PopupOpen. +// OvcEdCal: TOvcCustomDateEdit.PopupOpen. +// OvcEdSld (not yet ported). +begin +{$IFDEF MSWINDOWS} + Result := Windows.MoveWindow(hWnd, X, Y, nWidth, nHeight, bRepaint); +{$ENDIF} +end; + +function SetWindowPos(hWnd: HWND; hWndInsertAfter: HWND; + X, Y, cx, cy: Integer; uFlags: UINT): BOOL; +begin +{$IFDEF MSWINDOWS} + Result := Windows.SetWindowPos(hWnd, hWndInsertAfter, X, Y, cx, cy, uFlags); +{$ELSE} //Doesn't do much with GTK, but call it anyway. + Result := LclIntf.SetWindowPos(hWnd, hWndInsertAfter, X, Y, cx, cy, uFlags); + if (uFlags and SWP_HIDEWINDOW) <> 0 then + FindControl(hWnd).Visible := False + else if (uFlags and SWP_SHOWWINDOW) <> 0 then + FindControl(hWnd).Visible := True; +{$ENDIF} +end; + +function ValidateRect(hWnd: HWND; lpRect: PRect): BOOL; +// Since LCL InvalidateRect redraws window, shouldn't need this function, +// so leave it as stub for now. +begin +{$IFDEF MSWINDOWS} +// Result := Windows.ValidateRect(hWnd, lpRect); +{$ENDIF} + Result := True; +end; + +function InvalidateRect(hWnd: HWND; lpRect: PRect; bErase: BOOL): BOOL; + {InvalidateRect crashes if lpRect is nil with some versions of LCL.} +begin +{$IFDEF MSWINDOWS} + if Assigned(lpRect) then + Result := LclIntf.InvalidateRect(hWnd, lpRect, bErase) + else + Result := Windows.InvalidateRect(hWnd, lpRect, bErase); +{$ELSE} + if Assigned(lpRect) then + Result := LclIntf.InvalidateRect(hWnd, lpRect, bErase) + else + Result := True; + //For now just ignore if nil since no alternative as with Windows. +{$ENDIF} +end; + +function InvalidateRgn(hWnd: HWND; hRgn: HRGN; bErase: BOOL): BOOL; +{$IFDEF MSWINDOWS} +begin + Result := Windows.InvalidateRgn(hWnd, hRgn, bErase); +{$ELSE} +var + ARect : TRect; +begin + GetRgnBox(hRgn, @ARect); + Result := InvalidateRect(hWnd, @ARect, bErase); +{$ENDIF} +end; + +function GetRgnBox(RGN : HRGN; lpRect : PRect) : Longint; +begin +{$IFDEF MSWINDOWS} + Result := Windows.GetRgnBox(RGN, lpRect); +{$ELSE} + Result := LclIntf.GetRgnBox(RGN, lpRect); +{$ENDIF} +end; + +function PtInRegion(RGN: HRGN; X, Y: Integer) : Boolean; +{$IFDEF MSWINDOWS} +begin + Result := Windows.PtInRegion(RGN, X, Y); +{$ELSE} +var + ARect : TRect; + APt : TPoint; +begin + GetRgnBox(RGN, @ARect); + APt.X := X; + APt.Y := Y; + Result := LclIntf.PtInRect(ARect, APt); +{$ENDIF} +end; + +function SetWindowText(hWnd: HWND; lpString: PChar): BOOL; +begin +{$IFDEF MSWINDOWS} + Result := Windows.SetWindowText(hWnd, lpString); +{$ELSE} +// Use FindControl, then assign to control's Text property? +{$ENDIF} +end; + +function GetBkColor(hDC: HDC): COLORREF; +// Only used in: +// OvcEF: TOvcBaseEntryField.efPaintPrim. +// OvcLkOut (not yet ported). +// O32LkOut (not yet ported). +begin +{$IFDEF MSWINDOWS} + Result := Windows.GetBkColor(hDC); +{$ELSE} // Since SetBkColor returns previous color, use it to get color. + Result := SetBkColor(hDC, 0); //Set background color to black. + SetBkColor(hDC, Result); //Restore background color +{$ENDIF} +end; + +function GetBkMode(hDC: HDC): Integer; +begin +{$IFDEF MSWINDOWS} + Result := Windows.GetBkMode(hDC); +{$ELSE} + Result := TRANSPARENT; //For now +// Result := SetBkMode(hDC, TRANSPARENT); //Use when widgetsets support it +// SetBkMode(hDC, Result); +{$ENDIF} +end; + +function GetWindow(hWnd: HWND; uCmd: UINT): HWND; +{$IFDEF MSWINDOWS} +begin + Result := Windows.GetWindow(hWnd, uCmd); +{$ELSE} +var + AWinControl : TWinControl; +begin + Result := 0; + AWinControl := FindControl(hWnd); + if AWinControl <> nil then + begin + case uCmd of + GW_HWNDNEXT : + begin +// FindNextControl is declared in protected section, so can't use it. +// AWinControl := AWinControl.FindNextControl(AWinControl, True, False, False); +// if AWinControl <> nil then +// Result := AWinControl.Handle; + end; + GW_CHILD : + begin + if AWinControl.ControlCount > 0 then + Result := TWinControl(AWinControl.Controls[0]).Handle; + end; + GW_HWNDLAST : + begin + if AWinControl.Parent <> nil then + Result := TWinControl(AWinControl.Parent.Controls[Pred(AWinControl.Parent.ControlCount)]).Handle; + end; + end; + end; +{$ENDIF} +end; + +function GetNextWindow(hWnd: HWND; uCmd: UINT): HWND; +begin +{$IFDEF MSWINDOWS} + Result := Windows.GetNextWindow(hWnd, uCmd); +{$ELSE} + Result := GetWindow(hWnd, uCmd); +{$ENDIF} +end; + +function RedrawWindow(hWnd: HWND; lprcUpdate: PRect; hrgnUpdate: HRGN; flags: UINT): BOOL; +begin +{$IFDEF MSWINDOWS} + Result := Windows.RedrawWindow(hWnd, lprcUpdate, hrgnUpdate, flags); +{$ELSE} +{$ENDIF} +end; + +function GetWindowDC(hWnd: HWND): HDC; +begin +{$IFDEF MSWINDOWS} + Result := Windows.GetWindowDC(hWnd); +{$ELSE} +{$ENDIF} +end; + +function ScrollDC(DC: HDC; DX, DY: Integer; var Scroll, Clip: TRect; Rgn: HRGN; + Update: PRect): BOOL; +begin +{$IFDEF MSWINDOWS} + Result := Windows.ScrollDC(DC, DX, DY, Scroll, Clip, Rgn, Update); +{$ELSE} +{$ENDIF} +end; + +function SetScrollRange(hWnd: HWND; nBar, nMinPos, nMaxPos: Integer; bRedraw: BOOL): BOOL; +{$IFDEF MSWINDOWS} +begin + Result := Windows.SetScrollRange(hWnd, nBar, nMinPos, nMaxPos, bRedraw); +end; +{$ELSE} //GTK needs more information, so use SetScrollInfo +var + ScrInfo : TScrollInfo; +begin + ScrInfo.fMask := SIF_RANGE or SIF_UPDATEPOLICY; + ScrInfo.nTrackPos := SB_POLICY_CONTINUOUS; + ScrInfo.nMin := nMinPos; + ScrInfo.nMax := nMaxPos; + LclIntf.SetScrollInfo(hWnd, nBar, ScrInfo, True); + Result := True; +end; +{$ENDIF} + +function GetTabbedTextExtent(hDC: HDC; lpString: PChar; + nCount, nTabPositions: Integer; + var lpnTabStopPositions): DWORD; +begin +{$IFDEF MSWINDOWS} + Result := Windows.GetTabbedTextExtent(hDC, lpString, nCount, nTabPositions, + lpnTabStopPositions); +{$ELSE} +{$ENDIF} +end; + +function TabbedTextOut(hDC: HDC; X, Y: Integer; lpString: PChar; + nCount, nTabPositions: Integer; + var lpnTabStopPositions; nTabOrigin: Integer): Longint; +begin +{$IFDEF MSWINDOWS} + Result := Windows.TabbedTextOut(hDC, X, Y, lpString, nCount, nTabPositions, + lpnTabStopPositions, nTabOrigin); +{$ELSE} +{$ENDIF} +end; + +function LoadBitmap(hInstance: HINST; lpBitmapName: PAnsiChar): HBITMAP; +begin +{$IFDEF MSWINDOWS} + Result := Windows.LoadBitmap(hInstance, lpBitmapName); +{$ENDIF} +end; + +function LoadCursor(hInstance: HINST; lpCursorName: PAnsiChar): HCURSOR; +begin +{$IFDEF MSWINDOWS} + Result := Windows.LoadCursor(hInstance, lpCursorName); +{$ENDIF} +end; + +function EnumThreadWindows(dwThreadId: DWORD; lpfn: TFNWndEnumProc; lParam: LPARAM): BOOL; +// Only used in OvcMisc IsForegroundTask function, which is only +// used in OvcSpeed (not yet ported). +begin +{$IFDEF MSWINDOWS} + Result := Windows.EnumThreadWindows(dwThreadId, lpfn, lParam); +{$ENDIF} +end; + +procedure OutputDebugString(lpOutputString: PChar); +begin +{$IFDEF MSWINDOWS} + Windows.OutputDebugString(lpOutputString); +{$ENDIF} +end; + +function SetViewportOrgEx(DC: HDC; X, Y: Integer; Point: PPoint): BOOL; +// Only used in OvcMisc CopyParentImage procedure, which is only +// used by TOvcCustomSpeedButton.Paint in OvcSpeed (not yet ported). +begin +{$IFDEF MSWINDOWS} + Result := Windows.SetViewportOrgEx(DC, X, Y, Point); +{$ENDIF} +end; + +function GlobalAlloc(uFlags: UINT; dwBytes: DWORD): HGLOBAL; +// GlobalAlloc, GlobalLock, and GlobalUnlock are only used in: +// OvcEF: TOvcBaseEntryField.efCopyPrim and TOvcBaseEntryField.WMPaste. +// OvcEdit (not yet ported). +// OvcViewr (not yet ported). +// Replace code in those units with calls to standard Clipboard methods? +begin +{$IFDEF MSWINDOWS} + Result := Windows.GlobalAlloc(uFlags, dwBytes); +{$ELSE} + Result := THandle(GetMem(dwBytes)); +{$ENDIF} +end; + +function GlobalLock(hMem: HGLOBAL): Pointer; +begin +{$IFDEF MSWINDOWS} + Result := Windows.GlobalLock(hMem); +{$ELSE} + Result := PAnsiChar(hMem); +{$ENDIF} +end; + +function GlobalUnlock(hMem: HGLOBAL): BOOL; +begin +{$IFDEF MSWINDOWS} + Result := Windows.GlobalUnlock(hMem); +{$ELSE} + FreeMem(Pointer(hMem)); + Result := True; +{$ENDIF} +end; + +function DestroyCursor(hCursor: HICON): BOOL; +begin +{$IFDEF MSWINDOWS} + Result := Windows.DestroyCursor(hCursor); +{$ENDIF} +end; + + +function PostMessage(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): BOOL; + {Use control's Perform method to force it to respond to message} +var + AWinControl : TWinControl; +begin +// Result := LclIntf.PostMessage(hWnd, Msg, wParam, lParam); {Doesn't work} + Assert(hWnd <> 0, 'Window handle not assigned on entry to PostMessage'); + AWinControl := FindOwnerControl(hWnd); +// Assert(AWinControl <> nil, +// 'Owner control not found in PostMessage ($' + IntToHex(Msg, 4) + ') '); + if AWinControl <> nil then + AWinControl.Perform(Msg, wParam, lParam); + Result := True; +end; + +function SendMessage(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; + {Use control's Perform method to force it to respond to message} +var + AWinControl : TWinControl; +begin +// Result := LclIntf.SendMessage(hWnd, Msg, wParam, lParam); {Doesn't work} + Assert(hWnd <> 0, 'Window handle not assigned on entry to SendMessage'); + AWinControl := FindOwnerControl(hWnd); +// Assert(AWinControl <> nil, +// 'Owner control not found in SendMessage ($' + IntToHex(Msg, 4) + ') '); + if AWinControl <> nil then + Result := AWinControl.Perform(Msg, wParam, lParam); +end; + +procedure RecreateWnd(const AWinControl:TWinControl); +// Calls to Controls.RecreateWnd shouldn't be needed with GTK widgetset, +// so just ignore them. +begin +{$IFDEF MSWINDOWS} + Controls.RecreateWnd(AWinControl); +{$ENDIF} +end; + + + {These belong in Classes unit} +function MakeObjectInstance(Method: TWndMethod): Pointer; +begin +end; + +procedure FreeObjectInstance(ObjectInstance: Pointer); +begin +end; + +function AllocateHWnd(Method: TWndMethod): HWND; +begin +end; + +procedure DeallocateHWnd(Wnd: HWND); +begin +end; + + + {This belongs in System unit} +function FindClassHInstance(ClassType: TClass): LongWord; +begin +(* + Result := System.MainInstance; +*) + Result := System.HInstance; +end; + + + {This belongs in ExtCtrls unit} +procedure Frame3D(Canvas: TCanvas; var Rect: TRect; + TopColor, BottomColor: TColor; Width: Integer); +begin + Canvas.Frame3D(Rect, Width, bvLowered); + {Need a way of determining whether to pass bvNone, bvLowered, + bvRaised, or bvSpace based on TopColor and BottomColor. + See Delphi help for Frame3D.} +end; + + + {This should be a TCanvas method} +procedure BrushCopy(DestCanvas: TCanvas; const Dest: TRect; Bitmap: TBitmap; + const Source: TRect; Color: TColor); +begin + StretchBlt(DestCanvas.Handle, Dest.Left, Dest.Top, + Dest.Right - Dest.Left, Dest.Bottom - Dest.Top, + Bitmap.Canvas.Handle, Source.Left, Source.Top, + Source.Right - Source.Left, Source.Bottom - Source.Top, SrcCopy); +end; + + + {This belongs in Buttons unit} +function DrawButtonFace(Canvas: TCanvas; const Client: TRect; + BevelWidth: Integer; Style: TButtonStyle; + IsRounded, IsDown, IsFocused: Boolean): TRect; + {Draw a push button. + Style, IsRounded and IsFocused params appear to be left over + from Win 3.1, so ignore them.} +var + ARect : TRect; +begin + ARect := Client; + {The way LCL TCustomSpeedButton draws a button} + if IsDown then + Canvas.Frame3D(ARect, BevelWidth, bvLowered) + else + Canvas.Frame3D(ARect, BevelWidth, bvRaised); +end; + + + {Additional routines} +{$IFDEF LINUX} +function SearchForBrowser(const BrowserFileName : string) : string; + {Search path for specified browser file name, returning + its expanded file name that includes path to it.} +begin + Result := + SearchFileInPath(BrowserFileName, '', GetEnvironmentVariable('PATH'), + PathSeparator, [sffDontSearchInBasePath]); +end; + +function GetBrowserPath : string; + {Return path to first browser found.} +begin + Result := SearchForBrowser('firefox'); + if Result = '' then + Result := SearchForBrowser('konqueror'); {KDE browser} + if Result = '' then + Result := SearchForBrowser('epiphany'); {GNOME browser} + if Result = '' then + Result := SearchForBrowser('mozilla'); + if Result = '' then + Result := SearchForBrowser('opera'); +end; +{$ENDIF} + + +end. diff --git a/components/orpheus/myovcreg.pas b/components/orpheus/myovcreg.pas new file mode 100644 index 000000000..fab0a440e --- /dev/null +++ b/components/orpheus/myovcreg.pas @@ -0,0 +1,234 @@ +{*********************************************************} +{* myovcreg.pas *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* Phil Hess - adapted ovcreg.pas to register only ported controls. *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +unit MyOvcReg; + +{ + Registration unit for the ported Orpheus components. +} + +interface + +uses + Classes, + Forms, + LResources, + PropEdits, + ComponentEditors, + ovcabot0, {Property editors} + ovclbl0, + myovctbpe1, + myovctbpe2, + ovcbase, {Controls} + ovctcedt, + ovctchdr, + ovctccbx, + ovctcsim, + ovctcbox, + ovctcbmp, + ovctcgly, + ovctcico, + ovctbcls, + ovctbrws, + ovctable, + ovcurl, + ovcrlbl, + ovclabel, + ovcsf, + o32flxed, + o32tcflx, +// ovccalc, +// ovcclrcb, + ovcsc, + ovcvlb; + +procedure Register; + + +implementation + +type + TOvcHeaderProperty = class(TCaptionProperty); + + {component editor for the table} + TOvcTableEditor = class(TDefaultComponentEditor) + public + procedure ExecuteVerb(Index : Integer); + override; + function GetVerb(Index : Integer) : AnsiString; + override; + function GetVerbCount : Integer; + override; + end; + +{*** TOvcTableEditor ***} + +const + TableVerbs : array[0..1] of PAnsiChar = + ('Columns Editor', 'Rows Editor'); + +procedure TOvcTableEditor.ExecuteVerb(Index : Integer); +var + Table : TOvcTable; + C : TOvcfrmColEditor; + R : TOvcfrmRowEditor; +begin + Table := TOvcTable(Component); + if Index = 0 then begin + C := TOvcfrmColEditor.Create(Application); + try + C.Editor := Self; + C.SetCols(TOvcTableColumns(Table.Columns)); + C.ShowModal; + Designer.Modified; + finally + C.Free; + end; + end else if Index = 1 then begin + R := TOvcfrmRowEditor.Create(Application); + try + R.SetRows(TOvcTableRows(Table.Rows)); + R.ShowModal; + Designer.Modified; + finally + R.Free; + end; + end; +end; + +function TOvcTableEditor.GetVerb(Index : Integer) : AnsiString; +begin + Result := StrPas(TableVerbs[Index]); +end; + +function TOvcTableEditor.GetVerbCount : Integer; +begin + Result := High(TableVerbs) + 1; +end; + + +procedure Register; +begin + RegisterPropertyEditor(TypeInfo(string), TOvcURL, 'Caption', TOvcHeaderProperty); + RegisterPropertyEditor(TypeInfo(string), TOvcURL, 'URL', TOvcHeaderProperty); + + RegisterPropertyEditor(TypeInfo(string), TOvcRotatedLabel, 'About', TOvcAboutProperty); + RegisterPropertyEditor(TypeInfo(string), TOvcLabel, 'About', TOvcAboutProperty); + RegisterPropertyEditor(TypeInfo(string), TOvcURL, 'About', TOvcAboutProperty); + RegisterPropertyEditor(TypeInfo(string), TOvcSpinner, 'About', TOvcAboutProperty); + RegisterPropertyEditor(TypeInfo(string), TOvcVirtualListBox, 'About', TOvcAboutProperty); +{$IFDEF MSWINDOWS} + RegisterPropertyEditor(TypeInfo(string), TOvcSimpleField, 'About', TOvcAboutProperty); +{$ENDIF} + RegisterPropertyEditor(TypeInfo(string), TO32FlexEdit, 'About', TOvcAboutProperty); +// RegisterPropertyEditor(TypeInfo(string), TOvcCalculator, 'About', TOvcAboutProperty); +// RegisterPropertyEditor(TypeInfo(string), TOvcColorComboBox, 'About', TOvcAboutProperty); + RegisterPropertyEditor(TypeInfo(string), TOvcTable, 'About', TOvcAboutProperty); + RegisterPropertyEditor(TypeInfo(string), TOvcTCColHead, 'About', TOvcAboutProperty); + RegisterPropertyEditor(TypeInfo(string), TOvcTCRowHead, 'About', TOvcAboutProperty); + RegisterPropertyEditor(TypeInfo(string), TOvcTCString, 'About', TOvcAboutProperty); +{$IFDEF MSWINDOWS} + RegisterPropertyEditor(TypeInfo(string), TOvcTCSimpleField, 'About', TOvcAboutProperty); +{$ENDIF} + RegisterPropertyEditor(TypeInfo(string), TOvcTCMemo, 'About', TOvcAboutProperty); + RegisterPropertyEditor(TypeInfo(string), TOvcTCCheckBox, 'About', TOvcAboutProperty); + RegisterPropertyEditor(TypeInfo(string), TOvcTCComboBox, 'About', TOvcAboutProperty); + RegisterPropertyEditor(TypeInfo(string), TOvcTCBitMap, 'About', TOvcAboutProperty); + RegisterPropertyEditor(TypeInfo(string), TOvcTCGlyph, 'About', TOvcAboutProperty); + RegisterPropertyEditor(TypeInfo(string), TOvcTCIcon, 'About', TOvcAboutProperty); + RegisterPropertyEditor(TypeInfo(string), TO32TCFlexEdit, 'About', TOvcAboutProperty); + RegisterPropertyEditor(TypeInfo(string), TOvcController, 'About', TOvcAboutProperty); + + {register label component editor} + RegisterComponentEditor(TOvcCustomLabel, TOvcLabelEditor); + + {register property editors for the entry fields} +(* + RegisterPropertyEditor( + TypeInfo(Char), TOvcSimpleField, 'PictureMask', TSimpleMaskProperty); + RegisterPropertyEditor( + TypeInfo(string), TOvcPictureField, 'PictureMask', TPictureMaskProperty); + RegisterPropertyEditor( + TypeInfo(string), TOvcNumericField, 'PictureMask', TNumericMaskProperty); + RegisterPropertyEditor( + TypeInfo(string), TOvcSimpleField, 'RangeHi', OvcEfPe.TEfRangeProperty); + RegisterPropertyEditor( + TypeInfo(string), TOvcSimpleField, 'RangeLo', OvcEfPe.TEfRangeProperty); + RegisterPropertyEditor( + TypeInfo(string), TOvcPictureField, 'RangeHi', OvcEfPe.TEfRangeProperty); + RegisterPropertyEditor( + TypeInfo(string), TOvcPictureField, 'RangeLo', OvcEfPe.TEfRangeProperty); + RegisterPropertyEditor( + TypeInfo(string), TOvcNumericField, 'RangeHi', OvcEfPe.TEfRangeProperty); + RegisterPropertyEditor( + TypeInfo(string), TOvcNumericField, 'RangeLo', OvcEfPe.TEfRangeProperty); + RegisterPropertyEditor( + TypeInfo(string), TOvcPictureLabel, 'PictureMask', TPictureMaskProperty); +*) + + RegisterPropertyEditor(TypeInfo(TOvcTableRows), TOvcTable, '', TOvcTableRowProperty); + RegisterPropertyEditor(TypeInfo(TOvcTableColumns), TOvcTable, '', TOvcTableColumnProperty); + + {register component editor for the table} + RegisterComponentEditor(TOvcTable, TOvcTableEditor); + + RegisterComponents('Orpheus', [TOvcRotatedLabel]); + RegisterComponents('Orpheus', [TOvcLabel]); + RegisterComponents('Orpheus', [TOvcURL]); + RegisterComponents('Orpheus', [TOvcSpinner]); + RegisterComponents('Orpheus', [TOvcVirtualListBox]); +{$IFDEF MSWINDOWS} //If used, crashes IDE with GTK, so only register if Windows + RegisterComponents('Orpheus', [TOvcSimpleField]); +{$ENDIF} + RegisterComponents('Orpheus', [TO32FlexEdit]); +// RegisterComponents('Orpheus', [TOvcCalculator]); +// RegisterComponents('Orpheus', [TOvcColorComboBox]); + RegisterComponents('Orpheus', [TOvcTable]); + RegisterComponents('Orpheus', [TOvcTCColHead]); + RegisterComponents('Orpheus', [TOvcTCRowHead]); + RegisterComponents('Orpheus', [TOvcTCString]); +{$IFDEF MSWINDOWS} //If used, crashes IDE with GTK, so only register if Windows + RegisterComponents('Orpheus', [TOvcTCSimpleField]); +{$ENDIF} + RegisterComponents('Orpheus', [TOvcTCMemo]); + RegisterComponents('Orpheus', [TOvcTCCheckBox]); + RegisterComponents('Orpheus', [TOvcTCComboBox]); + RegisterComponents('Orpheus', [TOvcTCBitMap]); + RegisterComponents('Orpheus', [TOvcTCGlyph]); + RegisterComponents('Orpheus', [TOvcTCIcon]); + RegisterComponents('Orpheus', [TO32TCFlexEdit]); + RegisterComponents('Orpheus', [TOvcController]); +end; {Register} + +initialization +{$I ovcreg.lrs} + +end. + diff --git a/components/orpheus/myovctbpe1.lfm b/components/orpheus/myovctbpe1.lfm new file mode 100644 index 000000000..838d68de9 --- /dev/null +++ b/components/orpheus/myovctbpe1.lfm @@ -0,0 +1,342 @@ +object OvcfrmRowEditor: TOvcfrmRowEditor + Left = 387 + Top = 266 + BorderIcons = [biSystemMenu] + BorderStyle = bsDialog + Caption = 'Rows Editor' + ClientHeight = 280 + Height = 280 + ClientWidth = 401 + Width = 401 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Style = [] + Position = poScreenCenter + OnShow = FormShow + PixelsPerInch = 96 + TextHeight = 13 + object DoneButton: TBitBtn + Left = 307 + Top = 248 + Width = 75 + Height = 25 + Caption = 'Done' + ModalResult = 1 + TabOrder = 5 + OnClick = DoneButtonClick + NumGlyphs = 2 + end + object Panel1: TPanel + Left = 0 + Top = 0 + Width = 401 + Height = 41 + Align = alTop + Alignment = taLeftJustify + BevelInner = bvLowered + TabOrder = 0 + object SpeedButton1: TSpeedButton + Left = 8 + Top = 8 + Width = 25 + Height = 25 + Hint = 'Previous row' + Glyph.Data = { + 76010000424D7601000000000000760000002800000020000000100000000100 + 0400000000000001000000000000000000001000000010000000000000000000 + 80000080000000808000800000008000800080800000C0C0C000808080000000 + FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00BBBBBBBBBBBB + BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB0000 + BBBBBBBBBBBB777BBBBBBBBBBBB00CC0BBBBBBBBBBB7777BBBBBBBBBBB00CCC0 + BBBBBBBBBB77777BBBBBBBBBB00CCCC0BBBBBBBBB777777BBBBBBBBB00CCCCC0 + BBBBBBBB7777777BBBBBBBBF0CCCCCC0BBBBBBB77777777BBBBBBBBF0CCCCCC0 + BBBBBBB77777777BBBBBBBBBFCCCCCC0BBBBBBBB7777777BBBBBBBBBBFCCCCC0 + BBBBBBBBB777777BBBBBBBBBBBFCCCC0BBBBBBBBBB77777BBBBBBBBBBBBFCCC0 + BBBBBBBBBBB7777BBBBBBBBBBBBBFFFFBBBBBBBBBBBB777BBBBBBBBBBBBBBBBB + BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB} + NumGlyphs = 2 + ParentShowHint = False + ShowHint = True + OnClick = SpeedButton1Click + end + object SpeedButton2: TSpeedButton + Left = 32 + Top = 8 + Width = 25 + Height = 25 + Hint = 'Next row' + Glyph.Data = { + 76010000424D7601000000000000760000002800000020000000100000000100 + 0400000000000001000000000000000000001000000010000000000000000000 + 80000080000000808000800000008000800080800000C0C0C000808080000000 + FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00BBBBBBBBBBBB + BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBF000BBBBB + BBBBBBBFFFFBBBBBBBBBBBBF0000BBBBBBBBBBBFFFFFBBBBBBBBBBBFCCC00BBB + BBBBBBBFFFFFFBBBBBBBBBBFCCCC00BBBBBBBBBFFFFFFFBBBBBBBBBFCCCCC00B + BBBBBBBFFFFFFFFBBBBBBBBFCCCCCC00BBBBBBBFFFFFFFFFBBBBBBBFCCCCCC0F + BBBBBBBFFFFFFFFFBBBBBBBFCCCCCCFBBBBBBBBFFFFFFFFBBBBBBBBFCCCCCFBB + BBBBBBBFFFFFFFBBBBBBBBBFCCCCFBBBBBBBBBBFFFFFFBBBBBBBBBBFCCCFBBBB + BBBBBBBFFFFFBBBBBBBBBBBFFFFBBBBBBBBBBBBFFFFBBBBBBBBBBBBBBBBBBBBB + BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB} + NumGlyphs = 2 + ParentShowHint = False + ShowHint = True + OnClick = SpeedButton2Click + end + object SpeedButton3: TSpeedButton + Left = 72 + Top = 8 + Width = 25 + Height = 25 + Hint = 'First row' + Glyph.Data = { + 76010000424D7601000000000000760000002800000020000000100000000100 + 0400000000000001000000000000000000001000000010000000000000000000 + 80000080000000808000800000008000800080800000C0C0C000808080000000 + FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00BBBBBBBBBBBB + BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB00BBBBBB00 + BBBBBBFFBBBBBBFFBBBBBB00BBBBB000BBBBBBFFBBBBBFFFBBBBBB00BBBB00C0 + BBBBBBFFBBBBFFFFBBBBBB00BBB00CC0BBBBBBFFBBBFFFFFBBBBBB00BB00CCC0 + BBBBBBFFBBFFFFFFBBBBBB00B00CCCC0BBBBBBFFBFFFFFFFBBBBBB00BFCCCCC0 + BBBBBBFFBFFFFFFFBBBBBB00BBFCCCC0BBBBBBFFBBFFFFFFBBBBBB00BBBFCCC0 + BBBBBBFFBBBFFFFFBBBBBB00BBBBFCC0BBBBBBFFBBBBFFFFBBBBBB00BBBBBFC0 + BBBBBBFFBBBBBFFFBBBBBB00BBBBBBFFBBBBBBFFBBBBBBFFBBBBBBBBBBBBBBBB + BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB} + NumGlyphs = 2 + ParentShowHint = False + ShowHint = True + OnClick = SpeedButton3Click + end + object SpeedButton4: TSpeedButton + Left = 96 + Top = 8 + Width = 25 + Height = 25 + Hint = 'Last row' + Glyph.Data = { + 76010000424D7601000000000000760000002800000020000000100000000100 + 0400000000000001000000000000000000001000000010000000000000000000 + 80000080000000808000800000008000800080800000C0C0C000808080000000 + FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00BBBBBBBBBBBB + BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB00BBBBBB + 00BBBBBB77BBBBBB77BBBBBB000BBBBB00BBBBBB777BBBBB77BBBBBB0C00BBBB + 00BBBBBB7777BBBB77BBBBBB0CC00BBB00BBBBBB77777BBB77BBBBBB0CCC00BB + 00BBBBBB777777BB77BBBBBB0CCCC00B00BBBBBB7777777B77BBBBBB0CCCCCFB + 00BBBBBB7777777B77BBBBBB0CCCCFBB00BBBBBB777777BB77BBBBBB0CCCFBBB + 00BBBBBB77777BBB77BBBBBB0CCFBBBB00BBBBBB7777BBBB77BBBBBB0CFBBBBB + 00BBBBBB777BBBBB77BBBBBBFFBBBBBB00BBBBBB77BBBBBB77BBBBBBBBBBBBBB + BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB} + NumGlyphs = 2 + ParentShowHint = False + ShowHint = True + OnClick = SpeedButton4Click + end + object SpeedButton5: TSpeedButton + Left = 136 + Top = 8 + Width = 25 + Height = 25 + Hint = 'Insert row' + Glyph.Data = { + 76010000424D7601000000000000760000002800000020000000100000000100 + 0400000000000001000000000000000000001000000010000000000000000000 + 80000080000000808000800000008000800080800000C0C0C000808080000000 + FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00BBBBBBBBBBBB + BBBBBBBBBBBBBBBBBBBBBBBBBBF000BBBBBBBBBBBBF777BBBBBBBBBBBBFCC0BB + BBBBBBBBBBFBB7BBBBBBBBBBBBFCC0BBBBBBBBBBBBFBB7BBBBBBBBBBBBFCC0BB + BBBBBBBBBBFBB7BBBBBBBBBBBBFCC0BBBBBBBBBBBBFBB7BBBBBBB000000CC000 + 000BB777777BB777777BBFCCCCCCCCCCCC0BBFBBBBBBBBBBBB7BBFCCCCCCCCCC + CC0BBFBBBBBBBBBBBB7BBFFFFFFCC0FFFFFBBFFFFFFBB7FFFFFBBBBBBBFCC0BB + BBBBBBBBBBFBB7BBBBBBBBBBBBFCC0BBBBBBBBBBBBFBB7BBBBBBBBBBBBFCC0BB + BBBBBBBBBBFBB7BBBBBBBBBBBBFCC0BBBBBBBBBBBBFBB7BBBBBBBBBBBBFFF0BB + BBBBBBBBBBFFF7BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB} + NumGlyphs = 2 + ParentShowHint = False + ShowHint = True + OnClick = SpeedButton5Click + end + object SpeedButton6: TSpeedButton + Left = 160 + Top = 8 + Width = 25 + Height = 25 + Hint = 'Delete Row' + Glyph.Data = { + 76010000424D7601000000000000760000002800000020000000100000000100 + 0400000000000001000000000000000000001000000010000000000000000000 + 80000080000000808000800000008000800080800000C0C0C000808080000000 + FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00BBBBBBBBBBBB + BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB + BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB + BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB00000000000 + 000BB77777777777777BBFCCCCCCCCCCCC0BBFBBBBBBBBBBBB7BBFCCCCCCCCCC + CC0BBFBBBBBBBBBBBB7BBFFFFFFFFFFFFFFBBFFFFFFFFFFFFFFBBBBBBBBBBBBB + BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB + BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB + BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB} + NumGlyphs = 2 + ParentShowHint = False + ShowHint = True + OnClick = SpeedButton6Click + end + object Label1: TLabel + Left = 208 + Top = 13 + Width = 89 + Height = 16 + AutoSize = False + Caption = '&Row number' + end + object OvcSpinner1: TOvcSpinner + Left = 369 + Top = 12 + Width = 16 + Height = 21 + AutoRepeat = True + Delta = 1.000000000000000000 + FocusedControl = ctlRowNumber + end + object ctlRowNumber: TEdit + Left = 296 + Top = 12 + Width = 73 + Height = 21 + MaxLength = 8 + TabOrder = 0 + OnChange = ctlRowNumberChange + OnExit = ctlRowNumberExit + end + end + object GroupBox1: TGroupBox + Left = 8 + Top = 48 + Width = 273 + Height = 113 + Caption = 'Selected row details' + TabOrder = 1 + object ctlHidden: TCheckBox + Left = 16 + Top = 8 + Width = 89 + Height = 17 + Caption = 'Hidde&n' + TabOrder = 0 + end + object ctlUseDefHeight: TRadioButton + Left = 16 + Top = 40 + Width = 145 + Height = 25 + Caption = 'Use &default height' + TabOrder = 1 + TabStop = True + OnClick = ctlUseDefHeightClick + end + object ctlUseCustHeight: TRadioButton + Left = 16 + Top = 64 + Width = 145 + Height = 25 + Caption = 'Use &custom height' + TabOrder = 2 + OnClick = ctlUseCustHeightClick + end + object OvcSpinner2: TOvcSpinner + Left = 217 + Top = 67 + Width = 16 + Height = 21 + AutoRepeat = True + Delta = 1.000000000000000000 + FocusedControl = ctlHeight + end + object ctlHeight: TEdit + Left = 168 + Top = 68 + Width = 49 + Height = 21 + MaxLength = 5 + TabOrder = 3 + end + end + object GroupBox2: TGroupBox + Left = 8 + Top = 168 + Width = 273 + Height = 105 + Caption = 'Overall row details' + TabOrder = 2 + object Label2: TLabel + Left = 16 + Top = 17 + Width = 121 + Height = 16 + AutoSize = False + Caption = 'De&fault row height' + end + object Label3: TLabel + Left = 16 + Top = 53 + Width = 121 + Height = 16 + AutoSize = False + Caption = 'Ma&ximum rows' + end + object OvcSpinner3: TOvcSpinner + Left = 193 + Top = 17 + Width = 16 + Height = 21 + AutoRepeat = True + Delta = 1.000000000000000000 + FocusedControl = ctlDefaultHeight + end + object OvcSpinner4: TOvcSpinner + Left = 217 + Top = 53 + Width = 16 + Height = 21 + AutoRepeat = True + Delta = 1.000000000000000000 + FocusedControl = ctlRowLimit + end + object ctlRowLimit: TEdit + Left = 144 + Top = 52 + Width = 73 + Height = 21 + TabOrder = 1 + end + object ctlDefaultHeight: TEdit + Left = 144 + Top = 17 + Width = 49 + Height = 21 + MaxLength = 5 + TabOrder = 0 + end + end + object Reset: TBitBtn + Left = 307 + Top = 88 + Width = 75 + Height = 25 + Caption = 'Re&set' + TabOrder = 4 + OnClick = ResetClick + NumGlyphs = 2 + end + object ApplyButton: TBitBtn + Left = 307 + Top = 56 + Width = 75 + Height = 25 + Caption = '&Apply' + Default = True + TabOrder = 3 + OnClick = ApplyButtonClick + NumGlyphs = 2 + end +end diff --git a/components/orpheus/myovctbpe1.lrs b/components/orpheus/myovctbpe1.lrs new file mode 100644 index 000000000..a6207f82e --- /dev/null +++ b/components/orpheus/myovctbpe1.lrs @@ -0,0 +1,170 @@ +LazarusResources.Add('TOvcfrmRowEditor','FORMDATA',[ + 'TPF0'#16'TOvcfrmRowEditor'#15'OvcfrmRowEditor'#4'Left'#3#131#1#3'Top'#3#10#1 + +#11'BorderIcons'#11#12'biSystemMenu'#0#11'BorderStyle'#7#8'bsDialog'#7'Capti' + +'on'#6#11'Rows Editor'#12'ClientHeight'#3#24#1#6'Height'#3#24#1#11'ClientWid' + +'th'#3#145#1#5'Width'#3#145#1#5'Color'#7#9'clBtnFace'#12'Font.Charset'#7#15 + +'DEFAULT_CHARSET'#10'Font.Color'#7#12'clWindowText'#11'Font.Height'#2#245#10 + +'Font.Style'#11#0#8'Position'#7#14'poScreenCenter'#6'OnShow'#7#8'FormShow'#13 + +'PixelsPerInch'#2'`'#10'TextHeight'#2#13#0#7'TBitBtn'#10'DoneButton'#4'Left' + +#3'3'#1#3'Top'#3#248#0#5'Width'#2'K'#6'Height'#2#25#7'Caption'#6#4'Done'#11 + +'ModalResult'#2#1#8'TabOrder'#2#5#7'OnClick'#7#15'DoneButtonClick'#9'NumGlyp' + +'hs'#2#2#0#0#6'TPanel'#6'Panel1'#4'Left'#2#0#3'Top'#2#0#5'Width'#3#145#1#6'H' + +'eight'#2')'#5'Align'#7#5'alTop'#9'Alignment'#7#13'taLeftJustify'#10'BevelIn' + +'ner'#7#9'bvLowered'#8'TabOrder'#2#0#0#12'TSpeedButton'#12'SpeedButton1'#4'L' + +'eft'#2#8#3'Top'#2#8#5'Width'#2#25#6'Height'#2#25#4'Hint'#6#12'Previous row' + +#10'Glyph.Data'#10'z'#1#0#0'v'#1#0#0'BMv'#1#0#0#0#0#0#0'v'#0#0#0'('#0#0#0' ' + +#0#0#0#16#0#0#0#1#0#4#0#0#0#0#0#0#1#0#0#0#0#0#0#0#0#0#0#16#0#0#0#16#0#0#0#0#0 + +#0#0#0#0#128#0#0#128#0#0#0#128#128#0#128#0#0#0#128#0#128#0#128#128#0#0#192 + +#192#192#0#128#128#128#0#0#0#255#0#0#255#0#0#0#255#255#0#255#0#0#0#255#0#255 + +#0#255#255#0#0#255#255#255#0#187#187#187#187#187#187#187#187#187#187#187#187 + +#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187 + +#187#187#187#187#187#0#0#187#187#187#187#187#187'w{'#187#187#187#187#187#176 + +#12#192#187#187#187#187#187#183'w{'#187#187#187#187#187#0#204#192#187#187#187 + +#187#187'ww{'#187#187#187#187#176#12#204#192#187#187#187#187#183'ww{'#187#187 + +#187#187#0#204#204#192#187#187#187#187'www{'#187#187#187#191#12#204#204#192 + +#187#187#187#183'www{'#187#187#187#191#12#204#204#192#187#187#187#183'www{' + +#187#187#187#187#252#204#204#192#187#187#187#187'www{'#187#187#187#187#191 + +#204#204#192#187#187#187#187#183'ww{'#187#187#187#187#187#252#204#192#187#187 + +#187#187#187'ww{'#187#187#187#187#187#191#204#192#187#187#187#187#187#183'w{' + +#187#187#187#187#187#187#255#255#187#187#187#187#187#187'w{'#187#187#187#187 + +#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187 + +#187#187#187#187#187#187#187#187#187#187#187#9'NumGlyphs'#2#2#14'ParentShowH' + +'int'#8#8'ShowHint'#9#7'OnClick'#7#17'SpeedButton1Click'#0#0#12'TSpeedButton' + +#12'SpeedButton2'#4'Left'#2' '#3'Top'#2#8#5'Width'#2#25#6'Height'#2#25#4'Hin' + +'t'#6#8'Next row'#10'Glyph.Data'#10'z'#1#0#0'v'#1#0#0'BMv'#1#0#0#0#0#0#0'v'#0 + +#0#0'('#0#0#0' '#0#0#0#16#0#0#0#1#0#4#0#0#0#0#0#0#1#0#0#0#0#0#0#0#0#0#0#16#0 + +#0#0#16#0#0#0#0#0#0#0#0#0#128#0#0#128#0#0#0#128#128#0#128#0#0#0#128#0#128#0 + +#128#128#0#0#192#192#192#0#128#128#128#0#0#0#255#0#0#255#0#0#0#255#255#0#255 + +#0#0#0#255#0#255#0#255#255#0#0#255#255#255#0#187#187#187#187#187#187#187#187 + +#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187 + +#187#187#187#187#187#187#191#0#11#187#187#187#187#187#191#255#251#187#187#187 + +#187#187#191#0#0#187#187#187#187#187#191#255#255#187#187#187#187#187#191#204 + +#192#11#187#187#187#187#191#255#255#251#187#187#187#187#191#204#204#0#187#187 + +#187#187#191#255#255#255#187#187#187#187#191#204#204#192#11#187#187#187#191 + +#255#255#255#251#187#187#187#191#204#204#204#0#187#187#187#191#255#255#255 + +#255#187#187#187#191#204#204#204#15#187#187#187#191#255#255#255#255#187#187 + +#187#191#204#204#204#251#187#187#187#191#255#255#255#251#187#187#187#191#204 + +#204#207#187#187#187#187#191#255#255#255#187#187#187#187#191#204#204#251#187 + +#187#187#187#191#255#255#251#187#187#187#187#191#204#207#187#187#187#187#187 + +#191#255#255#187#187#187#187#187#191#255#251#187#187#187#187#187#191#255#251 + +#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187 + +#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#9'NumGl' + +'yphs'#2#2#14'ParentShowHint'#8#8'ShowHint'#9#7'OnClick'#7#17'SpeedButton2Cl' + +'ick'#0#0#12'TSpeedButton'#12'SpeedButton3'#4'Left'#2'H'#3'Top'#2#8#5'Width' + +#2#25#6'Height'#2#25#4'Hint'#6#9'First row'#10'Glyph.Data'#10'z'#1#0#0'v'#1#0 + +#0'BMv'#1#0#0#0#0#0#0'v'#0#0#0'('#0#0#0' '#0#0#0#16#0#0#0#1#0#4#0#0#0#0#0#0#1 + +#0#0#0#0#0#0#0#0#0#0#16#0#0#0#16#0#0#0#0#0#0#0#0#0#128#0#0#128#0#0#0#128#128 + +#0#128#0#0#0#128#0#128#0#128#128#0#0#192#192#192#0#128#128#128#0#0#0#255#0#0 + +#255#0#0#0#255#255#0#255#0#0#0#255#0#255#0#255#255#0#0#255#255#255#0#187#187 + +#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187 + +#187#187#187#187#187#187#187#187#187#187#187#187#0#187#187#187#0#187#187#187 + +#255#187#187#187#255#187#187#187#0#187#187#176#0#187#187#187#255#187#187#191 + +#255#187#187#187#0#187#187#0#192#187#187#187#255#187#187#255#255#187#187#187 + +#0#187#176#12#192#187#187#187#255#187#191#255#255#187#187#187#0#187#0#204#192 + +#187#187#187#255#187#255#255#255#187#187#187#0#176#12#204#192#187#187#187#255 + +#191#255#255#255#187#187#187#0#191#204#204#192#187#187#187#255#191#255#255 + ,#255#187#187#187#0#187#252#204#192#187#187#187#255#187#255#255#255#187#187 + +#187#0#187#191#204#192#187#187#187#255#187#191#255#255#187#187#187#0#187#187 + +#252#192#187#187#187#255#187#187#255#255#187#187#187#0#187#187#191#192#187 + +#187#187#255#187#187#191#255#187#187#187#0#187#187#187#255#187#187#187#255 + +#187#187#187#255#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187 + +#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187 + +#9'NumGlyphs'#2#2#14'ParentShowHint'#8#8'ShowHint'#9#7'OnClick'#7#17'SpeedBu' + +'tton3Click'#0#0#12'TSpeedButton'#12'SpeedButton4'#4'Left'#2'`'#3'Top'#2#8#5 + +'Width'#2#25#6'Height'#2#25#4'Hint'#6#8'Last row'#10'Glyph.Data'#10'z'#1#0#0 + +'v'#1#0#0'BMv'#1#0#0#0#0#0#0'v'#0#0#0'('#0#0#0' '#0#0#0#16#0#0#0#1#0#4#0#0#0 + +#0#0#0#1#0#0#0#0#0#0#0#0#0#0#16#0#0#0#16#0#0#0#0#0#0#0#0#0#128#0#0#128#0#0#0 + +#128#128#0#128#0#0#0#128#0#128#0#128#128#0#0#192#192#192#0#128#128#128#0#0#0 + +#255#0#0#255#0#0#0#255#255#0#255#0#0#0#255#0#255#0#255#255#0#0#255#255#255#0 + +#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187 + +#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#0#187#187#187#0 + +#187#187#187'w'#187#187#187'w'#187#187#187#0#11#187#187#0#187#187#187'w{'#187 + +#187'w'#187#187#187#12#0#187#187#0#187#187#187'ww'#187#187'w'#187#187#187#12 + +#192#11#187#0#187#187#187'ww{'#187'w'#187#187#187#12#204#0#187#0#187#187#187 + +'www'#187'w'#187#187#187#12#204#192#11#0#187#187#187'www{w'#187#187#187#12 + +#204#204#251#0#187#187#187'www{w'#187#187#187#12#204#207#187#0#187#187#187'w' + +'ww'#187'w'#187#187#187#12#204#251#187#0#187#187#187'ww{'#187'w'#187#187#187 + +#12#207#187#187#0#187#187#187'ww'#187#187'w'#187#187#187#12#251#187#187#0#187 + +#187#187'w{'#187#187'w'#187#187#187#255#187#187#187#0#187#187#187'w'#187#187 + +#187'w'#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187 + +#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#9'NumGlyphs' + +#2#2#14'ParentShowHint'#8#8'ShowHint'#9#7'OnClick'#7#17'SpeedButton4Click'#0 + +#0#12'TSpeedButton'#12'SpeedButton5'#4'Left'#3#136#0#3'Top'#2#8#5'Width'#2#25 + +#6'Height'#2#25#4'Hint'#6#10'Insert row'#10'Glyph.Data'#10'z'#1#0#0'v'#1#0#0 + +'BMv'#1#0#0#0#0#0#0'v'#0#0#0'('#0#0#0' '#0#0#0#16#0#0#0#1#0#4#0#0#0#0#0#0#1#0 + +#0#0#0#0#0#0#0#0#0#16#0#0#0#16#0#0#0#0#0#0#0#0#0#128#0#0#128#0#0#0#128#128#0 + +#128#0#0#0#128#0#128#0#128#128#0#0#192#192#192#0#128#128#128#0#0#0#255#0#0 + +#255#0#0#0#255#255#0#255#0#0#0#255#0#255#0#255#255#0#0#255#255#255#0#187#187 + +#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#240#0 + +#187#187#187#187#187#187#247'w'#187#187#187#187#187#187#252#192#187#187#187 + +#187#187#187#251#183#187#187#187#187#187#187#252#192#187#187#187#187#187#187 + +#251#183#187#187#187#187#187#187#252#192#187#187#187#187#187#187#251#183#187 + +#187#187#187#187#187#252#192#187#187#187#187#187#187#251#183#187#187#187#176 + +#0#0#12#192#0#0#11#183'ww{'#183'ww{'#191#204#204#204#204#204#204#11#191#187 + +#187#187#187#187#187'{'#191#204#204#204#204#204#204#11#191#187#187#187#187 + +#187#187'{'#191#255#255#252#192#255#255#251#191#255#255#251#183#255#255#251 + +#187#187#187#252#192#187#187#187#187#187#187#251#183#187#187#187#187#187#187 + +#252#192#187#187#187#187#187#187#251#183#187#187#187#187#187#187#252#192#187 + +#187#187#187#187#187#251#183#187#187#187#187#187#187#252#192#187#187#187#187 + +#187#187#251#183#187#187#187#187#187#187#255#240#187#187#187#187#187#187#255 + +#247#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187 + +#187#9'NumGlyphs'#2#2#14'ParentShowHint'#8#8'ShowHint'#9#7'OnClick'#7#17'Spe' + +'edButton5Click'#0#0#12'TSpeedButton'#12'SpeedButton6'#4'Left'#3#160#0#3'Top' + +#2#8#5'Width'#2#25#6'Height'#2#25#4'Hint'#6#10'Delete Row'#10'Glyph.Data'#10 + +'z'#1#0#0'v'#1#0#0'BMv'#1#0#0#0#0#0#0'v'#0#0#0'('#0#0#0' '#0#0#0#16#0#0#0#1#0 + +#4#0#0#0#0#0#0#1#0#0#0#0#0#0#0#0#0#0#16#0#0#0#16#0#0#0#0#0#0#0#0#0#128#0#0 + +#128#0#0#0#128#128#0#128#0#0#0#128#0#128#0#128#128#0#0#192#192#192#0#128#128 + +#128#0#0#0#255#0#0#255#0#0#0#255#255#0#255#0#0#0#255#0#255#0#255#255#0#0#255 + +#255#255#0#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187 + +#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187 + +#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187 + +#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187 + +#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187 + +#187#187#187#187#176#0#0#0#0#0#0#11#183'wwwwww{'#191#204#204#204#204#204#204 + +#11#191#187#187#187#187#187#187'{'#191#204#204#204#204#204#204#11#191#187#187 + +#187#187#187#187'{'#191#255#255#255#255#255#255#251#191#255#255#255#255#255 + +#255#251#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187 + +#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187 + +#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187 + +#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187 + ,#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187 + +#187#187#187#9'NumGlyphs'#2#2#14'ParentShowHint'#8#8'ShowHint'#9#7'OnClick'#7 + +#17'SpeedButton6Click'#0#0#6'TLabel'#6'Label1'#4'Left'#3#208#0#3'Top'#2#13#5 + +'Width'#2'Y'#6'Height'#2#16#8'AutoSize'#8#7'Caption'#6#11'&Row number'#0#0#11 + +'TOvcSpinner'#11'OvcSpinner1'#4'Left'#3'q'#1#3'Top'#2#12#5'Width'#2#16#6'Hei' + +'ght'#2#21#10'AutoRepeat'#9#5'Delta'#5#0#0#0#0#0#0#0#128#255'?'#14'FocusedCo' + +'ntrol'#7#12'ctlRowNumber'#0#0#5'TEdit'#12'ctlRowNumber'#4'Left'#3'('#1#3'To' + +'p'#2#12#5'Width'#2'I'#6'Height'#2#21#9'MaxLength'#2#8#8'TabOrder'#2#0#8'OnC' + +'hange'#7#18'ctlRowNumberChange'#6'OnExit'#7#16'ctlRowNumberExit'#0#0#0#9'TG' + +'roupBox'#9'GroupBox1'#4'Left'#2#8#3'Top'#2'0'#5'Width'#3#17#1#6'Height'#2'q' + +#7'Caption'#6#20'Selected row details'#8'TabOrder'#2#1#0#9'TCheckBox'#9'ctlH' + +'idden'#4'Left'#2#16#3'Top'#2#8#5'Width'#2'Y'#6'Height'#2#17#7'Caption'#6#7 + +'Hidde&n'#8'TabOrder'#2#0#0#0#12'TRadioButton'#15'ctlUseDefHeight'#4'Left'#2 + +#16#3'Top'#2'('#5'Width'#3#145#0#6'Height'#2#25#7'Caption'#6#19'Use &default' + +' height'#8'TabOrder'#2#1#7'TabStop'#9#7'OnClick'#7#20'ctlUseDefHeightClick' + +#0#0#12'TRadioButton'#16'ctlUseCustHeight'#4'Left'#2#16#3'Top'#2'@'#5'Width' + +#3#145#0#6'Height'#2#25#7'Caption'#6#18'Use &custom height'#8'TabOrder'#2#2#7 + +'OnClick'#7#21'ctlUseCustHeightClick'#0#0#11'TOvcSpinner'#11'OvcSpinner2'#4 + +'Left'#3#217#0#3'Top'#2'C'#5'Width'#2#16#6'Height'#2#21#10'AutoRepeat'#9#5'D' + +'elta'#5#0#0#0#0#0#0#0#128#255'?'#14'FocusedControl'#7#9'ctlHeight'#0#0#5'TE' + +'dit'#9'ctlHeight'#4'Left'#3#168#0#3'Top'#2'D'#5'Width'#2'1'#6'Height'#2#21#9 + +'MaxLength'#2#5#8'TabOrder'#2#3#0#0#0#9'TGroupBox'#9'GroupBox2'#4'Left'#2#8#3 + +'Top'#3#168#0#5'Width'#3#17#1#6'Height'#2'i'#7'Caption'#6#19'Overall row det' + +'ails'#8'TabOrder'#2#2#0#6'TLabel'#6'Label2'#4'Left'#2#16#3'Top'#2#17#5'Widt' + +'h'#2'y'#6'Height'#2#16#8'AutoSize'#8#7'Caption'#6#19'De&fault row height'#0 + +#0#6'TLabel'#6'Label3'#4'Left'#2#16#3'Top'#2'5'#5'Width'#2'y'#6'Height'#2#16 + +#8'AutoSize'#8#7'Caption'#6#13'Ma&ximum rows'#0#0#11'TOvcSpinner'#11'OvcSpin' + +'ner3'#4'Left'#3#193#0#3'Top'#2#17#5'Width'#2#16#6'Height'#2#21#10'AutoRepea' + +'t'#9#5'Delta'#5#0#0#0#0#0#0#0#128#255'?'#14'FocusedControl'#7#16'ctlDefault' + +'Height'#0#0#11'TOvcSpinner'#11'OvcSpinner4'#4'Left'#3#217#0#3'Top'#2'5'#5'W' + +'idth'#2#16#6'Height'#2#21#10'AutoRepeat'#9#5'Delta'#5#0#0#0#0#0#0#0#128#255 + +'?'#14'FocusedControl'#7#11'ctlRowLimit'#0#0#5'TEdit'#11'ctlRowLimit'#4'Left' + +#3#144#0#3'Top'#2'4'#5'Width'#2'I'#6'Height'#2#21#8'TabOrder'#2#1#0#0#5'TEdi' + +'t'#16'ctlDefaultHeight'#4'Left'#3#144#0#3'Top'#2#17#5'Width'#2'1'#6'Height' + +#2#21#9'MaxLength'#2#5#8'TabOrder'#2#0#0#0#0#7'TBitBtn'#5'Reset'#4'Left'#3'3' + +#1#3'Top'#2'X'#5'Width'#2'K'#6'Height'#2#25#7'Caption'#6#6'Re&set'#8'TabOrde' + +'r'#2#4#7'OnClick'#7#10'ResetClick'#9'NumGlyphs'#2#2#0#0#7'TBitBtn'#11'Apply' + +'Button'#4'Left'#3'3'#1#3'Top'#2'8'#5'Width'#2'K'#6'Height'#2#25#7'Caption'#6 + +#6'&Apply'#7'Default'#9#8'TabOrder'#2#3#7'OnClick'#7#16'ApplyButtonClick'#9 + +'NumGlyphs'#2#2#0#0#0 +]); diff --git a/components/orpheus/myovctbpe1.pas b/components/orpheus/myovctbpe1.pas new file mode 100644 index 000000000..a25ef7360 --- /dev/null +++ b/components/orpheus/myovctbpe1.pas @@ -0,0 +1,342 @@ +{*********************************************************} +{* myovctbpe1.pas *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* Phil Hess - adapted ovctbpe1.pas to eliminate TOvcSimpleField. *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit MyOvcTbPE1; + {Lazarus-specific Rows property editor for the table component.} + +interface + +uses + {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, LclType, LResources, {$ENDIF} + Classes, Graphics, Controls, + {$IFNDEF LCL} {$IFDEF VERSION6} DesignIntf, DesignEditors, {$ELSE} DsgnIntf, {$ENDIF} {$ELSE} PropEdits, {$ENDIF} + SysUtils, Forms, Dialogs, StdCtrls, Buttons, ExtCtrls, + OvcBase, OvcTCmmn, OvcTable, OvcTbRws, OvcSc; + +type + TOvcfrmRowEditor = class(TForm) + ctlHidden: TCheckBox; + ctlUseDefHeight: TRadioButton; + ctlUseCustHeight: TRadioButton; + DoneButton: TBitBtn; + Panel1: TPanel; + SpeedButton1: TSpeedButton; + SpeedButton2: TSpeedButton; + SpeedButton3: TSpeedButton; + SpeedButton4: TSpeedButton; + SpeedButton5: TSpeedButton; + SpeedButton6: TSpeedButton; + Label1: TLabel; + GroupBox1: TGroupBox; + GroupBox2: TGroupBox; + Label2: TLabel; + Label3: TLabel; + Reset: TBitBtn; + ctlHeight: TEdit; + ctlDefaultHeight: TEdit; + ctlRowLimit: TEdit; + ctlRowNumber: TEdit; + ApplyButton: TBitBtn; + OvcSpinner1: TOvcSpinner; + OvcSpinner2: TOvcSpinner; + OvcSpinner3: TOvcSpinner; + OvcSpinner4: TOvcSpinner; + procedure ctlUseDefHeightClick(Sender: TObject); + procedure ctlUseCustHeightClick(Sender: TObject); + procedure SpeedButton1Click(Sender: TObject); + procedure SpeedButton2Click(Sender: TObject); + procedure SpeedButton3Click(Sender: TObject); + procedure SpeedButton4Click(Sender: TObject); + procedure SpeedButton5Click(Sender: TObject); + procedure SpeedButton6Click(Sender: TObject); + procedure ctlRowNumberExit(Sender: TObject); + procedure FormShow(Sender: TObject); + procedure ResetClick(Sender: TObject); + procedure ApplyButtonClick(Sender: TObject); + procedure DoneButtonClick(Sender: TObject); + procedure ctlRowNumberChange(Sender: TObject); + private + { Private declarations } + FRows : TOvcTableRows; + FRowNum : TRowNum; + CurDefHt : boolean; + + protected + procedure RefreshRowData; + procedure SetRowNum(R : TRowNum); + + public + { Public declarations } + procedure SetRows(RS : TOvcTableRows); + + property Rows : TOvcTableRows + read FRows + write SetRows; + + property RowNum : TRowNum + read FRowNum + write SetRowNum; + + end; + + {-A table row property editor} + TOvcTableRowProperty = class(TClassProperty) + public + procedure Edit; override; + function GetAttributes: TPropertyAttributes; override; + end; + + +implementation + +{$IFNDEF LCL} +{$R *.DFM} +{$ENDIF} + + + +{===TOvcTableRowProperty=============================================} +procedure TOvcTableRowProperty.Edit; + var + RowEditor : TOvcfrmRowEditor; + begin + RowEditor := TOvcfrmRowEditor.Create(Application); + try + RowEditor.SetRows(TOvcTableRows(GetOrdValue)); + RowEditor.ShowModal; +{$IFNDEF LCL} + Designer.Modified; +{$ELSE} + Modified; +{$ENDIF} + finally + RowEditor.Free; + end;{try..finally} + end; +{--------} +function TOvcTableRowProperty.GetAttributes: TPropertyAttributes; + begin + Result := [paMultiSelect, paDialog, paReadOnly]; + end; +{====================================================================} + + +{===TRowEditor=======================================================} +procedure TOvcfrmRowEditor.ApplyButtonClick(Sender: TObject); + var + NewRowLimit : Integer; + NewDefHeight : Integer; + NewHeight : Integer; + RS : TRowStyle; + begin + NewRowLimit := StrToIntDef(ctlRowLimit.Text, FRows.Limit); + if (NewRowLimit < 1) or (NewRowLimit > MaxInt) then {Out of range?} + NewRowLimit := FRows.Limit; {Restore previous row limit} + FRows.Limit := NewRowLimit; + ctlRowLimit.Text := IntToStr(NewRowLimit); + if FRowNum >= FRows.Limit then + RowNum := pred(FRows.Limit); + + NewDefHeight := StrToIntDef(ctlDefaultHeight.Text, FRows.DefaultHeight); + if (NewDefHeight < 5) or (NewDefHeight > 32767) then {Out of range?} + NewDefHeight := FRows.DefaultHeight; {Restore previous default height} + FRows.DefaultHeight := NewDefHeight; + ctlDefaultHeight.Text := IntToStr(NewDefHeight); + + with RS do + begin + if ctlUseDefHeight.Checked then + Height := StrToIntDef(ctlDefaultHeight.Text, Height) + else + begin + NewHeight := StrToIntDef(ctlHeight.Text, Height); + if (NewHeight < 5) or (NewHeight > 32767) then {Out of range?} + NewHeight := Height; {Restore previous row height} + Height := NewHeight; + ctlHeight.Text := IntToStr(NewHeight); + if (Height = FRows.DefaultHeight) then + ctlUseDefHeight.Checked := true; + end; + Hidden := ctlHidden.Checked; + FRows[RowNum] := RS; + end; + end; +{--------} +procedure TOvcfrmRowEditor.ctlRowNumberExit(Sender: TObject); + begin + RowNum := StrToInt(ctlRowNumber.Text); + end; +{--------} +procedure TOvcfrmRowEditor.ctlUseCustHeightClick(Sender: TObject); + begin + CurDefHt := false; + ctlHeight.Enabled := true; + end; +{--------} +procedure TOvcfrmRowEditor.ctlUseDefHeightClick(Sender: TObject); + begin + CurDefHt := true; + ctlHeight.Text := IntToStr(FRows.DefaultHeight); + ctlHeight.Enabled := false; + end; +{--------} +procedure TOvcfrmRowEditor.FormShow(Sender: TObject); + begin + ctlDefaultHeight.Text := IntToStr(FRows.DefaultHeight); + ctlRowLimit.Text := IntToStr(FRows.Limit); + RefreshRowData; + end; +{--------} +procedure TOvcfrmRowEditor.RefreshRowData; + begin + CurDefHt := FRows.Height[RowNum] = FRows.DefaultHeight; + + ctlHidden.Checked := FRows.Hidden[RowNum]; + ctlHeight.Text := IntToStr(FRows.Height[RowNum]); + if CurDefHt then + begin + ctlUseDefHeight.Checked := true; + ctlHeight.Enabled := false; + end + else + begin + ctlUseCustHeight.Checked := true; + ctlHeight.Enabled := true; + end; + + ctlRowLimit.Text := IntToStr(FRows.Limit); + end; +{--------} +procedure TOvcfrmRowEditor.ResetClick(Sender: TObject); + begin + FRows.Clear; + ctlDefaultHeight.Text := IntToStr(FRows.DefaultHeight); + RefreshRowData; + end; +{--------} +procedure TOvcfrmRowEditor.SetRowNum(R : TRowNum); + begin + if (FRowNum <> R) then + begin + FRowNum := R; + RefreshRowData; + ctlRowNumber.Text := IntToStr(R); //Do this after refresh + end; + end; +{--------} +procedure TOvcfrmRowEditor.SetRows(RS : TOvcTableRows); + begin + if Assigned(FRows) then + FRows.Free; + FRows := RS; + FRowNum := 0; + ctlRowNumber.Text := '0'; + CurDefHt := FRows.Height[RowNum] = FRows.DefaultHeight; + end; +{--------} +procedure TOvcfrmRowEditor.SpeedButton1Click(Sender: TObject); + begin + ApplyButtonClick(Self); + if (RowNum > 0) then + RowNum := RowNum - 1; + end; +{--------} +procedure TOvcfrmRowEditor.SpeedButton2Click(Sender: TObject); + begin + ApplyButtonClick(Self); + if (RowNum < pred(FRows.Limit)) then + RowNum := RowNum + 1; + end; +{--------} +procedure TOvcfrmRowEditor.SpeedButton3Click(Sender: TObject); + begin + ApplyButtonClick(Self); + RowNum := 0; + end; +{--------} +procedure TOvcfrmRowEditor.SpeedButton4Click(Sender: TObject); + begin + ApplyButtonClick(Self); + RowNum := pred(FRows.Limit); + end; +{--------} +procedure TOvcfrmRowEditor.SpeedButton5Click(Sender: TObject); + var + RS : TRowStyle; + begin + RS.Hidden := false; + RS.Height := FRows.DefaultHeight; + FRows.Insert(FRowNum, RS); + RefreshRowData; + end; +{--------} +procedure TOvcfrmRowEditor.SpeedButton6Click(Sender: TObject); + begin + FRows.Delete(FRowNum); + RefreshRowData; + end; +{====================================================================} + +procedure TOvcfrmRowEditor.DoneButtonClick(Sender: TObject); +begin + ApplyButtonClick(Self); +end; + +procedure TOvcfrmRowEditor.ctlRowNumberChange(Sender: TObject); +var + NewRowNum : Integer; +begin + ApplyButtonClick(Self); + if not TryStrToInt(ctlRowNumber.Text, NewRowNum) then {Invalid?} + ctlRowNumber.Text := IntToStr(RowNum) {Restore previous row number} + else if NewRowNum = -1 then {Wrap around to last row?} + ctlRowNumber.Text := IntToStr(Pred(FRows.Limit)) + else if NewRowNum = FRows.Limit then {Wrap around to first row?} + ctlRowNumber.Text := '0' + else if not (NewRowNum in [0..Pred(FRows.Limit)]) then {Out of range?} + ctlRowNumber.Text := IntToStr(RowNum); {Restore previous row number} + RowNum := StrToInt(ctlRowNumber.Text); +end; + +initialization +{$IFDEF LCL} +{$I myovctbpe1.lrs} {Include form's resource file} +{$ENDIF} + +end. diff --git a/components/orpheus/myovctbpe2.lfm b/components/orpheus/myovctbpe2.lfm new file mode 100644 index 000000000..6f375c5ec --- /dev/null +++ b/components/orpheus/myovctbpe2.lfm @@ -0,0 +1,290 @@ +object OvcfrmColEditor: TOvcfrmColEditor + Left = 353 + Top = 207 + BorderIcons = [biSystemMenu] + BorderStyle = bsDialog + Caption = 'Columns Editor' + ClientHeight = 190 + Height = 190 + ClientWidth = 386 + Width = 386 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Style = [] + Position = poScreenCenter + OnShow = FormShow + PixelsPerInch = 96 + TextHeight = 13 + object Panel1: TPanel + Left = 0 + Top = 0 + Width = 386 + Height = 41 + Align = alTop + Alignment = taLeftJustify + BevelInner = bvLowered + TabOrder = 0 + object SpeedButton1: TSpeedButton + Left = 8 + Top = 8 + Width = 25 + Height = 25 + Hint = 'Previous column' + Glyph.Data = { + 76010000424D7601000000000000760000002800000020000000100000000100 + 0400000000000001000000000000000000001000000010000000000000000000 + 80000080000000808000800000008000800080800000C0C0C000808080000000 + FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00BBBBBBBBBBBB + BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB0000 + BBBBBBBBBBBB777BBBBBBBBBBBB00CC0BBBBBBBBBBB7777BBBBBBBBBBB00CCC0 + BBBBBBBBBB77777BBBBBBBBBB00CCCC0BBBBBBBBB777777BBBBBBBBB00CCCCC0 + BBBBBBBB7777777BBBBBBBBF0CCCCCC0BBBBBBB77777777BBBBBBBBF0CCCCCC0 + BBBBBBB77777777BBBBBBBBBFCCCCCC0BBBBBBBB7777777BBBBBBBBBBFCCCCC0 + BBBBBBBBB777777BBBBBBBBBBBFCCCC0BBBBBBBBBB77777BBBBBBBBBBBBFCCC0 + BBBBBBBBBBB7777BBBBBBBBBBBBBFFFFBBBBBBBBBBBB777BBBBBBBBBBBBBBBBB + BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB} + NumGlyphs = 2 + ParentShowHint = False + ShowHint = True + OnClick = SpeedButton1Click + end + object SpeedButton2: TSpeedButton + Left = 32 + Top = 8 + Width = 25 + Height = 25 + Hint = 'Next column' + Glyph.Data = { + 76010000424D7601000000000000760000002800000020000000100000000100 + 0400000000000001000000000000000000001000000010000000000000000000 + 80000080000000808000800000008000800080800000C0C0C000808080000000 + FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00BBBBBBBBBBBB + BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBF000BBBBB + BBBBBBBFFFFBBBBBBBBBBBBF0000BBBBBBBBBBBFFFFFBBBBBBBBBBBFCCC00BBB + BBBBBBBFFFFFFBBBBBBBBBBFCCCC00BBBBBBBBBFFFFFFFBBBBBBBBBFCCCCC00B + BBBBBBBFFFFFFFFBBBBBBBBFCCCCCC00BBBBBBBFFFFFFFFFBBBBBBBFCCCCCC0F + BBBBBBBFFFFFFFFFBBBBBBBFCCCCCCFBBBBBBBBFFFFFFFFBBBBBBBBFCCCCCFBB + BBBBBBBFFFFFFFBBBBBBBBBFCCCCFBBBBBBBBBBFFFFFFBBBBBBBBBBFCCCFBBBB + BBBBBBBFFFFFBBBBBBBBBBBFFFFBBBBBBBBBBBBFFFFBBBBBBBBBBBBBBBBBBBBB + BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB} + NumGlyphs = 2 + ParentShowHint = False + ShowHint = True + OnClick = SpeedButton2Click + end + object SpeedButton3: TSpeedButton + Left = 72 + Top = 8 + Width = 25 + Height = 25 + Hint = 'First column' + Glyph.Data = { + 76010000424D7601000000000000760000002800000020000000100000000100 + 0400000000000001000000000000000000001000000010000000000000000000 + 80000080000000808000800000008000800080800000C0C0C000808080000000 + FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00BBBBBBBBBBBB + BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB00BBBBBB00 + BBBBBBFFBBBBBBFFBBBBBB00BBBBB000BBBBBBFFBBBBBFFFBBBBBB00BBBB00C0 + BBBBBBFFBBBBFFFFBBBBBB00BBB00CC0BBBBBBFFBBBFFFFFBBBBBB00BB00CCC0 + BBBBBBFFBBFFFFFFBBBBBB00B00CCCC0BBBBBBFFBFFFFFFFBBBBBB00BFCCCCC0 + BBBBBBFFBFFFFFFFBBBBBB00BBFCCCC0BBBBBBFFBBFFFFFFBBBBBB00BBBFCCC0 + BBBBBBFFBBBFFFFFBBBBBB00BBBBFCC0BBBBBBFFBBBBFFFFBBBBBB00BBBBBFC0 + BBBBBBFFBBBBBFFFBBBBBB00BBBBBBFFBBBBBBFFBBBBBBFFBBBBBBBBBBBBBBBB + BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB} + NumGlyphs = 2 + ParentShowHint = False + ShowHint = True + OnClick = SpeedButton3Click + end + object SpeedButton4: TSpeedButton + Left = 96 + Top = 8 + Width = 25 + Height = 25 + Hint = 'Last column' + Glyph.Data = { + 76010000424D7601000000000000760000002800000020000000100000000100 + 0400000000000001000000000000000000001000000010000000000000000000 + 80000080000000808000800000008000800080800000C0C0C000808080000000 + FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00BBBBBBBBBBBB + BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB00BBBBBB + 00BBBBBB77BBBBBB77BBBBBB000BBBBB00BBBBBB777BBBBB77BBBBBB0C00BBBB + 00BBBBBB7777BBBB77BBBBBB0CC00BBB00BBBBBB77777BBB77BBBBBB0CCC00BB + 00BBBBBB777777BB77BBBBBB0CCCC00B00BBBBBB7777777B77BBBBBB0CCCCCFB + 00BBBBBB7777777B77BBBBBB0CCCCFBB00BBBBBB777777BB77BBBBBB0CCCFBBB + 00BBBBBB77777BBB77BBBBBB0CCFBBBB00BBBBBB7777BBBB77BBBBBB0CFBBBBB + 00BBBBBB777BBBBB77BBBBBBFFBBBBBB00BBBBBB77BBBBBB77BBBBBBBBBBBBBB + BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB} + NumGlyphs = 2 + ParentShowHint = False + ShowHint = True + OnClick = SpeedButton4Click + end + object SpeedButton5: TSpeedButton + Left = 136 + Top = 8 + Width = 25 + Height = 25 + Hint = 'Insert column' + Glyph.Data = { + 76010000424D7601000000000000760000002800000020000000100000000100 + 0400000000000001000000000000000000001000000010000000000000000000 + 80000080000000808000800000008000800080800000C0C0C000808080000000 + FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00BBBBBBBBBBBB + BBBBBBBBBBBBBBBBBBBBBBBBBBF000BBBBBBBBBBBBF777BBBBBBBBBBBBFCC0BB + BBBBBBBBBBFBB7BBBBBBBBBBBBFCC0BBBBBBBBBBBBFBB7BBBBBBBBBBBBFCC0BB + BBBBBBBBBBFBB7BBBBBBBBBBBBFCC0BBBBBBBBBBBBFBB7BBBBBBB000000CC000 + 000BB777777BB777777BBFCCCCCCCCCCCC0BBFBBBBBBBBBBBB7BBFCCCCCCCCCC + CC0BBFBBBBBBBBBBBB7BBFFFFFFCC0FFFFFBBFFFFFFBB7FFFFFBBBBBBBFCC0BB + BBBBBBBBBBFBB7BBBBBBBBBBBBFCC0BBBBBBBBBBBBFBB7BBBBBBBBBBBBFCC0BB + BBBBBBBBBBFBB7BBBBBBBBBBBBFCC0BBBBBBBBBBBBFBB7BBBBBBBBBBBBFFF0BB + BBBBBBBBBBFFF7BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB} + NumGlyphs = 2 + ParentShowHint = False + ShowHint = True + OnClick = SpeedButton5Click + end + object SpeedButton6: TSpeedButton + Left = 160 + Top = 8 + Width = 25 + Height = 25 + Hint = 'Delete column' + Glyph.Data = { + 76010000424D7601000000000000760000002800000020000000100000000100 + 0400000000000001000000000000000000001000000010000000000000000000 + 80000080000000808000800000008000800080800000C0C0C000808080000000 + FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00BBBBBBBBBBBB + BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB + BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB + BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB00000000000 + 000BB77777777777777BBFCCCCCCCCCCCC0BBFBBBBBBBBBBBB7BBFCCCCCCCCCC + CC0BBFBBBBBBBBBBBB7BBFFFFFFFFFFFFFFBBFFFFFFFFFFFFFFBBBBBBBBBBBBB + BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB + BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB + BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB} + NumGlyphs = 2 + ParentShowHint = False + ShowHint = True + OnClick = SpeedButton6Click + end + object Label1: TLabel + Left = 200 + Top = 12 + Width = 105 + Height = 16 + AutoSize = False + Caption = 'Column &number' + end + object OvcSpinner2: TOvcSpinner + Left = 361 + Top = 11 + Width = 16 + Height = 21 + AutoRepeat = True + Delta = 1.000000000000000000 + FocusedControl = ctlColNumber + end + object ctlColNumber: TEdit + Left = 312 + Top = 11 + Width = 49 + Height = 21 + MaxLength = 5 + TabOrder = 0 + OnChange = ctlColNumberChange + OnExit = ctlColNumberExit + end + end + object GroupBox1: TGroupBox + Left = 8 + Top = 48 + Width = 273 + Height = 137 + Caption = 'Column details' + TabOrder = 1 + object Label2: TLabel + Left = 8 + Top = 4 + Width = 75 + Height = 16 + AutoSize = False + Caption = 'De&fault Cell' + FocusControl = ctlDefaultCell + end + object Label3: TLabel + Left = 8 + Top = 92 + Width = 75 + Height = 16 + AutoSize = False + Caption = '&Width' + end + object Label4: TLabel + Left = 8 + Top = 56 + Width = 34 + Height = 13 + Caption = '&Hidden' + FocusControl = ctlHidden + end + object ctlDefaultCell: TComboBox + Left = 8 + Top = 24 + Width = 257 + Height = 21 + Style = csDropDownList + DropDownCount = 16 + ItemHeight = 13 + TabOrder = 0 + end + object ctlHidden: TCheckBox + Left = 96 + Top = 56 + Width = 17 + Height = 17 + TabOrder = 1 + end + object OvcSpinner1: TOvcSpinner + Left = 145 + Top = 90 + Width = 16 + Height = 21 + AutoRepeat = True + Delta = 1.000000000000000000 + FocusedControl = ctlWidth + end + object ctlWidth: TEdit + Left = 96 + Top = 90 + Width = 49 + Height = 21 + MaxLength = 5 + TabOrder = 2 + end + end + object DoneButton: TBitBtn + Left = 304 + Top = 160 + Width = 75 + Height = 25 + Caption = '&Done' + ModalResult = 1 + TabOrder = 3 + OnClick = DoneButtonClick + NumGlyphs = 2 + end + object ApplyButton: TBitBtn + Left = 304 + Top = 56 + Width = 75 + Height = 25 + Caption = '&Apply' + Default = True + TabOrder = 2 + OnClick = ApplyButtonClick + NumGlyphs = 2 + end +end diff --git a/components/orpheus/myovctbpe2.lrs b/components/orpheus/myovctbpe2.lrs new file mode 100644 index 000000000..b5ed4c140 --- /dev/null +++ b/components/orpheus/myovctbpe2.lrs @@ -0,0 +1,157 @@ +LazarusResources.Add('TOvcfrmColEditor','FORMDATA',[ + 'TPF0'#16'TOvcfrmColEditor'#15'OvcfrmColEditor'#4'Left'#3'a'#1#3'Top'#3#207#0 + +#11'BorderIcons'#11#12'biSystemMenu'#0#11'BorderStyle'#7#8'bsDialog'#7'Capti' + +'on'#6#14'Columns Editor'#12'ClientHeight'#3#190#0#6'Height'#3#190#0#11'Clie' + +'ntWidth'#3#130#1#5'Width'#3#130#1#5'Color'#7#9'clBtnFace'#12'Font.Charset'#7 + +#15'DEFAULT_CHARSET'#10'Font.Color'#7#12'clWindowText'#11'Font.Height'#2#245 + +#10'Font.Style'#11#0#8'Position'#7#14'poScreenCenter'#6'OnShow'#7#8'FormShow' + +#13'PixelsPerInch'#2'`'#10'TextHeight'#2#13#0#6'TPanel'#6'Panel1'#4'Left'#2#0 + +#3'Top'#2#0#5'Width'#3#130#1#6'Height'#2')'#5'Align'#7#5'alTop'#9'Alignment' + +#7#13'taLeftJustify'#10'BevelInner'#7#9'bvLowered'#8'TabOrder'#2#0#0#12'TSpe' + +'edButton'#12'SpeedButton1'#4'Left'#2#8#3'Top'#2#8#5'Width'#2#25#6'Height'#2 + +#25#4'Hint'#6#15'Previous column'#10'Glyph.Data'#10'z'#1#0#0'v'#1#0#0'BMv'#1 + +#0#0#0#0#0#0'v'#0#0#0'('#0#0#0' '#0#0#0#16#0#0#0#1#0#4#0#0#0#0#0#0#1#0#0#0#0 + +#0#0#0#0#0#0#16#0#0#0#16#0#0#0#0#0#0#0#0#0#128#0#0#128#0#0#0#128#128#0#128#0 + +#0#0#128#0#128#0#128#128#0#0#192#192#192#0#128#128#128#0#0#0#255#0#0#255#0#0 + +#0#255#255#0#255#0#0#0#255#0#255#0#255#255#0#0#255#255#255#0#187#187#187#187 + +#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187 + +#187#187#187#187#187#187#187#187#187#187#187#187#187#0#0#187#187#187#187#187 + +#187'w{'#187#187#187#187#187#176#12#192#187#187#187#187#187#183'w{'#187#187 + +#187#187#187#0#204#192#187#187#187#187#187'ww{'#187#187#187#187#176#12#204 + +#192#187#187#187#187#183'ww{'#187#187#187#187#0#204#204#192#187#187#187#187 + +'www{'#187#187#187#191#12#204#204#192#187#187#187#183'www{'#187#187#187#191 + +#12#204#204#192#187#187#187#183'www{'#187#187#187#187#252#204#204#192#187#187 + +#187#187'www{'#187#187#187#187#191#204#204#192#187#187#187#187#183'ww{'#187 + +#187#187#187#187#252#204#192#187#187#187#187#187'ww{'#187#187#187#187#187#191 + +#204#192#187#187#187#187#187#183'w{'#187#187#187#187#187#187#255#255#187#187 + +#187#187#187#187'w{'#187#187#187#187#187#187#187#187#187#187#187#187#187#187 + +#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187 + +#187#9'NumGlyphs'#2#2#14'ParentShowHint'#8#8'ShowHint'#9#7'OnClick'#7#17'Spe' + +'edButton1Click'#0#0#12'TSpeedButton'#12'SpeedButton2'#4'Left'#2' '#3'Top'#2 + +#8#5'Width'#2#25#6'Height'#2#25#4'Hint'#6#11'Next column'#10'Glyph.Data'#10 + +'z'#1#0#0'v'#1#0#0'BMv'#1#0#0#0#0#0#0'v'#0#0#0'('#0#0#0' '#0#0#0#16#0#0#0#1#0 + +#4#0#0#0#0#0#0#1#0#0#0#0#0#0#0#0#0#0#16#0#0#0#16#0#0#0#0#0#0#0#0#0#128#0#0 + +#128#0#0#0#128#128#0#128#0#0#0#128#0#128#0#128#128#0#0#192#192#192#0#128#128 + +#128#0#0#0#255#0#0#255#0#0#0#255#255#0#255#0#0#0#255#0#255#0#255#255#0#0#255 + +#255#255#0#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187 + +#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#191#0#11 + +#187#187#187#187#187#191#255#251#187#187#187#187#187#191#0#0#187#187#187#187 + +#187#191#255#255#187#187#187#187#187#191#204#192#11#187#187#187#187#191#255 + +#255#251#187#187#187#187#191#204#204#0#187#187#187#187#191#255#255#255#187 + +#187#187#187#191#204#204#192#11#187#187#187#191#255#255#255#251#187#187#187 + +#191#204#204#204#0#187#187#187#191#255#255#255#255#187#187#187#191#204#204 + +#204#15#187#187#187#191#255#255#255#255#187#187#187#191#204#204#204#251#187 + +#187#187#191#255#255#255#251#187#187#187#191#204#204#207#187#187#187#187#191 + +#255#255#255#187#187#187#187#191#204#204#251#187#187#187#187#191#255#255#251 + +#187#187#187#187#191#204#207#187#187#187#187#187#191#255#255#187#187#187#187 + +#187#191#255#251#187#187#187#187#187#191#255#251#187#187#187#187#187#187#187 + +#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187 + +#187#187#187#187#187#187#187#187#187#187#9'NumGlyphs'#2#2#14'ParentShowHint' + +#8#8'ShowHint'#9#7'OnClick'#7#17'SpeedButton2Click'#0#0#12'TSpeedButton'#12 + +'SpeedButton3'#4'Left'#2'H'#3'Top'#2#8#5'Width'#2#25#6'Height'#2#25#4'Hint'#6 + +#12'First column'#10'Glyph.Data'#10'z'#1#0#0'v'#1#0#0'BMv'#1#0#0#0#0#0#0'v'#0 + +#0#0'('#0#0#0' '#0#0#0#16#0#0#0#1#0#4#0#0#0#0#0#0#1#0#0#0#0#0#0#0#0#0#0#16#0 + +#0#0#16#0#0#0#0#0#0#0#0#0#128#0#0#128#0#0#0#128#128#0#128#0#0#0#128#0#128#0 + +#128#128#0#0#192#192#192#0#128#128#128#0#0#0#255#0#0#255#0#0#0#255#255#0#255 + +#0#0#0#255#0#255#0#255#255#0#0#255#255#255#0#187#187#187#187#187#187#187#187 + +#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187 + +#187#187#187#187#187#187#0#187#187#187#0#187#187#187#255#187#187#187#255#187 + +#187#187#0#187#187#176#0#187#187#187#255#187#187#191#255#187#187#187#0#187 + +#187#0#192#187#187#187#255#187#187#255#255#187#187#187#0#187#176#12#192#187 + +#187#187#255#187#191#255#255#187#187#187#0#187#0#204#192#187#187#187#255#187 + +#255#255#255#187#187#187#0#176#12#204#192#187#187#187#255#191#255#255#255#187 + +#187#187#0#191#204#204#192#187#187#187#255#191#255#255#255#187#187#187#0#187 + +#252#204#192#187#187#187#255#187#255#255#255#187#187#187#0#187#191#204#192 + +#187#187#187#255#187#191#255#255#187#187#187#0#187#187#252#192#187#187#187 + ,#255#187#187#255#255#187#187#187#0#187#187#191#192#187#187#187#255#187#187 + +#191#255#187#187#187#0#187#187#187#255#187#187#187#255#187#187#187#255#187 + +#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187 + +#187#187#187#187#187#187#187#187#187#187#187#187#187#187#9'NumGlyphs'#2#2#14 + +'ParentShowHint'#8#8'ShowHint'#9#7'OnClick'#7#17'SpeedButton3Click'#0#0#12'T' + +'SpeedButton'#12'SpeedButton4'#4'Left'#2'`'#3'Top'#2#8#5'Width'#2#25#6'Heigh' + +'t'#2#25#4'Hint'#6#11'Last column'#10'Glyph.Data'#10'z'#1#0#0'v'#1#0#0'BMv'#1 + +#0#0#0#0#0#0'v'#0#0#0'('#0#0#0' '#0#0#0#16#0#0#0#1#0#4#0#0#0#0#0#0#1#0#0#0#0 + +#0#0#0#0#0#0#16#0#0#0#16#0#0#0#0#0#0#0#0#0#128#0#0#128#0#0#0#128#128#0#128#0 + +#0#0#128#0#128#0#128#128#0#0#192#192#192#0#128#128#128#0#0#0#255#0#0#255#0#0 + +#0#255#255#0#255#0#0#0#255#0#255#0#255#255#0#0#255#255#255#0#187#187#187#187 + +#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187 + +#187#187#187#187#187#187#187#187#187#187#187#0#187#187#187#0#187#187#187'w' + +#187#187#187'w'#187#187#187#0#11#187#187#0#187#187#187'w{'#187#187'w'#187#187 + +#187#12#0#187#187#0#187#187#187'ww'#187#187'w'#187#187#187#12#192#11#187#0 + +#187#187#187'ww{'#187'w'#187#187#187#12#204#0#187#0#187#187#187'www'#187'w' + +#187#187#187#12#204#192#11#0#187#187#187'www{w'#187#187#187#12#204#204#251#0 + +#187#187#187'www{w'#187#187#187#12#204#207#187#0#187#187#187'www'#187'w'#187 + +#187#187#12#204#251#187#0#187#187#187'ww{'#187'w'#187#187#187#12#207#187#187 + +#0#187#187#187'ww'#187#187'w'#187#187#187#12#251#187#187#0#187#187#187'w{' + +#187#187'w'#187#187#187#255#187#187#187#0#187#187#187'w'#187#187#187'w'#187 + +#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187 + +#187#187#187#187#187#187#187#187#187#187#187#187#187#9'NumGlyphs'#2#2#14'Par' + +'entShowHint'#8#8'ShowHint'#9#7'OnClick'#7#17'SpeedButton4Click'#0#0#12'TSpe' + +'edButton'#12'SpeedButton5'#4'Left'#3#136#0#3'Top'#2#8#5'Width'#2#25#6'Heigh' + +'t'#2#25#4'Hint'#6#13'Insert column'#10'Glyph.Data'#10'z'#1#0#0'v'#1#0#0'BMv' + +#1#0#0#0#0#0#0'v'#0#0#0'('#0#0#0' '#0#0#0#16#0#0#0#1#0#4#0#0#0#0#0#0#1#0#0#0 + +#0#0#0#0#0#0#0#16#0#0#0#16#0#0#0#0#0#0#0#0#0#128#0#0#128#0#0#0#128#128#0#128 + +#0#0#0#128#0#128#0#128#128#0#0#192#192#192#0#128#128#128#0#0#0#255#0#0#255#0 + +#0#0#255#255#0#255#0#0#0#255#0#255#0#255#255#0#0#255#255#255#0#187#187#187 + +#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#240#0#187 + +#187#187#187#187#187#247'w'#187#187#187#187#187#187#252#192#187#187#187#187 + +#187#187#251#183#187#187#187#187#187#187#252#192#187#187#187#187#187#187#251 + +#183#187#187#187#187#187#187#252#192#187#187#187#187#187#187#251#183#187#187 + +#187#187#187#187#252#192#187#187#187#187#187#187#251#183#187#187#187#176#0#0 + +#12#192#0#0#11#183'ww{'#183'ww{'#191#204#204#204#204#204#204#11#191#187#187 + +#187#187#187#187'{'#191#204#204#204#204#204#204#11#191#187#187#187#187#187 + +#187'{'#191#255#255#252#192#255#255#251#191#255#255#251#183#255#255#251#187 + +#187#187#252#192#187#187#187#187#187#187#251#183#187#187#187#187#187#187#252 + +#192#187#187#187#187#187#187#251#183#187#187#187#187#187#187#252#192#187#187 + +#187#187#187#187#251#183#187#187#187#187#187#187#252#192#187#187#187#187#187 + +#187#251#183#187#187#187#187#187#187#255#240#187#187#187#187#187#187#255#247 + +#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187 + +#9'NumGlyphs'#2#2#14'ParentShowHint'#8#8'ShowHint'#9#7'OnClick'#7#17'SpeedBu' + +'tton5Click'#0#0#12'TSpeedButton'#12'SpeedButton6'#4'Left'#3#160#0#3'Top'#2#8 + +#5'Width'#2#25#6'Height'#2#25#4'Hint'#6#13'Delete column'#10'Glyph.Data'#10 + +'z'#1#0#0'v'#1#0#0'BMv'#1#0#0#0#0#0#0'v'#0#0#0'('#0#0#0' '#0#0#0#16#0#0#0#1#0 + +#4#0#0#0#0#0#0#1#0#0#0#0#0#0#0#0#0#0#16#0#0#0#16#0#0#0#0#0#0#0#0#0#128#0#0 + +#128#0#0#0#128#128#0#128#0#0#0#128#0#128#0#128#128#0#0#192#192#192#0#128#128 + +#128#0#0#0#255#0#0#255#0#0#0#255#255#0#255#0#0#0#255#0#255#0#255#255#0#0#255 + +#255#255#0#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187 + +#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187 + +#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187 + +#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187 + +#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187 + +#187#187#187#187#176#0#0#0#0#0#0#11#183'wwwwww{'#191#204#204#204#204#204#204 + +#11#191#187#187#187#187#187#187'{'#191#204#204#204#204#204#204#11#191#187#187 + +#187#187#187#187'{'#191#255#255#255#255#255#255#251#191#255#255#255#255#255 + +#255#251#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187 + +#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187 + +#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187 + +#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187 + +#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187#187 + +#187#187#187#9'NumGlyphs'#2#2#14'ParentShowHint'#8#8'ShowHint'#9#7'OnClick'#7 + ,#17'SpeedButton6Click'#0#0#6'TLabel'#6'Label1'#4'Left'#3#200#0#3'Top'#2#12#5 + +'Width'#2'i'#6'Height'#2#16#8'AutoSize'#8#7'Caption'#6#14'Column &number'#0#0 + +#11'TOvcSpinner'#11'OvcSpinner2'#4'Left'#3'i'#1#3'Top'#2#11#5'Width'#2#16#6 + +'Height'#2#21#10'AutoRepeat'#9#5'Delta'#5#0#0#0#0#0#0#0#128#255'?'#14'Focuse' + +'dControl'#7#12'ctlColNumber'#0#0#5'TEdit'#12'ctlColNumber'#4'Left'#3'8'#1#3 + +'Top'#2#11#5'Width'#2'1'#6'Height'#2#21#9'MaxLength'#2#5#8'TabOrder'#2#0#8'O' + +'nChange'#7#18'ctlColNumberChange'#6'OnExit'#7#16'ctlColNumberExit'#0#0#0#9 + +'TGroupBox'#9'GroupBox1'#4'Left'#2#8#3'Top'#2'0'#5'Width'#3#17#1#6'Height'#3 + +#137#0#7'Caption'#6#14'Column details'#8'TabOrder'#2#1#0#6'TLabel'#6'Label2' + +#4'Left'#2#8#3'Top'#2#4#5'Width'#2'K'#6'Height'#2#16#8'AutoSize'#8#7'Caption' + +#6#13'De&fault Cell'#12'FocusControl'#7#14'ctlDefaultCell'#0#0#6'TLabel'#6'L' + +'abel3'#4'Left'#2#8#3'Top'#2'\'#5'Width'#2'K'#6'Height'#2#16#8'AutoSize'#8#7 + +'Caption'#6#6'&Width'#0#0#6'TLabel'#6'Label4'#4'Left'#2#8#3'Top'#2'8'#5'Widt' + +'h'#2'"'#6'Height'#2#13#7'Caption'#6#7'&Hidden'#12'FocusControl'#7#9'ctlHidd' + +'en'#0#0#9'TComboBox'#14'ctlDefaultCell'#4'Left'#2#8#3'Top'#2#24#5'Width'#3#1 + +#1#6'Height'#2#21#5'Style'#7#14'csDropDownList'#13'DropDownCount'#2#16#10'It' + +'emHeight'#2#13#8'TabOrder'#2#0#0#0#9'TCheckBox'#9'ctlHidden'#4'Left'#2'`'#3 + +'Top'#2'8'#5'Width'#2#17#6'Height'#2#17#8'TabOrder'#2#1#0#0#11'TOvcSpinner' + +#11'OvcSpinner1'#4'Left'#3#145#0#3'Top'#2'Z'#5'Width'#2#16#6'Height'#2#21#10 + +'AutoRepeat'#9#5'Delta'#5#0#0#0#0#0#0#0#128#255'?'#14'FocusedControl'#7#8'ct' + +'lWidth'#0#0#5'TEdit'#8'ctlWidth'#4'Left'#2'`'#3'Top'#2'Z'#5'Width'#2'1'#6'H' + +'eight'#2#21#9'MaxLength'#2#5#8'TabOrder'#2#2#0#0#0#7'TBitBtn'#10'DoneButton' + +#4'Left'#3'0'#1#3'Top'#3#160#0#5'Width'#2'K'#6'Height'#2#25#7'Caption'#6#5'&' + +'Done'#11'ModalResult'#2#1#8'TabOrder'#2#3#7'OnClick'#7#15'DoneButtonClick'#9 + +'NumGlyphs'#2#2#0#0#7'TBitBtn'#11'ApplyButton'#4'Left'#3'0'#1#3'Top'#2'8'#5 + +'Width'#2'K'#6'Height'#2#25#7'Caption'#6#6'&Apply'#7'Default'#9#8'TabOrder'#2 + +#2#7'OnClick'#7#16'ApplyButtonClick'#9'NumGlyphs'#2#2#0#0#0 +]); diff --git a/components/orpheus/myovctbpe2.pas b/components/orpheus/myovctbpe2.pas new file mode 100644 index 000000000..36e2a7a84 --- /dev/null +++ b/components/orpheus/myovctbpe2.pas @@ -0,0 +1,345 @@ +{*********************************************************} +{* myovctbpe2.pas *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* Phil Hess - adapted ovctbpe2.pas to eliminate TOvcSimpleField. *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit MyOvcTbPE2; + {Lazarus-specific Columns property editor for the table component} + +interface + +uses + {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, LclType, LResources, {$ENDIF} + SysUtils, Classes, Graphics, Controls, + {$IFNDEF LCL} {$IFDEF VERSION6} DesignIntf, DesignEditors, {$ELSE} DsgnIntf, {$ENDIF} {$ELSE} PropEdits, ComponentEditors, {$ENDIF} + TypInfo, Forms, Dialogs, StdCtrls, Buttons, ExtCtrls, + OvcBase, OvcTCmmn, OvcTCell, OvcTbCls, OvcTable, OvcSc; + +type + TOvcfrmColEditor = class(TForm) + ctlColNumber: TEdit; + ctlDefaultCell: TComboBox; + ctlHidden: TCheckBox; + ctlWidth: TEdit; + Panel1: TPanel; + SpeedButton1: TSpeedButton; + SpeedButton2: TSpeedButton; + SpeedButton3: TSpeedButton; + SpeedButton4: TSpeedButton; + SpeedButton5: TSpeedButton; + SpeedButton6: TSpeedButton; + Label1: TLabel; + Label2: TLabel; + Label3: TLabel; + Label4: TLabel; + GroupBox1: TGroupBox; + DoneButton: TBitBtn; + ApplyButton: TBitBtn; + OvcSpinner1: TOvcSpinner; + OvcSpinner2: TOvcSpinner; + procedure ctlColNumberExit(Sender: TObject); + procedure ApplyButtonClick(Sender: TObject); + procedure SpeedButton1Click(Sender: TObject); + procedure SpeedButton2Click(Sender: TObject); + procedure SpeedButton3Click(Sender: TObject); + procedure SpeedButton4Click(Sender: TObject); + procedure SpeedButton5Click(Sender: TObject); + procedure SpeedButton6Click(Sender: TObject); + procedure FormShow(Sender: TObject); + procedure DoneButtonClick(Sender: TObject); + procedure ctlColNumberChange(Sender: TObject); + private + { Private declarations } + FCols : TOvcTableColumns; + FColNum : TColNum; + CurCellIndex : integer; + Cells : TStringList; + + protected + procedure GetCells; + procedure RefreshColData; + procedure SetColNum(C : TColNum); + + procedure AddCellComponentName(const S : string); + + public + { Public declarations } + Editor : TObject; + procedure SetCols(CS : TOvcTableColumns); + + property Cols : TOvcTableColumns + read FCols + write SetCols; + + property ColNum : TColNum + read FColNum + write SetColNum; + + end; + + {-A table column property editor} + TOvcTableColumnProperty = class(TClassProperty) + public + procedure Edit; override; + function GetAttributes: TPropertyAttributes; override; + end; + + +implementation + +{$IFNDEF LCL} +{$R *.DFM} +{$ENDIF} + + + +{===TOvcTableColumnProperty==========================================} +procedure TOvcTableColumnProperty.Edit; + var + ColEditor : TOvcfrmColEditor; + begin + ColEditor := TOvcfrmColEditor.Create(Application); + try + ColEditor.Editor := Self; + ColEditor.SetCols(TOvcTableColumns(GetOrdValue)); + ColEditor.ShowModal; +{$IFNDEF LCL} + Designer.Modified; +{$ELSE} + Modified; +{$ENDIF} + finally + ColEditor.Free; + end;{try..finally} + end; +{--------} +function TOvcTableColumnProperty.GetAttributes: TPropertyAttributes; + begin + Result := [paMultiSelect, paDialog, paReadOnly]; + end; +{====================================================================} + + +{===TColEditor=======================================================} +procedure TOvcfrmColEditor.AddCellComponentName(const S : string); + begin + Cells.Add(S); + end; +{--------} +procedure TOvcfrmColEditor.ApplyButtonClick(Sender: TObject); + var + NewColWidth : Integer; + begin + FCols[ColNum].Hidden := ctlHidden.Checked; + NewColWidth := StrToIntDef(ctlWidth.Text, FCols[ColNum].Width); + if (NewColWidth < 5) or (NewColWidth > 32767) then {Out of range?} + NewColWidth := FCols[ColNum].Width; {Restore previous column width} + FCols[ColNum].Width := NewColWidth; + ctlWidth.Text := IntToStr(NewColWidth); + if (ctlDefaultCell.ItemIndex <> CurCellIndex) then + begin + CurCellIndex := ctlDefaultCell.ItemIndex; + FCols[FColNum].DefaultCell := TOvcBaseTableCell(Cells.Objects[CurCellIndex]); + end; + end; +{--------} +procedure TOvcfrmColEditor.ctlColNumberExit(Sender: TObject); + begin + ApplyButtonClick(Self); + ColNum := StrToInt(ctlColNumber.Text); + end; +{--------} +procedure TOvcfrmColEditor.DoneButtonClick(Sender: TObject); + begin + ApplyButtonClick(Self); + Cells.Free; + end; +{--------} +procedure TOvcfrmColEditor.FormShow(Sender: TObject); + begin + if not Assigned(Cells) then + begin + Cells := TStringList.Create; + GetCells; + end; + RefreshColData; + end; +{--------} +procedure TOvcfrmColEditor.GetCells; + var + {$IFDEF VERSION4} + {$IFDEF VERSION6} +{$IFNDEF LCL} + Designer : IDesigner; +{$ENDIF} + {$ELSE} + Designer : IFormDesigner; + {$ENDIF} + {$ELSE} + Designer : TFormDesigner; + {$ENDIF} + TI : PTypeInfo; + Index: Integer; + C : TComponent; + Cell : TOvcBaseTableCell absolute C; + begin + Cells.Sorted := true; + Cells.AddObject('(None)', nil); + TI := TOvcBaseTableCell.ClassInfo; +{$IFNDEF LCL} + if (Editor is TClassProperty) then + Designer := TClassProperty(Editor).Designer + else {the editor is a TDefaultEditor} + Designer := TDefaultEditor(Editor).Designer; + Designer.GetComponentNames(GetTypeData(TI), AddCellComponentName); + for Index := 1 to pred(Cells.Count) do + Cells.Objects[Index] := Designer.GetComponent(Cells[Index]); +{$ELSE} + if (Editor is TClassProperty) then + begin + TClassProperty(Editor).PropertyHook.GetComponentNames(GetTypeData(TI), AddCellComponentName); + for Index := 1 to pred(Cells.Count) do + Cells.Objects[Index] := TClassProperty(Editor).PropertyHook.GetComponent(Cells[Index]); + end + else {the editor is a TDefaultComponentEditor} + begin + TDefaultComponentEditor(Editor).Designer.PropertyEditorHook.GetComponentNames(GetTypeData(TI), AddCellComponentName); + for Index := 1 to pred(Cells.Count) do + Cells.Objects[Index] := TDefaultComponentEditor(Editor).Designer.PropertyEditorHook.GetComponent(Cells[Index]); + end; +{$ENDIF} + ctlDefaultCell.Items := Cells; + end; +{--------} +procedure TOvcfrmColEditor.RefreshColData; + begin + CurCellIndex := Cells.IndexOfObject(FCols[ColNum].DefaultCell); + + ctlHidden.Checked := FCols[ColNum].Hidden; + ctlWidth.Text := IntToStr(FCols[ColNum].Width); + ctlDefaultCell.ItemIndex := CurCellIndex; + end; +{--------} +procedure TOvcfrmColEditor.SetColNum(C : TColNum); + begin + if (FColNum <> C) then + begin + FColNum := C; + RefreshColData; + ctlColNumber.Text := IntToStr(C); //Do this after refresh + end; + end; +{--------} +procedure TOvcfrmColEditor.SetCols(CS : TOvcTableColumns); + begin + if Assigned(FCols) then + FCols.Free; + FCols := CS; + FColNum := 0; + ctlColNumber.Text := '0'; + end; +{--------} +procedure TOvcfrmColEditor.SpeedButton1Click(Sender: TObject); + begin + ApplyButtonClick(Self); + if (ColNum > 0) then + ColNum := ColNum - 1; + end; +{--------} +procedure TOvcfrmColEditor.SpeedButton2Click(Sender: TObject); + begin + ApplyButtonClick(Self); + if (ColNum < pred(FCols.Count)) then + ColNum := ColNum + 1; + end; +{--------} +procedure TOvcfrmColEditor.SpeedButton3Click(Sender: TObject); + begin + ApplyButtonClick(Self); + ColNum := 0; + end; +{--------} +procedure TOvcfrmColEditor.SpeedButton4Click(Sender: TObject); + begin + ApplyButtonClick(Self); + ColNum := pred(FCols.Count); + end; +{--------} +procedure TOvcfrmColEditor.SpeedButton5Click(Sender: TObject); + var + C : TOvcTableColumn; + begin + C := TOvcTableColumn.Create(FCols.Table); + FCols.Insert(FColNum, C); + RefreshColData; + end; +{--------} +procedure TOvcfrmColEditor.SpeedButton6Click(Sender: TObject); + begin + if (FCols.Count > 1) then + begin + FCols.Delete(FColNum); + if (FColNum = FCols.Count) then + ColNum := pred(FColNum) + else RefreshColData; + end; + end; +{====================================================================} + + +procedure TOvcfrmColEditor.ctlColNumberChange(Sender: TObject); +var + NewColNum : Integer; +begin + ApplyButtonClick(Self); + if not TryStrToInt(ctlColNumber.Text, NewColNum) then {Invalid?} + ctlColNumber.Text := IntToStr(ColNum) {Restore previous column number} + else if NewColNum = -1 then {Wrap around to last column?} + ctlColNumber.Text := IntToStr(Pred(FCols.Count)) + else if NewColNum = FCols.Count then {Wrap around to first column?} + ctlColNumber.Text := '0' + else if not (NewColNum in [0..Pred(FCols.Count)]) then {Out of range?} + ctlColNumber.Text := IntToStr(ColNum); {Restore previous column number} + ColNum := StrToInt(ctlColNumber.Text); +end; + +initialization +{$IFDEF LCL} +{$I myovctbpe2.lrs} {Include form's resource file} +{$ENDIF} + +end. diff --git a/components/orpheus/o32bordr.pas b/components/orpheus/o32bordr.pas new file mode 100644 index 000000000..42e167f20 --- /dev/null +++ b/components/orpheus/o32bordr.pas @@ -0,0 +1,450 @@ +{*********************************************************} +{* O32BORDR.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit o32bordr; + {New Style Border control for Orpheus 4 components.} + +interface + +uses + {$IFNDEF LCL} Windows, {$ELSE} LclIntf, MyMisc, {$ENDIF} + Classes, Controls, Graphics; + +type + TO32BorderStyle = (bstyNone, bstyRaised, bstyLowered, bstyFlat, bstyChannel, + bstyRidge); + +const + THiliteColor: array[TO32BorderStyle] of TColor = (clWindow, clBtnHighlight, + clBtnShadow, clWindowFrame, clBtnShadow, clBtnHighlight); + + TBaseColor: array[TO32BorderStyle] of TColor = (clWindow, clBtnShadow, + clBtnHighlight, clWindowFrame, clBtnHighlight, clBtnShadow); + +type + TO32BorderSide = (bsidLeft, bsidRight, bsidTop, bsidBottom); + + TSides = (left, right, top, bottom); + + TO32Borders = class; + + TO32BorderSet = class(TPersistent) + protected {private} + FOwner : TPersistent; + FLeft : Boolean; + FTop : Boolean; + FRight : Boolean; + FBottom : Boolean; + procedure SetLeft(Value: Boolean); + procedure SetRight(Value: Boolean); + procedure SetBottom(Value: Boolean); + procedure SetTop(Value: Boolean); + public + constructor Create(AOwner: TPersistent); + published + property ShowLeft : Boolean read FLeft write SetLeft + default True; + property ShowRight : Boolean read FRight write SetRight + default True; + property ShowTop : Boolean read FTop write SetTop + default True; + property ShowBottom : Boolean read FBottom write SetBottom + default True; + end; + + TO32Borders = class(TPersistent) + protected {private} + Creating : Boolean; + FControl : TWinControl; + FBorderSet : TO32BorderSet; + FActive : Boolean; + FFlatColor : TColor; + FBorderWidth : Integer; + FBorderStyle : TO32BorderStyle; + procedure SetActive (Value : Boolean); + procedure SetBorderStyle (Value : TO32BorderStyle); + procedure SetFlatColor (Value : TColor); + + procedure Draw3dBox(Canvas: TCanvas; Rct: TRect; Hilite, + Base: TColor; DrawAllSides: Boolean); + procedure DrawFlatBorder(Canvas: TControlCanvas; Rct: TRect; + Color: TColor{; DrawAllSides: Boolean}); {!!!} + procedure DrawBevel(Canvas: TControlCanvas; Rct: TRect; HiliteColor, + BaseColor: TColor); + procedure Draw3dBorders(Canvas: TControlCanvas; Rct: TRect); + procedure EraseBorder(Canvas: TControlCanvas; Rct: TRect; + Color: TColor; AllSides: Boolean); + procedure DrawSingleSolidBorder(Canvas: TControlCanvas; Rct: TRect; + Color: TColor; Side: TSides; Width: Integer); + public + constructor Create(Control: TWinControl); + destructor Destroy; override; + procedure Changed; + procedure BordersChanged; + property Control: TWinControl read FControl; + procedure DrawBorders(var Canvas: TControlCanvas; Color: TColor); + procedure RedrawControl; + published + property Active : Boolean read FActive write SetActive + default False; + property BorderSet : TO32BorderSet + read FBorderSet write FBorderSet; + property BorderStyle: TO32BorderStyle read FBorderStyle write SetBorderStyle + default bstyRidge; + property FlatColor: TColor read FFlatColor write SetFlatColor + default clLime; + end; + +implementation + +{===== TO32BorderSet =================================================} +constructor TO32BorderSet.Create(AOwner: TPersistent); +begin + inherited Create; + FOwner := AOwner; +end; +{=====} + +procedure TO32BorderSet.SetLeft(Value: Boolean); +begin + if Value <> FLeft then begin + FLeft := Value; + TO32Borders(FOwner).BordersChanged; + end; +end; +{=====} + +procedure TO32BorderSet.SetRight(Value: Boolean); +begin + if Value <> FRight then begin + FRight := Value; + TO32Borders(FOwner).BordersChanged; + end; +end; +{=====} + +procedure TO32BorderSet.SetBottom(Value: Boolean); +begin + if Value <> FBottom then begin + FBottom := Value; + TO32Borders(FOwner).BordersChanged; + end; +end; +{=====} + +procedure TO32BorderSet.SetTop(Value: Boolean); +begin + if Value <> FTop then begin + FTop := Value; + TO32Borders(FOwner).BordersChanged; + end; +end; + +{===== TO32BorderSet - End =====} + + +{===== TO32Borders =================================================} +constructor TO32Borders.Create(Control: TWinControl); +begin + Creating := True; + inherited Create; + FControl := Control; + FBorderSet := TO32BorderSet.Create(self); + FActive := false; + FBorderWidth := 2; + FBorderStyle := bstyRidge; + FFlatColor := clLime; + FBorderSet.ShowBottom := true; + FBorderSet.ShowLeft := true; + FBorderSet.ShowRight := true; + FBorderSet.ShowTop := true; + Creating := False; +end; +{=====} + +destructor TO32Borders.Destroy; +begin + FBorderSet.Free; + inherited Destroy; +end; +{=====} + +procedure TO32Borders.SetActive(Value: Boolean); +begin + if FActive <> Value then begin + FActive := Value; + Changed; + end; +end; +{=====} + +procedure TO32Borders.SetBorderStyle(Value: TO32BorderStyle); +begin + if Value <> FBorderStyle then begin + FBorderStyle := Value; + Changed; + end; +end; +{=====} + +procedure TO32Borders.SetFlatColor(Value: TColor); +begin + if Value <> FFlatColor then begin + FFlatColor := Value; + if FBorderStyle = bstyFlat then + Changed; + end; +end; +{=====} + +procedure TO32Borders.DrawBorders(var Canvas: TControlCanvas; Color: TColor); +var + Rct : TRect; +begin + if not FActive then exit; + + Rct := Rect(0, 0, FControl.Width, FControl.Height); + + {Erase the existing border.} + EraseBorder(Canvas, Rct, Color, true); + + {If the border style is bstyNone then don't do anything else.} + if FBorderStyle = bstyNone then exit; + + {otherwise, draw the border.} + if FBorderStyle = bstyFlat then + DrawFlatBorder(Canvas, Rct, FFlatColor{, false}) + else Draw3dBorders(Canvas, Rct); +end; +{=====} + +procedure TO32Borders.Draw3dBorders(Canvas: TControlCanvas; Rct: TRect); +var + Hilite, Base: TColor; + R: TRect; +begin + Hilite := THiliteColor[FBorderStyle]; + Base := TBaseColor[FBorderStyle]; + + if FBorderStyle in [bstyLowered, bstyRaised ] then + DrawBevel(Canvas, Rct, Hilite, Base) + + else with FBorderSet do begin + R := Rct; + {Patch the border edges} + + if ShowRight then + Canvas.Pixels[R.Right - 1, R.Top] := Base; + if ShowTop and not ShowRight then + Canvas.Pixels[R.Right - 1, R.Top] := Hilite; + if ShowBottom then + Canvas.Pixels[R.Left, R.Bottom - 1] := Base; + if ShowLeft and not ShowBottom then + Canvas.Pixels[R.Left, R.Bottom - 1] := Hilite; + if ShowTop and not ShowLeft then + Canvas.Pixels[R.Left, R.Top + 1] := Base; + if not ShowTop and ShowLeft then + Canvas.Pixels[R.Left + 1, R.Top] := Base; + if ShowBottom and not ShowRight then + Canvas.Pixels[R.Right - 1, R.Bottom - 2] := Hilite; + if not ShowBottom and ShowRight then + Canvas.Pixels[R.Right - 2, R.Bottom - 1] := Hilite; + + Inc( R.Left ); + Inc( R.Top ); + Draw3dBox(Canvas, R, Base, Base, false); + OffsetRect(R, -1, -1); + Draw3dBox(Canvas, R, Hilite, Hilite, false); + +{ - dead code} +// if ShowLeft then Inc(Rct.Left, 2); +// if ShowTop then Inc(Rct.Top, 2); +// if ShowRight then Dec(Rct.Right, 2); +// if ShowBottom then Dec(Rct.Bottom, 2); + end; +end; +{=====} + +procedure TO32Borders.DrawSingleSolidBorder(Canvas: TControlCanvas; Rct: TRect; + Color: TColor; Side: TSides; Width: Integer); +var + i: Integer; +begin + with Canvas, FBorderSet do begin + Pen.Width := 1; + Pen.Color := Color; + + if Side = left then + for i := 0 to Width do begin + MoveTo(Rct.Left - 1, Rct.Top); + LineTo(Rct.Left - 1, Rct.Bottom); + Inc(Rct.Left); + end + else if Side = right then + for i := 0 to Width do begin + MoveTo(Rct.Right , Rct.Top); + LineTo(Rct.Right , Rct.Bottom); + Dec(Rct.Right); + end + else if Side = top then + for i := 0 to Width do begin + MoveTo(Rct.Left, Rct.Top - 1); + LineTo(Rct.Right, Rct.Top - 1); + Inc(Rct.Top); + end + else if Side = bottom then + for i := 0 to Width do begin + MoveTo(Rct.Left, Rct.Bottom); + LineTo(Rct.Right, Rct.Bottom); + Dec(Rct.Bottom); + end; + end; +end; +{=====} + +procedure TO32Borders.Draw3dBox(Canvas: TCanvas; Rct: TRect; Hilite, + Base: TColor; DrawAllSides: Boolean); +begin + with Canvas, Rct, FBorderSet do begin + Pen.Width := 1; + Pen.Color := Hilite; + if ShowLeft or DrawAllSides then begin + MoveTo( Left, Top ); + LineTo( Left, Bottom ); + end; + + if ShowTop or DrawAllSides then begin + MoveTo( Left, Top ); + LineTo( Right, Top ); + end; + + Pen.Color := Base; + if ShowRight or DrawAllSides then begin + MoveTo( Right - 1, Top ); + LineTo( Right - 1, Bottom ); + end; + + if ShowBottom or DrawAllSides then begin + MoveTo( Left, Bottom - 1 ); + LineTo( Right, Bottom - 1 ); + end; + end; +end; +{=====} + +procedure TO32Borders.DrawBevel(Canvas: TControlCanvas; Rct: TRect; HiliteColor, + BaseColor: TColor); +var + I: Integer; +begin + Canvas.Pen.Width := 1; + for I := 1 to FBorderWidth do + begin + Draw3dBox(Canvas, Rct, HiliteColor, BaseColor, False); + Inc(Rct.Left); + Inc(Rct.Top); + Dec(Rct.Right); + Dec(Rct.Bottom); + end; +end; +{=====} + +procedure TO32Borders.DrawFlatBorder(Canvas: TControlCanvas; Rct: TRect; + Color: TColor{; DrawAllSides: Boolean}); +begin + Canvas.Pen.Color := Color; + with BorderSet do begin + if ShowLeft then + DrawSingleSolidBorder(Canvas, Rct, Color, left, FBorderWidth); + if ShowRight then + DrawSingleSolidBorder(Canvas, Rct, Color, right, FBorderWidth); + if ShowTop then + DrawSingleSolidBorder(Canvas, Rct, Color, top, FBorderWidth); + if ShowBottom then + DrawSingleSolidBorder(Canvas, Rct, Color, bottom, FBorderWidth); + end; +end; +{=====} + +procedure TO32Borders.EraseBorder(Canvas: TControlCanvas; Rct: TRect; + Color: TColor; AllSides: Boolean); +var + i: Integer; +begin + Canvas.Pen.Color := Color; + with BorderSet do begin + for i := 1 to FBorderWidth do begin + Draw3dBox(Canvas, Rct, Color, Color, AllSides); + Inc(Rct.Left); + Inc(Rct.Top); + Dec(Rct.Right); + Dec(Rct.Bottom); + end; + end; +end; +{=====} + +procedure TO32Borders.BordersChanged; +begin + if FActive then Changed; +end; +{=====} + +procedure TO32Borders.RedrawControl; +var + Rct: TRect; +begin + if not Creating then begin + Rct := FControl.ClientRect; + RedrawWindow(FControl.Handle, @Rct, 0, + rdw_Invalidate or rdw_UpdateNow or rdw_Frame ); + end; +end; +{=====} + +procedure TO32Borders.Changed; +begin + FControl.Invalidate; + RedrawControl; +end; + +{===== TO32Borders - End =====} + +end. + + + diff --git a/components/orpheus/o32editf.pas b/components/orpheus/o32editf.pas new file mode 100644 index 000000000..97d4dacd3 --- /dev/null +++ b/components/orpheus/o32editf.pas @@ -0,0 +1,377 @@ +{*********************************************************} +{* O32EDITF.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} +{$J+} {Writable constants} + +unit o32editf; + {-base FlexEdit field class w/ attached label} + +interface + +uses + {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, Types, LclType, MyMisc, {$ENDIF} + Buttons, Classes, Controls, ExtCtrls, Forms, Graphics, Menus, + StdCtrls, SysUtils, OvcBase, OvcConst, OvcData, OvcVer, + OvcMisc; + +type + {base class for non-OvcController dependent edit fields...} + TO32CustomEdit = class(TCustomEdit) + protected {private} + {property variables} + FLabelInfo : TOvcLabelInfo; + {property methods} + function GetAbout : string; + function GetAttachedLabel : TOvcAttachedLabel; + procedure SetAbout(const Value : string); + {internal methods} + procedure LabelChange(Sender : TObject); + procedure LabelAttach(Sender : TObject; Value : Boolean); + procedure PositionLabel; + {VCL message methods} + procedure CMVisibleChanged(var Msg : TMessage); message CM_VISIBLECHANGED; + procedure OrAssignLabel(var Msg : TMessage); message OM_ASSIGNLABEL; + procedure OrPositionLabel(var Msg : TMessage); message OM_POSITIONLABEL; + procedure OrRecordLabelPosition(var Msg : TMessage); + message OM_RECORDLABELPOSITION; + protected + {descendants can set the value of this variable after calling inherited } + {create to set the default location and point-of-reference (POR) for the} + {attached label. if dlpTopLeft, the default location and POR will be at } + {the top left of the control. if dlpBottomLeft, the default location and} + {POR will be at the bottom left} + DefaultLabelPosition : TOvcLabelPosition; + procedure CreateWnd; override; + procedure Notification(AComponent : TComponent; Operation: TOperation); + override; + property About : string read GetAbout write SetAbout stored False; + property LabelInfo : TOvcLabelInfo read FLabelInfo write FLabelInfo; + public + constructor Create(AOwner : TComponent); override; + destructor Destroy; override; + procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override; + property AttachedLabel : TOvcAttachedLabel read GetAttachedLabel; + end; + + TO32Edit = class(TO32CustomEdit) + published + {properties} + {$IFDEF VERSION4} + property Anchors; +{$IFNDEF LCL} + property BiDiMode; + property ParentBiDiMode; +{$ENDIF} + property Constraints; + property DragKind; + {$ENDIF} + property About; +{$IFNDEF LCL} + property AutoSelect; // Added recently to LCL, but leave out for now +{$ENDIF} + property AutoSize; + property BorderStyle; + property CharCase; + property Color; + property Ctl3D; + property Cursor; + property DragCursor; + property DragMode; + property Enabled; + property Font; +{$IFNDEF LCL} + property HideSelection; + property ImeMode; + property ImeName; +{$ENDIF} + property LabelInfo; + property MaxLength; +{$IFNDEF LCL} + property OEMConvert; +{$ENDIF} + property ParentColor; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PasswordChar; + property PopupMenu; + property ReadOnly; + property ShowHint; + property TabOrder; + property TabStop; + property Text; + property Visible; + {events} + property OnChange; + property OnClick; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + {$IFDEF VERSION4} + property OnEndDock; + property OnStartDock; + {$ENDIF} + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnStartDrag; + end; + +implementation + +{===== TO32CustomEdit ==============================================} +procedure TO32CustomEdit.CMVisibleChanged(var Msg : TMessage); +begin + inherited; + + if csLoading in ComponentState then + Exit; + + if LabelInfo.Visible then + AttachedLabel.Visible := Visible; +end; +{=====} + +constructor TO32CustomEdit.Create(AOwner : TComponent); +begin + inherited Create(AOwner); + + ControlStyle := ControlStyle - [csSetCaption]; + + {set default position and reference point} + DefaultLabelPosition := lpTopLeft; + + FLabelInfo := TOvcLabelInfo.Create; + FLabelInfo.OnChange := LabelChange; + FLabelInfo.OnAttach := LabelAttach; +end; +{=====} + +procedure TO32CustomEdit.CreateWnd; +// OurForm : TWinControl; +begin +// OurForm := GetImmediateParentForm(Self); + inherited CreateWnd; +end; +{=====} + +destructor TO32CustomEdit.Destroy; +begin + {detatch and destroy label, if any} + FLabelInfo.Visible := False; + + {destroy label info} + FLabelInfo.Free; + FLabelInfo := nil; + + inherited Destroy; +end; +{=====} + +function TO32CustomEdit.GetAttachedLabel : TOvcAttachedLabel; +begin + if not FLabelInfo.Visible then + raise Exception.Create(GetOrphStr(SCLabelNotAttached)); + + Result := FLabelInfo.ALabel; +end; +{=====} + +function TO32CustomEdit.GetAbout : string; +begin + Result := OrVersionStr; +end; +{=====} + +procedure TO32CustomEdit.LabelAttach(Sender : TObject; Value : Boolean); +var +{$IFDEF VERSION5} + PF : TWinControl; +{$ELSE} + PF : TForm; +{$ENDIF} + S :string; +begin + if csLoading in ComponentState then + Exit; + +{$IFDEF VERSION5} + PF := GetImmediateParentForm(Self); +{$ELSE} + PF := TForm(GetParentForm(Self)); +{$ENDIF} + if Value then begin + if Assigned(PF) then begin + FLabelInfo.ALabel.Free; + FLabelInfo.ALabel := TOvcAttachedLabel.CreateEx(PF, Self); + FLabelInfo.ALabel.Parent := Parent; + + S := GenerateComponentName(PF, Name + 'Label'); + FLabelInfo.ALabel.Name := S; + FLabelInfo.ALabel.Caption := S; + + FLabelInfo.SetOffsets(0, 0); + PositionLabel; + FLabelInfo.ALabel.BringToFront; + {turn off auto size} + TLabel(FLabelInfo.ALabel).AutoSize := False; + end; + end else begin + if Assigned(PF) then begin + FLabelInfo.ALabel.Free; + FLabelInfo.ALabel := nil; + end; + end; +end; +{=====} + +procedure TO32CustomEdit.LabelChange(Sender : TObject); +begin + if not (csLoading in ComponentState) then + PositionLabel; +end; +{=====} + +procedure TO32CustomEdit.Notification(AComponent : TComponent; Operation: TOperation); +var +{$IFDEF VERSION5} + PF : TWinControl; +{$ELSE} + PF : TForm; +{$ENDIF} +begin + inherited Notification(AComponent, Operation); + + if Operation = opRemove then + if Assigned(FLabelInfo) and (AComponent = FLabelInfo.ALabel) then begin + {$IFDEF VERSION5} + PF := GetImmediateParentForm(Self); + {$ELSE} + PF := TForm(GetParentForm(Self)); + {$ENDIF} + if Assigned(PF) and not (csDestroying in PF.ComponentState) then begin + FLabelInfo.FVisible := False; + FLabelInfo.ALabel := nil; + end + end; +end; +{=====} + +procedure TO32CustomEdit.OrAssignLabel(var Msg : TMessage); +begin + FLabelInfo.ALabel := TOvcAttachedLabel(Msg.lParam); +end; +{=====} + +procedure TO32CustomEdit.OrPositionLabel(var Msg : TMessage); +const + DX : Integer = 0; + DY : Integer = 0; +begin + if FLabelInfo.Visible and Assigned(FLabelInfo.ALabel) and + (FLabelInfo.ALabel.Parent <> nil) and + not (csLoading in ComponentState) then begin + if DefaultLabelPosition = lpTopLeft then begin + DX := FLabelInfo.ALabel.Left - Left; + DY := FLabelInfo.ALabel.Top + FLabelInfo.ALabel.Height - Top; + end else begin + DX := FLabelInfo.ALabel.Left - Left; + DY := FLabelInfo.ALabel.Top - Top - Height; + end; + if (DX <> FLabelInfo.OffsetX) or (DY <> FLabelInfo.OffsetY) then + PositionLabel; + end; +end; +{=====} + +procedure TO32CustomEdit.OrRecordLabelPosition(var Msg : TMessage); +begin + if Assigned(FLabelInfo.ALabel) and (FLabelInfo.ALabel.Parent <> nil) then begin + {if the label was cut and then pasted, this will complete the reattachment} + FLabelInfo.FVisible := True; + + if DefaultLabelPosition = lpTopLeft then + FLabelInfo.SetOffsets(FLabelInfo.ALabel.Left - Left, + FLabelInfo.ALabel.Top + FLabelInfo.ALabel.Height - Top) + else + FLabelInfo.SetOffsets(FLabelInfo.ALabel.Left - Left, + FLabelInfo.ALabel.Top - Top - Height); + end; +end; +{=====} + +procedure TO32CustomEdit.PositionLabel; +begin + if FLabelInfo.Visible and Assigned(FLabelInfo.ALabel) and + (FLabelInfo.ALabel.Parent <> nil) and + not (csLoading in ComponentState) then begin + + if DefaultLabelPosition = lpTopLeft then begin + FLabelInfo.ALabel.SetBounds(Left + FLabelInfo.OffsetX, + FLabelInfo.OffsetY - FLabelInfo.ALabel.Height + Top, + FLabelInfo.ALabel.Width, FLabelInfo.ALabel.Height); + end else begin + FLabelInfo.ALabel.SetBounds(Left + FLabelInfo.OffsetX, + FLabelInfo.OffsetY + Top + Height, + FLabelInfo.ALabel.Width, FLabelInfo.ALabel.Height); + end; + end; +end; +{=====} + +procedure TO32CustomEdit.SetBounds(ALeft, ATop, AWidth, AHeight : Integer); +begin + inherited SetBounds(ALeft, ATop, AWidth, AHeight); + + if not HandleAllocated then + Exit; + + if HandleAllocated then + PostMessage(Handle, OM_POSITIONLABEL, 0, 0); +end; +{=====} + +procedure TO32CustomEdit.SetAbout(const Value : string); +begin +end; + +end. diff --git a/components/orpheus/o32flxed.pas b/components/orpheus/o32flxed.pas new file mode 100644 index 000000000..4663731ce --- /dev/null +++ b/components/orpheus/o32flxed.pas @@ -0,0 +1,1584 @@ +{*********************************************************} +{* O32FLXED.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} +{$J+} {Writable constants} + +unit o32flxed; + {OvcFlexEdit and support classes - Introduced in Orpheus 4.0} + +interface + +uses + {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, Types, LclType, MyMisc, {$ENDIF} + Classes, Controls, Forms, SysUtils, StdCtrls, Buttons, + OvcData, O32Editf, OvcEF, Graphics, O32SR, O32bordr, O32Vldtr, + O32VlOp1, o32ovldr, o32pvldr, o32rxvld, Dialogs; + +type + {Forward Declaration} + TO32CustomFlexEdit = class; + + TO32PopupAnchor = (paLeft, paRight); + + +// TO32FlexEditDataType = (feString, feFloat, feInteger, feDateTime, feExtended, +// feStDate, feStTime, feLogical); + + TO32FEButton = class(TBitBtn) + public + procedure Click; override; + end; + + TO32feButtonClickEvent = + procedure(Sender: TO32CustomFlexEdit; PopupPoint: TPoint) of object; + TFEUserValidationEvent = + procedure(Sender : TObject; var ValidEntry : Boolean) of object; + TFEValidationErrorEvent = + procedure(Sender : TObject; ErrorCode : Word; ErrorMsg : string) of object; + + TFlexEditValidatorOptions = class(TValidatorOptions) + published + property InputRequired; + end; + + TO32EditLines = class(TPersistent) + protected{private} + FlexEdit : TO32CustomFlexEdit; + FMaxLines : Integer; + FDefaultLines : Integer; + FFocusedLines : Integer; + FMouseOverLines: Integer; + procedure SetDefaultLines(Value: Integer); + procedure SetMaxLines(Value: Integer); + procedure SetFocusedLines(Value: Integer); + procedure SetMouseOverLines(Value: Integer); + public + constructor Create; virtual; + destructor Destroy; override; + published + property MaxLines: Integer read FMaxLines write SetMaxLines + default 3; + property DefaultLines: Integer read FDefaultLines write SetDefaultLines + default 1; + property FocusedLines: Integer read FFocusedLines write SetFocusedLines + default 3; + property MouseOverLines: Integer read FMouseOverLines write SetMouseOverLines + default 3; + end; + + TFlexEditStrings = class(TStrings) + protected {private} + FCapacity: Integer; + function Get(Index: Integer): string; override; + function GetCount: Integer; override; + function GetTextStr: string; override; + procedure Put(Index: Integer; const S: string); override; + procedure SetTextStr(const Value: string); override; + procedure SetUpdateState(Updating: Boolean); override; + + public + FlexEdit: TCustomEdit; + procedure Clear; override; + procedure SetCapacity(NewCapacity: Integer); override; + procedure Delete(Index: Integer); override; + procedure Insert(Index: Integer; const S: string); override; + end; + + TO32CustomFlexEdit = class(TO32CustomEdit) + protected {private} + FAlignment : TAlignment; + FBorders : TO32Borders; + FButton : TO32FEButton; + FButtonGlyph : TBitmap; + FCanvas : TControlCanvas; +// FDataType : TO32FlexEditDataType; + FEditLines : TO32EditLines; + FEFColors : TOvcEFColors; + FDisplayedLines : Integer; + FMaxLines : Integer; + FStrings : TFlexEditStrings; +// FPasswordChar : Char; + FPopupAnchor : TO32PopupAnchor; + FShowButton : Boolean; + FWordWrap : Boolean; + FWantReturns : Boolean; + FWantTabs : Boolean; + FMouseInControl : Boolean; + FValidation : TFlexEditValidatorOptions; + FValidator : TO32BaseValidator; + FValidationError : Integer; + + FOnButtonClick : TO32feButtonClickEvent; + FOnUserValidation : TFEUserValidationEvent; + FOnValidationError: TFEValidationErrorEvent; + FBeforeValidation : TNotifyEvent; + FAfterValidation : TNotifyEvent; + + {Internal Variables} + FSaveEdit : String; {saved copy of edit string} + FCreating : Boolean; + + FColor : TColor; + FFontColor : TColor; + + FUpdating : Integer; + feValid : Boolean; + + + {Property Methods} + function GetButtonGlyph : TBitmap; + procedure SetButtonGlyph(Value : TBitmap); + procedure SetShowButton (Value : Boolean); + function GetBoolean : Boolean; + function GetYesNo : Boolean; + function GetDateTime : TDateTime; + function GetDouble : Double; + function GetExtended : Extended; + function GetInteger : Integer; + function GetStrings : TStrings; + function GetVariant : Variant; + function GetText : String; + function GetColor : TColor; virtual; + + procedure SetBoolean (Value : Boolean); + procedure SetYesNo (Value : Boolean); + procedure SetDateTime (Value : TDateTime); +// procedure SetDataType (Value : TO32FlexEditDataType); + procedure SetDouble (Value : Double); + procedure SetExtended (Value : Extended); + procedure SetInteger (Value : Integer); + procedure SetStrings (Value : TStrings); + procedure SetVariant (Value : Variant); + procedure SetDisplayedLines(Value : Integer); + procedure SetWordWrap (Value : Boolean); + procedure SetWantReturns (Value : Boolean); + procedure SetWantTabs (Value : Boolean); + procedure SetText (const Value : String); + procedure SetColor (Value : TColor); virtual; + + {Message Handlers} + procedure WMGetDlgCode (var Message : TWMGetDlgCode); message WM_GETDLGCODE; + procedure CMMouseEnter (var Message : TMessage); message CM_MOUSEENTER; + procedure CMMouseLeave (var Message : TMessage); message CM_MOUSELEAVE; +{$IFNDEF LCL} + procedure CMGotFocus (var Message : TMessage); message WM_SETFOCUS; + procedure CMLostFocus (var Message : TMessage); message WM_KILLFOCUS; +{$ELSE} + procedure CMGotFocus (var Message : TLMSetFocus); message WM_SETFOCUS; + procedure CMLostFocus (var Message : TLMKillFocus); message WM_KILLFOCUS; +{$ENDIF} + + { - added} + procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED; + + procedure WMNCPaint (var Message : TWMNCPaint); message WM_NCPAINT; + +{ - was commented out in 4.02 and re-written in 4.06} + procedure WMPaint (var Message : TWMPaint); message WM_PAINT; + + procedure OMValidate (var Message : TMessage); message OM_VALIDATE; + procedure OMRecreateWnd(var Message : TMessage); message OM_RECREATEWND; + + {Internal Methods} + procedure KeyPress(var Key: Char); override; + procedure CreateParams(var Params : TCreateParams); override; + procedure SetParent(Value: TWinControl); override; + procedure CreateWnd; override; +{$IFNDEF LCL} + procedure CreateWindowHandle(const Params: TCreateParams); override; +{$ENDIF} + procedure AdjustHeight; + procedure GlyphChanged; dynamic; + procedure Loaded; override; + procedure SetAlignment(Value: TAlignment); + function MultiLineEnabled: Boolean; + function GetButtonWidth : Integer; + function GetButtonEnabled : Boolean; dynamic; + procedure SetMaxLines(Value: Integer); + function ValidateSelf: Boolean; virtual; + procedure SaveEditString; + + procedure DoOnChange; virtual; + +{$IFDEF LCL} + function ChildClassAllowed(ChildClass: TClass): Boolean; override; +{$ENDIF} + + public + constructor Create(AOwner : TComponent); override; + destructor Destroy; override; + + procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override; + procedure ButtonClick; dynamic; + procedure Restore; virtual; + + procedure BeginUpdate; + procedure EndUpdate; + + {properties} + property Alignment: TAlignment + read FAlignment write SetAlignment default taLeftJustify; +// property DataType: TO32FlexEditDataType +// read FDataType write SetDataType default feString; + property Borders: TO32Borders + read FBorders write FBorders; + property Color: TColor + read GetColor write SetColor default clWindow; + property EfColors: TOvcEfColors + read FEFColors write FEFColors; + property EditLines: TO32EditLines + read FEditLines write FEditLines; +// property PasswordChar: char +// read FPasswordChar write SetPwdChar; + property PopupAnchor : TO32PopupAnchor + read FPopupAnchor write FPopupAnchor; + property ShowButton : Boolean + read FShowButton write SetShowButton; + property Validation: TFlexEditValidatorOptions + read FValidation write FValidation; + property WantReturns: Boolean + read FWantReturns write SetWantReturns default False; + property WantTabs: Boolean + read FWantTabs write SetWantTabs default False; + property WordWrap: Boolean + read FWordWrap write SetWordWrap default False; + property Text: String + read GetText write SetText; + property Strings: TStrings + read GetStrings write SetStrings; + + property AsBoolean: Boolean + read GetBoolean write SetBoolean; + property AsYesNo: Boolean + read GetYesNo write SetYesNo; + property AsDateTime: TDateTime + read GetDateTime write SetDateTime; + property AsFloat: Double + read GetDouble write SetDouble; + property AsExtended: Extended + read GetExtended write SetExtended; + property AsInteger: Integer + read GetInteger write SetInteger; + property AsVariant: Variant + read GetVariant write SetVariant; + property ButtonGlyph : TBitmap + read GetButtonGlyph write SetButtonGlyph; + property Canvas :TControlCanvas + read FCanvas; + property OnButtonClick : TO32feButtonClickEvent + read FOnButtonClick write FOnButtonClick; + property OnUserValidation: TFEUserValidationEvent + read FOnUserValidation write FOnUserValidation; + property OnValidationError: TFEValidationErrorEvent + read FOnValidationError write FOnValidationError; + property BeforeValidation : TNotifyEvent + read FBeforeValidation write FBeforeValidation; + property AfterValidation : TNotifyEvent + read FAfterValidation write FAfterValidation; + end; + + {O32FlexEdit} + TO32FlexEdit = class(TO32CustomFlexEdit) + published + {$IFDEF VERSION4} + property Alignment; + property Anchors; +{$IFNDEF LCL} + property BiDiMode; + property ParentBiDiMode; +{$ENDIF} + property DragKind; + property DragMode; + property OnEndDock; + property OnStartDock; + {$ENDIF} + property AutoSize default False; + property About; +{$IFNDEF LCL} + property AutoSelect; // Added recently to LCL, but leave out for now +{$ENDIF} + property Borders; + property ButtonGlyph; + property CharCase; + property Color; + property Cursor; + property DragCursor; + property EditLines; + property EfColors; + property Enabled; + property Font; +{$IFNDEF LCL} + property HideSelection; + property ImeMode; + property ImeName; +{$ENDIF} + property LabelInfo; + property MaxLength; +{$IFNDEF LCL} + property OEMConvert; +{$ENDIF} + property ParentFont; + property ParentShowHint; + property PasswordChar; + property PopupAnchor default paLeft; + property PopupMenu; + property ReadOnly; + property ShowButton default False; + property ShowHint; + property TabOrder; + property TabStop; + property Text; + property Validation; + property Visible; + property WantReturns; + property WantTabs; + property WordWrap; + + property AfterValidation; + property BeforeValidation; + property OnButtonClick; + property OnChange; + property OnClick; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnStartDrag; + property OnUserValidation; + property OnValidationError; + end; + +implementation + +// The optional button inside a TO32FlexEdit doesn't work with LCL, +// so exclude all button-related code for now. +// For more information, see Lazarus bug 7097. +{$IFNDEF LCL} + {$DEFINE ButtonOkay} +{$ENDIF} + +{===== TO32FEButton ==================================================} + +procedure TO32FEButton.Click; +begin + TO32FlexEdit(Parent).SetFocus; + TO32FlexEdit(Parent).ButtonClick; +end; + +{===== TO32EditLines =================================================} + +constructor TO32EditLines.Create; +begin + inherited Create; + FMaxLines := 3{1}; + FFocusedLines := 3{1}; + FMouseOverLines := 3{1}; + FDefaultLines := 1; +end; +{=====} + +destructor TO32EditLines.Destroy; +begin + inherited Destroy; +end; +{=====} + +procedure TO32EditLines.SetDefaultLines(Value: Integer); +begin + if FDefaultLines <> Value then + FDefaultLines := Value; + if FDefaultLines > FMaxLines then + FDefaultLines := FMaxLines; +end; +{=====} + +procedure TO32EditLines.SetMaxLines(Value: Integer); +begin + if FMaxLines <> Value then begin + FMaxLines := Value; + TO32CustomFlexEdit(FlexEdit).SetMaxLines(FMaxLines); + end; +end; +{=====} + +procedure TO32EditLines.SetFocusedLines(Value: Integer); +begin + if FFocusedLines <> Value then + FFocusedLines := Value; + if FFocusedLines > FMaxLines then + FFocusedLines := FMaxLines; +end; +{=====} + +procedure TO32EditLines.SetMouseOverLines(Value: Integer); +begin + if FMouseOverLines <> Value then + FMouseOverLines := Value; + if FMouseOverLines > FMaxLines then + FMouseOverLines := FMaxLines; +end; + + +{===== TFlexEditStrings ==============================================} + +function TFlexEditStrings.GetCount: Integer; +begin + Result := 0; + if FlexEdit.HandleAllocated then + begin + Result := SendMessage(FlexEdit.Handle, EM_GETLINECOUNT, 0, 0); + if SendMessage(FlexEdit.Handle, EM_LINELENGTH, SendMessage(FlexEdit.Handle, + EM_LINEINDEX, Result - 1, 0), 0) = 0 then Dec(Result); + end; +end; +{=====} + +function TFlexEditStrings.Get(Index: Integer): string; +var + Text: array[0..4095] of Char; +begin + Word((@Text)^) := SizeOf(Text); + SetString(Result, Text, SendMessage(FlexEdit.Handle, EM_GETLINE, Index, + Longint(@Text))); +end; +{=====} + +procedure TFlexEditStrings.Put(Index: Integer; const S: string); +var + SelStart: Integer; +begin + SelStart := SendMessage(FlexEdit.Handle, EM_LINEINDEX, Index, 0); + if SelStart >= 0 then + begin + SendMessage(FlexEdit.Handle, EM_SETSEL, SelStart, SelStart + + SendMessage(FlexEdit.Handle, EM_LINELENGTH, SelStart, 0)); + SendMessage(FlexEdit.Handle, EM_REPLACESEL, 0, Longint(PChar(S))); + end; +end; +{=====} + +procedure TFlexEditStrings.Insert(Index: Integer; const S: string); +var + SelStart, LineLen: Integer; + Line: string; +begin + if Count = FCapacity then exit; + + if Index >= 0 then + begin + SelStart := SendMessage(FlexEdit.Handle, EM_LINEINDEX, Index, 0); + if SelStart >= 0 then Line := S + #13#10 else + begin + SelStart := SendMessage(FlexEdit.Handle, EM_LINEINDEX, Index - 1, 0); + if SelStart < 0 then Exit; + LineLen := SendMessage(FlexEdit.Handle, EM_LINELENGTH, SelStart, 0); + if LineLen = 0 then Exit; + Inc(SelStart, LineLen); + Line := #13#10 + s; + end; + SendMessage(FlexEdit.Handle, EM_SETSEL, SelStart, SelStart); + SendMessage(FlexEdit.Handle, EM_REPLACESEL, 0, Longint(PChar(Line))); + end; +end; +{=====} + +procedure TFlexEditStrings.Delete(Index: Integer); +const + Empty: PChar = ''; +var + SelStart, SelEnd: Integer; +begin + SelStart := SendMessage(FlexEdit.Handle, EM_LINEINDEX, Index, 0); + if SelStart >= 0 then + begin + SelEnd := SendMessage(FlexEdit.Handle, EM_LINEINDEX, Index + 1, 0); + if SelEnd < 0 then SelEnd := SelStart + + SendMessage(FlexEdit.Handle, EM_LINELENGTH, SelStart, 0); + SendMessage(FlexEdit.Handle, EM_SETSEL, SelStart, SelEnd); + SendMessage(FlexEdit.Handle, EM_REPLACESEL, 0, Longint(Empty)); + end; +end; +{=====} + +procedure TFlexEditStrings.Clear; +begin + FlexEdit.Clear; +end; +{=====} + +procedure TFlexEditStrings.SetUpdateState(Updating: Boolean); +begin + if FlexEdit.HandleAllocated then + begin + SendMessage(FlexEdit.Handle, WM_SETREDRAW, Ord(not Updating), 0); + if not Updating then + begin // WM_SETREDRAW causes visibility side effects in memo controls + FlexEdit.Perform(CM_SHOWINGCHANGED,0,0); // This reasserts the visibility we want + FlexEdit.Refresh; + end; + end; +end; +{=====} + +function TFlexEditStrings.GetTextStr: string; +begin + Result := FlexEdit.Text; +end; +{=====} + +procedure TFlexEditStrings.SetCapacity(NewCapacity: Integer); +begin + {Sets line-limit and destructively removes any lines that exceed the limit.} + if FCapacity <> NewCapacity then begin + FCapacity := NewCapacity; + while Count > FCapacity do Delete(FCapacity); + end; +end; +{=====} + +procedure TFlexEditStrings.SetTextStr(const Value: string); +var + NewText: string; +begin + NewText := AdjustLineBreaks(Value); + if (Length(NewText) <> FlexEdit.GetTextLen) or (NewText <> FlexEdit.Text) then + begin +{$IFNDEF LCL} + if SendMessage(FlexEdit.Handle, WM_SETTEXT, 0, Longint(NewText)) = 0 then + raise EInvalidOperation.Create(RSTooManyBytes); + FlexEdit.Perform(CM_TEXTCHANGED, 0, 0); +{$ELSE} //Previous SendMessage always returns 0 (error) with LCL + FlexEdit.SetTextBuf(PAnsiChar(NewText)); +{$ENDIF} + end; +end; + +{===== TO32CustomFlexEdit ============================================} + +constructor TO32CustomFlexEdit.Create(AOwner : TComponent); +begin + FCreating := True; + + inherited Create(AOwner); + + FWordWrap := False; + FWantReturns := False; + FWantTabs := False; + Width := 185; + AutoSize := False; + + {create support classes} + FCanvas := TControlCanvas.Create; + TControlCanvas(FCanvas).Control := Self; + + feValid := true; + FShowButton := False; +{$IFDEF ButtonOkay} + FButton := TO32FEButton.Create(Self); + FButton.Visible := True; + FButton.Parent := Self; + FButton.Caption := ''; + FButton.TabStop := False; + {$IFNDEF LCL} + FButton.Style := bsNew; + {$ENDIF} +{$ENDIF} + + FButtonGlyph := TBitmap.Create; + + FBorders := TO32Borders.Create(Self); + + FEFColors := TOvcEfColors.Create; + + FStrings := TFlexEditStrings.Create; + TFlexEditStrings(FStrings).FlexEdit := Self; + + FEditLines := TO32EditLines.Create; + TO32EditLines(FEditLines).FlexEdit := self; + + { now set in TO32EditLines.Create: + EditLines.MaxLines := 3; + EditLines.DefaultLines := 1; + EditLines.FocusedLines := 3; + EditLines.MouseOverLines := 3; + } + + FDisplayedLines := FEditLines.FDefaultLines; + TFlexEditStrings(FStrings).Capacity := FMaxLines; + + FMouseInControl := false; + + FSaveEdit := ''; + + Height := 80; + AdjustHeight; + + Validation := TFlexEditValidatorOptions.Create(self); + FColor := Color; + FFontColor := Font.Color; + FCreating := False; +end; +{=====} + +destructor TO32CustomFlexEdit.Destroy; +begin + {Free support classes} +{$IFDEF ButtonOkay} + FButton.Free; +{$ENDIF} + FEFColors.Free; + FEditLines.Free; + FStrings.Free; + FButtonGlyph.Free; + FCanvas.Free; + FBorders.Free; + FValidation.Free; + + inherited Destroy; +end; +{=====} + +procedure TO32CustomFlexEdit.CreateParams(var Params: TCreateParams); +const + Passwords: array[Boolean] of DWORD = (0, ES_PASSWORD); + Alignments: array[Boolean, TAlignment] of DWORD = + ((ES_LEFT, ES_RIGHT, ES_CENTER),(ES_RIGHT, ES_LEFT, ES_CENTER)); + WordWraps: array[Boolean] of DWORD = (0, ES_AUTOHSCROLL); +begin + inherited CreateParams(Params); + with Params do + begin + { - begin} + if MultilineEnabled then + Style := Style and not WordWraps[FWordWrap] or ES_MULTILINE + {$IFDEF VERSION4} +{$IFNDEF LCL} + or Alignments[UseRightToLeftAlignment, FAlignment] +{$ELSE} + or Alignments[False, FAlignment] +{$ENDIF} + {$ENDIF} + or WS_CLIPCHILDREN + else + Style := Style and not WordWraps[FWordWrap] + or Passwords[PasswordChar <> #0] + {$IFDEF VERSION4} +{$IFNDEF LCL} + or Alignments[UseRightToLeftAlignment, FAlignment] +{$ELSE} + or Alignments[False, FAlignment] +{$ENDIF} + {$ENDIF} + or WS_CLIPCHILDREN + { - end} + end; +end; +{=====} + +procedure TO32CustomFlexEdit.SetParent(Value: TWinControl); +begin + inherited; + {$IFNDEF VERSION4} + {$IFDEF CBuilder} + HandleNeeded; {BCB3 needs a handle here} + {$ENDIF} + {$ENDIF} +end; +{=====} + +procedure TO32CustomFlexEdit.WMGetDlgCode(var Message: TWMGetDlgCode); +begin + inherited; + if FWantTabs then Message.Result := Message.Result or DLGC_WANTTAB + else Message.Result := Message.Result and not DLGC_WANTTAB; + if not FWantReturns then + Message.Result := Message.Result and not DLGC_WANTALLKEYS; +end; +{=====} + +procedure TO32CustomFlexEdit.WMNCPaint(var Message: TWMNCPaint); +var + DC: HDC; +begin + if (FUpdating > 0) then exit; + + inherited; + + if Borders.Active then begin + DC := GetWindowDC(Handle); + FCanvas.Handle := DC; + try + FBorders.DrawBorders(FCanvas, Color); + finally + FCanvas.Handle := 0; + ReleaseDC( Handle, DC ); + end; + Message.Result := 0; + end; +end; +{=====} + +{WMPaint had been completely commented out in 4.02. It is now } +{ re introduced as follows.... } +{ - Re-written} +procedure TO32CustomFlexEdit.WMPaint(var Message: TWMPaint); +begin + { known limitation, The ancestor is overriding the font color when the } + { control is disabled } + if not Enabled then begin + inherited Color := efColors.Disabled.BackColor; + Font.Color := efColors.Disabled.TextColor; + end else begin + if feValid then begin + inherited Color := FColor; + Font.Color := FFontColor; + end else if Validation.SoftValidation then begin + inherited Color := EFColors.Error.BackColor; + Font.Color := EFColors.Error.TextColor; + end; + end; + inherited; +end; + +{ - Not necessary } +(* +procedure TO32CustomFlexEdit.WMPaint(var Message: TWMPaint); +var + Rct: TRect; + Str: string; + DC: HDC; + PS: TPaintStruct; +begin + if (FUpdating > 0) then exit; + + if ((FAlignment = taLeftJustify ) or Focused) + and not (csPaintCopy in ControlState) + then inherited + else begin + DC := Message.DC; + if DC = 0 then DC := BeginPaint(Handle, PS); + FCanvas.Handle := DC; + try + if (FAlignment = taRightJustify) then begin + FCanvas.Font := Font; + with FCanvas do begin + Rct := ClientRect; + Brush.Color := Color; + Str := Text; + TextRect(Rct, Rct.Right - TextWidth(Str) - 2, 2, Str); + end; + end; + finally + FCanvas.Handle := 0; + if Message.DC = 0 then EndPaint( Handle, PS ); + end; + end; +end; +{=====} +*) + +procedure TO32CustomFlexEdit.OMValidate (var Message : TMessage); +begin + if not ValidateSelf then begin + if Assigned(FOnValidationError) then +// TurboPower bug: With vtUser, FValidator is nil here. +// FOnValidationError(Self, FValidator.ErrorCode, 'Invalid input'); + FOnValidationError(Self, FValidationError, 'Invalid input'); //Fixed + Message.Result := FValidationError; + if (Validation.ValidationEvent = veOnChange) then begin + Validation.BeginUpdate; + Restore; + Validation.EndUpdate; + end; + end else begin + Message.Result := 0; + end; +end; +{=====} + +function TO32CustomFlexEdit.ValidateSelf: Boolean; +begin + result := true; + if (FUpdating > 0) then exit; + + case Validation.ValidationType of + + vtNone: begin + {User can specify that the field be non-empty even if he is specifying no + custom validation} + if Validation.InputRequired and (Text = '') then + result := false; + exit; + end; + + vtUser: begin + if (Text = '') then begin + if Validation.InputRequired then + result := false + else + result := true; + end else + if Assigned(FOnUserValidation) then + FOnUserValidation(Self, result); + + if not Result then + FValidationError := 1; + end; {vtUser} + + vtValidator: begin + + if (text = '') then begin + if Validation.InputRequired then begin + {Fail Validation for an empty, required field} + result := false; + FValidationError := 1; + end else begin + {Pass validation for a non-required, empty field} + result := true; + FValidationError := 0; + end; + end + + else if Validation.Mask = '' then begin + result := true; + FValidationError := 0; + exit; + end + + else if FValidation.ValidatorClass = nil then begin + result := false; + raise(Exception.Create('Error: Unknown validator Class.')); + end + + else begin + FValidator := FValidation.ValidatorClass.Create(Self); + try + FValidator.Mask := Validation.Mask; + FValidator.Input := Text; + + if Assigned(FBeforeValidation) then + FBeforeValidation(self); + + result := FValidator.IsValid; + FValidationError := FValidator.ErrorCode; + + if Assigned(FAfterValidation) then + FAfterValidation(self); + + finally + FValidator.Free; + end; {try} + end; {if} + end; {VtValidator} + + end; {case} + +{ - begin} + feValid := result; + if result then + SaveEditString + else + if Validation.BeepOnError then + MessageBeep(0); + + { Invalidate; } { !!.04 - Commented out - Causes flicker } {!!!!} +{ - end} +end; +{=====} + +procedure TO32CustomFlexEdit.OMRecreateWnd(var Message : TMessage); +begin + if (FUpdating > 0) then exit; +{$IFNDEF LCL} + RecreateWnd; +{$ELSE} + MyMisc.RecreateWnd(Self); +{$ENDIF} +end; +{=====} + +procedure TO32CustomFlexEdit.CMMouseEnter(var Message : TMessage); +begin + inherited; + if Enabled and MultiLineEnabled and (not FMouseInControl) + and (not Focused) then begin + if FDisplayedLines <> FEditLines.FMouseOverLines then begin + SetDisplayedLines(FEditLines.FMouseOverLines); + AdjustHeight; + end; + end; + FMouseInControl := True; +end; +{=====} + +procedure TO32CustomFlexEdit.CMMouseLeave(var Message : TMessage); +begin + inherited; +{$IFDEF ButtonOkay} + if FButton.Focused then exit; +{$ENDIF} + if Enabled and FMouseInControl and MultiLineEnabled then begin + if (Focused) then begin + if FDisplayedLines <> FEditLines.FocusedLines then + SetDisplayedLines(FEditLines.FocusedLines); + end else begin + if FDisplayedLines <> FEditLines.DefaultLines then + SetDisplayedLines(FEditLines.DefaultLines); + end; + AdjustHeight; + end; + FMouseInControl := False; +end; +{=====} + +{$IFNDEF LCL} +procedure TO32CustomFlexEdit.CMGotFocus(var Message : TMessage); +{$ELSE} +procedure TO32CustomFlexEdit.CMGotFocus(var Message : TLMSetFocus); +{$ENDIF} +begin + inherited; + if Enabled and MultiLineEnabled then begin + if FDisplayedLines <> FEditLines.FocusedLines then begin + SetDisplayedLines(FEditLines.FocusedLines); + AdjustHeight; + end; + end; +{$IFNDEF LCL} // AutoSelect is False by default in LCL TEdit + if AutoSelect then + SelectAll; +{$ENDIF} + SaveEditString; +end; +{=====} + +{$IFNDEF LCL} +procedure TO32CustomFlexEdit.CMLostFocus(var Message : TMessage); +{$ELSE} +procedure TO32CustomFlexEdit.CMLostFocus(var Message : TLMKillFocus); +{$ENDIF} +begin + inherited; + if Enabled and MultiLineEnabled then begin + if FMouseInControl then begin + if FDisplayedLines <> FEditLines.MouseOverLines then + SetDisplayedLines(FEditLines.MouseOverLines); + end else begin + if FDisplayedLines <> FEditLines.DefaultLines then + SetDisplayedLines(FEditLines.DefaultLines); + end; + AdjustHeight; + end; +end; +{=====} + +{ - added} +procedure TO32CustomFlexEdit.CMFontChanged(var Message: TMessage); +begin + inherited; + AdjustHeight; +end; +{=====} + +function TO32CustomFlexEdit.GetText: String; +begin + result := FStrings.Text; +end; +{=====} + +procedure TO32CustomFlexEdit.SetText(const Value: String); +var + buffer: String; + i : Integer; +begin + buffer := Value; + + if buffer <> '' then begin + if not MultiLineEnabled then + {strip out cr and lf's} +// for i := Length(buffer) downto 0 do <== TurboPower bug! + for i := Length(buffer) downto 1 do + if (buffer[i] = #13) or (buffer[i] = #10) then begin + Delete(buffer, i, 1); + if ((buffer[i - 1] <> ' ') and (buffer[i - 1] <> #10) + and (buffer[i - 1] <> #13))and (buffer[i] <> ' ') then + Insert(' ', buffer, i); + end; + end; + + FStrings.Text := buffer; + + SetTextBuf(PAnsiChar(buffer)); + + if Borders.Active then Borders.RedrawControl; +end; +{=====} + +function TO32CustomFlexEdit.GetColor: TColor; +begin + Result := inherited Color; +end; +{=====} + +procedure TO32CustomFlexEdit.SetColor( Value: TColor ); +begin + if Color <> Value then begin + inherited Color := Value; + FColor := Value; + if Borders.Active then Borders.RedrawControl; + end; +end; +{=====} + +procedure TO32CustomFlexEdit.KeyPress(var Key: Char); +begin + inherited KeyPress(Key); + if (Key = Char(VK_RETURN)) then + if not FWantReturns then + Key := #0 + else begin + if TFlexEditStrings(FStrings).Count >= FMaxLines then + Key := #0; + end; +end; +{=====} + +procedure TO32CustomFlexEdit.CreateWnd; +begin + if (FUpdating > 0) then exit; + + inherited CreateWnd; + + {force button placement} + SetBounds(Left, Top, Width, Height); + +{$IFDEF ButtonOkay} + FButton.Enabled := GetButtonEnabled; +{$ENDIF} + AdjustHeight; + + if Validation <> nil then + Validation.AttachTo(Self); +end; + +{$IFNDEF LCL} //With LCL, will never be called since not in ancestor +procedure TO32CustomFlexEdit.CreateWindowHandle(const Params: TCreateParams); +begin + if (FUpdating > 0) then exit; + + if not HandleAllocated then begin + if (csDesigning in ComponentState) then + inherited + else begin + with Params do + WindowHandle := CreateWindowEx(ExStyle, WinClassName, '', Style, + X, Y, Width, Height, WndParent, 0, WindowClass.HInstance, + Param); + SendMessage(WindowHandle, WM_SETTEXT, 0, Longint(Caption)); + end; + end; +end; +{$ENDIF} +{=====} + +procedure TO32CustomFlexEdit.AdjustHeight; +var + DC: HDC; + SaveFont: HFont; + I: Integer; + SysMetrics, Metrics: TTextMetric; + Str: String; +begin + if (FUpdating > 0) then exit; + + if FCreating then exit; + + DC := GetDC(0); + GetTextMetrics(DC, SysMetrics); + SaveFont := SelectObject(DC, Font.Handle); + GetTextMetrics(DC, Metrics); + SelectObject(DC, SaveFont); + ReleaseDC(0, DC); + if NewStyleControls then + begin + if Ctl3D then I := 8 else I := 6; + I := GetSystemMetrics(SM_CYBORDER) * I; + end else + begin + I := SysMetrics.tmHeight; + if I > Metrics.tmHeight then I := Metrics.tmHeight; + I := I div 4 + GetSystemMetrics(SM_CYBORDER) * 4; + end; + Height := (Metrics.tmHeight * FDisplayedLines) + I; + if Borders.Active and not FCreating then begin + Str := Text; + Borders.RedrawControl; + Text := Str; + end; +end; +{=====} + +function TO32CustomFlexEdit.GetButtonEnabled : Boolean; +begin + result := (not ReadOnly); +end; +{=====} + +procedure TO32CustomFlexEdit.SetMaxLines(Value: Integer); +var + buffer: String; +begin + if Value <> FMaxLines then begin + FMaxLines := Value; + TFlexEditStrings(FStrings).Capacity := FMaxLines; + buffer := FStrings.Text; + if buffer <> '' then + while (buffer[Length(buffer)] = #13) or (buffer[Length(buffer)] = #10) do + Delete(buffer, Length(buffer), 1); + FStrings.Text := buffer; + end; +end; +{=====} + +procedure TO32CustomFlexEdit.SaveEditString; +begin + if (Text <> FSaveEdit) then + FSaveEdit := Text; +end; +{=====} + +procedure TO32CustomFlexEdit.DoOnChange; +begin + if Assigned(OnChange) then + OnChange(Self); +end; +{=====} + +function TO32CustomFlexEdit.GetButtonWidth : Integer; +begin + if FShowButton then begin + Result := GetSystemMetrics(SM_CXHSCROLL); + if Assigned(FButtonGlyph) and not FButtonGlyph.Empty then + if FButtonGlyph.Width + 4 > Result then + Result := FButtonGlyph.Width + 4; + end else + Result := 0; +end; +{=====} + +function TO32CustomFlexEdit.GetButtonGlyph : TBitmap; +begin + if not Assigned(FButtonGlyph) then + FButtonGlyph := TBitmap.Create; + + Result := FButtonGlyph +end; +{=====} + +procedure TO32CustomFlexEdit.GlyphChanged; +begin +end; +{=====} + +procedure TO32CustomFlexEdit.Loaded; +begin + inherited Loaded; + +{$IFDEF ButtonOkay} + if Assigned(FButtonGlyph) then + FButton.Glyph.Assign(FButtonGlyph); +{$ENDIF} +end; +{=====} + +{ - rewritten to solve the "Text disappearing at alignment change" bug. } +procedure TO32CustomFlexEdit.SetAlignment(Value: TAlignment); +var + Str: string; +begin + if FAlignment <> Value then + begin + Str := Text; + FAlignment := Value; +{$IFNDEF LCL} + RecreateWnd; +{$ELSE} + MyMisc.RecreateWnd(Self); +{$ENDIF} + Text := Str; + end; +end; +{=====} + +function TO32CustomFlexEdit.MultiLineEnabled: Boolean; +begin + { The control is only multi-line able if either WordWrap or WantReturns is } + { set and Password char is not being used } + result := (FWantReturns or FWordWrap) and (PasswordChar = #0); +end; +{=====} + +procedure TO32CustomFlexEdit.ButtonClick; +var + P: TPoint; +begin + if (Assigned(FOnButtonClick)) then begin + {Get the screen coordinates of the bottom-left or bottom-right corner of + the control.} + if PopupAnchor = paLeft then + P := Point(Left, Top + Height) + else + P := Point(Left + Width, Top + Height); + + {Call the user defined event handler, passing the desired popup point} + FOnButtonClick(Self, P); + end; +end; +{=====} + +procedure TO32CustomFlexEdit.Restore; + {-restore the previous contents of the FlexEdit} +var + CursorPos: Integer; +begin + BeginUpdate; + CursorPos := SelStart; + Text := FSaveEdit; + Repaint; + DoOnChange; + SelStart := CursorPos; + EndUpdate; +end; +{=====} + +procedure TO32CustomFlexEdit.BeginUpdate; +begin + Inc(FUpdating); + Validation.BeginUpdate; +end; +{=====} + +procedure TO32CustomFlexEdit.EndUpdate; +begin + Dec(FUpdating); + Validation.EndUpdate; + if (FUpdating < 0) then + FUpdating := 0; +end; +{=====} + +procedure TO32CustomFlexEdit.SetBounds(ALeft, ATop, AWidth, AHeight : Integer); +var + CHgt : Integer; +begin + if (FUpdating > 0) then exit; + + inherited SetBounds(ALeft, ATop, AWidth, AHeight); + + if not HandleAllocated then + Exit; + +{$IFDEF ButtonOkay} + if not FShowButton then begin + FButton.Height := 0; + FButton.Width := 0; + Exit; + end; + + CHgt := ClientHeight; + if BorderStyle = bsNone then begin + FButton.Height := CHgt; + FButton.Width := GetButtonWidth; + FButton.Left := Width - FButton.Width; + FButton.Top := 0; + end else if Ctl3D then begin + FButton.Height := CHgt; + FButton.Width := GetButtonWidth; + FButton.Left := Width - FButton.Width - 4; + FButton.Top := 0; + end else begin + FButton.Height := CHgt - 2; + FButton.Width := GetButtonWidth; + FButton.Left := Width - FButton.Width - 1; + FButton.Top := 1; + end; +{$ENDIF} +end; +{=====} + +procedure TO32CustomFlexEdit.SetButtonGlyph(Value : TBitmap); +begin + if not Assigned(FButtonGlyph) then + FButtonGlyph := TBitmap.Create; + + if not Assigned(Value) then begin + FButtonGlyph.Free; + FButtonGlyph := TBitmap.Create; + end else + FButtonGlyph.Assign(Value); + + GlyphChanged; + +{$IFDEF ButtonOkay} + FButton.Glyph.Assign(FButtonGlyph); +{$ENDIF} + SetBounds(Left, Top, Width, Height); +end; +{=====} + +procedure TO32CustomFlexEdit.SetShowButton(Value : Boolean); +begin + if Value <> FShowButton then begin + FShowButton := Value; + {force resize and redisplay of button} + SetBounds(Left, Top, Width, Height); + end; +end; +{=====} + +function TO32CustomFlexEdit.GetBoolean: Boolean; +begin + result := (AnsiUpperCase(Text) = AnsiUppercase(RSTrue)); +end; +{=====} + +function TO32CustomFlexEdit.GetYesNo: Boolean; +begin + result := (AnsiUpperCase(Text) = AnsiUppercase(RSYes)); +end; +{=====} + +function TO32CustomFlexEdit.GetDateTime: TDateTime; +begin + try + result := StrToDateTime(Text); + except + result := 0; + end; +end; +{=====} + +function TO32CustomFlexEdit.GetDouble: Double; +begin + try + result := StrToFloat(Text); + except + result := -1; + end; +end; +{=====} + +function TO32CustomFlexEdit.GetExtended: Extended; +begin + {Note: StrToFloat returns an Extended} + try + result := StrToFloat(Text); + except + result := -1; + end; +end; +{=====} + +function TO32CustomFlexEdit.GetInteger: Integer; +begin + result := StrToIntDef(Text, -1); +end; +{=====} + +function TO32CustomFlexEdit.GetStrings: TStrings; +begin + result := TStrings(FStrings); +end; +{=====} + +function TO32CustomFlexEdit.GetVariant: Variant; +begin + result := Text; +end; +{=====} + +procedure TO32CustomFlexEdit.SetBoolean(Value: Boolean); +begin + if Value then + Text := 'True' + else + Text := 'False'; +end; +{=====} + +procedure TO32CustomFlexEdit.SetYesNo(Value: Boolean); +begin + if Value then + Text := 'Yes' + else + Text := 'No'; +end; +{=====} + +procedure TO32CustomFlexEdit.SetDateTime(Value: TDateTime); +begin + Text := DateTimeToStr(Value); +end; +{=====} + +(* +procedure TO32CustomFlexEdit.SetDataType(Value : TO32FlexEditDataType); +begin + { TODO : Implement } +end; +{=====} +*) + +procedure TO32CustomFlexEdit.SetDouble(Value: Double); +begin + Text := FloatToStr(Value); +end; +{=====} + +procedure TO32CustomFlexEdit.SetExtended(Value: Extended); +begin + Text := FloatToStr(Value); +end; +{=====} + +procedure TO32CustomFlexEdit.SetInteger(Value: Integer); +begin + Text := IntToStr(Value); +end; +{=====} + +procedure TO32CustomFlexEdit.SetStrings(Value: TStrings); +begin + FStrings.Assign(Value); + Invalidate; +end; +{=====} + +procedure TO32CustomFlexEdit.SetVariant(Value: Variant); +begin + try + Text := Value; + except + Text := ''; + end; +end; +{=====} + +procedure TO32CustomFlexEdit.SetDisplayedLines(Value: Integer); +var + buffer: String; +begin + if Value <> FDisplayedLines then begin + buffer := Text; + FDisplayedLines := Value; + AdjustHeight; + Text:= Buffer; + end; +end; +{=====} + +procedure TO32CustomFlexEdit.SetWordWrap(Value: Boolean); +var + buffer: String; +begin + if Value <> FWordWrap then + begin + buffer := Text; + FWordWrap := Value; +{$IFNDEF LCL} + RecreateWnd; +{$ELSE} + MyMisc.RecreateWnd(Self); +{$ENDIF} + Text:= buffer; + end; +end; +{=====} + +procedure TO32CustomFlexEdit.SetWantReturns (Value : Boolean); +var + buffer: String; +begin + if Value <> FWantReturns then + begin + buffer := Text; + FWantReturns := Value; +{$IFNDEF LCL} + RecreateWnd; +{$ELSE} + MyMisc.RecreateWnd(Self); +{$ENDIF} + Text:= buffer; + end; +end; +{=====} + +procedure TO32CustomFlexEdit.SetWantTabs(Value : Boolean); +var + buffer: String; +begin + if Value <> FWantTabs then + begin + buffer := Text; + FWantTabs := Value; +{$IFNDEF LCL} + RecreateWnd; +{$ELSE} + MyMisc.RecreateWnd(Self); +{$ENDIF} + Text:= buffer; + end; +end; + +{$IFDEF LCL} +// Eliminates LCL "[Type1] can not have [Type2] as child" runtime message, +// but button still doesn't work. See Lazarus bug 7097. +function TO32CustomFlexEdit.ChildClassAllowed(ChildClass: TClass): Boolean; +begin + Result := True; +end; +{$ENDIF} + + +end. diff --git a/components/orpheus/o32intdeq.pas b/components/orpheus/o32intdeq.pas new file mode 100644 index 000000000..5e482e99f --- /dev/null +++ b/components/orpheus/o32intdeq.pas @@ -0,0 +1,146 @@ +{*********************************************************} +{* O32INTDEQ.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{The following is a modified version of deque code, which was originally written + for Algorithms Alfresco. It is copyright(c)2001 by Julian M. Bucknall and is + used here with permission.} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit o32intdeq; + {A simple deque class for Orpheus} + +interface + +uses + Classes; + +type + TO32IntDeque = class + protected {private} + FList : TList; + FHead : integer; + FTail : integer; + procedure idGrow; + public + constructor Create(aCapacity : integer); + destructor Destroy; override; + function IsEmpty : boolean; + procedure Enqueue(aValue: integer); + procedure Push(aValue: integer); + function Pop: integer; + end; + +implementation + +uses + SysUtils; + +{=== TO32IntDeque ====================================================} +constructor TO32IntDeque.Create(aCapacity : integer); +begin + inherited Create; + FList := TList.Create; + FList.Count := aCapacity; + {let's help out the user of the deque by putting the head and tail + pointers in the middle: it's probably more efficient} + FHead := aCapacity div 2; + FTail := FHead; +end; +{--------} +destructor TO32IntDeque.Destroy; +begin + FList.Free; + inherited Destroy; +end; +{--------} +procedure TO32IntDeque.Enqueue(aValue : integer); +begin + FList.List^[FTail] := pointer(aValue); + inc(FTail); + if (FTail = FList.Count) then + FTail := 0; + if (FTail = FHead) then + idGrow; +end; +{--------} +procedure TO32IntDeque.idGrow; +var + OldCount : integer; + i, j : integer; +begin + {grow the list by 50%} + OldCount := FList.Count; + FList.Count := (OldCount * 3) div 2; + {expand the data into the increased space, maintaining the deque} + if (FHead = 0) then + FTail := OldCount + else begin + j := FList.Count; + for i := pred(OldCount) downto FHead do begin + dec(j); + FList.List^[j] := FList.List^[i] + end; + FHead := j; + end; +end; +{--------} +function TO32IntDeque.IsEmpty : boolean; +begin + Result := FHead = FTail; +end; +{--------} +procedure TO32IntDeque.Push(aValue : integer); +begin + if (FHead = 0) then + FHead := FList.Count; + dec(FHead); + FList.List^[FHead] := pointer(aValue); + if (FTail = FHead) then + idGrow; +end; +{--------} +function TO32IntDeque.Pop : integer; +begin + if FHead = FTail then + raise Exception.Create('Integer deque is empty: cannot pop'); + Result := integer(FList.List^[FHead]); + inc(FHead); + if (FHead = FList.Count) then + FHead := 0; +end; +{=== TO32IntDeque - end ==============================================} + +end. diff --git a/components/orpheus/o32intlst.pas b/components/orpheus/o32intlst.pas new file mode 100644 index 000000000..28fffcee1 --- /dev/null +++ b/components/orpheus/o32intlst.pas @@ -0,0 +1,195 @@ +{*********************************************************} +{* O32INTLST.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +//{$APPTYPE GUI} +//{$A+,B-,C+,D+,E-,F-,G+,H+,I+,J+,K-,L+,M-,N+,O+,P+,Q-,R-,S-,T-,U-,V+,W-,X+,Y+,Z1} +//{$MINSTACKSIZE $00004000} +//{$MAXSTACKSIZE $00100000} +//{$IMAGEBASE $00400000} + +{The following is a modified version of stack code, which was originally written + for Algorithms Alfresco. It is copyright(c)2001 by Julian M. Bucknall and is + used here with permission.} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit o32intlst; + {Integer List class for Orpheus.} + +interface + +uses + Classes; + +type + TO32IntList = class + protected {private} + FAllowDups : boolean; + FCount : integer; + FIsSorted : boolean; + FList : TList; + function ilGetCapacity : integer; + function ilGetItem(aInx : integer) : integer; + procedure ilSetCapacity(aValue : integer); + procedure ilSetCount(aValue : integer); + procedure ilSetIsSorted(aValue : boolean); + procedure ilSetItem(aInx : integer; aValue : integer); + procedure ilSort; + public + constructor Create; + destructor Destroy; override; + function Add(aItem : integer) : integer; + procedure Clear; + procedure Insert(aInx : Integer; aItem : Pointer); + property AllowDups : boolean + read FAllowDups write FAllowDups; + property Capacity : integer + read ilGetCapacity write ilSetCapacity; + property Count : integer + read FCount write ilSetCount; + property IsSorted : boolean + read FIsSorted write ilSetIsSorted; + property Items[aInx : integer] : integer + read ilGetItem write ilSetItem; default; + end; + +implementation + +uses + SysUtils; + +{===== TO32IntList ===================================================} +constructor TO32IntList.Create; +begin + inherited Create; + FList := TList.Create; + FIsSorted := true; + FAllowDups := false; +end; +{--------} +destructor TO32IntList.Destroy; +begin + FList.Free; + inherited Destroy; +end; +{--------} +function TO32IntList.Add(aItem : integer) : integer; +var + L, R, M : integer; +begin + if (not IsSorted) or (Count = 0) then + Result := FList.Add(pointer(aItem)) + else begin + Result := -1; + L := 0; + R := pred(Count); + while (L <= R) do begin + M := (L + R) div 2; + if (integer(FList.List^[M]) = aItem) then begin + if AllowDups then begin + FList.Insert(M, pointer(aItem)); + Result := M; + end; + Exit; + end; + if (integer(FList.List^[M]) < aItem) then + L := M + 1 + else + R := M - 1; + end; + FList.Insert(L, pointer(aItem)); + Result := L; + end; + inc(FCount); +end; +{--------} +procedure TO32IntList.Clear; +begin + FList.Clear; + FCount := 0; + FIsSorted := true; +end; +{--------} +function TO32IntList.ilGetCapacity : integer; +begin + Result := FList.Capacity; +end; +{--------} +function TO32IntList.ilGetItem(aInx : integer) : integer; +begin + Assert((0 <= aInx) and (aInx < Count), 'Index out of bounds'); + Result := integer(FList.List^[aInx]); +end; +{--------} +procedure TO32IntList.ilSetCapacity(aValue : integer); +begin + FList.Capacity := aValue; +end; +{--------} +procedure TO32IntList.ilSetCount(aValue : integer); +begin + FList.Count := aValue; + FCount := FList.Count; +end; +{--------} +procedure TO32IntList.ilSetIsSorted(aValue : boolean); +begin + if (aValue <> FIsSorted) then begin + FIsSOrted := aValue; + if FIsSorted then + ilSort; + end; +end; +{--------} +procedure TO32IntList.ilSetItem(aInx : integer; aValue : integer); +begin + Assert((0 <= aInx) and (aInx < Count), 'Index out of bounds'); + FList.List^[aInx] := pointer(aValue); +end; +{--------} +procedure TO32IntList.ilSort; +begin + Assert(false, 'TO32IntList.ilSort has not been implemented yet'); +end; +{--------} +procedure TO32IntList.Insert(aInx : Integer; aItem : Pointer); +begin + FIsSorted := false; + FList.Insert(aInx, pointer(aItem)); + inc(FCount); +end; +{===== TO32IntList - end =============================================} + +end. diff --git a/components/orpheus/o32ovldr.pas b/components/orpheus/o32ovldr.pas new file mode 100644 index 000000000..5eb2d7930 --- /dev/null +++ b/components/orpheus/o32ovldr.pas @@ -0,0 +1,365 @@ +{*********************************************************} +{* O32OVLDR.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +unit o32ovldr; + {Orpheus Mask Validator} + +interface + +uses + Classes, O32VlDtr; + +const + OrpheusMaskCount = 17; + OrpheusMaskLength = 11; + + { Sample Orpheus Masks } + OrpheusMaskLookup : array [1..OrpheusMaskCount] of string = + ('XXXXXXXXXX any character', + '!!!!!!!!!! any char (upper)', + 'LLLLLLLLLL any char (lower)', + 'xxxxxxxxxx any char (mixed)', + 'aaaaaaaaaa alphas only', + 'AAAAAAAAAA alphas (upper)', + 'llllllllll alphas (lower)', + '9999999999 0-9', + 'iiiiiiiiii 0-9, -', + '########## 0-9, -, .', + 'EEEEEEEEEE 0-9, E, -, .', + 'KKKK Hexadecimal (1F3E) Allows 0-9, A-F, uppercase Alpha characters', + 'KK Hexadecimal (FF) Allows 0-9, A-F, uppercase Alpha characters', + 'OOOOOOOOOO 0-7 (octal)', + 'bbbbbbbbbb 0, 1 (binary)', + 'B T or F (upper)', + 'Y Y or N (upper)'); + + + {Validation Error Codes} + vecNotAnyOrUpperChar = 1; + vecNotAnyOrLowerChar = 2; + vecNotAlphaChar = 3; + vecNotUpperAlpha = 4; + vecNotLowerAlpha = 5; + vecNotDS = 6; + vecNotDSM = 9; + vecNotDSMP = 10; + vecNotDSMPE = 11; + vecNotHexadecimal = 12; + vecNotBinary = 13; + vecNotOctal = 14; + vecNotTrueFalse = 15; + vecNotYesNo = 16; + +type +{class - TO32OrMaskValidator} + TO32OrMaskValidator = class(TO32BaseValidator) + protected {private} + FMaskBlank: Char; + + procedure SetInput(const Value: string); override; + procedure SetMask(const Value: string); override; + function GetValid: Boolean; override; + function GetSampleMasks: TStringList; override; + function Validate(const Value: string; var ErrorPos: Integer): Boolean; + public + function IsValid: Boolean; override; + property Valid; + property Input; + published + {Properties} + property Mask; + {Events} + property BeforeValidation; + property AfterValidation; + property OnValidationError; + end; + +implementation + +uses + SysUtils, OvcData, O32VlReg; + + +{===== TO32OrMaskValidator ===========================================} + +function TO32OrMaskValidator.GetSampleMasks: TStringList; +var + I : Integer; +begin + { Set the length of the mask portion of the string } + FSampleMaskLength := OrpheusMaskLength; + + FSampleMasks.Clear; + + { Load the string list } + for I := 1 to OrpheusMaskCount do + FSampleMasks.Add(OrpheusMaskLookup[I]); + result := FSampleMasks; +end; +{=====} + +function TO32OrMaskValidator.GetValid: Boolean; +begin + result := IsValid; +end; +{=====} + +function TO32OrMaskValidator.IsValid: Boolean; +var + ErrorStr: string; + ErrorPos: Integer; +begin + DoBeforeValidation; + + {assume the worst} + FValid := false; + + {Set up validation and execute it against the input} + FValid := Validate(FInput, ErrorPos); + + DoAfterValidation; + + if not FValid then begin + case FErrorCode of + vecNotAnyOrUpperChar : + ErrorStr := 'Lowercase characters not allowed in position ' + + IntToStr(ErrorPos) + '.'; + vecNotAnyOrLowerChar : + ErrorStr := 'Uppercase characters not allowed in position ' + + IntToStr(ErrorPos) + '.'; + vecNotAlphaChar : + ErrorStr := 'Non-Alpha characters not allowed in position ' + + IntToStr(ErrorPos) + '.'; + vecNotUpperAlpha : + ErrorStr := 'Non-Uppercase Alpha characters not allowed in position ' + + IntToStr(ErrorPos) + '.'; + vecNotLowerAlpha : + ErrorStr := 'Non-Lowercase Alpha characters not allowed in position ' + + IntToStr(ErrorPos) + '.'; + vecNotDS : + ErrorStr := 'Digits and spaces only allowed in position ' + + IntToStr(ErrorPos) + '.'; + vecNotDSM : + ErrorStr := 'Digits, spaces and ''-'' only allowed in position ' + + IntToStr(ErrorPos) + '.'; + vecNotDSMP : + ErrorStr := 'Digits, spaces ''-'', and ''.'' only allowed in position ' + + IntToStr(ErrorPos) + '.'; + vecNotDSMPE : + ErrorStr := 'Digits, spaces ''-'', ''.'', and ''e/E'' only allowed ' + + 'in position ' + IntToStr(ErrorPos) + '.'; + vecNotHexadecimal : + ErrorStr := 'Hexadecimal characters only (0-F) allowed in position ' + + IntToStr(ErrorPos) + '.'; + vecNotBinary : + ErrorStr := 'Binary characters only (0, 1, and space) allowed in ' + + 'position ' + IntToStr(ErrorPos) + '.'; + vecNotOctal : + ErrorStr := 'Octal characters only (0-7) allowed in position ' + + IntToStr(ErrorPos) + '.'; + vecNotTrueFalse : + ErrorStr := 'Only True/false characters (T, t, F, f) allowed in ' + + 'position ' + IntToStr(ErrorPos) + '.'; + vecNotYesNo : + ErrorStr := 'Only Yes/No characters (Y, y, N, n) allowed in position ' + + IntToStr(ErrorPos) + '.'; + end; + DoOnError(self, 'Invalid match at character position ' + IntToStr(ErrorPos)); + end; + result := FValid; +end; +{=====} + +procedure TO32OrMaskValidator.SetInput(const Value: string); +begin + if FInput <> Value then + FInput := Value; +end; +{=====} + +procedure TO32OrMaskValidator.SetMask(const Value: string); +begin + if FMask <> Value then + FMask := Value; +end; +{=====} + +function TO32OrMaskValidator.Validate(const Value: string; + var ErrorPos: Integer): Boolean; +var + I: Integer; +begin + ErrorPos := 0; + result := true; + if Length(Input) > Length(FMask) then begin + result := false; + ErrorPos := Length(FMask) + 1; + exit; + end; + + for I := 1 to Length(Input) do begin + case FMask[I] of + {pmAnyChar : 'X' allows any character} + { do nothing here - All entry is OK.} + + pmForceUpper : {'!' allows any uppercase character} + if (ord(Input[I]) in [97..122]{lowercase characters}) then begin + result := false; + ErrorPos := I; + FErrorCode := vecNotAnyOrUpperChar; + exit; + end; + + pmForceLower : {'L' allows any lowercase character} + if (ord(Input[I]) in [65..90]{uppercase characters}) then begin + result := false; + ErrorPos := I; + FErrorCode := vecNotAnyOrLowerChar; + exit; + end; + + {pmForceMixed : 'x' allows any character. Just like 'X'} + { do nothing here - All entry is ok, no way to force mixed case without } + { back tracking } + + pmAlpha : {'a' allows alphas only} + if not (ord(Input[I]) in [65..90, 97..122]{any alpha}) then begin + result := false; + ErrorPos := I; + FErrorCode := vecNotAlphaChar; + exit; + end; + + pmUpperAlpha : {'A' allows uppercase alphas only} + if not (ord(Input[I]) in [65..90]{uppercase alpha}) then begin + result := false; + ErrorPos := I; + FErrorCode := vecNotUpperAlpha; + exit; + end; + + pmLowerAlpha : {'l' allows lowercase alphas only} + if not (ord(Input[I]) in [97..122]{lowercase alpha}) then begin + result := false; + ErrorPos := I; + FErrorCode := vecNotLowerAlpha; + exit; + end; + + pmPositive : {'9' allows numbers and spaces only} + if not (ord(Input[I]) in [48..57, 32]) then begin + result := false; + ErrorPos := I; + FErrorCode := vecNotDS; + exit; + end; + + pmWhole : {'i' allows numbers, spaces, minus} + if not (ord(Input[I]) in [48..57, 32, 45]) then + begin + result := false; + ErrorPos := I; + FErrorCode := vecNotDSM; + exit; + end; + + pmDecimal : {'#' allows numbers, spaces, minus, period} + if not (ord(Input[I]) in [48..57, 32, 45, 46]) + then begin + result := false; + ErrorPos := I; + FErrorCode := vecNotDSMP; + exit; + end; + + pmScientific : {'E' allows numbers, spaces, minus, period, 'e'} + if not (ord(Input[I]) in [48..57, 32, 45, 46, 101, 69]) + then begin + result := false; + ErrorPos := I; + FErrorCode := vecNotDSMPE; + exit; + end; + + pmHexadecimal : {'K' allows 0-9 and uppercase A-F} + if not (ord(Input[I]) in [48..57, 65..70]) + then begin + result := false; + ErrorPos := I; + FErrorCode := vecNotHexadecimal; + exit; + end; + + pmBinary : {'b' allows 0-1, space} + if not (ord(Input[I]) in [48, 49, 32]) + then begin + result := false; + ErrorPos := I; + FErrorCode := vecNotBinary; + exit; + end; + + pmOctal : {'O' allows 0-7, space} + if not (ord(Input[I]) in [48..55, 32]) + then begin + result := false; + ErrorPos := I; + FErrorCode := vecNotOctal; + exit; + end; + + pmTrueFalse : {'B' allows T, t, F, f} + if not (ord(Input[I]) in [84, 116, 70, 102]) + then begin + result := false; + ErrorPos := I; + FErrorCode := vecNotTrueFalse; + exit; + end; + + pmYesNo : {'Y' allows Y, y, N, n} + if not (ord(Input[I]) in [89, 121, 78, 110]) + then begin + result := false; + ErrorPos := I; + FErrorCode := vecNotYesNo; + exit; + end; + end; + end; +end; + + +initialization + RegisterValidator(TO32OrMaskValidator); + +finalization + UnRegisterValidator(TO32OrMaskValidator); + +end. + diff --git a/components/orpheus/o32pvldr.pas b/components/orpheus/o32pvldr.pas new file mode 100644 index 000000000..4c1f2e49f --- /dev/null +++ b/components/orpheus/o32pvldr.pas @@ -0,0 +1,446 @@ +{*********************************************************} +{* O32PVLDR.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} {-Defines} + +unit o32pvldr; + {Paradox Mask Validator} + +interface + +uses + {$IFNDEF LCL} Windows, {$ELSE} LclIntf, MyMisc, {$ENDIF} O32Vldtr, Classes; + +const + ParadoxMaskCount = 8; + ParadoxMaskLength = 25; + + {Sample Paradox Masks} + ParadoxMaskLookup : array [1..ParadoxMaskCount] of string = + ('!\(999\)000-0000;1;_ Phone (415)555-1212', + '!99999;1;_ Extension 15450', + '000\-00\-0000;1;_ Social Security 555-55-5555', + '00000;1;_ Short Zip Code 90504', + '00000\-9999;1;_ Long Zip Code 90504-0000', + '!99/99/00;1;_ Date 06/27/01', + '!90:00:00>LL;1;_ Long Time 09:05:15PM', + '!90:00;1;_ Short Time 13:45'); + +type +{class - TO32ParadoxValidator} + TO32ParadoxValidator = class(TO32BaseValidator) + protected {private} + FMaskBlank: Char; + + procedure SetInput(const Value: string); override; + procedure SetMask(const Value: string); override; + function GetValid: Boolean; override; + function GetSampleMasks: TStringList; override; + function Validate(const Value: string; var Pos: Integer): Boolean; + function DoValidateChar(NewChar: Char; + MaskOffset: Integer): Boolean; + function ValidateChar(NewChar: Char; + Offset: Integer): Boolean; + function FindLiteralChar(MaskOffset: Integer; InChar: Char): Integer; + public + constructor Create(AOwner: TComponent); override; + function IsValid: Boolean; override; + property Valid; + property Input; + published + {Properties} + property Mask; + {Events} + property BeforeValidation; + property AfterValidation; + property OnValidationError; + end; + +implementation + +uses + {$IFNDEF LCL} Mask, {$IFDEF VERSION6} MaskUtils, {$ENDIF} {$ELSE} MaskEdit, {$ENDIF} + SysUtils, O32VlReg; + +// Note commented out IFNDEF in order to use these functions with LCL. +// This means this unit can't be compiled by Delphi 5 and earlier. +//{$IFNDEF VERSION6} + { These are declared in the implementation section of the VCL unit Mask.pas, } + { so I had to copy them here so that I could use it. Delphi 6 has made them } + { available by moving them to MaskUtils.pas and making them globally } + { available } + function MaskGetCharType(const EditMask: string; + MaskOffset: Integer): TMaskCharType; + var + MaskChar: Char; + begin + Result := mcLiteral; + MaskChar := #0; + if MaskOffset <= Length(EditMask) then + MaskChar := EditMask[MaskOffset]; + if MaskOffset > Length(EditMask) then + Result := mcNone + + else if ByteType(EditMask, MaskOffset) <> mbSingleByte then + Result := mcLiteral + + else if (MaskOffset > 1) and (EditMask[MaskOffset - 1] = mDirLiteral) and + (ByteType(EditMask, MaskOffset - 1) = mbSingleByte) and + not ((MaskOffset > 2) and (EditMask[MaskOffset - 2] = mDirLiteral) and + (ByteType(EditMask, MaskOffset - 2) = mbSingleByte)) then + Result := mcLiteral + + else if (MaskChar = MaskFieldSeparator) and + (Length(EditMask) >= 4) and + (MaskOffset > Length(EditMask) - 4) then + Result := mcFieldSeparator + + else if (Length(EditMask) >= 4) and + (MaskOffset > (Length(EditMask) - 4)) and + (EditMask[MaskOffset - 1] = MaskFieldSeparator) and + not ((MaskOffset > 2) and (EditMask[MaskOffset - 2] = mDirLiteral) and + (ByteType(EditMask, MaskOffset - 2) <> mbTrailByte)) then + Result := mcField + + else if MaskChar in [mMskTimeSeparator, mMskDateSeparator] then + Result := mcIntlLiteral + + else if MaskChar in [mDirReverse, mDirUpperCase, mDirLowerCase, + mDirLiteral] then + Result := mcDirective + + else if MaskChar in [mMskAlphaOpt, mMskAlphaNumOpt, mMskAsciiOpt, + mMskNumSymOpt, mMskNumericOpt] then + Result := mcMaskOpt + + else if MaskChar in [mMskAlpha, mMskAlphaNum, mMskAscii, mMskNumeric] then + Result := mcMask; + end; + {=====} + + function MaskOffsetToOffset(const EditMask: String; MaskOffset: Integer): Integer; + var + I: Integer; + CType: TMaskCharType; + begin + Result := 0; + for I := 1 to MaskOffset do + begin + CType := MaskGetCharType(EditMask, I); + if not (CType in [mcDirective, mcField, mcFieldSeparator]) then + Inc(Result); + end; + end; + {=====} + + function OffsetToMaskOffset(const EditMask: string; Offset: Integer): Integer; + var + I: Integer; + Count: Integer; + MaxChars: Integer; + begin + MaxChars := MaskOffsetToOffset(EditMask, Length(EditMask)); + if Offset > MaxChars then + begin + Result := -1; + Exit; + end; + + Result := 0; + Count := Offset; + for I := 1 to Length(EditMask) do + begin + if not (mcDirective = MaskGetCharType(EditMask, I)) then begin + Dec(Count); + if Count < 0 then + Exit; + end; + Inc(Result); + end; + end; + {=====} + + function MaskIntlLiteralToChar(IChar: Char): Char; + begin + Result := IChar; + case IChar of + mMskTimeSeparator: Result := TimeSeparator; + mMskDateSeparator: Result := DateSeparator; + end; + end; + {=====} + + function MaskGetCurrentDirectives(const EditMask: string; + MaskOffset: Integer): TMaskDirectives; + var + I: Integer; + MaskChar: Char; + begin + Result := []; + for I := 1 to Length(EditMask) do + begin + MaskChar := EditMask[I]; + if (MaskChar = mDirReverse) then + Include(Result, mdReverseDir) + else if (MaskChar = mDirUpperCase) and (I < MaskOffset) then + begin + Exclude(Result, mdLowerCase); + if not ((I > 1) and (EditMask[I-1] = mDirLowerCase)) then + Include(Result, mdUpperCase); + end + else if (MaskChar = mDirLowerCase) and (I < MaskOffset) then + begin + Exclude(Result, mdUpperCase); + Include(Result, mdLowerCase); + end; + end; + if MaskGetCharType(EditMask, MaskOffset) = mcLiteral then + Include(Result, mdLiteralChar); + end; +//{$ENDIF} + +{===== TO32ParadoxValidator ==========================================} + +constructor TO32ParadoxValidator.Create(AOwner: TComponent); +begin + inherited; + FMaskBlank := DefaultBlank; +end; +{=====} + +function TO32ParadoxValidator.GetValid: Boolean; +begin + result := IsValid; +end; +{=====} + +function TO32ParadoxValidator.GetSampleMasks: TStringList; +var + I : Integer; +begin + { Set the length of the mask portion of the string } + FSampleMaskLength := ParadoxMaskLength; + + FSampleMasks.Clear; + + { Load the string list } + for I := 1 to ParadoxMaskCount do + FSampleMasks.Add(ParadoxMaskLookup[I]); + result := FSampleMasks; +end; +{=====} + +function TO32ParadoxValidator.IsValid: Boolean; +var + ErrorPos: Integer; +begin + DoBeforeValidation; + + {assume the worst} + FValid := false; + + {Set up validation and execute it against the input} + FValid := Validate(FInput, ErrorPos); + + DoAfterValidation; + + if not FValid then begin + DoOnError(self, 'Validation Error Encountered at string position ' + + IntToStr(ErrorPos)); + end; + + result := FValid; +end; +{=====} + +procedure TO32ParadoxValidator.SetInput(const Value: string); +begin + if FInput <> Value then + FInput := Value; +end; +{=====} + +procedure TO32ParadoxValidator.SetMask(const Value: string); +begin + if FMask <> Value then + FMask := Value; +end; +{=====} + +function TO32ParadoxValidator.Validate(const Value: string; var Pos: Integer): Boolean; +var + I : Integer; +begin + result := true; + Pos := 0; + for I := 1 to Length(Value) do begin + if not ValidateChar(Value[I], I) then begin + result := false; + Pos := I; + Exit; + end; + end; +end; +{=====} + +function TO32ParadoxValidator.ValidateChar(NewChar: Char; + Offset: Integer): Boolean; +var + MaskOffset: Integer; +begin + Result := True; + if FMask <> '' then + begin + Result := False; + MaskOffset := OffsetToMaskOffset(FMask, Offset); + if MaskOffset >= 0 then + begin + Result := DoValidateChar(NewChar, MaskOffset); + end; + end; +end; +{=====} + +function TO32ParadoxValidator.FindLiteralChar(MaskOffset: Integer; + InChar: Char): Integer; +var + CType: TMaskCharType; + LitChar: Char; +begin + Result := -1; + while MaskOffset < Length(Mask) do + begin + Inc(MaskOffset); + CType := MaskGetCharType(Mask, MaskOffset); + if CType in [mcLiteral, mcIntlLiteral] then + begin + LitChar := Mask[MaskOffset]; + if CType = mcIntlLiteral then + LitChar := MaskIntlLiteralToChar(LitChar); + if LitChar = InChar then + Result := MaskOffset; + Exit; + end; + end; +end; +{=====} + +function TO32ParadoxValidator.DoValidateChar(NewChar: Char; + MaskOffset: Integer): Boolean; +var + Dir: TMaskDirectives; + Str: string; + CType: TMaskCharType; + + function IsKatakana(const Chr: Byte): Boolean; + begin + Result := (SysLocale.PriLangID = LANG_JAPANESE) and (Chr in [$A1..$DF]); + end; + + function TestChar(NewChar: Char): Boolean; + var + Offset: Integer; + begin + Offset := MaskOffsetToOffset(FMask, MaskOffset); + Result := not ((MaskOffset < Length(FMask)) and + (UpCase(FMask[MaskOffset]) = UpCase(Mask[MaskOffset+1]))) or + (ByteType(FMask, Offset) = mbTrailByte) or + (ByteType(FMask, Offset+1) = mbLeadByte); + end; + +begin + Result := True; + CType := MaskGetCharType(FMask, MaskOffset); + if not (CType in [mcLiteral, mcIntlLiteral]) then begin + Dir := MaskGetCurrentDirectives(FMask, MaskOffset); + case FMask[MaskOffset] of + mMskNumeric, mMskNumericOpt: + begin + if not ((NewChar >= '0') and (NewChar <= '9')) then + Result := False; + end; + mMskNumSymOpt: + begin + if not (((NewChar >= '0') and (NewChar <= '9')) or + (NewChar = ' ') or(NewChar = '+') or(NewChar = '-')) then + Result := False; + end; + mMskAscii, mMskAsciiOpt: + begin + if (NewChar in LeadBytes) and TestChar(NewChar) then + begin + Result := False; + Exit; + end; + if IsCharAlpha(NewChar) then + begin + Str := ' '; + Str[1] := NewChar; + if (mdUpperCase in Dir) then + Str := AnsiUpperCase(Str) + else if mdLowerCase in Dir then + Str := AnsiLowerCase(Str); + end; + end; + mMskAlpha, mMskAlphaOpt, mMskAlphaNum, mMskAlphaNumOpt: + begin + if (NewChar in LeadBytes) then + begin + if TestChar(NewChar) then + Result := False; + Exit; + end; + Str := ' '; + Str[1] := NewChar; + if IsKatakana(Byte(NewChar)) then + Exit; + if not IsCharAlpha(NewChar) then + begin + Result := False; + if ((FMask[MaskOffset] = mMskAlphaNum) or + (FMask[MaskOffset] = mMskAlphaNumOpt)) and + (IsCharAlphaNumeric(NewChar)) then + Result := True; + end + else if mdUpperCase in Dir then + Str := AnsiUpperCase(Str) + else if mdLowerCase in Dir then + Str := AnsiLowerCase(Str); + end; + end; + end; +end; + +initialization + RegisterValidator(TO32ParadoxValidator); + +finalization + UnRegisterValidator(TO32ParadoxValidator); + +end. + diff --git a/components/orpheus/o32rxngn.pas b/components/orpheus/o32rxngn.pas new file mode 100644 index 000000000..464e66546 --- /dev/null +++ b/components/orpheus/o32rxngn.pas @@ -0,0 +1,1063 @@ +{*********************************************************} +{* O32RXNGN.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{The following is a modified version of a Regex engine, which was originally + written for Algorithms Alfresco. It is copyright(c)2001 by Julian M. Bucknall + and is used here with permission.} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +{Notes: these classes parse regular expressions that follow this grammar: + + ::= | + '^' | + '$' | + '^' '$' + ::= | + '|' - alternation + ::= | + - concatenation + ::= | + '?' | - zero or one + '*' | - zero or more + '+' - one or more + ::= | + '.' | - any char + '(' ') | - parentheses + '[' ']' | - normal class + '[^' ']' - negated class + ::= | + + ::= | + '-' + ::= | + '\' + ::= | + '\' + + This means that parentheses have maximum precedence, followed + by square brackets, followed by the closure operators, + followed by concatenation, finally followed by alternation.} + +unit o32rxngn; + {Orpheus Regex Engine} + +interface + +uses + Classes, SysUtils, O32IntDeq, O32IntLst; + +type + PO32CharSet = ^TO32CharSet; + TO32CharSet = set of char; + + TO32NFAMatchType = ( {types of matching performed...} + mtNone, {..no match (an epsilon no-cost move)} + mtAnyChar, {..any character} + mtChar, {..a particular character} + mtClass, {..a character class} + mtNegClass, {..a negated character class} + mtTerminal, {..the final state--no matching} + mtUnused); {..an unused state--no matching} + + TO32RegexError = ( {error codes for invalid regex strings} + recNone, {..no error} + recSuddenEnd, {..unexpected end of string} + recMetaChar, {..read metacharacter, but needed normal char} + recNoCloseParen, {..expected close paren, but not there} + recExtraChars); {..extra characters at the end of the Regex string} + + TO32UpcaseChar = function (aCh : char) : char; + + {- Regex Engine Class} + TO32RegexEngine = class + protected {private} + FAnchorEnd : boolean; + FAnchorStart : boolean; + FErrorCode : TO32RegexError; + FIgnoreCase : boolean; + FPosn : PAnsiChar; + FRegexStr : string; + FStartState : integer; + FTable : TList; + FUpcase : TO32UpcaseChar; + FLogging : Boolean; + Log : System.Text; + FLogFile : string; + + procedure SetLogFile(const Value: String); + + procedure rcSetIgnoreCase(aValue : boolean); + procedure rcSetRegexStr(const aRegexStr : string); + procedure rcSetUpcase(aValue : TO32UpcaseChar); + procedure rcSetLogging(const aValue : Boolean); + + procedure rcClear; + procedure rcLevel1Optimize; + procedure rcLevel2Optimize; + function rcMatchSubString(const S : string; + StartPosn : integer) : boolean; + function rcAddState(aMatchType : TO32NFAMatchType; + aChar : char; + aCharClass : PO32CharSet; + aNextState1: integer; + aNextState2: integer) : integer; + function rcSetState(aState : integer; + aNextState1: integer; + aNextState2: integer) : integer; + + function rcParseAnchorExpr : integer; + function rcParseAtom : integer; + function rcParseCCChar : char; + function rcParseChar : integer; + function rcParseCharClass(aClass : PO32CharSet) : boolean; + function rcParseCharRange(aClass : PO32CharSet) : boolean; + function rcParseExpr : integer; + function rcParseFactor : integer; + function rcParseTerm : integer; + + procedure rcWalkNoCostTree(aList : TO32IntList; + aState : integer); + procedure rcDumpTable; + + public + constructor Create(const aRegexStr : string); + destructor Destroy; override; + + function Parse(var aErrorPos : integer; + var aErrorCode: TO32RegexError) : boolean; + function MatchString(const S : string) : integer; + + property IgnoreCase : boolean + read FIgnoreCase write rcSetIgnoreCase; + property RegexString : string + read FRegexStr write rcSetRegexStr; + property Upcase : TO32UpcaseChar + read FUpcase write rcSetUpcase; + property Logging : Boolean + read FLogging write rcSetLogging; + property LogFile : String read FLogFile write SetLogFile; + end; + +implementation + +const + MetaCharacters: set of char = + ['?', '*', '+', '-', '.', '|', '(', ')', '[', ']', '^', '$']; + + {handy constants} + UnusedState = -1; + NewFinalState = -2; + CreateNewState = -3; + ErrorState = -4; + MustScan = -5; + +type + PO32NFAState = ^TO32NFAState; + TO32NFAState = record + sdNextState1: integer; + sdNextState2: integer; + sdNextList : TO32IntList; + sdClass : PO32CharSet; + sdMatchType : TO32NFAMatchType; + sdChar : char; + end; + +{===TO32RegexEngine=================================================} +constructor TO32RegexEngine.Create(const aRegexStr : string); +begin + inherited Create; + FRegexStr := aRegexStr; + FIgnoreCase := true; + FUpcase := System.Upcase; + FTable := TList.Create; + FTable.Capacity := 64; + FLogging := false; +end; +{--------} +destructor TO32RegexEngine.Destroy; +begin + if (FTable <> nil) then begin + rcClear; + FTable.Free; + end; + inherited Destroy; +end; +{--------} +procedure TO32RegexEngine.rcSetLogging(const aValue : Boolean); +begin + FLogging := aValue; +end; +{--------} +procedure TO32RegexEngine.SetLogFile(const Value: String); +begin + FLogFile := Value; +end; +{--------} +function TO32RegexEngine.MatchString(const S : string) : integer; +var + i : integer; + ErrorPos : integer; + ErrorCode : TO32RegexError; +begin + {if the regex string hasn't been parsed yet, do so} + if (FTable.Count = 0) then begin + if not Parse(ErrorPos, ErrorCode) then begin + raise Exception.Create( + Format('The regex was invalid at position %d', [ErrorPos])); + end; + end; + {now try and see if the string matches (empty strings don't)} + Result := 0; + if (S <> '') then + {if the regex specified a start anchor, then we only need to check + the string starting at the first position} + if FAnchorStart then begin + if rcMatchSubString(S, 1) then + Result := 1; + end + {otherwise we try and match the string at every position and + return at the first success} + else begin + for i := 1 to length(S) do + if rcMatchSubString(S, i) then begin + Result := i; + Break; + end; + end; +end; +{--------} +function TO32RegexEngine.Parse(var aErrorPos : integer; + var aErrorCode: TO32RegexError) + : boolean; + procedure WriteError(aErrorPos : integer; + aErrorCode: TO32RegexError); + begin + writeln(Log, '***parse error found at ', aErrorPos); + case aErrorCode of + recNone : writeln(Log, '-->no error'); + recSuddenEnd : writeln(Log, '-->unexpected end of regex'); + recMetaChar : writeln(Log, '-->found metacharacter in wrong place'); + recNoCloseParen : writeln(Log, '-->missing close paren'); + recExtraChars : writeln(Log, '-->extra chars after valid regex'); + end; + writeln(Log, '"', FRegexStr, '"'); + writeln(Log, '^':succ(aErrorPos)); + end; +begin + result := false; + if FLogging then begin + if FLogFile = '' then FLogFile := 'Parse.log'; + System.Assign(Log, FLogFile); + System.Rewrite(Log); + end; + + try + if FLogging then writeln(Log, 'Parsing regex: "', FRegexStr, '"'); + + {clear the current transition table} + rcClear; + {empty regex strings are not allowed} + if (FRegexStr = '') then begin + aErrorPos := 1; + aErrorCode := recSuddenEnd; + + if FLogging then WriteError(aErrorPos, aErrorCode); + Exit; + end; + {parse the regex string} + FPosn := PAnsiChar(FRegexStr); + FStartState := rcParseAnchorExpr; + + {if an error occurred or we're not at the end of the regex string, + clear the transition table, return false and the error position} + if (FStartState = ErrorState) or (FPosn^ <> #0) then begin + if (FStartState <> ErrorState) and (FPosn^ <> #0) then + FErrorCode := recExtraChars; + rcClear; + aErrorPos := succ(FPosn - PAnsiChar(FRegexStr)); + aErrorCode := FErrorCode; + + if FLogging then WriteError(aErrorPos, aErrorCode); + end + {otherwise add a terminal state, optimize, return true} + else begin + rcAddState(mtTerminal, #0, nil, UnusedState, UnusedState); + rcLevel1Optimize; + rcLevel2Optimize; + Result := true; + aErrorPos := 0; + aErrorCode := recNone; + + if FLogging then rcDumpTable; + end; + finally + if FLogging then System.Close(Log); + end; +end; +{--------} +function TO32RegexEngine.rcAddState(aMatchType : TO32NFAMatchType; + aChar : char; + aCharClass : PO32CharSet; + aNextState1: integer; + aNextState2: integer) : integer; +var + StateData : PO32NFAState; +begin + {create the new state record} + StateData := AllocMem(sizeof(TO32NFAState)); + {set up the fields in the state record} + if (aNextState1 = NewFinalState) then + StateData^.sdNextState1 := succ(FTable.Count) + else + StateData^.sdNextState1 := aNextState1; + StateData^.sdNextState2 := aNextState2; + StateData^.sdMatchType := aMatchType; + if (aMatchType = mtChar) then + StateData^.sdChar := aChar + else if (aMatchType = mtClass) or (aMatchType = mtNegClass) then + StateData^.sdClass := aCharClass; + {add the new state} + Result := FTable.Count; + FTable.Add(StateData); +end; +{--------} +procedure TO32RegexEngine.rcClear; +var + i : integer; + StateData : PO32NFAState; +begin + {free all items in the state transition table} + for i := 0 to pred(FTable.Count) do begin + StateData := PO32NFAState(FTable.List^[i]); + if (StateData <> nil) then begin + with StateData^ do begin + if (sdMatchType = mtClass) or + (sdMatchType = mtNegClass) then + if (sdClass <> nil) then + FreeMem(StateData^.sdClass); + sdNextList.Free; + end; + Dispose(StateData); + end; + end; + {clear the state transition table} + FTable.Clear; + FTable.Capacity := 64; + FAnchorStart := false; + FAnchorEnd := false; +end; +{--------} +procedure TO32RegexEngine.rcDumpTable; +var + i, j : integer; +begin + writeln(Log); + if (FTable.Count = 0) then + writeln(Log, 'No transition table to dump!') + else begin + writeln(Log, 'Transition table dump for "', FRegexStr, '"'); + if FAnchorStart then + writeln(Log, 'anchored at start of string'); + if FAnchorEnd then + writeln(Log, 'anchored at end of string'); + writeln(Log, 'start state: ', FStartState:3); + for i := 0 to pred(FTable.Count) do begin + write(Log, i:3); + with PO32NFAState(FTable[i])^ do begin + case sdMatchType of + mtNone : write(Log, ' no match'); + mtAnyChar : write(Log, ' any char'); + mtChar : write(Log, ' char:', sdChar); + mtClass : write(Log, ' class'); + mtNegClass: write(Log, ' neg class'); + mtTerminal: write(Log, '*******END'); + mtUnused : write(Log, ' --'); + else + write(Log, ' **error**'); + end; + if (sdNextList <> nil) then begin + write(Log, ' next:'); + for j := 0 to pred(sdNextList.Count) do + write(Log, ' ', sdNextList[j]); + end + else begin + if (sdMatchType <> mtTerminal) and + (sdMatchType <> mtUnused) then begin + write(Log, ' next1: ', sdNextState1:3); + if (sdNextState2 <> UnusedState) then + write(Log, ' next2: ', sdNextState2:3); + end; + end; + end; + writeln(Log); + end; + end; +end; +{--------} +procedure TO32RegexEngine.rcLevel1Optimize; +var + i : integer; + Walker : PO32NFAState; +begin + {level 1 optimization removes all states that have only a single + no-cost move to another state} + + {cycle through all the state records, except for the last one} + for i := 0 to (FTable.Count - 2) do begin + {get this state} + with PO32NFAState(FTable.List^[i])^ do begin + {walk the chain pointed to by the first next state, unlinking + the states that are simple single no-cost moves} + Walker := PO32NFAState(FTable.List^[sdNextState1]); + while (Walker^.sdMatchType = mtNone) and + (Walker^.sdNextState2 = UnusedState) do begin + sdNextState1 := Walker^.sdNextState1; + Walker := PO32NFAState(FTable.List^[sdNextState1]); + end; + {walk the chain pointed to by the first next state, unlinking + the states that are simple single no-cost moves} + if (sdNextState2 <> UnusedState) then begin + Walker := PO32NFAState(FTable.List^[sdNextState2]); + while (Walker^.sdMatchType = mtNone) and + (Walker^.sdNextState2 = UnusedState) do begin + sdNextState2 := Walker^.sdNextState1; + Walker := PO32NFAState(FTable.List^[sdNextState2]); + end; + end; + end; + end; +end; +{--------} +procedure TO32RegexEngine.rcLevel2Optimize; +var + i : integer; +begin + {level 2 optimization removes all no-cost moves, except for those + from the start state, if that is a no-cost move state} + + {cycle through all the state records, except for the last one} + for i := 0 to (FTable.Count - 2) do begin + {get this state} + with PO32NFAState(FTable.List^[i])^ do begin + {if it's not a no-cost move state or it's the start state...} + if (sdMatchType <> mtNone) or (i = FStartState) then begin + {create the state list} + sdNextList := TO32IntList.Create; + {walk the chain pointed to by the first next state, adding + the non-no-cost states to the list} + rcWalkNoCostTree(sdNextList, sdNextState1); + {if this is the start state, and it's a no-cost move state + walk the chain pointed to by the second next state, adding + the non-no-cost states to the list} + if (sdMatchType = mtNone) then + rcWalkNoCostTree(sdNextList, sdNextState2); + end; + end; + end; + + {cycle through all the state records, except for the last one, + marking unused ones--not strictly necessary but good for debugging} + for i := 0 to (FTable.Count - 2) do begin + if (i <> FStartState) then + with PO32NFAState(FTable.List^[i])^ do begin + if (sdMatchType = mtNone) then + sdMatchType := mtUnused; + end; + end; +end; +{--------} +function TO32RegexEngine.rcMatchSubString(const S : string; + StartPosn : integer) + : boolean; +var + i : integer; + Ch : char; + State : integer; + Deque : TO32IntDeque; + StrInx : integer; +begin + {assume we fail to match} + Result := false; + {create the deque} + Deque := TO32IntDeque.Create(64); + try + {enqueue the special value to start scanning} + Deque.Enqueue(MustScan); + {enqueue the first state} + Deque.Enqueue(FStartState); + {prepare the string index} + StrInx := StartPosn - 1; + Ch := #0; //just to fool the engine + {loop until the deque is empty or we run out of string} + while (StrInx <= length(S)) and not Deque.IsEmpty do begin + {pop the top state from the deque} + State := Deque.Pop; + {process the "must scan" state first} + if (State = MustScan) then begin + {if the deque is empty at this point, we might as well give up + since there are no states left to process new characters} + if not Deque.IsEmpty then begin + {if we haven't run out of string, get the character, and + enqueue the "must scan" state again} + inc(StrInx); + if (StrInx <= length(S)) then begin + if IgnoreCase then + Ch := Upcase(S[StrInx]) + else + Ch := S[StrInx]; + Deque.Enqueue(MustScan); + end; + end; + end + {otherwise, process the state} + else with PO32NFAState(FTable.List^[State])^ do begin + case sdMatchType of + mtNone : + begin + if (State <> FStartState) then + Assert(false, 'no-cost states shouldn''t be seen'); + for i := 0 to pred(sdNextList.Count) do + Deque.Push(sdNextList[i]); + end; + mtAnyChar : + begin + {for a match of any character, enqueue the next states} + for i := 0 to pred(sdNextList.Count) do + Deque.Enqueue(sdNextList[i]); + end; + mtChar : + begin + {for a match of a character, enqueue the next states} + if (Ch = sdChar) then + for i := 0 to pred(sdNextList.Count) do + Deque.Enqueue(sdNextList[i]); + end; + mtClass : + begin + {for a match within a class, enqueue the next states} + if (Ch in sdClass^) then + for i := 0 to pred(sdNextList.Count) do + Deque.Enqueue(sdNextList[i]); + end; + mtNegClass : + begin + {for a match not within a class, enqueue the next states} + if not (Ch in sdClass^) then + for i := 0 to pred(sdNextList.Count) do + Deque.Enqueue(sdNextList[i]); + end; + mtTerminal : + begin + {for a terminal state, the string successfully matched + if the regex had no end anchor, or we're at the end + of the string} + if (not FAnchorEnd) or (StrInx > length(S)) then begin + Result := true; + Exit; + end; + end; + mtUnused : + begin + Assert(false, 'unused state ' + IntToStr(State) + + ' shouldn''t be seen'); + end; + end; + end; + end; + {if we reach this point we've either exhausted the deque or we've + run out of string; if the former, the substring did not match + since there are no more states. If the latter, we need to check + the states left on the deque to see if one is the terminating + state; if so the string matched the regular expression defined by + the transition table} + while not Deque.IsEmpty do begin + State := Deque.Pop; + with PO32NFAState(FTable.List^[State])^ do begin + case sdMatchType of + mtTerminal : + begin + {for a terminal state, the string successfully matched + if the regex had no end anchor, or we're at the end + of the string} + if (not FAnchorEnd) or (StrInx > length(S)) then begin + Result := true; + Exit; + end; + end; + end;{case} + end; + end; + finally + Deque.Free; + end; +end; +{--------} +function TO32RegexEngine.rcParseAnchorExpr : integer; +begin + {check for an initial '^'} + if (FPosn^ = '^') then begin + FAnchorStart := true; + inc(FPosn); + + if FLogging then writeln(Log, 'parsed start anchor'); + + end; + + {parse an expression} + Result := rcParseExpr; + + {if we were successful, check for the final '$'} + if (Result <> ErrorState) then begin + if (FPosn^ = '$') then begin + FAnchorEnd := true; + inc(FPosn); + + if FLogging then writeln(Log, 'parsed end anchor'); + end; + end; +end; +{--------} +function TO32RegexEngine.rcParseAtom : integer; +var + MatchType : TO32NFAMatchType; + CharClass : PO32CharSet; +begin + case FPosn^ of + '(' : + begin + {move past the open parenthesis} + inc(FPosn); + + if FLogging then writeln(Log, 'parsed open paren'); + + {parse a complete regex between the parentheses} + Result := rcParseExpr; + if (Result = ErrorState) then + Exit; + {if the current character is not a close parenthesis, + there's an error} + if (FPosn^ <> ')') then begin + FErrorCode := recNoCloseParen; + Result := ErrorState; + Exit; + end; + {move past the close parenthesis} + inc(FPosn); + + if FLogging then writeln(Log, 'parsed close paren'); + end; + '[' : + begin + {move past the open square bracket} + inc(FPosn); + + if Logging then + writeln(Log, 'parsed open square bracket (start of class)'); + + {if the first character in the class is a '^' then the + class if negated, otherwise it's a normal one} + if (FPosn^ = '^') then begin + inc(FPosn); + MatchType := mtNegClass; + + if FLogging then writeln(Log, 'it is a negated class'); + end + else begin + MatchType := mtClass; + + if FLogging then writeln(Log, 'it is a normal class'); + end; + {allocate the class character set and parse the character + class; this will return either with an error, or when the + closing square bracket is encountered} + New(CharClass); + CharClass^ := []; + if not rcParseCharClass(CharClass) then begin + Dispose(CharClass); + Result := ErrorState; + Exit; + end; + {move past the closing square bracket} + Assert(FPosn^ = ']', + 'the rcParseCharClass terminated without finding a "]"'); + inc(FPosn); + + if Logging then + writeln(Log, 'parsed close square bracket (end of class)'); + + {add a new state for the character class} + Result := rcAddState(MatchType, #0, CharClass, + NewFinalState, UnusedState); + end; + '.' : + begin + {move past the period metacharacter} + inc(FPosn); + + if FLogging then writeln(Log, 'parsed anychar operator "."'); + + {add a new state for the 'any character' token} + Result := rcAddState(mtAnyChar, #0, nil, + NewFinalState, UnusedState); + end; + else + {otherwise parse a single character} + Result := rcParseChar; + end;{case} +end; +{--------} +function TO32RegexEngine.rcParseCCChar : char; +begin + {if we hit the end of the string, it's an error} + if (FPosn^ = #0) then begin + FErrorCode := recSuddenEnd; + Result := #0; + Exit; + end; + {if the current char is a metacharacter (at least in terms of a + character class), it's an error} + if FPosn^ in [']', '-'] then begin + FErrorCode := recMetaChar; + Result := #0; + Exit; + end; + {otherwise return the character and advance past it} + if (FPosn^ = '\') then + {..it's an escaped character: get the next character instead} + inc(FPosn); + Result := FPosn^; + inc(FPosn); + + if FLogging then writeln(Log, 'parsed charclass char: "', Result, '"'); + +end; +{--------} +function TO32RegexEngine.rcParseChar : integer; +var + Ch : char; +begin + {if we hit the end of the string, it's an error} + if (FPosn^ = #0) then begin + Result := ErrorState; + FErrorCode := recSuddenEnd; + Exit; + end; + {if the current char is one of the metacharacters, it's an error} + if FPosn^ in MetaCharacters then begin + Result := ErrorState; + FErrorCode := recMetaChar; + Exit; + end; + {otherwise add a state for the character} + {..if it's an escaped character: get the next character instead} + if (FPosn^ = '\') then + inc(FPosn); + if IgnoreCase then + Ch := Upcase(FPosn^) + else + Ch := FPosn^; + Result := rcAddState(mtChar, Ch, nil, NewFinalState, UnusedState); + inc(FPosn); + + if FLogging then writeln(Log, 'parsed char: "', Ch, '"'); +end; +{--------} +function TO32RegexEngine.rcParseCharClass(aClass : PO32CharSet) : boolean; +begin + {assume we can't parse a character class properly} + Result := false; + {parse a character range; if we can't there was an error and the + caller will take care of it} + if not rcParseCharRange(aClass) then + Exit; + {if the current character was not the right bracket, parse another + character class (note: we're removing the tail recursion here)} + while (FPosn^ <> ']') do begin + if not rcParseCharRange(aClass) then + Exit; + end; + {if we reach here we were successful} + Result := true; +end; +{--------} +function TO32RegexEngine.rcParseCharRange(aClass : PO32CharSet) : boolean; +var + StartChar : char; + EndChar : char; + Ch : char; +begin + {assume we can't parse a character range properly} + Result := false; + {parse a single character; if it's null there was an error} + StartChar := rcParseCCChar; + if (StartChar = #0) then + Exit; + {if the current character is not a dash, the range consisted of a + single character} + if (FPosn^ <> '-') then begin + if IgnoreCase then + Include(aClass^, Upcase(StartChar)) + else + Include(aClass^, StartChar) + end + {otherwise it's a real range, so get the character at the end of the + range; if that's null, there was an error} + else begin + + if FLogging then writeln(Log, '-range to-'); + + inc(FPosn); {move past the '-'} + EndChar := rcParseCCChar; + if (EndChar = #0) then + Exit; + {build the range as a character set} + if (StartChar > EndChar) then begin + Ch := StartChar; + StartChar := EndChar; + EndChar := Ch; + end; + for Ch := StartChar to EndChar do begin + Include(aClass^, Ch); + if IgnoreCase then + Include(aClass^, Upcase(Ch)); + end; + end; + {if we reach here we were successful} + Result := true; +end; +{--------} +function TO32RegexEngine.rcParseExpr : integer; +var + StartState1 : integer; + StartState2 : integer; + EndState1 : integer; + OverallStartState : integer; +begin + {assume the worst} + Result := ErrorState; + {parse an initial term} + StartState1 := rcParseTerm; + if (StartState1 = ErrorState) then + Exit; + {if the current character is *not* a pipe character, no alternation + is present so return the start state of the initial term as our + start state} + if (FPosn^ <> '|') then + Result := StartState1 + {otherwise, we need to parse another expr and join the two together + in the transition table} + else begin + + if FLogging then writeln(Log, 'OR (alternation)'); + + {advance past the pipe} + inc(FPosn); + {the initial term's end state does not exist yet (although there + is a state in the term that points to it), so create it} + EndState1 := rcAddState(mtNone, #0, nil, UnusedState, UnusedState); + {for the OR construction we need a new initial state: it will + point to the initial term and the second just-about-to-be-parsed + expr} + OverallStartState := rcAddState(mtNone, #0, nil, + UnusedState, UnusedState); + {parse another expr} + StartState2 := rcParseExpr; + if (StartState2 = ErrorState) then + Exit; + {alter the state state for the overall expr so that the second + link points to the start of the second expr} + Result := rcSetState(OverallStartState, StartState1, StartState2); + {now set the end state for the initial term to point to the final + end state for the second expr and the overall expr} + rcSetState(EndState1, FTable.Count, UnusedState); + end; +end; +{--------} +function TO32RegexEngine.rcParseFactor : integer; +var + StartStateAtom : integer; + EndStateAtom : integer; +begin + {assume the worst} + Result := ErrorState; + {first parse an atom} + StartStateAtom := rcParseAtom; + if (StartStateAtom = ErrorState) then + Exit; + {check for a closure operator} + case FPosn^ of + '?' : begin + if FLogging then writeln(Log, 'zero or one closure'); + + {move past the ? operator} + inc(FPosn); + {the atom's end state doesn't exist yet, so create one} + EndStateAtom := rcAddState(mtNone, #0, nil, + UnusedState, UnusedState); + {create a new start state for the overall regex} + Result := rcAddState(mtNone, #0, nil, + StartStateAtom, EndStateAtom); + {make sure the new end state points to the next unused + state} + rcSetState(EndStateAtom, FTable.Count, UnusedState); + end; + '*' : begin + if FLogging then writeln(Log, 'zero or more closure'); + + {move past the * operator} + inc(FPosn); + {the atom's end state doesn't exist yet, so create one; + it'll be the start of the overall regex subexpression} + Result := rcAddState(mtNone, #0, nil, + NewFinalState, StartStateAtom); + end; + '+' : begin + if FLogging then writeln(Log, 'one or more closure'); + + {move past the + operator} + inc(FPosn); + {the atom's end state doesn't exist yet, so create one} + rcAddState(mtNone, #0, nil, NewFinalState, StartStateAtom); + {the start of the overall regex subexpression will be the + atom's start state} + Result := StartStateAtom; + end; + else + Result := StartStateAtom; + end;{case} +end; +{--------} +function TO32RegexEngine.rcParseTerm : integer; +var + StartState2 : integer; + EndState1 : integer; +begin + {parse an initial factor, the state number returned will also be our + return state number} + Result := rcParseFactor; + if (Result = ErrorState) then + Exit; + {Note: we have to "break the grammar" here. We've parsed a regular + subexpression and we're possibly following on with another + regular subexpression. There's no nice operator to key off + for concatenation: we just have to know that for + concatenating two subexpressions, the current character will + be + - an open parenthesis + - an open square bracket + - an any char operator + - a character that's not a metacharacter + i.e., the three possibilities for the start of an "atom" in + our grammar} + if (FPosn^ = '(') or + (FPosn^ = '[') or + (FPosn^ = '.') or + ((FPosn^ <> #0) and not (FPosn^ in MetaCharacters)) then begin + if FLogging then writeln(Log, 'concatenation'); + + {the initial factor's end state does not exist yet (although there + is a state in the term that points to it), so create it} + EndState1 := rcAddState(mtNone, #0, nil, UnusedState, UnusedState); + {parse another term} + StartState2 := rcParseTerm; + if (StartState2 = ErrorState) then begin + Result := ErrorState; + Exit; + end; + {join the first factor to the second term} + rcSetState(EndState1, StartState2, UnusedState); + end; +end; +{--------} +procedure TO32RegexEngine.rcSetIgnoreCase(aValue : boolean); +begin + if (aValue <> FIgnoreCase) then begin + rcClear; + FIgnoreCase := aValue; + end; +end; +{--------} +procedure TO32RegexEngine.rcSetRegexStr(const aRegexStr : string); +begin + if (aRegexStr <> FRegexStr) then begin + rcClear; + FRegexStr := aRegexStr; + end; +end; +{--------} +function TO32RegexEngine.rcSetState(aState : integer; + aNextState1: integer; + aNextState2: integer) : integer; +var + StateData : PO32NFAState; +begin + Assert((0 <= aState) and (aState < FTable.Count), + 'trying to change an invalid state'); + + {get the state record and change the transition information} + StateData := PO32NFAState(FTable.List^[aState]); + StateData^.sdNextState1 := aNextState1; + StateData^.sdNextState2 := aNextState2; + Result := aState; +end; +{--------} +procedure TO32RegexEngine.rcSetUpcase(aValue : TO32UpcaseChar); +begin + if not Assigned(aValue) then + FUpcase := System.Upcase + else + FUpcase := aValue; +end; +{--------} +procedure TO32RegexEngine.rcWalkNoCostTree(aList : TO32IntList; + aState : integer); +begin + {look at this state's record...} + with PO32NFAState(FTable.List^[aState])^ do begin + {if it's a no-cost state, recursively walk the + first, then the second chain} + if (sdMatchType = mtNone) then begin + rcWalkNoCostTree(aList, sdNextState1); + rcWalkNoCostTree(aList, sdNextState2); + end + {otherwise, add it to the list} + else + aList.Add(aState); + end; +end; +{----} + +end. diff --git a/components/orpheus/o32rxvld.pas b/components/orpheus/o32rxvld.pas new file mode 100644 index 000000000..4d8a4d3be --- /dev/null +++ b/components/orpheus/o32rxvld.pas @@ -0,0 +1,294 @@ +{*********************************************************} +{* O32RXVLD.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit o32rxvld; + {Unit for the Orpheus RegEx Validator} + +interface + +uses Classes, O32Vldtr, O32RxNgn, SysUtils; + +const + RXMaskCount = 13; + RXMaskLength = 80; + + {Sample Regular Expressions for the Regex validator Property editor...} + RXMaskLookup : array [1..RXMaskCount] of string = + ('.+ 1 or more of any characters allowed. Minimum of 1 character required. Note: This is the default behavior. No expression is needed.', + '.* Any number of any character allowed. Note: Although This expression allows an empty string, The RegexEngine will fail an empty string.', + '(1[012]|[1-9]):[0-5][0-9] (am|pm) Time of day: Standard AM/PM time display (9:17 am) or (12:30 pm)', + '(1[012]|[1-9]):[0-5][0-9]:[0-5][0-9] (am|pm) Time of day: Standard AM/PM time diplay with seconds. (9:17:22 am)', + '(([01]?[0-9])|(2[0-3])):[0-5][0-9] Time of day: 24 hour clock (15:22).', + '(([01]?[0-9])|(2[0-3])):[0-5][0-9]:[0-5][0-9] Time of day: 24 hour clock with seconds (15:22:07).', + '(\(?[1-9][0-9][0-9]\)? )?[1-9][0-9][0-9]\-[0-9][0-9][0-9][0-9] Telephone Number: Optional area-code with optional parenthesis', + '(0?[1-9]|1[012])(\\|/|\-)([012]?[1-9]|[123]0|31)(\\|/|\-)([123][0-9])?[0-9][0-9] Date: (mm\dd\yy) or (mm\dd\yyyy) formats. Also accepts / and - separators. Note: Only covers years from 1000-3999', + '(y(es)?)|(no?) Boolean: Y, y, N, n, Yes, yes, No or no', + '(t(rue)?)|(f(alse)?) Boolean: T, t, F, f, True, False, true or false', + '([0-9]|[A-F])+ Hexadecimal: Allows any number of characters in the range 0-9 and A-F', + '[0-7]+ Octal: Allows any number of characters in the range 0-7.', + '[01]+ Binary:Allows any number of binary characters (0 and 1).'); + + {Error Codes} + EC_NO_ERROR = 0; + EC_INVALID_EXPR = 1; + EC_INVALID_INPUT = 2; + EC_NO_MATCH = 3; + +type +{class - TO32RegExValidator} + TO32RegExValidator = class(TO32BaseValidator) + protected {private} + FLogging : Boolean; {Log validator parsing?} + FLogFile : String; {Logging file name} + FRegexEngine : TO32RegExEngine; {Regex engine used by the validator} + FExprErrorPos : Integer; {Error position in the Regex string} + FExprErrorCode : TO32RegexError; {Regex string error code} + FIgnoreCase : Boolean; {Case sensitive matching} + procedure SetIgnoreCase(const Value: Boolean); + procedure SetLogging(const Value: Boolean); + procedure SetLogFile(const Value: String); + procedure SetMask(const Value: String); override; + function GetValid: Boolean; override; + function GetSampleMasks: TStringList; override; + procedure SetInput(const Value: string); override; + function CheckExpression(var ErrorPos: Integer): Boolean; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + function IsValid: Boolean; override; + function GetExprError: String; + property Valid; + property ExprErrorPos: Integer read FExprErrorPos write FExprErrorPos; + published + property Input; + { Surfaced the Mask property as "Expression" for the Regex validator + Left Mask exposed as public for automated use such as the ValidatorPool} + property Expression: string read FMask write SetMask stored true; + property Logging: Boolean read FLogging write SetLogging + default False; + property LogFile: String read FLogFile write SetLogFile; + property IgnoreCase: Boolean read FIgnoreCase write SetIgnoreCase stored true + default True; + {Events} + property BeforeValidation; + property AfterValidation; + property OnValidationError; + end; + +implementation + +uses + O32VlReg; + +{=== TO32RegExValidator ==============================================} +constructor TO32RegExValidator.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + + FLogging := false; + FLogFile := 'parse.log'; + FIgnoreCase := true; + + FRegexEngine := TO32RegExEngine.Create(''); + FRegexEngine.Logging := FLogging; + FRegexEngine.LogFile := FLogFile; + FRegexEngine.IgnoreCase := FIgnoreCase; +end; +{=====} + +destructor TO32RegExValidator.Destroy; +begin + FRegexEngine.Free; + inherited Destroy; +end; +{=====} + +function TO32RegExValidator.GetSampleMasks: TStringList; +var + I : Integer; +begin + { Set the length of the mask portion of the string } + FSampleMaskLength := RXMaskLength; + + FSampleMasks.Clear; + + { Load the string list } + for I := 1 to RXMaskCount do + FSampleMasks.Add(RXMaskLookup[I]); + result := FSampleMasks; +end; +{=====} + +procedure TO32RegExValidator.SetMask(const Value: String); +var + OldExpression: String; +begin + OldExpression := FMask; + FMask := Value; + if not CheckExpression(FExprErrorPos) then + FMask := OldExpression; +end; +{=====} + +procedure TO32RegExValidator.SetInput(const Value: string); +begin + if FInput <> Value then + FInput := Value; +end; +{=====} + +function TO32RegExValidator.CheckExpression(var ErrorPos: Integer): Boolean; +begin + if (FMask <> '') then begin + FRegexEngine.RegexString := FMask; + if not FRegexEngine.Parse(FExprErrorPos, FExprErrorCode) then begin + result := false; + FErrorCode := EC_INVALID_EXPR; + DoOnError(self, GetExprError); + end else + result := true; + end else begin + {Allow the user to initialize the Validator with an empty string} + result := true; + ErrorPos := 0; + FExprErrorPos := 0; + FErrorCode := EC_NO_ERROR; + FExprErrorCode := recNone; + end; +end; +{=====} + +function TO32RegExValidator.GetValid: Boolean; +begin + result := IsValid; +end; +{=====} + +function TO32RegExValidator.IsValid: Boolean; +var + RegExStr: String; +begin + DoBeforeValidation; + + {assume the worst} + FValid := false; + + {Create a copy of the Expression and then enclose it in anchor operators so + that the RegexEngine only matches the whole string...} + RegExStr := FMask; + {Check for Anchor operator ^} + if (Pos('^', RegExStr) <> 1) then + Insert('^', RegExStr, 1); + {Check for Anchor operator $} + if (Pos('$', RegExStr) <> Length(RegExStr)) then + RegexStr := RegExStr + '$'; + + {Pass the RegexStr into the RegexEngine} + FRegexEngine.RegexString := RegExStr; + + if (RegExStr = '') then begin + FErrorCode := EC_INVALID_EXPR; + FValid := false; + end else if (FInput = '') then begin + FErrorCode := EC_INVALID_INPUT; + FValid := false; + end else begin + if (FRegexEngine.MatchString(FInput) = 1) then begin + FValid := true; + FErrorCode := 0; + end else begin + FValid := false; + FErrorCode := EC_NO_MATCH; + end; + end; + + result := FValid; + + DoAfterValidation +end; +{=====} + +procedure TO32RegExValidator.SetLogging(const Value: Boolean); +begin + if (FLogging <> Value) then begin + FLogging := Value; + FRegexEngine.Logging := FLogging; + end; +end; +{=====} + +procedure TO32RegExValidator.SetIgnoreCase(const Value: Boolean); +begin + if (FIgnoreCase <> Value) then begin + FIgnoreCase := Value; + FRegexEngine.IgnoreCase := FIgnoreCase; + end; +end; +{=====} + +procedure TO32RegExValidator.SetLogFile(const Value: String); +begin + if (FLogFile <> Value) then begin + FLogFile := Value; + FRegexEngine.LogFile := FLogFile; + end; +end; +{=====} + +function TO32RegExValidator.GetExprError: String; +begin + case FExprErrorCode of + recNone : result := ''; + recSuddenEnd : result := 'Incomplete Expression'; + recMetaChar : result := 'Read a metacharacter where there should have' + + ' been a normal character'; + recNoCloseParen : result := 'Missing closing parenthesis'; + recExtraChars : result := 'Unrecognizable text at the end of the' + + ' expression'; + end; +end; +{=====} + +initialization + + RegisterValidator(TO32RegexValidator); + +finalization + + UnRegisterValidator(TO32RegexValidator); + +end. diff --git a/components/orpheus/o32sr.inc b/components/orpheus/o32sr.inc new file mode 100644 index 000000000..ea0849521 --- /dev/null +++ b/components/orpheus/o32sr.inc @@ -0,0 +1,253 @@ +{*********************************************************} +{* O32SR.INC *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{Orhpheus String Resources - To create language specific versions of Orpheus + controls, translate these strings to the desired language and re-compile.} + +resourcestring + RSNoneStr = '(None)'; + RSccUser = 'ccUser'; + RSccUserNum = 'ccUser%d'; + RSDeleteTable = 'Delete the %s table?'; + RSRenameTable = 'Rename Table'; + RSEnterTableName = 'Enter new table name for %s:'; + RSNewTable = 'NewTable'; + RSDefaultTableName = 'Default'; + RSWordStarTableName = 'WordStar'; + RSGridTableName = 'Grid'; + RSUnknownTable = '(Unknown)'; + RSDefaultEntryErrorText = 'Entry Error'; + RSGotItemWarning = '%d. *** Warning *** OnGetItem not assigned!'; + RSSampleListItem = '%d. - Sample virtual list box item'; + RSAlphaString = 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ'; + RSTallLowChars = 'Wy'; + RSDefault = 'Default'; + RSYes = 'Y'; + RSNo = 'N'; + RSTrue = 'T'; + RSFalse = 'F'; + RSDescending = ' - Desc'; + RSDefaultIndex = '(Default)'; + RSDuplicateCommand = 'Duplicate command found while adding a new command to the table'; + RSTableNotFound = 'Command table not found or command table index out of range'; + RSNotDoneYet = 'This feature is not implemented at this time'; + RSNoControllerAssigned = 'No Controller assigned'; + RSCantCreateCommandTable = 'Unable to create command table'; + RSCantDelete = 'Can''t delete this table. Must have at least one command table defined'; + RSInvalidKeySequence = 'Invalid or no key sequence entered'; + RSNotWordStarCommands = 'Keys entered are not WordStar style commands'; + RSNoCommandSelected = 'No command selected'; + RSDuplicateKeySequence = 'Duplicate key sequence'; + RSRangeError = 'Value is not within required range'; + RSInvalidNumber = 'Value is not valid for this field type'; + RSRequiredField = 'A value is required in this field'; + RSInvalidDate = 'Value is not a valid date'; + RSInvalidTime = 'Value is not a valid time'; + RSBlanksInField = 'This field should contain no blanks'; + RSPartialEntry = 'This field should be either empty or completely full'; + RSRegionTooLarge = 'Region is too large (> 64K)'; + RSOutOfMemoryForCopy = 'Could not allocate memory for clipboard copy'; + RSInvalidParamValue = 'Parameter value is invalid'; + RSNoTimersAvail = 'No Window''s timers are available'; + RSTooManyEvents = 'Too many trigger events'; + RSBadTriggerHandle = 'Invalid trigger handle'; + RSOnSelectNotAssigned = 'OnSelect event is not assigned'; + RSInvalidPageIndex = 'Invalid page index value'; + RSInvalidDataType = 'Invalid data type for this field'; + RSInvalidTabFont = 'Invalid font. Non toTop oriented tabs require a True-Type font'; + RSInvalidLabelFont = 'Invalid font. Rotated text requires a True-Type font'; + RSOutOfMemory = 'insufficient memory for requested operation'; + RSTooManyParas = 'Current operation will exceed the maximum number of allowed paragraphs'; + RSCannotJoin = 'Cannot join paragraphs. New paragraph size exceeds maximum paragraph size'; + RSTooManyBytes = 'Current operation will exceed the maximum text size'; + RSParaTooLong = 'Current operation will exceed the maximum paragraph size'; + RSUnknownError = 'Unknown Error condition'; + RSInvalidPictureMask = 'Invalid picture mask: %s'; + RSInvalidRange = 'Invalid range. Enter a value between (%d) and (%d)'; + RSInvalidRealRange = 'Invalid range. Enter a value between (-1.7e+38) and (+1.7e+38)'; + RSInvalidExtendedRange = 'Invalid range. Enter a value between (-1.1e+4932) and (+1.1e+4932)'; + RSInvalidDoubleRange = 'Invalid range. Enter a value between (-1.7e+308) and (+1.7e+308)'; + RSInvalidSingleRange = 'Invalid range. Enter a value between (-3.4e+38) and (+3.4e+38)'; + RSInvalidCompRange = 'Invalid range. Enter a value between (-9.2e+18) and (+9.2e+18)'; + RSInvalidDateRange = 'Invalid date range. Enter a value using ''%s'' as the format'; + RSInvalidTimeRange = 'Invalid time range. Enter a value using ''%s'' as the format'; + RSInvalidRangeValue = 'Invalid range value'; + RSInvalidMinMaxValue = 'Invalid value - Maximum must always be greater than Minimum'; + RSRangeNotSupported = 'Range limits for the currently selected data type are not supported'; + RSInvalidLineOrParaIndex = 'Invalid line or paragraph index'; + RSNonFixedFont = 'Invalid font assignment. Font must be a fixed font'; + RSInvalidFontParam = 'Invalid font assignemnt. Font must be a TFont or TOvcFixedFont'; + RSInvalidLineOrColumn = 'Invalid line or column'; + RSSAEGeneral = 'Unknown sparse array error'; + RSSAEAtMaxSize = 'Sparse array is at the maximum size'; + RSInvalidXMLFile = 'Invalid XMLStore File Format'; + RSUnterminatedElement = 'Improperly terminated element'; + RSBadColorConstant = 'Invalid color constant'; + RSBadColorValue = 'Invalid color value'; + RSSAEOutOfBounds = 'Index is out of bounds for sparse array'; + RSInvalidFieldType = 'Requested field type is not supported'; + RSBadAlarmHandle = 'Invalid alarm handle'; + RSOnIsSelectedNotAssigned = 'OnIsSelected event is not assigned'; + RSInvalidDateForMask = 'Invalid date value for picture mask. (Year is outside the Epoch range)'; + RSViewerIOError = 'Viewer triggered I/O error %d'; + RSViewerFileNotFound = 'Viewer: file not found'; + RSViewerPathNotFound = 'Viewer: path not found or invalid file name'; + RSViewerTooManyOpenFiles = 'Viewer: too many open files'; + RSViewerFileAccessDenied = 'Viewer: file access denied'; + RSControlAttached = 'This control is already attached to %s'; + RSCantEdit = 'Could not enter edit mode'; + RSChildTableError = 'Data Source can not be a child table. Component %s has a MasterSource defined'; + RSNoTableAttached = 'DataSource must be attached to a TTable (or compatible) source'; + RSNoCollection = 'No collection exists in the owner component'; + RSNotOvcDescendant = 'Owner must be a TOvcComponent or TOvcCustomComponent descendant'; + RSItemIncompatible = 'Item incompatible with collection'; + RSLabelNotAttached = 'Label not attached'; + RSClassNotSet = 'Item class not set'; + RSCollectionNotFound = 'No collection found for this type'; + RSDayConvertError = 'Error converting day'; + RSMonthConvertError = 'Error converting month'; + RSMonthNameConvertError = 'Error converting month name'; + RSYearConvertError = 'Error converting year'; + RSInvalidDay = 'Invalid day'; + RSInvalidMonth = 'Invalid month'; + RSInvalidMonthName = 'Invalid month name'; + RSInvalidYear = 'Invalid year'; + RSDayRequired = 'Day is required'; + RSMonthRequired = 'Month is required'; + RSYearRequired = 'Year is required'; + RSOwnerMustBeForm = 'Owner must be a TForm or descendant'; + RSTimeConvertError = 'Error converting time value'; + RSCancelQuery = 'Cancel and lose changes?'; + RSNoPagesAssigned = 'No notebook pages assigned'; + RSRestoreMI = '&Restore'; + RSCutMI = 'Cu&t'; + RSCopyMI = '&Copy'; + RSPasteMI = '&Paste'; + RSDeleteMI = '&Delete'; + RSSelectAllMI = 'Select &All'; + RSTableRowOutOfBounds = 'Table row out of bounds'; + RSTableMaxRows = 'Table max rows error'; + RSTableMaxColumns = 'Table max columns error'; + RSTableGeneral = 'Table general error'; + RSTableToManyColumns = 'Too many columns'; + RSTableInvalidFieldIndex = 'Invalid field index'; + RSTableHeaderNotAssigned = 'Header not assigned'; + RSTableInvalidHeaderCell = 'Invalid header cell'; + RSCalcBack = 'Back'; + RSCalcMC = 'MC'; + RSCalcMR = 'MR'; + RSCalcMS = 'MS'; + RSCalcMPlus = 'M+'; + RSCalcMMinus = 'M-'; + RSCalcCT = 'CT'; + RSCalcCE = 'CE'; + RSCalcC = 'C'; + RSCalcSqrt = 'Sqrt'; + RSCalNext = 'NEXT'; + RSCalLast = 'LAST'; + RSCalPrev = 'PREV'; + RSCalFirst = 'FIRST'; + RSCal1st = '1ST'; + RSCalSecond = 'SECOND'; + RSCal2nd = '2ND'; + RSCalThird = 'THIRD'; + RSCal3rd = '3RD'; + RSCalFourth = 'FOURTH'; + RSCal4th = '4TH'; + RSCalFinal = 'FINAL'; + RSCalBOM = 'BOM'; + RSCalBegin = 'BEGIN'; + RSCalEOM = 'EOM'; + RSCalEnd = 'END'; + RSCalYesterday = 'YESTERDAY'; + RSCalToday = 'TODAY'; + RSCalTomorrow = 'TOMORROW'; + RSEditingSections = 'Header Sections Editor'; + RSEditingItems = 'Folder Items Editor'; + RSEditingFolders = 'Folder Editor'; + RSEditingPages = 'Tab Pages Editor'; + RSEditingImages = 'Image List Editor'; + RSSectionBaseName = 'Section'; + RSItemBaseName = 'Item'; + RSFolderBaseName = 'Folder'; + RSPageBaseName = 'Page'; + RSImageBaseName = 'Image'; + RSHoursName = 'Hours'; + RSMinutesName = 'Minutes'; + RSSecondsName = 'Seconds'; + RSCloseCaption = 'Close'; + RSViewFieldNotFound = 'The view field %s was not found'; + RSCantResolveField = 'Unable to resolve view field %s'; + RSItemAlreadyExists = 'Can''t add item %p - it already exists in the index'; + RSAlreadyInTempMode = 'The view is already in temporary index mode'; + RSItemNotFound = 'Specified report view data item %p was not found'; + RSUpdatePending = 'This report view operation is invalid while updates are pending'; + RSOnCompareNotAssigned = 'OnCompareFields not assigned'; + RSOnFilterNotAssigned = 'OnFilter not assigned'; + RSGetAsFloatNotAssigned = 'GetAsFloat not assigned'; + RSNotInTempMode = 'Report view is not in temporary index mode'; + RSItemNotInIndex = 'The specified data item (%p) is not in the index'; + RSNoActiveView = 'No active view'; + RSItemIsNotGroup = 'Item at line %d is not a group'; + RSNotMultiSelect = 'This report view operation is only allowed when multiselect is enabled'; + RSLineNoOutOfRange = 'Invalid index %d'; + RSUnknownView = 'Unknown view: %s'; + RSOnKeySearchNotAssigned = 'The OnKeySearch event is not assigned'; + RSOnEnumNotAssigned = 'The OnEnum event is not assigned'; + RSOnEnumSelectedNA = 'OnEnumSelected not assigned'; + RSNoMenuAssigned = 'No menu item assigned'; + RSNoAnchorAssigned = 'No anchor item assigned'; + RSInvalidParameter = 'Invalid parameter: mpAnchor'; + RSInvalidOperation = 'Invalid operation: Call AddSplit for split menus'; + RSFormUseOnly = 'This component can only be used on forms'; + RSColorBlack = 'Black'; + RSColorMaroon = 'Maroon'; + RSColorGreen = 'Green'; + RSColorOlive = 'Olive'; + RSColorNavy = 'Navy'; + RSColorPurple = 'Purple'; + RSColorTeal = 'Teal'; + RSColorGray = 'Gray'; + RSColorSilver = 'Silver'; + RSColorRed = 'Red'; + RSColorLime = 'Lime'; + RSColorYellow = 'Yellow'; + RSColorBlue = 'Blue'; + RSColorFuchsia = 'Fuchsia'; + RSColorAqua = 'Aqua'; + RSColorWhite = 'White'; + RSColorLightGray = 'Light Gray'; + RSColorMediumGray = 'Medium Gray'; + RSColorDarkGray = 'Dark Gray'; + RSColorMoneyGreen = 'Money Green'; + RSColorSkyBlue = 'Sky Blue'; + RSColorCream = 'Cream'; + + {end - Index based resource strings} + + diff --git a/components/orpheus/o32sr.pas b/components/orpheus/o32sr.pas new file mode 100644 index 000000000..59ba68c90 --- /dev/null +++ b/components/orpheus/o32sr.pas @@ -0,0 +1,661 @@ +{*********************************************************} +{* O32SR.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +(* Replaces the old String Resource Manager from Orpheus versions 3.x and + below. The string resource is broken into 3 parts. + Part 1: The actual string resources contained in O32***RS.inc + (O32ENGRS.inc for English). (Translate these strings and define the + language below to create new language versions of Orpheus.) + Part 2: The index constants defined in OvcConst.pas. + Part 3: The cross reference array (SrMsgNumLookup) used to convert an + index into the corresponding string. + It is very important that the cross reference array be kept in numerical + order. The lookup is performed by a binary search and if any of the items + are out of order, the lookup will fail some or all strings. *) + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit o32sr; + {- Orpheus String Resources + Replaces the String Resource Manager from the olden days...} + +interface + +uses + ovcconst; + +{$I O32SR.inc} + +resourcestring + +{Orpheus Internal and Design-time resource strings...} + +{!!!! - These should not be translated as they are used internally - !!!!} +{!!!! - See O32SR.INC for the user visible resource strings - !!!!} + + {Navigation Commands} + ccNoneStr = 'ccNone'; + ccBackStr = 'ccBack'; + ccBotOfPageStr = 'ccBotOfPage'; + ccBotRightCellStr = 'ccBotRightCell'; + ccCompleteDateStr = 'ccCompleteDate'; + ccCompleteTimeStr = 'ccCompleteTime'; + ccCopyStr = 'ccCopy'; + ccCtrlCharStr = 'ccCtrlChar'; + ccCutStr = 'ccCut'; + ccDecStr = 'ccDec'; + ccDelStr = 'ccDel'; + ccDelBolStr = 'ccDelBol'; + ccDelEolStr = 'ccDelEol'; + ccDelLineStr = 'ccDelLine'; + ccDelWordStr = 'ccDelWord'; + ccDownStr = 'ccDown'; + ccEndStr = 'ccEnd'; + ccExtendDownStr = 'ccExtendDown'; + ccExtendEndStr = 'ccExtendEnd'; + ccExtendHomeStr = 'ccExtendHome'; + ccExtendLeftStr = 'ccExtendLeft'; + ccExtendPgDnStr = 'ccExtendPgDn'; + ccExtendPgUpStr = 'ccExtendPgUp'; + ccExtendRightStr = 'ccExtendRight'; + ccExtendUpStr = 'ccExtendUp'; + ccExtBotOfPageStr = 'ccExtBotOfPage'; + ccExtFirstPageStr = 'ccExtFirstPage'; + ccExtLastPageStr = 'ccExtLastPage'; + ccExtTopOfPageStr = 'ccExtTopOfPage'; + ccExtWordLeftStr = 'ccExtWordLeft'; + ccExtWordRightStr = 'ccExtWordRight'; + ccFirstPageStr = 'ccFirstPage'; + ccGotoMarker0Str = 'ccGotoMarker0'; + ccGotoMarker1Str = 'ccGotoMarker1'; + ccGotoMarker2Str = 'ccGotoMarker2'; + ccGotoMarker3Str = 'ccGotoMarker3'; + ccGotoMarker4Str = 'ccGotoMarker4'; + ccGotoMarker5Str = 'ccGotoMarker5'; + ccGotoMarker6Str = 'ccGotoMarker6'; + ccGotoMarker7Str = 'ccGotoMarker7'; + ccGotoMarker8Str = 'ccGotoMarker8'; + ccGotoMarker9Str = 'ccGotoMarker9'; + ccHomeStr = 'ccHome'; + ccIncStr = 'ccInc'; + ccInsStr = 'ccIns'; + ccLastPageStr = 'ccLastPage'; + ccLeftStr = 'ccLeft'; + ccNewLineStr = 'ccNewLine'; + ccNextPageStr = 'ccNextPage'; + ccPageLeftStr = 'ccPageLeft'; + ccPageRightStr = 'ccPageRight'; + ccPasteStr = 'ccPaste'; + ccPrevPageStr = 'ccPrevPage'; + ccRedoStr = 'ccRedo'; + ccRestoreStr = 'ccRestore'; + ccRightStr = 'ccRight'; + ccScrollDownStr = 'ccScrollDown'; + ccScrollUpStr = 'ccScrollUp'; + ccSetMarker0Str = 'ccSetMarker0'; + ccSetMarker1Str = 'ccSetMarker1'; + ccSetMarker2Str = 'ccSetMarker2'; + ccSetMarker3Str = 'ccSetMarker3'; + ccSetMarker4Str = 'ccSetMarker4'; + ccSetMarker5Str = 'ccSetMarker5'; + ccSetMarker6Str = 'ccSetMarker6'; + ccSetMarker7Str = 'ccSetMarker7'; + ccSetMarker8Str = 'ccSetMarker8'; + ccSetMarker9Str = 'ccSetMarker9'; + ccTabStr = 'ccTab'; + ccTableEditStr = 'ccTableEdit'; + ccTopLeftCellStr = 'ccTopLeftCell'; + ccTopOfPageStr = 'ccTopOfPage'; + ccUndoStr = 'ccUndo'; + ccUpStr = 'ccUp'; + ccWordLeftStr = 'ccWordLeft'; + ccWordRightStr = 'ccWordRight'; + + {DataType strings} + StringStr = 'String'; + CharStr = 'Char'; + BooleanStr = 'Boolean'; + YesNoStr = 'YesNo'; + LongIntStr = 'LongInt'; + WordStr = 'Word'; + SmallIntStr = 'SmallInt'; + ByteStr = 'Byte'; + ShortIntStr = 'ShortInt'; + RealStr = 'Real'; + ExtendedStr = 'Extended'; + DoubleStr = 'Double'; + SingleStr = 'Single'; + CompStr = 'Comp'; + DateStr = 'Date'; + TimeStr = 'Time'; + + {Sample masks for the EditField's property editors} + CharMask1Str = 'X any character'; + CharMask2Str = '! any char (upper)'; + CharMask3Str = 'L any char (lower)'; + CharMask4Str = 'x any char (mixed)'; + CharMask5Str = 'a alphas only'; + CharMask6Str = 'A alphas (upper)'; + CharMask7Str = 'l alphas (lower)'; + CharMask8Str = '9 0-9'; + CharMask9Str = 'i 0-9, -'; + CharMask10Str = '# 0-9, -, .'; + CharMask11Str = 'E 0-9, E, -, .'; + CharMask12Str = 'K 0-9, A-F (hex)'; + CharMask14Str = 'O 0-7 (octal)'; + CharMask15Str = 'b 0, 1 (binary)'; + CharMask16Str = 'B T or F (upper)'; + CharMask17Str = 'Y Y or N (upper)'; + CharMask18Str = '1 User 1'; + CharMask19Str = '2 User 2'; + CharMask20Str = '3 User 3'; + CharMask21Str = '4 User 4'; + CharMask22Str = '5 User 5'; + CharMask23Str = '6 User 6'; + CharMask24Str = '7 User 7'; + CharMask25Str = '8 User 8'; + + FieldMask1Str = '$##,###.## Allows entry of 0 through 9, space, minus, and period Uses floating currency symbol'; + FieldMask2Str = '9999999999 Allows entry of 0 through 9, and space'; + FieldMask3Str = 'iiiiiiiiii Allows entry of 0 through 9, space, and minus'; + FieldMask4Str = 'ii,iii,iii Allows entry of 0 through 9, space, and minus Displays number separators as needed'; + FieldMask5Str = '$iiiiiiiii Allows entry of 0 through 9, space, and minus Uses floating currency symbol'; + FieldMask6Str = '########## Allows entry of 0 through 9, space, minus, and period'; + FieldMask7Str = '#######.## Allows entry of 0 through 9, space, minus, and period Fixed decimal position'; + FieldMask8Str = '###,###.## Allows entry of 0 through 9, space, minus, and period Displays number separators as needed'; + FieldMask9Str = '$######.## Allows entry of 0 through 9, space, minus, and period Fixed decimal position Uses floating currency symbol'; + FieldMask10Str = '##########p Allows entry of 0 through 9, space, minus, and period Negative amounts use ()'; + FieldMask11Str = '###,###.##C Allows entry of 0 through 9, space, minus, and period Currency symbol at right'; + FieldMask12Str = 'KKKKKKKK Hexadecimal (E4401F3E) Allows entry of 0 through 9 and A through F Force upper case'; + FieldMask13Str = 'KKKK Hexadecimal (1F3E) Allows entry of 0 through 9 and A through F Force upper case'; + FieldMask14Str = 'KK Hexadecimal (3E) Allows entry of 0 through 9 and A through F Force upper case'; + FieldMask15Str = 'OOOOOOOO Octal (45135677) Allows entry of 0 through 7 '; + FieldMask16Str = 'OOOO Octal (5677) Allows entry of 0 through 7 '; + FieldMask17Str = 'bbbbbbbbbbbbbbbb Binary (0101001010010100) Allows entry of 0 and 1'; + FieldMask18Str = 'bbbbbbbb Binary (10010100) Allows entry of 0 and 1'; + FieldMask19Str = 'XXXXXXXXXX Any character can be entered'; + FieldMask20Str = '!!!!!!!!!! Any character can be entered Alphabetic characters are forced to upper case'; + FieldMask21Str = 'LLLLLLLLLL Any character can be entered Alphabetic characters are forced to lower case'; + FieldMask22Str = 'xxxxxxxxxx Any character can be entered Uses mixed case'; + FieldMask23Str = 'aaaaaaaaaa Alphabetic characters plus space, minus, period, and comma'; + FieldMask24Str = 'AAAAAAAAAA Alphabetic characters plus space, minus, period, and comma Alphabetic characters are forced to upper case'; + FieldMask25Str = 'llllllllll Alphabetic characters plus space, minus, period, and comma Alphabetic characters are forced to lower case'; + FieldMask26Str = '(999) 999-9999 Phone number mask Allows 0 through 9 and space'; + FieldMask27Str = '999-999-9999 Phone number mask Allows 0 through 9 and space'; + FieldMask28Str = '99999-9999 US Zip Code mask Allows 0 through 9 and space'; + FieldMask29Str = 'B Boolean mask Allows T, t, F, f Forces input to upper case'; + FieldMask30Str = 'Y Boolean mask Allows Y, y, N, n Forces input to upper case'; + FieldMask31Str = 'mm/dd/yy Date mask (01/05/96) Allows entry of 0 through 9 plus space Month and Day are padded with zeros'; + FieldMask32Str = 'mm/dd/yyyy Date mask (01/05/1996) Allows entry of 0 through 9 plus space Month and Day are padded with zeros'; + FieldMask33Str = 'dd nnn yyyy Date mask (05 Jan 1996) Allows entry of 0 through 9 plus space Day is padded with zeros'; + FieldMask34Str = 'MM/DD/yy Date mask ( 1/ 5/96) Allows entry of 0 through 9 plus space Month and Day are padded with spaces'; + FieldMask35Str = 'MM/DD/yyyy Date mask ( 1/ 5/1996) Allows entry of 0 through 9 plus space Month and Day are padded with spaces'; + FieldMask36Str = 'DD nnn yyyy Date mask ( 5 Jan 1996) Allows entry of 0 through 9 plus space Day is padded with spaces'; + FieldMask37Str = 'hh:mm Time mask (03:25) Allows entry of 0 through 9 plus space Hours and minutes are padded with zeros (24 hour clock)'; + FieldMask38Str = 'hh:mm tt Time mask (03:25 pm) Allows entry of 0 through 9 plus space Hours and minutes are padded with zeros'; + FieldMask39Str = 'hh:mm:ss Time mask (03:25:07) Allows entry of 0 through 9 plus space Hours, minutes, and seconds are padded with zeros'; + FieldMask40Str = 'HH:MM Time mask ( 3:25) Allows entry of 0 through 9 plus space Hours and minutes are padded with spaces (24 hour clock)'; + FieldMask41Str = 'HH:MM tt Time mask ( 3:25 pm) Allows entry of 0 through 9 plus space Hours and minutes are padded with spaces'; + FieldMask42Str = 'HH:MM:SS Time mask ( 3:25: 7) Allows entry of 0 through 9 plus space Hours, minutes, and seconds are padded with spaces'; + +const + {Change this when new strings are added.} + SrMaxMessages = 375; + +type + SrMsgNumLookupRec = record + MessageNum : integer; + MessageStr : string; + end; + +const + {Matches the index numbers to their associated Strings} + + {WARNING! When adding to or deleting from this array, make sure you keep the + items in ascending numerical order by the value of the MessageNum constants. + Otherwise, the Lookup will fail some or all strings...} + + SrMsgNumLookup : array [1..SrMaxMessages] of SrMsgNumLookupRec = + {External Resource String Mapping. External resource strings are contained in + O32SR.INC...} + ((MessageNum : SCUnknownError; MessageStr : RSUnknownError), + (MessageNum : SCDuplicateCommand; MessageStr : RSDuplicateCommand), + (MessageNum : SCTableNotFound; MessageStr : RSTableNotFound), + (MessageNum : SCNotDoneYet; MessageStr : RSNotDoneYet), + (MessageNum : SCNoControllerAssigned; MessageStr : RSNoControllerAssigned), + (MessageNum : SCCantCreateCommandTable; MessageStr : RSCantCreateCommandTable), + (MessageNum : SCCantDelete; MessageStr : RSCantDelete), + (MessageNum : SCInvalidKeySequence; MessageStr : RSInvalidKeySequence), + (MessageNum : SCNotWordStarCommands; MessageStr : RSNotWordStarCommands), + (MessageNum : SCNoCommandSelected; MessageStr : RSNoCommandSelected), + (MessageNum : SCDuplicateKeySequence; MessageStr : RSDuplicateKeySequence), + (MessageNum : SCRangeError; MessageStr : RSRangeError), + (MessageNum : SCInvalidNumber; MessageStr : RSInvalidNumber), + (MessageNum : SCRequiredField; MessageStr : RSRequiredField), + (MessageNum : SCInvalidDate; MessageStr : RSInvalidDate), + (MessageNum : SCInvalidTime; MessageStr : RSInvalidTime), + (MessageNum : SCBlanksInField; MessageStr : RSBlanksInField), + (MessageNum : SCPartialEntry; MessageStr : RSPartialEntry), + (MessageNum : SCRegionTooLarge; MessageStr : RSRegionTooLarge), + (MessageNum : SCOutOfMemoryForCopy; MessageStr : RSOutOfMemoryForCopy), + (MessageNum : SCInvalidParamValue; MessageStr : RSInvalidParamValue), + (MessageNum : SCNoTimersAvail; MessageStr : RSNoTimersAvail), + (MessageNum : SCTooManyEvents; MessageStr : RSTooManyEvents), + (MessageNum : SCBadTriggerHandle; MessageStr : RSBadTriggerHandle), + (MessageNum : SCOnSelectNotAssigned; MessageStr : RSOnSelectNotAssigned), + (MessageNum : SCInvalidPageIndex; MessageStr : RSInvalidPageIndex), + (MessageNum : SCInvalidDataType; MessageStr : RSInvalidDataType), + (MessageNum : SCInvalidTabFont; MessageStr : RSInvalidTabFont), + (MessageNum : SCInvalidLabelFont; MessageStr : RSInvalidLabelFont), + (MessageNum : SCOutOfMemory; MessageStr : RSOutOfMemory), + (MessageNum : SCTooManyParas; MessageStr : RSTooManyParas), + (MessageNum : SCCannotJoin; MessageStr : RSCannotJoin), + (MessageNum : SCTooManyBytes; MessageStr : RSTooManyBytes), + (MessageNum : SCParaTooLong; MessageStr : RSParaTooLong), + (MessageNum : SCInvalidPictureMask; MessageStr : RSInvalidPictureMask), + (MessageNum : SCInvalidRange; MessageStr : RSInvalidRange), + (MessageNum : SCInvalidRealRange; MessageStr : RSInvalidRealRange), + (MessageNum : SCInvalidExtendedRange; MessageStr : RSInvalidExtendedRange), + (MessageNum : SCInvalidDoubleRange; MessageStr : RSInvalidDoubleRange), + (MessageNum : SCInvalidSingleRange; MessageStr : RSInvalidSingleRange), + (MessageNum : SCInvalidCompRange; MessageStr : RSInvalidCompRange), + (MessageNum : SCInvalidDateRange; MessageStr : RSInvalidDateRange), + (MessageNum : SCInvalidTimeRange; MessageStr : RSInvalidTimeRange), + (MessageNum : SCInvalidRangeValue; MessageStr : RSInvalidRangeValue), + (MessageNum : SCRangeNotSupported; MessageStr : RSRangeNotSupported), + (MessageNum : SCInvalidLineOrParaIndex; MessageStr : RSInvalidLineOrParaIndex), + (MessageNum : SCNonFixedFont; MessageStr : RSNonFixedFont), + (MessageNum : SCInvalidFontParam; MessageStr : RSInvalidFontParam), + (MessageNum : SCInvalidLineOrColumn; MessageStr : RSInvalidLineOrColumn), + (MessageNum : SCSAEGeneral; MessageStr : RSSAEGeneral), + (MessageNum : SCSAEAtMaxSize; MessageStr : RSSAEAtMaxSize), + (MessageNum : SCInvalidXMLFile; MessageStr : RSInvalidXMLFile), + (MessageNum : SCUnterminatedElement; MessageStr : RSUnterminatedElement), + (MessageNum : SCBadColorConst; MessageStr : RSBadColorConstant), + (MessageNum : SCBadColorValue; MessageStr : RSBadColorValue), + (MessageNum : SCSAEOutOfBounds; MessageStr : RSSAEOutOfBounds), + (MessageNum : SCInvalidFieldType; MessageStr : RSInvalidFieldType), + (MessageNum : SCBadAlarmHandle; MessageStr : RSBadAlarmHandle), + (MessageNum : SCOnIsSelectedNotAssigned; MessageStr : RSOnIsSelectedNotAssigned), + (MessageNum : SCInvalidDateForMask; MessageStr : RSInvalidDateForMask), + (MessageNum : SCNoTableAttached; MessageStr : RSNoTableAttached), + (MessageNum : SCViewerIOError; MessageStr : RSViewerIOError), + (MessageNum : SCViewerFileNotFound; MessageStr : RSViewerFileNotFound), + (MessageNum : SCViewerPathNotFound; MessageStr : RSViewerPathNotFound), + (MessageNum : SCViewerTooManyOpenFiles; MessageStr : RSViewerTooManyOpenFiles), + (MessageNum : SCViewerFileAccessDenied; MessageStr : RSViewerFileAccessDenied), + (MessageNum : SCControlAttached; MessageStr : RSControlAttached), + (MessageNum : SCCantEdit; MessageStr : RSCantEdit), + (MessageNum : SCChildTableError; MessageStr : RSChildTableError), + (MessageNum : SCNoCollection; MessageStr : RSNoCollection), + (MessageNum : SCNotOvcDescendant; MessageStr : RSNotOvcDescendant), + (MessageNum : SCItemIncompatible; MessageStr : RSItemIncompatible), + (MessageNum : SCLabelNotAttached; MessageStr : RSLabelNotAttached), + (MessageNum : SCClassNotSet; MessageStr : RSClassNotSet), + (MessageNum : SCCollectionNotFound; MessageStr : RSCollectionNotFound), + (MessageNum : SCDayConvertError; MessageStr : RSDayConvertError), + (MessageNum : SCMonthConvertError; MessageStr : RSMonthConvertError), + (MessageNum : SCMonthNameConvertError; MessageStr : RSMonthNameConvertError), + (MessageNum : SCYearConvertError; MessageStr : RSYearConvertError), + (MessageNum : SCDayRequired; MessageStr : RSDayRequired), + (MessageNum : SCMonthRequired; MessageStr : RSMonthRequired), + (MessageNum : SCYearRequired; MessageStr : RSYearRequired), + (MessageNum : SCInvalidDay; MessageStr : RSInvalidDay), + (MessageNum : SCInvalidMonth; MessageStr : RSInvalidMonth), + (MessageNum : SCInvalidMonthName; MessageStr : RSInvalidMonthName), + (MessageNum : SCInvalidYear; MessageStr : RSInvalidYear), + (MessageNum : SCTableRowOutOfBounds; MessageStr : RSTableRowOutOfBounds), + (MessageNum : SCTableMaxRows; MessageStr : RSTableMaxRows), + (MessageNum : SCTableMaxColumns; MessageStr : RSTableMaxColumns), + (MessageNum : SCTableGeneral; MessageStr : RSTableGeneral), + (MessageNum : SCTableToManyColumns; MessageStr : RSTableToManyColumns), + (MessageNum : SCTableInvalidFieldIndex; MessageStr : RSTableInvalidFieldIndex), + (MessageNum : SCTableHeaderNotAssigned; MessageStr : RSTableHeaderNotAssigned), + (MessageNum : SCTableInvalidHeaderCell; MessageStr : RSTableInvalidHeaderCell), + (MessageNum : SCGridTableName; MessageStr : RSGridTableName), + (MessageNum : SCNoneStr; MessageStr : RSNoneStr), + (MessageNum : SCccUser; MessageStr : RSccUser), + (MessageNum : SCccUserNum; MessageStr : RSccUserNum), + (MessageNum : SCDeleteTable; MessageStr : RSDeleteTable), + (MessageNum : SCRenameTable; MessageStr : RSRenameTable), + (MessageNum : SCEnterTableName; MessageStr : RSEnterTableName), + (MessageNum : SCNewTable; MessageStr : RSNewTable), + (MessageNum : SCDefaultTableName; MessageStr : RSDefaultTableName), + (MessageNum : SCWordStarTableName; MessageStr : RSWordStarTableName ), + (MessageNum : SCUnknownTable; MessageStr : RSUnknownTable), + (MessageNum : SCDefaultEntryErrorText; MessageStr : RSDefaultEntryErrorText), + (MessageNum : SCGotItemWarning; MessageStr : RSGotItemWarning), + (MessageNum : SCSampleListItem; MessageStr : RSSampleListItem), + (MessageNum : SCAlphaString; MessageStr : RSAlphaString), + (MessageNum : SCTallLowChars; MessageStr : RSTallLowChars), + (MessageNum : SCDefault; MessageStr : RSDefault), + (MessageNum : SCDescending; MessageStr : RSDescending), + (MessageNum : SCDefaultIndex; MessageStr : RSDefaultIndex), + (MessageNum : SCRestoreMI; MessageStr : RSRestoreMI), + (MessageNum : SCCutMI; MessageStr : RSCutMI), + (MessageNum : SCCopyMI; MessageStr : RSCopyMI), + (MessageNum : SCPasteMI; MessageStr : RSPasteMI), + (MessageNum : SCDeleteMI; MessageStr : RSDeleteMI), + (MessageNum : SCSelectAllMI; MessageStr : RSSelectAllMI), + (MessageNum : SCCalcBack; MessageStr : RSCalcBack), + (MessageNum : SCCalcMC; MessageStr : RSCalcMC), + (MessageNum : SCCalcMR; MessageStr : RSCalcMR), + (MessageNum : SCCalcMS; MessageStr : RSCalcMS), + (MessageNum : SCCalcMPlus; MessageStr : RSCalcMPlus), + (MessageNum : SCCalcMMinus; MessageStr : RSCalcMMinus), + (MessageNum : SCCalcCT; MessageStr : RSCalcCT), + (MessageNum : SCCalcCE; MessageStr : RSCalcCE), + (MessageNum : SCCalcC; MessageStr : RSCalcC), + (MessageNum : SCCalcSqrt; MessageStr : RSCalcSqrt), + (MessageNum : SCCalNext; MessageStr : RSCalNext), + (MessageNum : SCCalLast; MessageStr : RSCalLast), + (MessageNum : SCCalFirst; MessageStr : RSCalFirst), + (MessageNum : SCCal1st; MessageStr : RSCal1st), + (MessageNum : SCCalSecond; MessageStr : RSCalSecond), + (MessageNum : SCCal2nd; MessageStr : RSCal2nd), + (MessageNum : SCCalThird; MessageStr : RSCalThird), + (MessageNum : SCCal3rd; MessageStr : RSCal3rd), + (MessageNum : SCCalFourth; MessageStr : RSCalFourth), + (MessageNum : SCCal4th; MessageStr : RSCal4th), + (MessageNum : SCCalFinal; MessageStr : RSCalFinal), + (MessageNum : SCCalBOM; MessageStr : RSCalBOM), + (MessageNum : SCCalEnd; MessageStr : RSCalEnd), + (MessageNum : SCCalEOM; MessageStr : RSCalEOM), + (MessageNum : SCCalYesterday; MessageStr : RSCalYesterday), + (MessageNum : SCCalToday; MessageStr : RSCalToday), + (MessageNum : SCCalTomorrow; MessageStr : RSCalTomorrow), + (MessageNum : SCEditingSections; MessageStr : RSEditingSections), + (MessageNum : SCEditingItems; MessageStr : RSEditingItems), + (MessageNum : SCEditingFolders; MessageStr : RSEditingFolders), + (MessageNum : SCEditingPages; MessageStr : RSEditingPages), + (MessageNum : SCEditingImages; MessageStr : RSEditingImages), + (MessageNum : SCSectionBaseName; MessageStr : RSSectionBaseName), + (MessageNum : SCItemBaseName; MessageStr : RSItemBaseName), + (MessageNum : SCFolderBaseName; MessageStr : RSFolderBaseName), + (MessageNum : SCPageBaseName; MessageStr : RSPageBaseName), + (MessageNum : SCImageBaseName; MessageStr : RSImageBaseName), + (MessageNum : SCOwnerMustBeForm; MessageStr : RSOwnerMustBeForm), + (MessageNum : SCTimeConvertError; MessageStr : RSTimeConvertError), + (MessageNum : SCCancelQuery; MessageStr : RSCancelQuery), + (MessageNum : SCNoPagesAssigned; MessageStr : RSNoPagesAssigned), + (MessageNum : SCCalPrev; MessageStr : RSCalPrev), + (MessageNum : SCCalBegin; MessageStr : RSCalBegin), + (MessageNum : SCInvalidMinMaxValue; MessageStr : RSInvalidMinMaxValue), + (MessageNum : SCFormUseOnly; MessageStr : RSFormUseOnly), + (MessageNum : SCYes; MessageStr : RSYes), + (MessageNum : SCNo; MessageStr : RSNo), + (MessageNum : SCTrue; MessageStr : RSTrue), + (MessageNum : SCFalse; MessageStr : RSFalse), + (MessageNum : SCHoursName; MessageStr : RSHoursName), + (MessageNum : SCMinutesName; MessageStr : RSMinutesName), + (MessageNum : SCSecondsName; MessageStr : RSSecondsName), + (MessageNum : SCCloseCaption; MessageStr : RSCloseCaption), + (MessageNum : SCViewFieldNotFound; MessageStr : RSViewFieldNotFound), + (MessageNum : SCCantResolveField; MessageStr : RSCantResolveField), + (MessageNum : SCItemAlreadyExists; MessageStr : RSItemAlreadyExists), + (MessageNum : SCAlreadyInTempMode; MessageStr : RSAlreadyInTempMode), + (MessageNum : SCItemNotFound; MessageStr : RSItemNotFound), + (MessageNum : SCUpdatePending; MessageStr : RSUpdatePending), + (MessageNum : SCOnCompareNotAssigned; MessageStr : RSOnCompareNotAssigned), + (MessageNum : SCOnFilterNotAssigned; MessageStr : RSOnFilterNotAssigned), + (MessageNum : SCGetAsFloatNotAssigned; MessageStr : RSGetAsFloatNotAssigned), + (MessageNum : SCNotInTempMode; MessageStr : RSNotInTempMode), + (MessageNum : SCItemNotInIndex; MessageStr : RSItemNotInIndex), + (MessageNum : SCNoActiveView; MessageStr : RSNoActiveView), + (MessageNum : SCItemIsNotGroup; MessageStr : RSItemIsNotGroup), + (MessageNum : SCNotMultiSelect; MessageStr : RSNotMultiSelect), + (MessageNum : SCLineNoOutOfRange; MessageStr : RSLineNoOutOfRange), + (MessageNum : SCUnknownView; MessageStr : RSUnknownView), + (MessageNum : SCOnKeySearchNotAssigned; MessageStr : RSOnKeySearchNotAssigned), + (MessageNum : SCOnEnumNotAssigned; MessageStr : RSOnEnumNotAssigned), + (MessageNum : SCOnEnumSelectedNA; MessageStr : RSOnEnumSelectedNA), + (MessageNum : SCNoMenuAssigned; MessageStr : RSNoMenuAssigned), + (MessageNum : SCNoAnchorAssigned; MessageStr : RSNoAnchorAssigned), + (MessageNum : SCInvalidParameter; MessageStr : RSInvalidParameter), + (MessageNum : SCInvalidOperation; MessageStr : RSInvalidOperation), + (MessageNum : SCColorBlack; MessageStr : RSColorBlack), + (MessageNum : SCColorMaroon; MessageStr : RSColorMaroon), + (MessageNum : SCColorGreen; MessageStr : RSColorGreen), + (MessageNum : SCColorOlive; MessageStr : RSColorOlive), + (MessageNum : SCColorNavy; MessageStr : RSColorNavy), + (MessageNum : SCColorPurple; MessageStr : RSColorPurple), + (MessageNum : SCColorTeal; MessageStr : RSColorTeal), + (MessageNum : SCColorGray; MessageStr : RSColorGray), + (MessageNum : SCColorSilver; MessageStr : RSColorSilver), + (MessageNum : SCColorRed; MessageStr : RSColorRed), + (MessageNum : SCColorLime; MessageStr : RSColorLime), + (MessageNum : SCColorYellow; MessageStr : RSColorYellow), + (MessageNum : SCColorBlue; MessageStr : RSColorBlue), + (MessageNum : SCColorFuchsia; MessageStr : RSColorFuchsia), + (MessageNum : SCColorAqua; MessageStr : RSColorAqua), + (MessageNum : SCColorWhite; MessageStr : RSColorWhite), + (MessageNum : SCColorLightGray; MessageStr : RSColorLightGray), + (MessageNum : SCColorMediumGray; MessageStr : RSColorMediumGray), + (MessageNum : SCColorDarkGray; MessageStr : RSColorDarkGray), + (MessageNum : SCColorMoneyGreen; MessageStr : RSColorMoneyGreen), + (MessageNum : SCColorSkyBlue; MessageStr : RSColorSkyBlue), + (MessageNum : SCColorCream; MessageStr : RSColorCream), + + {End - Resource String Mapping...} + + {Internal Strings} + (MessageNum : IccNone; MessageStr : ccNoneStr), + (MessageNum : IccBack; MessageStr : ccBackStr), + (MessageNum : IccBotOfPage; MessageStr : ccBotOfPageStr), + (MessageNum : IccBotRightCell; MessageStr : ccBotRightCellStr), + (MessageNum : IccCompleteDate; MessageStr : ccCompleteDateStr), + (MessageNum : IccCompleteTime; MessageStr : ccCompleteTimeStr), + (MessageNum : IccCopy; MessageStr : ccCopyStr), + (MessageNum : IccCtrlChar; MessageStr : ccCtrlCharStr), + (MessageNum : IccCut; MessageStr : ccCutStr), + (MessageNum : IccDec; MessageStr : ccDecStr), + (MessageNum : IccDel; MessageStr : ccDelStr), + (MessageNum : IccDelBol; MessageStr : ccDelBolStr), + (MessageNum : IccDelEol; MessageStr : ccDelEolStr), + (MessageNum : IccDelLine; MessageStr : ccDelLineStr), + (MessageNum : IccDelWord; MessageStr : ccDelWordStr), + (MessageNum : IccDown; MessageStr : ccDownStr), + (MessageNum : IccEnd; MessageStr : ccEndStr), + (MessageNum : IccExtendDown; MessageStr : ccExtendDownStr), + (MessageNum : IccExtendEnd; MessageStr : ccExtendEndStr), + (MessageNum : IccExtendHome; MessageStr : ccExtendHomeStr), + (MessageNum : IccExtendLeft; MessageStr : ccExtendLeftStr), + (MessageNum : IccExtendPgDn; MessageStr : ccExtendPgDnStr), + (MessageNum : IccExtendPgUp; MessageStr : ccExtendPgUpStr), + (MessageNum : IccExtendRight; MessageStr : ccExtendRightStr), + (MessageNum : IccExtendUp; MessageStr : ccExtendUpStr), + (MessageNum : IccExtBotOfPage; MessageStr : ccExtBotOfPageStr), + (MessageNum : IccExtFirstPage; MessageStr : ccExtFirstPageStr), + (MessageNum : IccExtLastPage; MessageStr : ccExtLastPageStr), + (MessageNum : IccExtTopOfPage; MessageStr : ccExtTopOfPageStr), + (MessageNum : IccExtWordLeft; MessageStr : ccExtWordLeftStr), + (MessageNum : IccExtWordRight; MessageStr : ccExtWordRightStr), + (MessageNum : IccFirstPage; MessageStr : ccFirstPageStr), + (MessageNum : IccGotoMarker0; MessageStr : ccGotoMarker0Str), + (MessageNum : IccGotoMarker1; MessageStr : ccGotoMarker1Str), + (MessageNum : IccGotoMarker2; MessageStr : ccGotoMarker2Str), + (MessageNum : IccGotoMarker3; MessageStr : ccGotoMarker3Str), + (MessageNum : IccGotoMarker4; MessageStr : ccGotoMarker4Str), + (MessageNum : IccGotoMarker5; MessageStr : ccGotoMarker5Str), + (MessageNum : IccGotoMarker6; MessageStr : ccGotoMarker6Str), + (MessageNum : IccGotoMarker7; MessageStr : ccGotoMarker7Str), + (MessageNum : IccGotoMarker8; MessageStr : ccGotoMarker8Str), + (MessageNum : IccGotoMarker9; MessageStr : ccGotoMarker9Str), + (MessageNum : IccHome; MessageStr : ccHomeStr), + (MessageNum : IccInc; MessageStr : ccIncStr), + (MessageNum : IccIns; MessageStr : ccInsStr), + (MessageNum : IccLastPage; MessageStr : ccLastPageStr), + (MessageNum : IccLeft; MessageStr : ccLeftStr), + (MessageNum : IccNewLine; MessageStr : ccNewLineStr), + (MessageNum : IccNextPage; MessageStr : ccNextPageStr), + (MessageNum : IccPageLeft; MessageStr : ccPageLeftStr), + (MessageNum : IccPageRight; MessageStr : ccPageRightStr), + (MessageNum : IccPaste; MessageStr : ccPasteStr), + (MessageNum : IccPrevPage; MessageStr : ccPrevPageStr), + (MessageNum : IccRedo; MessageStr : ccRedoStr), + (MessageNum : IccRestore; MessageStr : ccRestoreStr), + (MessageNum : IccRight; MessageStr : ccRightStr), + (MessageNum : IccScrollDown; MessageStr : ccScrollDownStr), + (MessageNum : IccScrollUp; MessageStr : ccScrollUpStr), + (MessageNum : IccSetMarker0; MessageStr : ccSetMarker0Str), + (MessageNum : IccSetMarker1; MessageStr : ccSetMarker1Str), + (MessageNum : IccSetMarker2; MessageStr : ccSetMarker2Str), + (MessageNum : IccSetMarker3; MessageStr : ccSetMarker3Str), + (MessageNum : IccSetMarker4; MessageStr : ccSetMarker4Str), + (MessageNum : IccSetMarker5; MessageStr : ccSetMarker5Str), + (MessageNum : IccSetMarker6; MessageStr : ccSetMarker6Str), + (MessageNum : IccSetMarker7; MessageStr : ccSetMarker7Str), + (MessageNum : IccSetMarker8; MessageStr : ccSetMarker8Str), + (MessageNum : IccSetMarker9; MessageStr : ccSetMarker9Str), + (MessageNum : IccTab; MessageStr : ccTabStr), + (MessageNum : IccTableEdit; MessageStr : ccTableEditStr), + (MessageNum : IccTopLeftCell; MessageStr : ccTopLeftCellStr), + (MessageNum : IccTopOfPage; MessageStr : ccTopOfPageStr), + (MessageNum : IccUndo; MessageStr : ccUndoStr), + (MessageNum : IccUp; MessageStr : ccUpStr), + (MessageNum : IccWordLeft; MessageStr : ccWordLeftStr), + (MessageNum : IccWordRight; MessageStr : ccWordRightStr), + (MessageNum : IString; MessageStr : StringStr), + (MessageNum : IChar; MessageStr : CharStr), + (MessageNum : IBoolean; MessageStr : BooleanStr), + (MessageNum : IYesNo; MessageStr : YesNoStr), + (MessageNum : ILongInt; MessageStr : LongIntStr), + (MessageNum : IWord; MessageStr : WordStr), + (MessageNum : ISmallInt; MessageStr : SmallIntStr), + (MessageNum : IByte; MessageStr : ByteStr), + (MessageNum : IShortInt; MessageStr : ShortIntStr), + (MessageNum : IReal; MessageStr : RealStr), + (MessageNum : IExtended; MessageStr : ExtendedStr), + (MessageNum : IDouble; MessageStr : DoubleStr), + (MessageNum : ISingle; MessageStr : SingleStr), + (MessageNum : IComp; MessageStr : CompStr), + (MessageNum : IDate; MessageStr : DateStr), + (MessageNum : ITime; MessageStr : TimeStr), + (MessageNum : ICharMask1; MessageStr : CharMask1Str), + (MessageNum : ICharMask2; MessageStr : CharMask2Str), + (MessageNum : ICharMask3; MessageStr : CharMask3Str), + (MessageNum : ICharMask4; MessageStr : CharMask4Str), + (MessageNum : ICharMask5; MessageStr : CharMask5Str), + (MessageNum : ICharMask6; MessageStr : CharMask6Str), + (MessageNum : ICharMask7; MessageStr : CharMask7Str), + (MessageNum : ICharMask8; MessageStr : CharMask8Str), + (MessageNum : ICharMask9; MessageStr : CharMask9Str), + (MessageNum : ICharMask10; MessageStr : CharMask10Str), + (MessageNum : ICharMask11; MessageStr : CharMask11Str), + (MessageNum : ICharMask12; MessageStr : CharMask12Str), + (MessageNum : ICharMask13; MessageStr : CharMask14Str), + (MessageNum : ICharMask14; MessageStr : CharMask15Str), + (MessageNum : ICharMask15; MessageStr : CharMask16Str), + (MessageNum : ICharMask16; MessageStr : CharMask17Str), + (MessageNum : ICharMask17; MessageStr : CharMask18Str), + (MessageNum : ICharMask18; MessageStr : CharMask19Str), + (MessageNum : ICharMask19; MessageStr : CharMask20Str), + (MessageNum : ICharMask20; MessageStr : CharMask21Str), + (MessageNum : ICharMask21; MessageStr : CharMask22Str), + (MessageNum : ICharMask22; MessageStr : CharMask23Str), + (MessageNum : ICharMask23; MessageStr : CharMask24Str), + (MessageNum : ICharMask24; MessageStr : CharMask25Str), + (MessageNum : IFieldMask1; MessageStr : FieldMask1Str), + (MessageNum : IFieldMask2; MessageStr : FieldMask2Str), + (MessageNum : IFieldMask3; MessageStr : FieldMask3Str), + (MessageNum : IFieldMask4; MessageStr : FieldMask4Str), + (MessageNum : IFieldMask5; MessageStr : FieldMask5Str), + (MessageNum : IFieldMask6; MessageStr : FieldMask6Str), + (MessageNum : IFieldMask7; MessageStr : FieldMask7Str), + (MessageNum : IFieldMask8; MessageStr : FieldMask8Str), + (MessageNum : IFieldMask9; MessageStr : FieldMask9Str), + (MessageNum : IFieldMask10; MessageStr : FieldMask10Str), + (MessageNum : IFieldMask11; MessageStr : FieldMask11Str), + (MessageNum : IFieldMask12; MessageStr : FieldMask12Str), + (MessageNum : IFieldMask13; MessageStr : FieldMask13Str), + (MessageNum : IFieldMask14; MessageStr : FieldMask14Str), + (MessageNum : IFieldMask15; MessageStr : FieldMask15Str), + (MessageNum : IFieldMask16; MessageStr : FieldMask16Str), + (MessageNum : IFieldMask17; MessageStr : FieldMask17Str), + (MessageNum : IFieldMask18; MessageStr : FieldMask18Str), + (MessageNum : IFieldMask19; MessageStr : FieldMask19Str), + (MessageNum : IFieldMask20; MessageStr : FieldMask20Str), + (MessageNum : IFieldMask21; MessageStr : FieldMask21Str), + (MessageNum : IFieldMask22; MessageStr : FieldMask22Str), + (MessageNum : IFieldMask23; MessageStr : FieldMask23Str), + (MessageNum : IFieldMask24; MessageStr : FieldMask24Str), + (MessageNum : IFieldMask25; MessageStr : FieldMask25Str), + (MessageNum : IFieldMask26; MessageStr : FieldMask26Str), + (MessageNum : IFieldMask27; MessageStr : FieldMask27Str), + (MessageNum : IFieldMask28; MessageStr : FieldMask28Str), + (MessageNum : IFieldMask29; MessageStr : FieldMask29Str), + (MessageNum : IFieldMask30; MessageStr : FieldMask30Str), + (MessageNum : IFieldMask31; MessageStr : FieldMask31Str), + (MessageNum : IFieldMask32; MessageStr : FieldMask32Str), + (MessageNum : IFieldMask33; MessageStr : FieldMask33Str), + (MessageNum : IFieldMask34; MessageStr : FieldMask34Str), + (MessageNum : IFieldMask35; MessageStr : FieldMask35Str), + (MessageNum : IFieldMask36; MessageStr : FieldMask36Str), + (MessageNum : IFieldMask37; MessageStr : FieldMask37Str), + (MessageNum : IFieldMask38; MessageStr : FieldMask38Str), + (MessageNum : IFieldMask39; MessageStr : FieldMask39Str), + (MessageNum : IFieldMask40; MessageStr : FieldMask40Str), + (MessageNum : IFieldMask41; MessageStr : FieldMask41Str), + (MessageNum : IFieldMask42; MessageStr : FieldMask42Str)); + + {End - Internal Strings...} + +function ResourceStrByNumber(Num: Word): String; + +implementation + +function ResourceStrByNumber(Num: Word): String; +{Implements a simple binary search through the SrMsgNumLookup array. + Returns an empty string is a match isn't found.} +var + Mid, Min, Max : integer; +begin + result := ''; + Min := 0; + Max := SrMaxMessages; + while (Min <= Max) do begin + Mid := (Min + Max) div 2; + if SrMsgNumLookup[Mid].MessageNum = Num then begin + result := SrMsgNumLookup[Mid].MessageStr; + exit; + end else begin + if Num < SrMsgNumLookup[Mid].MessageNum + then Max := Mid - 1 + else Min := Mid + 1; + end; + end; +end; + +end. diff --git a/components/orpheus/o32tcflx.pas b/components/orpheus/o32tcflx.pas new file mode 100644 index 000000000..fbe39fcea --- /dev/null +++ b/components/orpheus/o32tcflx.pas @@ -0,0 +1,708 @@ +{*********************************************************} +{* OVCTCFLX.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit o32tcflx; + {Orpheus Table Cell version of the FlexEdit} + +interface + +uses + {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, Types, LclType, MyMisc, {$ENDIF} + SysUtils, Graphics, Classes, Controls, Forms, StdCtrls, + Menus, OvcTCmmn, OvcTCell, + OvcTCStr, O32FlxEd, O32bordr, OvcEf, OvcCmd, O32VlOp1, O32Vldtr; + +type + + { Event for the TCFlexEdit User Validation } + TTCFEUserValidationEvent = + procedure(Sender : TObject; Value: string; + var ValidEntry : Boolean) of object; + + + {Class for storing the validation properties. These properties will be + loaded dynamically when the editor is created.} + TO32TCValidatorOptions = class(TPersistent) + protected {private} + FValidationType : TValidationType; + FValidatorType : String; + FValidatorClass : TValidatorClass; + FMask : String; + FLastValid : Boolean; + FLastErrorCode : Word; + FBeepOnError : Boolean; + FInputRequired : Boolean; + + procedure SetValidatorType(const VType: String); + procedure AssignValidator; + public + constructor Create; dynamic; + property LastValid: Boolean + read FLastValid write FLastValid; + property LastErrorCode: Word + read FLastErrorCode write FLastErrorCode; + + { - Moved from published} + property ValidatorClass: TValidatorClass + read FValidatorClass write FValidatorClass stored true; + published + property BeepOnError: Boolean + read FBeepOnError write FBeepOnError stored true; + property InputRequired: Boolean + read FInputRequired write FInputRequired stored true; + property ValidatorType : string + read FValidatorType write SetValidatorType stored true; + property ValidationType: TValidationType + read FValidationType write FValidationType stored true; + property Mask: String + read FMask write FMask stored true; + end; + + + TO32TCFlexEditEditor = class(TO32CustomFlexEdit) + protected {private} + FCell : TOvcBaseTableCell; + procedure WMChar(var Msg : TWMKey); message WM_CHAR; +{$IFNDEF LCL} + procedure WMGetDlgCode(var Msg : TMessage); message WM_GETDLGCODE; +{$ELSE} + procedure WMGetDlgCode(var Msg : TWMGetDlgCode); message WM_GETDLGCODE; +{$ENDIF} + procedure WMKeyDown(var Msg : TWMKey); message WM_KEYDOWN; + procedure WMKillFocus(var Msg : TWMKillFocus); message WM_KILLFOCUS; + procedure WMSetFocus(var Msg : TWMSetFocus); message WM_SETFOCUS; + + function ValidateSelf: Boolean; override; + +// TurboPower bug? CellOwner property wasn't published. + published //Added + property CellOwner : TOvcBaseTableCell read FCell write FCell; //Moved to here + end; + + TO32TCBorderProperties = class(TPersistent) + protected {private} + FActive : Boolean; + FFlatColor : TColor; + FBorderStyle : TO32BorderStyle; + public + constructor Create; virtual; + published + property Active: Boolean read FActive write FActive; + property FlatColor: TColor read FFlatColor write FFlatColor; + property BorderStyle: TO32BorderStyle read FBorderStyle write FBorderStyle; + end; + + TO32TCEditorProperties = class(TPersistent) + protected + FAlignment : TAlignment; + FBorders : TO32Borders; + FButtonGlyph : TBitmap; + FColor : TColor; + FCursor : TCursor; + FMaxLines : Integer; + FShowButton : Boolean; + FPasswordChar : Char; + FReadOnly : Boolean; + procedure SetButtonGlyph(Value :TBitmap); + function GetButtonGlyph :TBitmap; + public + constructor Create; virtual; + destructor Destroy; override; + + property Borders: TO32Borders read FBorders write FBorders; + + published + {$IFDEF VERSION4} + property Alignment: TAlignment read FAlignment write FAlignment; + {$ENDIF} + property ButtonGlyph: TBitmap + read GetButtonGlyph write SetButtonGlyph; + + property Color: TColor Read FColor write FColor; + property Cursor: TCursor read FCursor write FCursor; + property MaxLines: Integer read FMaxLines write FMaxLines; + property PasswordChar: Char read FPasswordChar write FPasswordChar; + property ReadOnly: Boolean Read FReadOnly write FReadOnly; + property ShowButton: Boolean read FShowButton write FShowButton; + end; + + TO32TCCustomFlexEdit = class(TOvcTCBaseString) + protected {private} + FBorderProps : TO32TCBorderProperties; + FEdit : TO32TCFlexEditEditor; + FEditorOptions : TO32TCEditorProperties; + FMaxLength : word; + FValidation : TO32TCValidatorOptions; + FWantReturns : Boolean; + FWantTabs : Boolean; + FWordWrap : Boolean; + + FOnError : TValidationErrorEvent; + FOnUserCommand : TUserCommandEvent; + FOnUserValidation : TTCFEUserValidationEvent; + + FOnButtonClick : TO32feButtonClickEvent; + + protected + function GetCellEditor : TControl; override; + function GetModified : boolean; + + property MaxLength : word + read FMaxLength write FMaxLength stored true; + property WantReturns : boolean + read FWantReturns write FWantReturns stored true; + property WantTabs : boolean + read FWantTabs write FWantTabs stored true; + property WordWrap: Boolean + read FWordWrap write FWordWrap stored true; + property EditorBorders: TO32TCBorderProperties + read FBorderProps write FBorderProps; + property OnButtonClick: TO32feButtonClickEvent + read FOnButtonClick write FOnButtonClick; + property Validation: TO32TCValidatorOptions + read FValidation write FValidation; + public + constructor Create(AOwner : TComponent); override; + destructor Destroy; override; + function CreateEditControl(AOwner : TComponent) : TO32TCFlexEditEditor; virtual; + function EditHandle : THandle; override; + procedure EditHide; override; + procedure EditMove(CellRect : TRect); override; + + function CanSaveEditedData(SaveValue : boolean) : boolean; override; + procedure SaveEditedData(Data : pointer); override; + function ValidateEntry: Boolean; + procedure StartEditing(RowNum : TRowNum; ColNum : TColNum; + CellRect : TRect; + const CellAttr : TOvcCellAttributes; + CellStyle: TOvcTblEditorStyle; + Data : pointer); override; + procedure StopEditing(SaveValue : boolean; + Data : pointer); override; + property Modified : boolean + read GetModified; + property EditorOptions: TO32TCEditorProperties + read FEditorOptions write FEditorOptions; + property OnUserValidation: TTCFEUserValidationEvent + read FOnUserValidation write FOnUserValidation; + end; + + TO32TCFlexEdit = class(TO32TCCustomFlexEdit) + published + {properties inherited from custom ancestor} + property Access default otxDefault; + property Adjust default otaDefault; + property EditorBorders; + property Color; + property EditorOptions; + property Font; + property Hint; + property Margin default 4; + property MaxLength default 255; + property ShowHint default False; + property Table; + property TableColor default True; + property TableFont default True; + property TextHiColor default clBtnHighlight; + property TextStyle default tsFlat; + property Validation; + property WantReturns default False; + property WantTabs default False; + property WordWrap default False; + {events inherited from custom ancestor} + property OnButtonClick; + property OnChange; + property OnClick; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnOwnerDraw; + property OnUserValidation; + end; + +implementation + +{===== TO32TCValidatorOptions ========================================} + +constructor TO32TCValidatorOptions.Create; +begin + inherited Create; + FValidationType := vtNone; + FValidatorType := 'None'; + FValidatorClass := nil; + FMask := ''; + FLastValid := false; + FLastErrorCode := 0; + FBeepOnError := true; + FInputRequired := false; +end; + +procedure TO32TCValidatorOptions.AssignValidator; +begin + if (FValidatorType = 'None') or (FValidatorType = '')then + FValidatorClass := nil + else try + FValidatorClass := TValidatorClass(FindClass(FValidatorType)); + except + FValidatorClass := nil; + end; +end; +{=====} + +procedure TO32TCValidatorOptions.SetValidatorType(const VType: String); +begin + if FValidatorType <> VType then begin + FValidatorType := VType; + AssignValidator; + end; +end; + + +{===== TO32TCFlexEditEditor ==========================================} + +procedure TO32TCFlexEditEditor.WMChar(var Msg : TWMKey); +begin + if (not CellOwner.TableWantsTab) or (Msg.CharCode <> 9) then + inherited; +end; +{=====} + +{$IFNDEF LCL} +procedure TO32TCFlexEditEditor.WMGetDlgCode(var Msg : TMessage); +{$ELSE} +procedure TO32TCFlexEditEditor.WMGetDlgCode(var Msg : TWMGetDlgCode); +{$ENDIF} +begin + inherited; + if CellOwner.TableWantsTab then + Msg.Result := Msg.Result or DLGC_WANTTAB; +end; +{=====} + +procedure TO32TCFlexEditEditor.WMKeyDown(var Msg : TWMKey); + {Local Method} + procedure GetSelection(var S, E : word); + type + LH = packed record L, H : word; end; + var + GetSel : longint; + begin + GetSel := SendMessage(Handle, EM_GETSEL, 0, 0); + S := LH(GetSel).L; + E := LH(GetSel).H; + end; +var + GridReply : TOvcTblKeyNeeds; + GridUsedIt : boolean; + SStart, SEnd : word; +begin + GridUsedIt := false; + GridReply := otkDontCare; + if (CellOwner <> nil) then + GridReply := CellOwner.FilterTableKey(Msg); + case GridReply of + otkMustHave : + begin + CellOwner.SendKeyToTable(Msg); + GridUsedIt := true; + end; + otkWouldLike : + case Msg.CharCode of + VK_RETURN : + if not WantReturns then + begin + CellOwner.SendKeyToTable(Msg); + GridUsedIt := true; + end; + VK_LEFT : + begin + GetSelection(SStart, SEnd); + if (SStart = SEnd) and (SStart = 0) then + begin + CellOwner.SendKeyToTable(Msg); + GridUsedIt := true; + end; + end; + VK_RIGHT : + begin + GetSelection(SStart, SEnd); + if ((SStart = SEnd) or (SStart = 0)) and (SEnd = GetTextLen) then + begin + CellOwner.SendKeyToTable(Msg); + GridUsedIt := true; + end; + end; + VK_UP, VK_DOWN, VK_PRIOR, VK_NEXT : //TurboPower bug? left out this case + begin + CellOwner.SendKeyToTable(Msg); + GridUsedIt := true; + end; + end; + end;{case} + + if not GridUsedIt then + inherited; +end; +{=====} + +procedure TO32TCFlexEditEditor.WMKillFocus(var Msg : TWMKillFocus); +begin +{$IFNDEF LCL} + inherited; +{$ELSE} + inherited WMKillFocus(Msg); +{$ENDIF} + +// Apparent TurboPower bug: change of focus with tab or mouse doesn't +// trigger validation, so do it here and don't change focus if invalid. + if not TO32TCCustomFlexEdit(CellOwner).ValidateEntry then //These lines added + begin +{$IFNDEF LCL} + SetFocus; +{$ENDIF} + Exit; + end; + + CellOwner.PostMessageToTable(ctim_KillFocus, Msg.FocusedWnd, 0); +end; +{=====} + +procedure TO32TCFlexEditEditor.WMSetFocus(var Msg : TWMSetFocus); +begin +{$IFNDEF LCL} + inherited; +{$ELSE} + inherited WMSetFocus(Msg); +{$ENDIF} + CellOwner.PostMessageToTable(ctim_SetFocus, Msg.FocusedWnd, 0); +end; +{=====} + +function TO32TCFlexEditEditor.ValidateSelf; +begin + result := inherited ValidateSelf; +end; + +{===== TO32TCBorderProperties ========================================} +constructor TO32TCBorderProperties.Create; +begin + inherited; + FActive := False; + FFlatColor := clBlack; + FBorderStyle := bstyRaised; +end; + +{===== TO32TCEditorProperties ========================================} +constructor TO32TCEditorProperties.Create; +begin + inherited Create; + FAlignment := taLeftJustify; + FButtonGlyph := TBitmap.Create; + FColor := clWindow; + FCursor := crDefault; + FMaxLines := 3; + FShowButton := false; +// TurboPower bug: No default efoPasswordMode=False like TOvcTCSimpleField, +// so '*' means TO32TCFlexEdit would be in password mode by default. +// FPasswordChar := '*'; + FPasswordChar := #0; //Fixed + FReadOnly := false; +end; +{=====} + +destructor TO32TCEditorProperties.Destroy; +begin + FButtonGlyph.Free; + inherited Destroy; +end; +{=====} + +{ - begin} +procedure TO32TCEditorProperties.SetButtonGlyph(Value :TBitmap); +begin + FButtonGlyph.Assign(Value); +end; +{=====} + +function TO32TCEditorProperties.GetButtonGlyph :TBitmap; +begin + Result := FButtonGlyph; +end; +{=====} +{ - end} + +{===== TO32TCCustomFlexEdit ==========================================} +constructor TO32TCCustomFlexEdit.Create(AOwner : TComponent); +begin + inherited Create(AOwner); + UseASCIIZStrings := true; + UseWordWrap := true; + FEditorOptions := TO32TCEditorProperties.Create; + FBorderProps := TO32TCBorderProperties.Create; + FValidation := TO32TCValidatorOptions.Create; + MaxLength := 255; +end; +{=====} + +destructor TO32TCCustomFlexEdit.Destroy; +begin + FEditorOptions.Free; + FBorderProps.Free; + FValidation.Free; + inherited; +end; +{=====} + +function TO32TCCustomFlexEdit.GetCellEditor : TControl; +begin + Result := FEdit; + FEditorOptions.Free; +end; +{=====} + +function TO32TCCustomFlexEdit.GetModified : boolean; +begin + if Assigned(FEdit) then + Result := FEdit.Modified + else + Result := false; +end ; +{=====} + +function TO32TCCustomFlexEdit.CreateEditControl(AOwner : TComponent): + TO32TCFlexEditEditor; +begin + Result := TO32TCFlexEditEditor.Create(AOwner); +end; +{=====} + +function TO32TCCustomFlexEdit.EditHandle : THandle; +begin + if Assigned(FEdit) then + Result := FEdit.Handle + else + Result := 0; +end; +{=====} + +procedure TO32TCCustomFlexEdit.EditHide; +begin + if Assigned(FEdit) then +// with FEdit do + SetWindowPos(FEdit.Handle, HWND_TOP, 0, 0, 0, 0, SWP_HIDEWINDOW + or SWP_NOREDRAW or SWP_NOZORDER); +end; +{=====} + +procedure TO32TCCustomFlexEdit.EditMove(CellRect : TRect); +begin + if Assigned(FEdit) then + begin + with CellRect do + SetWindowPos(FEdit.Handle, HWND_TOP, + Left, Top, Right-Left, Bottom-Top, + SWP_SHOWWINDOW or SWP_NOREDRAW or SWP_NOZORDER); + InvalidateRect(FEdit.Handle, nil, false); + UpdateWindow(FEdit.Handle); + end; +end; +{=====} + +function TO32TCCustomFlexEdit.CanSaveEditedData(SaveValue : boolean) : boolean; +begin + Result := true; + if Validation.InputRequired and (FEdit.Text = '') then begin + result := false; + FEdit.Restore; + end + + else if (Validation.FValidationType <> vtNone) then + if Assigned(FEdit) then + if SaveValue then + Result := ValidateEntry + else begin + FEdit.Restore; + result := false; + end; +end; +{=====} + +function TO32TCCustomFlexEdit.ValidateEntry: Boolean; +begin + if Assigned(FOnUserValidation) then begin + FOnUserValidation(FEdit, FEdit.Text, result); +// if Validation.BeepOnError then MessageBeep(0); <== TurboPower bug? not checking result + if (not result) and Validation.BeepOnError then MessageBeep(0); //Fixed + exit; + end; + + result := FEdit.ValidateSelf; + Validation.LastValid := FEdit.Validation.LastValid; + Validation.LastErrorCode := FEdit.Validation.LastErrorCode; +end; + +procedure TO32TCCustomFlexEdit.SaveEditedData(Data : pointer); +begin + {Abstract method does nothing. + It is stubbed out so that BCB doesn't think this as an abstract class} +end; +{=====} + +procedure TO32TCCustomFlexEdit.StartEditing(RowNum : TRowNum; ColNum : TColNum; + CellRect : TRect; + const CellAttr : TOvcCellAttributes; + CellStyle: TOvcTblEditorStyle; + Data : pointer); +{var + Str: String;} +begin + FEdit := TO32TCFlexEditEditor.Create(FTable); + + FEdit.Validation.EnableHooking := false; + FEdit.Validation.InputRequired := Validation.InputRequired; + FEdit.Validation.ValidationType := Validation.ValidationType; + FEdit.Validation.ValidatorType := Validation.ValidatorType; + FEdit.Validation.ValidatorClass := Validation.ValidatorClass; + FEdit.Validation.Mask := Validation.Mask; + FEdit.Validation.BeepOnError := Validation.BeepOnError; + FEdit.Validation.InputRequired := Validation.InputRequired; + FEdit.Validation.ValidationEvent := veOnExit; + + + FEdit.ShowButton := FEditorOptions.ShowButton; + if FEdit.ShowButton then begin + FEdit.ButtonGlyph := FEditorOptions.ButtonGlyph; + if Assigned(OnButtonClick) then + FEdit.OnButtonClick := OnButtonClick; + end; + + with FEdit do begin + Parent := FTable; + + Borders.Active := FBorderProps.FActive; + + if Borders.Active then begin + Borders.BorderStyle := FBorderProps.FBorderStyle; + Borders.FlatColor := FBorderProps.FFlatColor; + BorderStyle := bsSingle; + Ctl3D := true; + end else begin + BorderStyle := bsNone; + Ctl3D := false; + case CellStyle of + tesBorder : BorderStyle := bsSingle; + tes3D : Ctl3D := true; + end;{case} + end; + + Color := FEditorOptions.Color; + Font := CellAttr.caFont; + Font.Color := CellAttr.caFontColor; + MaxLength := Self.MaxLength; + WantReturns := Self.WantReturns; + WantTabs := Self.WantTabs; + WordWrap := Self.WordWrap; + EditLines.MaxLines := FEditorOptions.MaxLines; + EditLines.DefaultLines := 1; + EditLines.FocusedLines := 3; + EditLines.MouseOverLines := 3; + Cursor := FEditorOptions.Cursor; + PasswordChar := FEditorOptions.PasswordChar; + ReadOnly := FEditorOptions.ReadOnly; + Left := CellRect.Left; + Top := CellRect.Top; + Width := CellRect.Right - CellRect.Left; + Height := CellRect.Bottom - CellRect.Top; + Visible := true; + TabStop := false; + CellOwner := Self; + Hint := Self.Hint; + ShowHint := Self.ShowHint; + + {Str := PAnsiChar(Data);} {!!!} + if (Data = nil) then + SetTextBuf('') + else begin + SetTextBuf(PAnsiChar(Data)); + end; + + OnChange := Self.OnChange; + OnClick := Self.OnClick; + OnDblClick := Self.OnDblClick; + OnDragDrop := Self.OnDragDrop; + OnDragOver := Self.OnDragOver; + OnEndDrag := Self.OnEndDrag; + OnEnter := Self.OnEnter; + OnExit := Self.OnExit; + OnKeyDown := Self.OnKeyDown; + OnKeyPress := Self.OnKeyPress; + OnKeyUp := Self.OnKeyUp; + OnMouseDown := Self.OnMouseDown; + OnMouseMove := Self.OnMouseMove; + OnMouseUp := Self.OnMouseUp; + end; +end; +{=====} + +procedure TO32TCCustomFlexEdit.StopEditing(SaveValue : boolean; + Data : pointer); +{var + Str: String;} +begin + try + if SaveValue and Assigned(Data) then begin + FEdit.GetTextBuf(PAnsiChar(Data), MaxLength); + {Str := PAnsiChar(Data);} {!!!} + end; + finally + FEdit.Free; + FEdit := nil; + end; +end; +{=====} + + +end. diff --git a/components/orpheus/o32vldtr.pas b/components/orpheus/o32vldtr.pas new file mode 100644 index 000000000..99ec76364 --- /dev/null +++ b/components/orpheus/o32vldtr.pas @@ -0,0 +1,193 @@ +{*********************************************************} +{* O32VLDTR.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit o32vldtr; + {-Base classes for the TO32Validator and descendant components} + +{ +TO32BaseValidator is the abstract ancestor for all Orpheus Validator components +Descendants must override SetInput, SetMask, GetValid and IsValid plus define +the validation to provide full functionality. + +Descendant classes which call the RegisterValidator and UnRegisterValidator +procedures in their unit's Initialization and Finalization sections will be +available as a selection in the ValidatorType property of components that use +validators internally. +} + +interface + +uses + {$IFNDEF LCL} Windows, {$ELSE} LclIntf, MyMisc, {$ENDIF} Classes, OvcBase; + +type + TValidationEvent = (veOnChange, veOnEnter, veOnExit); + + TValidatorErrorEvent = + procedure(Sender: TObject; const ErrorMsg: string) of object; + + TValidatorClass = class of TO32BaseValidator; + + TO32BaseValidator = class(TO32Component) + protected {private} + {property variables} + FBeforeValidation : TNotifyEvent; + FAfterValidation : TNotifyEvent; + FOnUserValidation : TNotifyEvent; + FOnErrorEvent : TValidatorErrorEvent; + + FInput : string; + FMask : string; + FValid : boolean ; + FErrorCode : Word; + FSampleMaskLength : Word; + FSampleMasks : TStringList; + + procedure SetAbout(const Value: string); + procedure SetInput(const Value: string); virtual; abstract; + procedure SetMask(const Value: string); virtual; abstract; + procedure SetValid(Value: boolean); + function GetAbout: string; + function GetValid: Boolean; virtual; abstract; + function GetSampleMasks: TStringList; virtual; abstract; + procedure DoOnUserValidation; + procedure DoBeforeValidation; + procedure DoAfterValidation; + procedure DoOnError(Sender: TObject; const ErrorMsg: string); + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + + {Public Methods} + function IsValid: Boolean; virtual; abstract; + function SampleMaskLength: integer; + + {Public Properties} + property Input : string read FInput + write SetInput; + property Mask : string read FMask write SetMask; + property Valid : boolean read GetValid; + property ErrorCode: Word read FErrorCode; + property SampleMasks: TStringList read GetSampleMasks; + + {Public Events} + property BeforeValidation : TNotifyEvent + read FBeforeValidation write FBeforeValidation; + property AfterValidation : TNotifyEvent + read FAfterValidation write FAfterValidation; + property OnValidationError : TValidatorErrorEvent + read FOnErrorEvent write FOnErrorEvent; + + published + property About : string read GetAbout write SetAbout + stored False; + end; + +implementation + +uses + OvcVer; + +{===== TO32BaseValidator ===========================================} +constructor TO32BaseValidator.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FSampleMaskLength := 0; + FSampleMasks := TStringList.Create; +end; +{=====} + +destructor TO32BaseValidator.Destroy; +begin + FSampleMasks.Clear; + FSampleMasks.Free; + inherited Destroy; +end; +{=====} + +function TO32BaseValidator.SampleMaskLength: integer; +begin + result := FSampleMaskLength; +end; +{=====} + +function TO32BaseValidator.GetAbout : string; +begin + Result := OrVersionStr; +end; +{=====} + +procedure TO32BaseValidator.SetAbout(const Value : string); +begin +end; +{=====} + +procedure TO32BaseValidator.SetValid(Value: boolean); +begin + if FValid <> Value then + FValid := Value; +end; +{=====} + +procedure TO32BaseValidator.DoOnUserValidation; +begin + if Assigned(FOnUserValidation) then + FOnUserValidation(Self); +end; +{=====} + +procedure TO32BaseValidator.DoBeforeValidation; +begin + if Assigned(FBeforeValidation) then + FBeforeValidation(Self); +end; +{=====} + +procedure TO32BaseValidator.DoAfterValidation; +begin + if Assigned(FAfterValidation) then + FAfterValidation(Self); +end; +{=====} + +procedure TO32BaseValidator.DoOnError(Sender: TObject; const ErrorMsg: string); +begin + if Assigned(FOnErrorEvent) then + FOnErrorEvent(Self, ErrorMsg); +end; + +end. diff --git a/components/orpheus/o32vlop1.pas b/components/orpheus/o32vlop1.pas new file mode 100644 index 000000000..6d36f7acd --- /dev/null +++ b/components/orpheus/o32vlop1.pas @@ -0,0 +1,339 @@ +{*********************************************************} +{* O32VLOP1.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit o32vlop1; + {-ValidatorOptions class for use in components and classes which contain + their own validator objects, like the ValidatorPool, FlexEdit, Etc...} + +interface + + +uses + {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, Types, LclType, MyMisc, {$ENDIF} + Controls, Classes, Forms, SysUtils, + O32Vldtr, OvcData, OvcExcpt, OvcConst; + +type + TValidationType = (vtNone, vtUser, vtValidator); + + TProtectedControl = class(TWinControl); + + TValidatorOptions = class(TPersistent) + protected {private} + FOwner : TWinControl; + FHookedControl : TWinControl; + FValidationType : TValidationType; + FValidatorType : String; + FValidatorClass : TValidatorClass; + FSoftValidation : Boolean; + FMask : String; + FLastValid : Boolean; + FLastErrorCode : Word; + FBeepOnError : Boolean; + FInputRequired : Boolean; + FEnableHooking : Boolean; + FUpdating : Integer; + + {Event for which this object will execute a validation} + FEvent : TValidationEvent; + + {WndProc Pointers} + NewWndProc : Pointer; + PrevWndProc : Pointer; + + procedure HookControl; + procedure UnHookControl; + procedure voWndProc(var Msg : TMessage); + + procedure RecreateHookedWnd; + function Validate: Boolean; + + procedure AssignValidator; + procedure SetValidatorType(const VType: String); + procedure SetEvent(Event: TValidationEvent); + procedure SetEnableHooking(Value: Boolean); + + property InputRequired: Boolean read FInputRequired write FInputRequired; + + public + constructor Create(AOwner: TWinControl); dynamic; + destructor Destroy; override; + + procedure AttachTo(Value : TWinControl); + procedure SetLastErrorCode(Code: Word); + procedure SetLastValid(Valid: Boolean); + + procedure BeginUpdate; + procedure EndUpdate; + + property LastValid: Boolean read FLastValid; + property LastErrorCode: Word read FLastErrorCode; + property EnableHooking: Boolean read FEnableHooking write SetEnableHooking; + property ValidatorClass: TValidatorClass read FValidatorClass + write FValidatorClass; + published + property BeepOnError: Boolean read FBeepOnError write FBeepOnError; + + + property SoftValidation: Boolean read FSoftValidation write FSoftValidation; + + property ValidationEvent: TValidationEvent read FEvent write SetEvent + stored true; + property ValidatorType : string + read FValidatorType write SetValidatorType stored true; + property ValidationType: TValidationType + read FValidationType write FValidationType stored true; + property Mask: String read FMask write FMask stored true; + end; + +implementation + +{===== TValidatorOptions =============================================} +constructor TValidatorOptions.Create(AOwner: TWinControl); +begin + inherited Create; + + FOwner := AOwner; + +{$IFNDEF LCL} + {create a callable window proc pointer} + {$IFDEF VERSION6} + NewWndProc := Classes.MakeObjectInstance(voWndProc); + {$ELSE} + NewWndProc := MakeObjectInstance(voWndProc); + {$ENDIF} +{$ENDIF} + + ValidatorType := 'None'; + FSoftValidation := false; + ValidationType := vtNone; + ValidationEvent := veOnExit; + FInputRequired := false; + FEnableHooking := true; + BeepOnError := true; + FValidatorClass := nil; + FMask := ''; + FLastValid := false; + FLastErrorCode := 0; +end; +{=====} + +destructor TValidatorOptions.Destroy; +begin + UnhookControl; + FValidatorClass := nil; + inherited destroy; +end; +{=====} + +procedure TValidatorOptions.HookControl; +var + P : Pointer; +begin + if not FEnableHooking then exit; + {hook into owner's window procedure} + if (FHookedControl <> nil) then begin + if not FHookedControl.HandleAllocated then FHookedControl.HandleNeeded; + {save original window procedure if not already saved} + P := Pointer(GetWindowLong(FHookedControl.Handle, GWL_WNDPROC)); + if (P <> NewWndProc) then begin + PrevWndProc := P; + {redirect message handling to ours} + SetWindowLong(FHookedControl.Handle, GWL_WNDPROC, LongInt(NewWndProc)); + end; + end; +end; +{=====} + +procedure TValidatorOptions.UnHookControl; +begin + if (FHookedControl <> nil) then begin + if Assigned(PrevWndProc) and FHookedControl.HandleAllocated then + SetWindowLong(FHookedControl.Handle, GWL_WNDPROC, LongInt(PrevWndProc)); + end; + PrevWndProc := nil; +end; +{=====} + +procedure TValidatorOptions.AttachTo(Value : TWinControl); +var + WC : TWinControl; +begin + if not FEnableHooking then Exit; + + FHookedControl := Value; + + {unhook from attached control's window procedure} + UnHookControl; + + {insure that we are the only one to hook to this control} + if not (csLoading in FOwner.ComponentState) and Assigned(Value) then begin + {send message asking if this control is attached to anything} + {the control itself won't be able to respond unless it is attached} + {in which case, it will be our hook into the window procedure that} + {is actually responding} + + if not Value.HandleAllocated then + Value.HandleNeeded; + + if Value.HandleAllocated then begin + WC := TWinControl(SendMessage(Value.Handle, OM_ISATTACHED, 0, 0)); + if Assigned(WC) then + raise EOvcException.CreateFmt(GetOrphStr(SCControlAttached), + [WC.Name]) + else + HookControl; + end; + end; +end; +{=====} + +procedure TValidatorOptions.SetEvent(Event: TValidationEvent); +begin + if Event <> FEvent then + FEvent := Event; +end; +{=====} + +procedure TValidatorOptions.SetEnableHooking(Value: Boolean); +begin + if FEnableHooking <> Value then begin + FEnableHooking := Value; + if FEnableHooking and (FHookedControl <> nil) then + AttachTo(FHookedControl); + end else + UnHookControl; +end; +{=====} + +procedure TValidatorOptions.RecreateHookedWnd; +begin + if not (csDestroying in FHookedControl.ComponentState) then + PostMessage(FHookedControl.Handle, OM_RECREATEWND, 0, 0); +end; +{=====} + +procedure TValidatorOptions.voWndProc(var Msg : TMessage); +begin + with Msg do begin + case FEvent of + veOnEnter : if Msg = CM_ENTER then + Validate; + + veOnExit : if Msg = CM_EXIT then + if (not Validate) and (not FSoftValidation) then + FHookedControl.SetFocus; + + {TextChanged} + veOnChange : if Msg = 48435 then + Validate; + + end; + + {Pass the message on...} + if PrevWndProc <> nil then + Result := CallWindowProc(PrevWndProc, FHookedControl.Handle, Msg, + WParam, LParam) + else + Result := CallWindowProc(TProtectedControl(FHookedControl).DefWndProc, + FHookedControl.Handle, Msg, wParam, lParam); + end; +end; +{=====} + +procedure TValidatorOptions.AssignValidator; +begin + if (FValidatorType = 'None') or (FValidatorType = '')then + FValidatorClass := nil + else try + FValidatorClass := TValidatorClass(FindClass(FValidatorType)); + except + FValidatorClass := nil; + end; +end; +{=====} + +procedure TValidatorOptions.SetLastErrorCode(Code: Word); +begin + FLastErrorCode := Code; +end; +{=====} + +function TValidatorOptions.Validate: Boolean; +begin + {Don't validate if we're in the middle of updates.} + if FUpdating > 0 then begin + result := true; + exit; + end; + + {Send a Validate message to the Owner} + SetLastErrorCode(SendMessage(FOwner.Handle, OM_VALIDATE, 0, 0)); + SetLastValid(FLastErrorCode = 0); + result := FLastValid; +end; + +procedure TValidatorOptions.SetLastValid(Valid: Boolean); +begin + FLastValid := Valid; +end; +{=====} + +procedure TValidatorOptions.BeginUpdate; +begin + Inc(FUpdating); +end; +{=====} + +procedure TValidatorOptions.EndUpdate; +begin + Dec(FUpdating); + if FUpdating < 0 then + FUpdating := 0; +end; +{=====} + +procedure TValidatorOptions.SetValidatorType(const VType: String); +begin + if FValidatorType <> VType then begin + FValidatorType := VType; + AssignValidator; + end; +end; + + +end. diff --git a/components/orpheus/o32vlreg.pas b/components/orpheus/o32vlreg.pas new file mode 100644 index 000000000..0eff8b5c1 --- /dev/null +++ b/components/orpheus/o32vlreg.pas @@ -0,0 +1,99 @@ +{*********************************************************} +{* O32VLREG.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit o32vlreg; + {Registration unit for the Orpheus Validator components.} + +interface + +uses + Classes, O32Vldtr; + +var + ValidatorList: TStrings; + +procedure RegisterValidator(ValidatorClass: TValidatorClass); +procedure UnRegisterValidator(ValidatorClass: TValidatorClass); +procedure GetRegisteredValidators(aList: TStrings); + +implementation + +procedure RegisterValidator(ValidatorClass: TValidatorClass); +begin + if ValidatorClass.InheritsFrom(TO32BaseValidator) then begin + if ValidatorList.IndexOf(ValidatorClass.ClassName) = -1 then begin + RegisterClass(TPersistentClass(ValidatorClass)); + ValidatorList.Add(ValidatorClass.ClassName); + end; + end; +end; +{=====} + +procedure UnRegisterValidator(ValidatorClass: TValidatorClass); +var + i: Integer; +begin + i := ValidatorList.IndexOf(ValidatorClass.ClassName); + if i > -1 then begin + ValidatorList.Delete(i); + UnRegisterClass(TPersistentClass(ValidatorClass)); + end; +end; +{=====} + +procedure GetRegisteredValidators(aList: TStrings); +begin + Assert(Assigned(ValidatorList)); + Assert(Assigned(aList)); + + aList.Clear; + aList.BeginUpdate; + aList.Assign(ValidatorList); + aList.EndUpdate; +end; + +initialization + + ValidatorList := TStringList.Create; + ValidatorList.Add('None'); + + +finalization + + ValidatorList.Free; + +end. diff --git a/components/orpheus/o32vpool.pas b/components/orpheus/o32vpool.pas new file mode 100644 index 000000000..0ca2483df --- /dev/null +++ b/components/orpheus/o32vpool.pas @@ -0,0 +1,312 @@ +{*********************************************************} +{* O32VPOOL.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit o32vpool; + {O32ValidatorPool component classes} + +interface + +uses + OvcBase, Classes, Graphics, stdctrls, O32Vldtr, o32ovldr, o32pvldr, o32rxvld; + +type + TO32ValidatorPool = class; + + TVPoolNotifyEvent = + procedure (Sender: TObject; ValidatorItem: Integer) of object; + + + { - TO32ValidatorItem - } + TO32ValidatorItem = class(TO32CollectionItem) + protected {private} + FValidator : TO32BaseValidator; + FValidationEvent : String; + FValidatorClass : TValidatorClass; + FValidatorType : String; + FBeepOnError : Boolean; + FMask : String; + + {Component for which this item will validate} + FComponent : TCustomEdit; + FComponentColor : TColor; + FErrorColor : TColor; + {Event for which this object will execute a validation} + FEvent : TValidationEvent; + + procedure DoValidation(Sender: TObject); + procedure SetComponent(Value: TCustomEdit); + procedure SetValidatorType(const Value: String); + procedure AssignValidator; + procedure SetEvent(Event: TValidationEvent); + procedure AssignEvent; + function ValidatorPool: TO32ValidatorPool; + public + constructor Create(Collection: TCollection); override; + property Validator: TO32BaseValidator + read FValidator write FValidator; + property ValidatorClass: TValidatorClass read FValidatorClass + write FValidatorClass; + published + property BeepOnError: Boolean + read FBeepOnError write FBeepOnError; + property Name; + property ErrorColor: TCOlor + read FErrorColor write FErrorColor; + property Component: TCustomEdit + read FComponent write SetComponent; + property Mask: String + read FMask write FMask; + property ValidationEvent: TValidationEvent + read FEvent write SetEvent; + property ValidatorType : string + read FValidatorType write SetValidatorType stored true; + end; + + TO32Validators = class(TO32Collection) + protected {private} + FValidatorPool : TO32ValidatorPool; + function GetItem(Index: Integer): TO32ValidatorItem; + public + constructor Create(AOwner : TPersistent; + ItemClass : TCollectionItemClass); override; + function AddItem(ValidatorClass: TValidatorClass): TCollectionItem; + procedure Delete(Index: Integer); + procedure DeleteByName(const Name: String); + function GetValidatorByName(const Name: String): TO32BaseValidator; + property ValidatorPool: TO32ValidatorPool + read FValidatorPool; + property Items[index: Integer]: TO32ValidatorItem + read GetItem; + end; + + { - TO32ValidatorPool - } + TO32ValidatorPool = class(TO32Component) + protected {private} + FValidators: TO32Validators; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + published + property Name; + property Validators: TO32Validators + read FValidators + write FValidators; + end; + +implementation + +uses + {$IFNDEF LCL} Windows, {$ELSE} LclIntf, MyMisc, {$ENDIF} SysUtils, Controls, Dialogs; + +{===== TO32ValidatorPool =============================================} + +constructor TO32ValidatorPool.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FValidators := TO32Validators.Create(self, TO32ValidatorItem); +end; +{=====} + +destructor TO32ValidatorPool.Destroy; +begin + FValidators.Free; + inherited Destroy; +end; + + +{===== TO32Validators ================================================} +constructor TO32Validators.Create(AOwner : TPersistent; + ItemClass : TCollectionItemClass); +begin + inherited; + FValidatorPool := TO32ValidatorPool(AOwner); +end; +{=====} + +function TO32Validators.GetValidatorByName(const Name: String): TO32BaseValidator; +var + i: Integer; +begin + for i := 0 to Count - 1 do begin + if TO32ValidatorItem(Items[i]).Name = Name then begin + result := TO32ValidatorItem(Items[i]).Validator; + exit; + end; + end; + result := nil; +end; +{=====} + +function TO32Validators.AddItem(ValidatorClass: TValidatorClass): + TCollectionItem; +var + NewItem: TO32ValidatorItem; +begin + NewItem := TO32ValidatorItem(inherited Add); + NewItem.ValidatorClass := ValidatorClass; + NewItem.Validator := ValidatorClass.Create(FValidatorPool); + result := NewItem; +end; +{=====} + +procedure TO32Validators.Delete(Index: Integer); +begin + TO32ValidatorItem(Items[Index]).Validator.Free; + {$IFDEF VERSION5} + inherited Delete(Index); + {$ENDIF} +end; +{=====} + +procedure TO32Validators.DeleteByName(const Name: String); +var + i: Integer; +begin + for i := 0 to Count - 1 do begin + if TO32ValidatorItem(Items[i]).Name = Name then begin + TO32ValidatorItem(Items[i]).Validator.Free; + {$IFDEF VERSION5} + inherited Delete(i); + {$ENDIF} + exit; + end; + end; +end; +{=====} + +function TO32Validators.GetItem(Index : LongInt) : TO32ValidatorItem; +begin + result := TO32ValidatorItem(inherited GetItem(Index)); +end; + +{===== TO32ValidatorItem =============================================} +type + TProtectedCustomEdit = class(TCustomEdit); + TProtectedWinControl = class(TWinControl); + +constructor TO32ValidatorItem.Create(Collection: TCollection); +begin + inherited; + SetName('ValidatorItem' + IntToStr(Collection.Count)); + FErrorColor := clRed; + FBeepOnError := true; +end; +{=====} + +procedure TO32ValidatorItem.DoValidation(Sender: TObject); +begin + if not (csDesigning in ValidatorPool.ComponentState) + and (FValidator <> nil) then begin + { set the validator's values } + FValidator.Mask := FMask; + FValidator.Input := FComponent.Text; + { execute validation } + if not FValidator.IsValid then begin + { beep or not } + if BeepOnError then MessageBeep(0); + TProtectedCustomEdit(FComponent).Color := FErrorColor; + FComponent.SetFocus; + end + else + if (FComponent is TCustomEdit) then + TProtectedCustomEdit(FComponent).Color := FComponentColor; + end; +end; + +procedure TO32ValidatorItem.SetComponent(Value: TCustomEdit); +begin + if (Value is TCustomEdit) and (FComponent <> Value) then begin + FComponent := Value; + FComponentColor := TProtectedCustomEdit(FComponent).Color; + AssignEvent; + end; +end; +{=====} + +procedure TO32ValidatorItem.SetEvent(Event: TValidationEvent); +begin + FEvent := Event; + AssignEvent; +end; +{=====} + +procedure TO32ValidatorItem.AssignEvent; +begin + if (FComponent <> nil) then + case FEvent of + veOnChange: + TProtectedCustomEdit(FComponent).OnChange := DoValidation; + veOnEnter : + TProtectedCustomEdit(FComponent).OnEnter := DoValidation; + veOnExit : + TProtectedCustomEdit(FComponent).OnExit := DoValidation; + end; +end; +{=====} + +procedure TO32ValidatorItem.SetValidatorType(const Value: string); +begin + if FValidatorType <> Value then begin + FValidatorType := Value; + AssignValidator; + end; +end; +{=====} + +procedure TO32ValidatorItem.AssignValidator; +begin + if (FValidatorType = 'None') or (FValidatorType = '')then + FValidatorClass := nil + else try + FValidatorClass := TValidatorClass(FindClass(FValidatorType)); + except + FValidatorClass := nil; + end; + + if FValidatorClass <> nil then + FValidator + := FValidatorClass.Create((Collection as TO32Validators).FValidatorPool); +end; +{=====} + +function TO32ValidatorItem.ValidatorPool: TO32ValidatorPool; +begin + Result := TO32Validators(Collection).FValidatorPool; +end; +{=====} + +end. diff --git a/components/orpheus/orpheus.lpk b/components/orpheus/orpheus.lpk new file mode 100644 index 000000000..ae02192cf --- /dev/null +++ b/components/orpheus/orpheus.lpk @@ -0,0 +1,59 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/components/orpheus/orpheus.pas b/components/orpheus/orpheus.pas new file mode 100644 index 000000000..43c0c3c73 --- /dev/null +++ b/components/orpheus/orpheus.pas @@ -0,0 +1,21 @@ +{ This file was automatically created by Lazarus. Do not edit! +This source is only used to compile and install the package. + } + +unit Orpheus; + +interface + +uses + MyOvcReg, LazarusPackageIntf; + +implementation + +procedure Register; +begin + RegisterUnit('MyOvcReg', @MyOvcReg.Register); +end; + +initialization + RegisterPackage('Orpheus', @Register); +end. diff --git a/components/orpheus/ovc.inc b/components/orpheus/ovc.inc new file mode 100644 index 000000000..6067cda76 --- /dev/null +++ b/components/orpheus/ovc.inc @@ -0,0 +1,189 @@ +{*********************************************************} +{* OVC.INC *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{Conditional defines that affect compilation} + +(* +{$Q-} {Overflow Checking} +{$R-} {Range-Checking} +{$S-} {Stack-Overflow Checking} +*) + +{$IFDEF OrphChecksOn} + {$Q+,R+,S+} +{$ELSE} + {$IFDEF OrphChecksOff} + {$Q-,R-,S-} + {$ELSE} + {$IFOPT Q+} + {$Q+} + {$ELSE} + {$Q-} + {$ENDIF} + + {$IFOPT R+} + {$R+} + {$ELSE} + {$R-} + {$ENDIF} + + {$IFOPT S+} + {$S+} + {$ELSE} + {$S-} + {$ENDIF} + {$ENDIF} +{$ENDIF} + +{$V-} {Var-String Checking} +{$T-} {No type-checked pointers} +{$X+} {Extended syntax} +{$P-} {No open string parameters} +{$B-} {Incomplete Boolean evaluation} +{$J+} {Writable constants} +{$H+} {Huge strings} + +{General define indicating use under C++ Builder} +{$IFDEF VER93} + {$DEFINE CBuilder} +{$ENDIF} +{$IFDEF VER110} + {$DEFINE CBuilder} + {$ObjExportAll On} +{$ENDIF} +{$IFDEF VER125} + {$DEFINE CBuilder} + {$ObjExportAll On} +{$ENDIF} +{$IFDEF VER130} + {$IFDEF BCB} + {$DEFINE CBuilder} + {$ObjExportAll On} + {$ENDIF} +{$ENDIF} +{$IFDEF VER140} {!!.04} + {$IFDEF BCB} {!!.04} + {$DEFINE CBuilder} {!!.04} + {$ObjExportAll On} {!!.04} + {$ENDIF} {!!.04} +{$ENDIF} {!!.04} + +{$IFNDEF VER80} {Delphi 1.0} + {$DEFINE VERSION2} {Delphi 2.0 and BCB 1 or higher} +{$ENDIF} + +{$IFDEF VERSION2} + {$IFNDEF VER90} {Delphi 2.0} + {$IFNDEF VER93} {BCB 1.0} + {$DEFINE VERSION3} {Delphi 3.0 or BCB 3.0} + {$ENDIF} + {$ENDIF} +{$ENDIF} + +{$IFDEF VERSION3} + {$IFNDEF VER100} {Delphi 3} + {$IFNDEF VER110} {BCB 3} + {$DEFINE VERSION4} {Delphi 4.0 or higher} + {$ENDIF} + {$ENDIF} +{$ENDIF} + +{$IFDEF VERSION4} + {$IFNDEF VER120} {Delphi 4} + {$IFNDEF VER125} {BCB 4} + {$DEFINE VERSION5} {Delphi 5.0 or higher} + {$ENDIF} + {$ENDIF} +{$ENDIF} + +{$IFDEF VERSION5} + {$IFNDEF VER130} {Delphi 5} + {$IFNDEF VER135} {BCB 5} + {$DEFINE VERSION6} {Delphi 6.0 or higher} + {$ENDIF} + {$ENDIF} +{$ENDIF} + +{$IFDEF VERSION6} + {$IFNDEF VER140} {Delphi 6} + {$IFNDEF VER145} {BCB 6} + {$DEFINE VERSION7} {Delphi 7.0 or higher} + {$ENDIF} + {$ENDIF} +{$ENDIF} + +{$IFDEF VERSION2} + {$IFNDEF VERSION3} + {$DEFINE VERSION2ONLY} + {$ENDIF} +{$ENDIF} + +{$IFDEF VERSION3} + {$IFNDEF VERSION4} + {$DEFINE VERSION3ONLY} + {$ENDIF} +{$ENDIF} + +{$IFDEF Win32} + {$A+} {Word Align Data} +{$ELSE} + {$A-} {Byte Align Data} +{$ENDIF} + +{$IFDEF VERSION6} + {$IFNDEF FPC} + {$WARN SYMBOL_PLATFORM OFF} + {$ENDIF} + {$IFDEF VERSION7} + {$B- Incomplete boolean evaluation} + {$H+ Long string support} + {$J+ Writeable typed constants} + {$P- No open string parameters} + {$T- No type-checked pointers} + {$V- No var string checking} + {$X+ Extended syntax} + {$Z1 Enumerations are word sized} + {$IFNDEF FPC} + {$WARN UNIT_PLATFORM OFF} + {$WARN UNSAFE_CODE OFF} + {$WARN UNSAFE_TYPE OFF} + {$WARN UNSAFE_CAST OFF} + {$WARN UNIT_DEPRECATED OFF} + {$ENDIF} + {$ENDIF} +{$ENDIF} +{ This define turns off all platform warnings in Delphi 6. Delphi 6 } +{ is cross-platform compatible with Kylix and all of Orpheus' Win32 } +{ only stuff causes the compiler to throw a truckload of platform } +{ warnings when rebuilding packages. } + +{.$DEFINE ZeroDateAsNull} +{This define enables special handling for a zero date. If defined, } +{assigning 0 to a date field is treated the same as assigning the } +{constant "BadDate" (see manual) using the AsDateTime property. } +{Otherwise, 0 is treated as a valid date. (32-bit only) } diff --git a/components/orpheus/ovcabot0.lfm b/components/orpheus/ovcabot0.lfm new file mode 100644 index 000000000..23a797a04 --- /dev/null +++ b/components/orpheus/ovcabot0.lfm @@ -0,0 +1,1291 @@ +object OvcfrmAboutForm: TOvcfrmAboutForm + Left = 202 + Top = 223 + BorderStyle = bsDialog + Caption = 'About Orpheus' + ClientHeight = 311 + Height = 311 + ClientWidth = 472 + Width = 472 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Style = [] + OnCreate = FormCreate + PixelsPerInch = 96 + TextHeight = 13 + object TBevel + Left = 6 + Top = 265 + Width = 451 + Height = 17 + Shape = bsTopLine + end + object TLabel + Left = 152 + Top = 8 + Width = 59 + Height = 16 + Caption = 'Orpheus' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -13 + Font.Style = [fsBold] + ParentFont = False + end + object TLabel + Left = 7 + Top = 273 + Width = 232 + Height = 13 + Caption = 'Copyright '#169' 1995-2003 TurboPower Software Co' + end + object TLabel + Left = 7 + Top = 289 + Width = 86 + Height = 13 + Caption = 'All rights reserved.' + end + object Label1: TLabel + Left = 151 + Top = 40 + Width = 290 + Height = 49 + AutoSize = False + Caption = + 'Orpheus was released under the Mozilla 1.1 license in January, 2' + + '003. The project is hosted on SourceForge at sourceforge.net/pro' + + 'jects/tporpheus.' + WordWrap = True + end + object VisitUsLabel: TLabel + Left = 153 + Top = 108 + Width = 194 + Height = 13 + Caption = 'Visit the Orpheus project on SourceForge' + end + object lblTurboLink: TLabel + Left = 161 + Top = 124 + Width = 204 + Height = 13 + Cursor = crHandPoint + Caption = 'http://sourceforge.net/projects/tporpheus/' + Font.Charset = DEFAULT_CHARSET + Font.Color = clBlue + Font.Height = -11 + Font.Style = [fsUnderline] + ParentFont = False + OnClick = lblTurboLinkClick + end + object Bevel3: TBevel + Left = 152 + Top = 160 + Width = 305 + Height = 96 + Shape = bsFrame + end + object GeneralNewsgroupsLabel: TLabel + Left = 160 + Top = 168 + Width = 113 + Height = 13 + Caption = 'Orpheus support groups' + end + object lblHelp: TLabel + Left = 168 + Top = 198 + Width = 276 + Height = 13 + Cursor = crHandPoint + Caption = 'http://sourceforge.net/forum/forum.php?forum_id=241874' + Font.Charset = DEFAULT_CHARSET + Font.Color = clBlue + Font.Height = -11 + Font.Style = [fsUnderline] + ParentFont = False + OnClick = lblHelpClick + end + object lblGeneralDiscussion: TLabel + Left = 168 + Top = 230 + Width = 276 + Height = 13 + Cursor = crHandPoint + Caption = 'http://sourceforge.net/forum/forum.php?forum_id=241873' + Font.Charset = DEFAULT_CHARSET + Font.Color = clBlue + Font.Height = -11 + Font.Style = [fsUnderline] + ParentFont = False + OnClick = lblGeneralDiscussionClick + end + object Label3: TLabel + Left = 168 + Top = 217 + Width = 94 + Height = 13 + Caption = 'General Discussion:' + end + object Label2: TLabel + Left = 168 + Top = 186 + Width = 25 + Height = 13 + Caption = 'Help:' + end + object Panel1: TPanel + Left = 6 + Top = 6 + Width = 139 + Height = 251 + BevelOuter = bvLowered + TabOrder = 0 + object Image1: TImage + Left = 1 + Top = 1 + Width = 137 + Height = 249 + Align = alClient + Picture.Data = { + 07544269746D6170628C0000424D628C00000000000036040000280000008900 + 0000F900000001000800000000002C8800000000000000000000000100000001 + 0000000000000000800000800000008080008000000080008000808000008080 + 8000C0DCC000F0CAA600AA3F2A00FF3F2A00005F2A00555F2A00AA5F2A00FF5F + 2A00007F2A00557F2A00AA7F2A00FF7F2A00009F2A00559F2A00AA9F2A00FF9F + 2A0000BF2A0055BF2A00AABF2A00FFBF2A0000DF2A0055DF2A00AADF2A00FFDF + 2A0000FF2A0055FF2A00AAFF2A00FFFF2A000000550055005500AA005500FF00 + 5500001F5500551F5500AA1F5500FF1F5500003F5500553F5500AA3F5500FF3F + 5500005F5500555F5500AA5F5500FF5F5500007F5500557F5500AA7F5500FF7F + 5500009F5500559F5500AA9F5500FF9F550000BF550055BF5500AABF5500FFBF + 550000DF550055DF5500AADF5500FFDF550000FF550055FF5500AAFF5500FFFF + 550000007F0055007F00AA007F00FF007F00001F7F00551F7F00AA1F7F00FF1F + 7F00003F7F00553F7F00AA3F7F00FF3F7F00005F7F00555F7F00AA5F7F00FF5F + 7F00007F7F00557F7F00AA7F7F00FF7F7F00009F7F00559F7F00AA9F7F00FF9F + 7F0000BF7F0055BF7F00AABF7F00FFBF7F0000DF7F0055DF7F00AADF7F00FFDF + 7F0000FF7F0055FF7F00AAFF7F00FFFF7F000000AA005500AA00AA00AA00FF00 + AA00001FAA00551FAA00AA1FAA00FF1FAA00003FAA00553FAA00AA3FAA00FF3F + AA00005FAA00555FAA00AA5FAA00FF5FAA00007FAA00557FAA00AA7FAA00FF7F + AA00009FAA00559FAA00AA9FAA00FF9FAA0000BFAA0055BFAA00AABFAA00FFBF + AA0000DFAA0055DFAA00AADFAA00FFDFAA0000FFAA0055FFAA00AAFFAA00FFFF + AA000000D4005500D400AA00D400FF00D400001FD400551FD400AA1FD400FF1F + D400003FD400553FD400AA3FD400FF3FD400005FD400555FD400AA5FD400FF5F + D400007FD400557FD400AA7FD400FF7FD400009FD400559FD400AA9FD400FF9F + D40000BFD40055BFD400AABFD400FFBFD40000DFD40055DFD400AADFD400FFDF + D40000FFD40055FFD400AAFFD400FFFFD4005500FF00AA00FF00001FFF00551F + FF00AA1FFF00FF1FFF00003FFF00553FFF00AA3FFF00FF3FFF00005FFF00555F + FF00AA5FFF00FF5FFF00007FFF00557FFF00AA7FFF00FF7FFF00009FFF00559F + FF00AA9FFF00FF9FFF0000BFFF0055BFFF00AABFFF00FFBFFF0000DFFF0055DF + FF00AADFFF00FFDFFF0055FFFF00AAFFFF00FFCCCC00FFCCFF00FFFF3300FFFF + 6600FFFF9900FFFFCC00007F0000557F0000AA7F0000FF7F0000009F0000559F + 0000AA9F0000FF9F000000BF000055BF0000AABF0000FFBF000000DF000055DF + 0000AADF0000FFDF000055FF0000AAFF000000002A0055002A00AA002A00FF00 + 2A00001F2A00551F2A00AA1F2A00FF1F2A00003F2A00553F2A00F0FBFF00A4A0 + A000808080000000FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFF + FF00000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 000000000000000000000000000000000000000000000000000000F700000000 + 0000F5F000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 00000000000055FFF000002DF007FFF000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 000000000000000000000000000000000031F5FF310031FF2D08AF0000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 000000000000000000000000000000000000000000000000F52D000031FFF0F6 + F62D07FF00FF0700000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000007FFF000F5FF31F7FF2D0708F5FFF6F0F7F6F5F559F1000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000F6FF072DAA862DFFF0860707F6F52D + FF07F0FFFFF00000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 000000000000000000000000000000000000000000000000000000002D00AFFF + 82F5FFF1FFF0AB3108F700FF5EF0FF0800000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000FFF70008FFEC08310855082DFFECAF82F0FFFF0700000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000F7FFF7000886558207868631 + 08F708F0FFFF07F0F52D00000000000000000000072D0000000000F582AF0831 + 0000003107000000F0F7F52D07F7073100000000000007AAAFAA07000000002D + F700000000000000000007AAAF08070000000000000031F10000000000310000 + 0000F0070707F707F7002D07000000F0F72D00000000000000000000F0F50000 + F0F5FFAA00D4080831FF82F7F686F1FF0700F5AAFFFFF5000000000000000000 + FF820000000007FFFFAAAFFF86000008FF000000AFFFF0AFFFF6FFFFF6F00000 + 31FFFFAF08AFFFF62D000007FF000000000000002DFFFFAFAAAFFFFF31000000 + 000008070000000000FFF5000000F5FFFFFFFFFFFFF008FF000000AFFFF00000 + 0000000000000000F5F6F6F7F6310008AF00AAFF07083186D1F5F60731AFF686 + 31F0F5550000000000000000FFF7000000F0FF8200000031FF5500AAFF0000F7 + F6F50008080000F0FFAF002DF608F0000000F0AFF6F50007FF0000000000002D + FF08F0000000F008F63100000000FFF60000000055FF07000000F0FF31000000 + 000086F6000007FFF50000000000000000000000000786FFFFFF82F05A08F186 + 2D00000000F6FF868655F12D07F6FFFF0700000000000000FFF70000005AFF00 + 00000000AF080086F600F0FFF70000AFAA00000007FF00FFAF00000000000000 + F6F60007FF000000000000FFF600000000000000AFF600000007FFFFF5000000 + 08FFF6000000F5FF31000000000086D100F0FFF7000000000000000000000000 + 00F02DF0F55586D108F6F60000000000002D0755F708FFFFF6AF31F000000000 + 00000000FFF7000000AAFF0000000000F7FF0086AF00D108000000AFAA000000 + F7F607FFF000000000000000F5FF2D31FF000000000031FFF500000000000000 + F1FF310000FF86AFF70000F1FFF7FF2D0000F0FF310000000000AA0800D10800 + 00000000000000000000000000F5FFFFAFF7312D31F7F70000000000000008FF + 8207F0F1313100000000000000000000F6F700000086F6000000000007FF0082 + FF08FF31000000AF0800F007FF07F7FF000000000000000000FF0731F6F7F731 + 0000F7FF000000000000000000FF86002DFFF007FF0000F7FF00D1080000F1F6 + 31000000000086D108FF3100000000000000000000000000000031550782AA86 + AA8231000000000000000782868686F731312D000000000000000000FFF70000 + 0008D1000000000007FF00F7FF0808FF86000008FFFFFFFF070008D100000000 + 0000000000FFF731FFAFF6FFF60082F6000000000000000000AFAA0008FF0000 + FF3100FFF70007FFF000F0FFAF86AAD4860082FF0808FFAA0000000000000000 + 000000000000003131F5F50786FF86000000000000008607312D0782F6FFFFF5 + 0000000000000000FFF700000086F60000000000F7FF0082F60000F5FF070008 + AA002DFF310082FF000000000000000000FF0731FF0000F0FF8607FF00000000 + 0000000000FFF700FF070000AF082DF6F00000FF0700F1FFAFAA0808AA0082D1 + 0000F5FF070000000000000000000000F0F131F6FFF6F6AA0731072D00000000 + 0000FFF608D18631F5F02DF00000000000000000FFF700000008D10000000000 + 07FF0086FF000000AAAB00AF08000007FF0031F6F50000000000000031FFF031 + FF00000055FFF5FF31000000000000002DF6F531FFF0000031FFF6AF00000008 + FF00F0FF31000000000086F600000082AF000000000000000000000082FFF6AF + 072DF10786AAFF08000000002D082DAA07F086FFFFFF08310000000000000000 + FF0700000086F6000000000007FF0082F600000008080008AA000007FF0000F6 + F600000000000000FFAF0007FF00000007FF0008FF00000000000000FFAF00FF + 0800000000FFFF310000002DFFF500FF31000000000086AF0000000808F02DF5 + 00000000000000000031F5F03108F6082DF7082DF6F7318607FF08F5AF820059 + FFF7F6F60000000000000000FFF7000000AAF6000000000007FF0086F600F007 + FF3100D10800F5FF080000F1FFF6F50000002DFFFFF00007FF000031FFAA00F0 + FFFF2D0000002DF6FFF0F5F63100000000F7FF0000000000FF86ECFF31000000 + 000086F600F007FF072DF7070000000000000000000031FFF686F100F7AF2D08 + D10708D13186F7AFF008FFF1F00000F5F00000000008FFFFFFFFFFFF2D86F600 + 00000000F7F60086FFFFFFFFF7000008FFFFFF0800000000F0AFF6FFFFFFFF08 + F0000007FFFFFFFF08000000F008FFFFF6FFFF08F000AFF600000000002DF700 + 0000000007FF31F6FFFFFFFFFFF082F6FFFFFF5E002D07070000000000000000 + 00000031F1F0F7FFFFF0AB07082DAA0807862D82F60086FF0700000000000000 + 002D31312D31313100F52D0000000000F13100F131312D00000000F5312DF000 + 0000000000002D07F707F500000000F031312DF0000000000000F5078207F500 + 000031F5000000000000F000000000000031F52D313131313100F131312DF000 + 0000F5000000000000000000000000000007FFF6F00808F0AF318607AA070800 + FFAF0082FF000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 00000000000000000000000000000000000000000000000000000000F0AFF600 + 82F60008820782F5F6F5F6F0F7FFF60031000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 00000000000000F5FFFFF05AFFF131FF5586F72DFFF5AFF7F007FFFF00000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 00000000000000000000000000000000000000F007F031FF07F0FFFFF5FF0731 + FF0755FFF000F0FF310000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 00000000000007FFF0FF3155F608F1FF2D0000F5F00000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 000000000000000000000000000000000000F6862DFF2D0031FFF03100000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000F5F631 + F0F50000F1F63100000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 000000000000000000F0F5000000000000F70000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 00000DF4F4F40D0D0CF5F4F4F40D0D0D0DF00000F0F400F4F4F0F50CF500F511 + 1115101111F5F000F0F0F400F00D0C0DF5F4F5110C00F0F100F0F00000F5F50C + 110DF4F000F000F011F40D0DF4F40D11F4F5F4F5F40D110CF5F0F5F000F0F4F0 + 00F1F0F0F4F00D0C2D35F4F5F42CF429F4352C2C2855582C55544C4C4C797471 + 707194BB98BB98BB95BABB0000000CF00000F40DF4F0F5F0F100000000F000F0 + 00F5F400F5F400F1F400F00C110D0DF0F0F400F000F0F50000F0F5F0F4F0F40D + F5F000F0F500F000F0F00C0D15F40000F00000F0F5F00000F0F5F0F000F4F4F0 + 00F00D11F4F4F400F0F0F5F4F0F0F0F0F1F43130F4352CF42DF02C2C2C312C28 + 2830552C5554284D4C784C71709895B69994BB94BA95940000000DF10000F50C + 0D00F4F0F40000F00000F00000F0F0F1F4F5F4F4F0F5F4F5F40C0DF50C0DF500 + 0000F400F0000000F5F0F400F0F0F000F0F0F000F40DF000F5F0000000F00000 + F400F000F0F40000F00D19F000F0F40DF5F0F5F000F00CF1F0F0F0F4F0F40D0D + F435F428F42DF4292C342D2C2830555058514C4C4C794C4C95BA999894999499 + 9998990000000CF4F0F0F40D0CF0F5F400F00000F00000F000F4F5F4F000F500 + F50DF0F4F50C110C0D0CF4F000F0F4000000F0F411F4F5F0F10000F4F000000D + 0DF4F00000EC00F0F00000F011F00000F0F500F0F41111F4F1F4110CF4F4F400 + F0F00DF4F0F0F1F0F0F4303031342DF42C2C2C2C2C312C282855542C55544C4C + 4D7C4D94949598959898999498959800000011F5F411110CF5F0F400F511F400 + F000F000F0F000F40DF4F0F4F400F4F50C0DF00D0C15110CF5F0F0F5F40D110D + F0F5F400F0F0F0F1F000F00DF4000D110D11110D110CF0F10DF4F400F0F4F0F5 + 11101111F0F41111F4F5F4F000F10CF0F0F0F42C313031313031302C2C2C2D2C + 2C592C282854555055544D4C4C7970989998999899999498999899000000F4F0 + F0F0F50D0CF0F5F0F0F5F00000F00000F0F5F5F0F400F0F1F0F0F0F40D0CF0F4 + 0D11150DF4F0F40DF5F4F4F0F0F40CF4F40000F0F100F00D11F0F40C0CF50C0D + F40DF4F0F0F4F500F0F5F0F41515100DF40D0C0DF4F4F5F0F0F00DF4F4313130 + 59315834553055312C2C2C2C50592C502855545059504C4C7578999499949899 + 94989995BA9598000000F5F000F0F40CF5F0F4F0F0F4F000F000F00000F0F4F5 + F4F1F4F4F0F5F0F50C0DF5F40C0D11F50CF5F0F0F411F0000D0D0D110DF000F0 + F000F000F515110D110D0C0D110D00F000F50CF5F0F41035111111F4F4110D11 + F4F5F4F0F0F00C2D3058345934595959595854555455502C2C592C2950545950 + 7C554C4C5079989994999598BB989899989998000000F4F0F0000D11F4F1F4F1 + F4F500F00000F000F000F0F0F4F000F5F400F4F4F50C0DF40D0D0CF0F5F0F0F4 + F5F40D0CF4F000F5F0F000F0F400F000F0F4F4F4F4F4F5F4F4F4000000F0F411 + 0C0D1515111111F5F00C0C31F4F4F5F0F0F43130353559595958590303595958 + 55035554555950505055555059744C71749C9598999898999499989499989900 + 0000F4F5F4F4F40D0CF4F0F400F4000000F000F00000F0F1F4F0F4F400F4F00D + F40D0C11150CF4F50C0C0DF400000D0CF500F0F0F00000F10000F000F4000D11 + 0D0D10111111F0F5F4F000F1F40DF0F50C390CF4F0F51111F4F5F4F0F02D3035 + 5459585958590359597D0359545554595903515050557C507D784D4C749998BB + 989499BA999899BB9899940000000CF4F411110CF5F0F5F0F4F1F4F5F000F000 + F0F1F4F0F500F1F4F1F0F1F4F40D0C111100F5F40DF5F40DF4F00D0DF4F0F5F4 + F5F4F4F4F5F0F000F5340D0C0D0C0DF40D0CF0F00D00F4F40C11F40C0D10F5F0 + F40D3011F430F5F02C313455355859035D03597D0303597C59547D54545D5403 + 557C55507D547070759899989899989998999498989998000000F50C351511F4 + F4F0F4F1F0F4F40DF0F0F0F1F40DF4F0F4F4F0F4F0F4F00DF40D0D0C11F0F0F4 + F0F011F4F5F40CF4F500F0F4F4F100F0F4F0F03111110C0D0C0D110C110D00F0 + F4F40D393511393939110C0DF00C1539F50CF5F4303031585959035959595C59 + 7D597C597C7D547978597D037D037D547D795071749998999998999899BA9999 + BA9598000000302D0CF50CF5110DF0F4F0F500000DF0F0F0F000F40DF4F1F0F4 + F5F0F00CF510113915F50DF4F5F0110DF00D11110CF0F50DF0F0F0F5F000F511 + 100D0D0C0D0DF40D0CF5F0F4F1F0F4110C35110DF40DF4110C3939350C31F42C + 3135543558595903807D598059807D7C597C7D7C7DA07879787D78797C787474 + 74BB98989899BA98989998989998990000000D0C0D0C0DF40D0CF4F4F1F400F0 + 11F0000000000D0DF4F0F0F5F4F0F4F5F411100D11F4F0F0F400F515F4F40DF4 + 0DF0F0F4F400F0F0F0F0F0F4F50D0C0D0C0C0D0C0D0CF40D0C00F00DF40D0CF4 + F0F4F00D353939112C0DF42C31545958595903595D59807D807D7C7DA4A5A5A0 + A1A0A1A0A1A09D78797974759998999899989999999898BB9499980000003031 + 0C11F4F4F1F0F5F0F4F4F000F4F000F0F000F0F0F4F5F4F4F1F4F50C0D1111F4 + F4F0F40D0DF4F00C0D15350C0DF4F1F4F5F0F0F5F000F0F5F40C110D110D3011 + 110DF0F5F4F50C110DF40DF5F435310CF01035350C3031303134595903598159 + 7C7C5D7D807DA5A4A5C6A4C6A5A4A5A0A0A1A0A19C9C79747499989998999898 + BA999998999894000000313435390D0CF4F4F4F5F0F500F0F5F0F000F00000F0 + F4F0F0F4F4F0F40D103911F4F5F00DF4F00D35F40C0DF4F5F4F40C110C00F0F0 + F5F0F0F41115F4F4F4F5F5F40CF5F0F43530F5F4F40CF0303D3911350C353435 + 0D303031543154585903038159817C7DA5A4C6A5C6A5A4A5C6A5A0C7A0A1A0A1 + A19C9C9D9C987598959899999898999894999900000030350CF5F4F5F5F411F4 + F4F4F000F4F40DF000F0F0F0F5F4F5F5F4F5F40D11391139F4F0F4F500F4F4F5 + 0D39110C0D0D39150DECF0F4F000F40D0DF43535390CF4F5F0F000F5F4F5F4F0 + F5353911350C2C3131113535303131303154595503597D037D7C81A4A4C7A4C7 + A4C6C7C7A4A4C7A4A1A4A0A0A09DA09D9C9D9899749994989998949999989400 + 000031350DF40D0CF4F4F5F4F4F500F0F5F50DECF0F000F0F4F4F00CF4F4F40D + F4310C350DF00DF4EC0CF5F4F0F0F0F50CF0F5F40D00F4F5F0F0F1F4F40C110C + 0DF4F50C0D31F0F0F00C0D350C3939350C350DF4F43134353031303055585558 + 597D03817C81A4A5CBA4C7A8C6A9A4A4A4C7A4C7A4A0C3A1A1A09D9C9D9C9D98 + 989598999499989998949900000030350C3011340DF400F4F5F4F0F0F4F0F400 + 00F0F0F0F5F4F5F40D35F5F4F00D0DF4F4F4F4F5F4F5F40CF50C00F00D00F0F0 + F4F0F0F4F1F0F4F41139393535F4F00D3030F0F4F42D2C303130303130313031 + 30312C353031305554555859037D037D7DA4C7A4C6CBA4CAA5C6CBC6C7A4C6A4 + C7A5A0A0A0A1A09DA09D9C9C7598719499949994989994000000353535393939 + 39F5F0F5F4F500F0F5F4F5F4F0EC0D300DF4F431F4F40C0DF430F42D2C312C2C + 2DF4F5F43135F0F00CF0F5F4F5F0F5F4F0F0F0F431F4F5F0F5F4F4390DF52C2C + 31303130303130313031303130353534313031303154555459037D7CA5A5A4CB + A4CAC7CAA4CBA4A9C6A9C7A4C6A4C7A1A0A1A0A09D9C9D9C9998997494759499 + 95949900000035300D2C1135F0F0F0F4F4F4F0F0F4F4F435F5F00C0DF0F4F539 + 0DF0313030313130303031302C302C2C0DF4300D0DF0F0F4F4F0F0F4F1F0F535 + 0D0CF4F4F431F0F12C2C30313031305531543154313031303134353130353055 + 545558597C7D7C7DA4A4C7C6A8C7A8C7CACBC6CAC7C6A4C7A4C7A4A4C2A1A09D + A09D9C9D9C987594997194709499940000003031300D3534F4F1F00DF42DF0F0 + 0DF4F530F0F0F5F534350C2C2CF0313031303430313130313031302D2C2C310D + 0CF0F5F431F0F4F5F0F0F435300D35343530F42C302D31305530593054355435 + 303154313035595C355D59305455037903597CA5A4C7CAA9C6CBC6CACBA4CAA5 + C6A8C7CAA5C6A4C3A5A0A1A09DA09D9C9D9D7498717098719994950000003130 + 31303135F4F0F00CF50CF0F031F4F40DF0F030F435F42DF4F530303558595535 + 5430313031303130302D2C2C31F0F4F50CF0F52CF4F0F50C0D3039353935302D + 2C30305530595459595859545954355459303535035D5C5955545558797C7DC6 + A4CBA4C7CAA4CAA5CACAC7CACAC7A4C6A5C6A5A4A0A5A0A1A09D9C9D9C9C9971 + 74987170707170000000583158313035F4F0F0310CF5F0F00CF5F431F4F03130 + 312CF42C2C595859590358595959585534315431303031302DF02C0C31F0F4F5 + F4F4F4313130F42D2C312C30313055545903590359035959585554555455585D + 5D5D595C5954557C597CA5A5C6A4CAA4CBCBCACAA5CAA8C7A8CAC7A8C6A5C6A5 + C2A0A1A09DA09D9C9D9C9875707174717070710000005935303154312CF4F530 + F431F0F42DF42C31F0F43130352C2C2D5859597C595959030359595855583130 + 5531302C302CF42D31F0F42CF1F42C3030312C30312C30315455585503595903 + 59597C03595958595459035D615C5D8559540355787DA0C6A5C6C7CAC6A8CACB + CACAC7CACBC6A8C7A4C6A5C6A5A0A0A1A0A19C7D9C9D78747574717471707000 + 00005958593031302C3534353530F0F435303134F42C3531593031545D5D5C5D + 5C5D5C59595903595954555431543031552C3130302C2C312C2C2D3139615D5D + 343055545554595903597C81597C5D5959037D545554555D5C5D595C59545579 + 7C7DA4A5C6A9CAA9CACBCBA4CBCBA8CBC6A9C6C7CAC7A4C7A0C7A1A0A1789D9C + 9D789D7475707071707071000000035959585431305935303530F03135343159 + 2C2C5D345D30305980818181818181805D7C5959035959545530553030513035 + 352C3130303130305D5D30355455545503597D038159805980597D037C590359 + 587D545D5D5D0359545578037DA0A5C6CBC6C6CAA5CACACBCACACBA4CAC7CAA4 + C7A4C6A5A4A0A0A1A0A17C9D789D78757470754C714C700000005D0359553455 + 3031345D3531282C303130342D2C59355C5D5D818180818081808181805D7C03 + 590303595855545530305534352C31352C3031583559315455545554597C037D + 7C7D817C817C817D037D597C5558557C5959550351545578797CA5A4A4CBA4CB + CAA9CACAA9C6CACBA8CACBCAA4C7A4C6C7A4A5A0A19CA178A1789D7851744C75 + 70714C0000008059035955583154316134312C31593055352C54595459618580 + 81858085A481818081818181037D59585503555855542C31592C54312C313035 + 59585855545558597C7D7D7C8180818180817C817D7C7D59037D7C5503590381 + 037D58557CA1A4C7C6A4C7CAC7CACBCACBCACBCACBC6A4C7CAA4C7A4A4A1A0A1 + A0A178A1789D7878744D744C504C4C0000008159590354555431302C31302C30 + 303131582C555C555D85808185A885A9858584818180817C817D037D58555455 + 54555459032C35302C5459595C5D858154597C7D7D81808180A5A5A4A5A5A4A5 + 7C7D7C7C7D7C557C597C597D59808178797CA1C6A4CBCACAA9CAA4CBCACBA8CB + C6A9CACBA4C7C6A5C7A4A1A0A17CA1789D7879797954504D4C4D4C000000807D + 035959545554315859312C315930545954555D035D858580A8A9A9A8A8A4A5A4 + A4A5A0A5A17C7D7C7D7C555455545459592C55592C5558815D0355037D7C7D7C + 817CA5A4A5A4A4A5C6A4A5A4A5A4A17D7C7D7C7903595454547D7C557C7DA4C7 + CAA4A8C7CACACBC6A9CACBCACACBC6A4CAC7A4A4C6A1A4A1A0A178A178797878 + 7C595050504C4C00000081807D0359035554595D58592C54595954595454617D + 808181A9A9A8A9A9A5A4A5A5A5A4A5A4A4A1A07D7C7D7C555455555C59505859 + 515859035D5D54597C7D7C7D7CA5A8A5C6CBCAA8A5C6A5C6A5A4A0A5A07D7C7D + 7C81797855037D7879A0A5A4C7C6C7CAA5CACACBCACAC6A9C6A4CBC7A4A4C7A4 + A5A4A1A0A17CA178A178797903555059545954000000807D7C7D7C5558555459 + 5954505558595903795479038585A8A9A8A5A4C6A4A9C6CAA4A9C6A5A5A4A5A0 + A1A07D7C795454595950595850595459858081807D7C7DA4A5CAC7CAA9C6A9C7 + C6A9C6A4A4C7A4A0A1A0A17C7D7C5455787D7D78797CA1C6A4A5C6A4CAC7A8C6 + A9CAA9CACBCACAA4CBCAA4C7A4A5A0A5A0A17CA17C797C78595451582D542D00 + 0000A5A17C7D7C7D7855035958595903550303590355547D808181A8C7A8CAA9 + CBCAA5A8A5C6A5C6A4A4A5A4A17C7D7C9D7C55037D545903557C590385858185 + 7C7DA4A5CACAA4CAC6CBC6CAA8C6A8A5C7A4A5A5A0A17CA1A07D7D78797C7C79 + 7C7DA0C6A5C6C7A4C7A4C7CBCACBCACBCAA9C6CBA8C7A5C6A5C6A4A1A07DA07D + 7879787903555459542828000000A4A4A17C7D7C7D7859035903855903597D7C + 5978797C8184A5CAA8CACBCAA8CBCACBCACBA8C6A9C7A4A5A4A1A07D7CA1787D + 5C55037D5459037D8180798081A0C7CACBCACBA8CBCAA9CAC7A8C7CAA4C7A4A4 + A5A0A1A07DA07C7D7C817D78797CA1A4A5A4A4C7A4C6A8CACBCACBA8CBCAA9CA + C7A4CAA4C7A4A5A4A1A0A1A07D7C797859543055302C28000000C7A4A5A07D78 + 7D787D7D0359597C590359817C7D787D80A9CACBCAA9CACBCACBA8CBCAA8C7A8 + C6A4C7A4A1A4A1A07D7CA17C7D588159587D7C8184817881A9CACACACAA9CACB + A8CBCACBCACBA4C7A8A5C6C7A4A1A4A1A0A1A1A07D7C8178797CA1A4A1A4A1A4 + A5CACBCAA9CACACBCACBCAA9CACBC6A9C6A4C7A4A5A07D7CA17C7D0359595431 + 502D2C000000A4A5A4A1A07D7C7DA0787D0354597C7D7C81817C7D7CA5CACBCA + CBCBCAA9CBCACBCACBCACACBA5CAA4A5C6A5A0A1A0A17CA17879037D787D7C81 + 81857CA1C6CBA8CBCACBCACACBCACAA9CAA4CBCAC6C6A5A4A5A4A1A0A1A0A0A1 + A0817C797C797CA1A4A1A4A5CAA9CACBCACBCBCAA9CACBCACAA4CBA4C6A5A4A4 + A5A0A5A07D7C7D545D5C5D59302C2C000000C7A4C7A4A17C7DA0797D7C7D8181 + 7C817C79807D7CA5CACBA8CBCACECBCACACBCACBA8CBCBA4CAC6A5C6A5A4A1A0 + A17CA1A0A17C7D8055807D8085A8A5A4CACACBCAA9CACBCACBCAA9CACACBCAA4 + CBA5A4C7A4A4A1A0A1A0A1A1A0A57C7D7C7DA0A1A0A5A0C7CACBCACBCACBCACB + CACACBCAA9CBC6A8C7A8C7A5A4A5A07D80A17D7C5D595930313031000000A4A5 + A4A5A0A1A07DA09CA17C857C7D7D7C798081A9CACBCACFCACBCBCECBCBA8CBCA + CBA8CACBCAA5C6A4C7A4A1A0A0A1A0A1A0A17C7D787D7C81A985A5CACBCACBCA + CBCACBA9CACBCACBCBA8C7CAA4CAC6A5C6A5A4A1A0A1A0A0A1A0A18081A4A57C + A1A0A5CACACBCACBCACBA8CACBCBA8CBCAA8CBA9C6A5A8C6A5A4A5A07D7C7C7D + 7C593059305D39000000C6A5C6A0A5A0A17C7D7DA0A17C7D7C8081A07DA0A9CA + CBCACBCBCACBCACBCACFCACBCACBCAA8C7CAA9C6A4A5A4A5A0A1A0A1A0A0A17C + 7D7C7D80A9A4A5CAA8CBCACBCACBCACACBCACBCACACBCACBC6A9C6A4C7A4A5A4 + A1A0A1A0A1A0A0A57C7D7CA5A0A5A4CBCACBCACBA8CBCBCBCACBCACBCBCAC6CA + A9C6A5A4A5A4A580A1817C7D7D585558313030000000A8C6A5A4A5A0A0A1A0A0 + A1A0A17C817D808180A5A4CBCACBCACBCFCACFCBCECBCBCACBCACBCACBA4C6A5 + C6A4C7A0A1A0A1A0A1A0A0A178817DA885A5C6CACBCAA9CACBCACBCBCACBCACB + CAA9CAA8CBC6A4C7A5A4C6A1A0A1A4A1A0A1A0A580A5A4A5A4A1CACAA9CACBCA + CBCACBCACBCACBCAA8CBA8CBC6CBA8C7A4A5A4A580807D8080815C8103593500 + 0000C6A5C6A5A0A1A1A0A1A1A0A1A0A581A481A4A5A4CBCACBCACBCECACBCBCA + CBCBCACBA8CBA8C7A8C6A9C6A5C7A4A1A4A1A0A1A0A1A1A178A580A9A5A4C6CB + CACBCACFCBCACFCACBCAA9CACBCACBC6CBA4CBC6A4C6A5A0A5A0A1A0A5A0C3A0 + 81A07DA4A5A4C6CBCACBCBCACBCFCACBA8CBA8CBCBCACBC6A9A8C6A5A4A4A580 + 7DA5858581815D5D5D5903000000CBA4C7A4A5A0A0A1A0A0A1A0A1A07C81A4A5 + A9A8CBCACBCACFCBCBCFCACFCBCECBCACBCACBCAC6CBC6A4C6A4A5A4A1A4A1A0 + A1A0A0A07D80A1A8A5A4A9CACBCACBCBCECBCBCACFCACBCBCACBA8CBA4CAC7A4 + C7A5A0A5A0A5A0A1A0A5A0A1A081A4A5A4C7CACBCACBCECBCBCACBCBCBCACBCA + CAA9CAA9CAC6A9A8A5A5A481848584858485805D5C5D59000000C6A5C6A5C6A5 + A4A1A1A0A0C7A0A1A1A481A4A0A5CACFCACFCACFCACBCFCACBCBCACBCACBCAA9 + CAA8C7CAA5C6C6A0A1A0A1A4A1A5A1A0A0A580A5A4A1CACACBCBCACACBCECBCB + CACBCACBCACBCACACBC6A8C6A4C6A5A4C7A0A5A0A1A0A5A0A5A0A5A4A1A4A9CA + CBCACBCACFCBCACECBCBCACBCBCACBCAA9CAA5A4A8A980A9ADA8858585858581 + 5D5C5D000000A9C6A4C6A5A0A1A0A0A1A0A1A0A0A0A5A4A5A1A8CBCACBCACBCA + CBCECBCBCECACFCBCACBCACACBC7A8C7C6A5A4C7A4A4A0A1C2A0A0C7A0A5A0A9 + A4A5C6CBCACACBCFCACBCACFCBCACBCAA9CACBCAC6A9C6A5C6A5C6A0A4A1A0C3 + A4A0C7A0A1A481A4A5C6CACBCACBCACBCACBCFCBCBCACBA8CBCACBA8CACBA8CB + A5A4A9AC8585A98485848160815D5D000000C6A4C7A5C6A0A5A0A1A0A1A0A5C2 + A5A9A4A5A8C6CBCECBCFCBCFCFCBCBCECBCBCBCACBCAA9CBC6A8C6C6A5A4C7A4 + A1C3A1A4A0A1C3A0A1A481A8A9C2CACBCACBCBCACBCBCECBCACBCACBCACBA8C7 + A9C6CBC6A5C6A4C7A1A4A1A4A0A5A0C2A5A4A5A4C3A4CBCACFCBCFCACFCBCACB + CACBCACBCAA9CBCAA9A5A8A5A8A9ADA985A88585858585615D5C5D000000CAC7 + A4C6A4C7A0A5A0A1A4C2A1A1A4A9A9A4A5A4CBCACBCACECBCACFCACBCFCACAA9 + CACBCACACAC7CAA5C6C6A4C3A4A4A0A0C7A0A4A1A4A1A4A9A5A5CACBCACFCACB + CECBCBCBCACBCACBCACBCACACACAA5CAA4C7A5A0C6A1A4A1A4C3A0A5A4A1A0A5 + A4C6CBCACBCACBCBCACBCFCACBCFA9CACBCBA8CBA8CAA9A8A9A8A988A9898585 + 8584855C855D5D000000A5CAC7A4C7A4A1A4C3A4A1A4C2A4A1A0ADA4A5CBCACF + CBCBCBCECBCFCFCACBCFCBCACBCACBA8CBA4CBC6A5C6A5A4C3A5C2A5A0C7A0C2 + A5A4A1A8A4C2A8CBCACBCACFCBCACFCACFCBCBA8CBCACBCAA5CAC6A5C6A4C6A5 + A0C6A1C6A1A4C3A0A57CA1A0A5A4CACBCACBCECBCFCACBCBCACBCBCBA8CACBA8 + CBA8CBA8A9ADA9ADA9AD858885856185615C5D000000CAC6A4C7A4C7A4C2A4A5 + C2A5A1C6A0A5A8A9A4A4CBCACACFCACBCFCACBCBCECACBCBCACBCAC7CACAC6A5 + C6A5C6A5A0A4A5A1C6A0A5C7A0A1A4A9C7A5C6CACBCACBCBCACBCACBCACBCACB + CACBA8C7CAC7A8C6A5C6A5C6A5A4A0A5C6A1A4C6A0A1A0A5A4C7CACBCBCACBCB + CACBCFCACFCACACBCBCBA8CBA8CBA9A8ADADA9AD8589A98585858584615D5D00 + 0000C7A4C7A4A4C7A0A5A1C2A5A0C6A4C7A4A5A5A4C7CACBCFCBCBCFCACBCFCA + CBCBCBCACBCAA9CAA9C6A5CAA4C6A5C6A4C7A0C6A0A5C6A0A4A5A4A9A4A4C6CB + CACBCECACFCACFCACBCACBCACBCACBCAA5CAC6A5C6C7A4C7A4C3A4C7A0A4C6A5 + A1A0A5A0C7A4CBCBCECBCBCACFCBCACBCBCBCBCBCAA8CBA8CBA9CAA9ADA9ADAD + 85AD85858984856181605D000000CAC7A8C7C6A4C7A0C6A4A1C7A4C3A4A5A4A4 + A5C6CACBCACFCACFCBCFCACFCACBCACBCACBCAC6CAC7CAC6A5C7C6A4C7A0C7A0 + A5C2A5C2A1A4A5ADA5C6A5CACBCACBCBCACBCBCACBCACACBCAA9C6CACAA5C6C6 + A5A4C6A5A4C6A1A4A4C7A1C6A07DA0A5A4C6CACBCBCBCECBCACBCFCAA9CACBA8 + CBCBA8CBA8A9A8A9ADAD89A9AD85898585858461615D5D000000A8C6C7A4C7A4 + C6A5A1C6A4C2A5A4C6A9A9A5A4A5CBCACBCACBCACBCACBCBCBA8CBCAA9CACBA9 + C6A8C7A4C6A4C7A4C6A5A4C7A4C7A4C7A0A5A4A8A9A4C6CBCACBCACBCACACBCA + CBCBCBA8CBCACBA4CBCAA5CAC6A5C6C6A5A5C6A5C6A4C7A4A5A0A1A0A5A5A8CA + CACBCBCBCFCACBCBCECBCACBA8CBCBA8CBA9A8ADA9ADA989A989858985618585 + 605D5D000000C7C6A8C7A4C7A4C6C6A5C6A5C6C3A4A9A4A4A9C6A8CBCFCACFCB + CECBCFCACBCACBCACBCACAC6CBC6C6CBA5C6A4C7A5C6C6A4C7A4C2A4A5A4A5A9 + CBA4A5CACBCACBCACBCBCAA9CACACACBCACBCACBC6A4CAA5C6C6A5A4C6C6A5C6 + C7A4C6A5A0A1A4A5A4C6C7CBCBCACACBCACBCACBCBCBCBCACBA9CAA9A8A9A9A9 + ADADADAD89A98984858585615D5D5D000000C6A8C7C6C7A4C7A4A5A4C7A4C7A4 + A5CBA4A5A5A4CBCBCACBCBCACBCBCACBCACBCACBCACBA4CBC6A4CBA4C6A4C7A4 + C6A4A5C7C6A4C7A5A0A5A4CBADA5C6CBCACACBCACBCACACBCACBCBCACBA8C6CA + A5CBC6C7C6A9C6C7C6A5A4C7A4A5A5A4A5C6A5A4A5A5CACBCACBCBCBCBCBCBCB + CACBA8CBA9CAA9A8CBA9A8ADADA98985858985858561615C615C39000000CAC7 + A4CAA5C6A4C7C6C6A5C6A4C7A4A9A5C6A9A4C7CACBCBCACBCBCACBCBCBA8CBCA + A9CACBA4CBC6A4C7C6A5C6C7A4C7C6C6A4C7A4C6A4A5A4A4A8C7A4A4CBCBCACB + CACBCBCACBCACAA9CAC6A9C7CAC6A5CAA4C7A4C6A5C6C7A4C7CACAC7CAA9CAC7 + A4CAA5CAA5CBCACBCACBCACBA9CACBCBCAA9CBA9A8A9A9A984858585855D8585 + 858485615D5D5D000000A5CAC7C6C7A4CBA4C7A4C6A5C6A8CBA8C7A8C7CAA5CA + CBCACBCACBCBCACBCACBCAC7CAC7CAC6A8CBC6A8C7C6A4C7C6A4C7A4C7A4C7A4 + CBCAC7CBC6A8C7CAA4CACBCAA8CACBCAA9CACBC6CBCAC6CAA5CACBC6CBC6C7A4 + C7A8CBCACBA9CAA9CBC6A9CBCBA5CAA5CAA5CBC6A9CAA5CACBA9CBA8CBA8A9A9 + ADA989A9858985858461605D5D6161605D395D000000CAC7A8C7A8C7C6C7A4CB + A9CACBCBCACBCACBCAA9C6C7A8C7CAA9CAC6CBC6CBCACACBA8CAA5CAC7C6A5C6 + C6A5C6C6A4C7C6A9CACACACBCAA4CAA8C7CAC6A5CAC7A4CAC7C7C6C6C6CBC6CA + CAA5CAA5CAC6A4C7A4C7A4CBCACBCACBA8CBCBCBCAA9CBC6A9CAA5CBA4A5A4A9 + C6A5A8A5A4A9A8A5A9A9A9ADA989AD85AD85858585855D5D5C5D5D5D5D5C3900 + 0000C6A9C6C7C6A4C7A4CBCBCACBCBCACBCBCBA9CBC7A8CBA4C7A4C7C6A5A4C7 + A4C6C7A4C6C7C6C7C6A5C6C6A5C6C7A4C7C6A8CACBCACBA8CBCBCAC7CACAA5CA + C7A4C6A5C6A4C6A5C7A4C6A5C7C6CBC6C6A9C7CAC7A4C7CACBCBA9CBCBCBCBCB + A9CBCBA9CBA5CBA4C7A9CBA4A5A8A5A4A9A4A584A9A9ADADADA9A98985858584 + 85615C5D5D39595C5D3959000000CBC6CBA4CBC7CACFCBCBCBCFCBCBCBA9CACB + A8CBC6A9C7CAA5C6A5C6C7A4C6A1C6C6A5C6A4C7A4C6A4C7C6A4C6C6A9CACBCB + CAA9CACBCACAA9CAA9C6CBA4CAA5CBA4C7C6A5C6A4C6A5C6A4C6A4C7A5C6C6A5 + C6CBCECBCBCFCBCBCBCBA9CBCBA9CBCBA9CBA9CBA9A4A5A5A9A5A9A581A981A9 + ADADADA989AD89A9898585856161615D5D5C3935593835000000C6A9C6CBA4CB + CBCBCFCFCBCBCBA9CBCBCBCBCBA9CBC7A8C7A9C6A5A4C7A4A5A4A1A1C6A1C6A4 + C7A4C7A4C7C6A5CACACBCACBCACBCACBCBCACBCACBCAA8C7CAC6A4C7A4A5C6A5 + C6A1C6A1C6A1C6A4C6A5C6C7A8CBCBCFCBCBCFCBCFCBCBCBCBCBA9CBCBA5CBA5 + CBA5A9A8A5A8A9A8A9A481A9ADADADADA989A9898589858585845D5C395D0339 + 353535000000A4C7A4C7CBCFCBCFCBCBCFCFCBCBCFCBCBA9CBCBCBA8C7A9C6A5 + C6A5A4C7C6A1A4A0A1A4A1C6A0C7A4C6A4A5CACBCBCACFCACBCACBCAA9CACBCA + A8CBC6CAA5A5CAA4C7C6A4C6A5A4A5A4A1A4A5C2A5C6A5A4CBCBCFCBCFCBCBCF + CBCBCFCBCBA9CBA9CBA9CBA9A5A9A5A5A9A5A5A9A98185ADADADADA989AD8985 + 898585856161615D5D393935343530000000C7C6C7CBCFCBCFCFCBCFCFCBCBCF + CBCBCFCBCBCBA9C7CBA4C7A4A5C6A5C6A5A4A0A1A4A0A5A0A5A4C3A4C7CACBCE + CACBCACBCACBCACBCACBA8CBCACBCAA9C6CAC6A5C6A4A5C7A4C7A0A1A4A1A0A5 + A4A5C6CBCFCBCFCBCBCFCFCCCBCFCCA9CFCBCBCBA9CBA9A5A9A9A5A9A5A5A9A5 + A9A9ADADAD85ADAD89AD85898585856184615D5C395C3534353535000000A4C7 + A9CBCFCFCBCFCCCFCBCFCFCBCFA9CBCBA9CBCBA9CBA5A5C6A5A5A0A5A0C7A0A1 + A0A1A0A5A0A1A4A1A4CBCACBCFCACBCECBCFCACBCBCACBCACBA4CBC6A8C7A5C6 + A4A5C6A4C2A5C6A0A1A4A5A0A5A4A5CFCBCFCBCFD0CBCBCFD0CBCFCBCBAACBAA + CBAAA9A9A5A5A581A5A985A9A985ADA9ADAD89A9AD8589858585858561615D5D + 3539353535340D000000A5A5CBCFCBCFCFCFCFCBD0CBCFD0CBD0CBCBCBA9CBCB + A5CBA5A5A4A4A5A4A5A0A5A0A17CA1A0A1A4A0A5CACACFCACBCFCBCBCECBCBCE + CBCBCACBCACBCAA5CAA4C6A5C7C6A5C7A4C6A5A4A1A0A1A4A1A4CBCBCFCBCFCB + CFCFCFCBCFD0CBD0CBCFCBCBA9CBCBAAA9A9A9A585A581A985A9ADADAD89AD8A + AD8989858961856185605D5D5C353534353530000000A5CBCFCFCFCBD0CBCFD0 + CFCFD0CBCFCBCBD0CBCBCBA9CBA5CBA5A5A5A0A5A0A5A4A1A0A1A0A1A0A1A5A4 + CBCFCACBCFCACFCACBCACFCBCACFCAA9CACBA8CACBC7A8C6A4A5A0A4A5A4C6A5 + A0A5A4A5A4A5CBCFCBCFCBCFCBD0CBD0CBCFD0CBCCAAAAAAA986818581A58185 + 818185A585AD8AAD85AD86AD8985898585858585615D5D3939353435350C0D00 + 0000A5CFCFCBD0CFCFCFD0CFCBD0CBD0D0CBD0A9CBCBA9CCA5CBA5A5A5A4A1A4 + A1A4A1A4A1A47CA5A4A5A4A4CBCACBCBCECBCBCFCBCFCBCACBCACBCBCACBCAC7 + A4A4C6A5A5C6A4C7A0C7A5C6A17CA1A4A5CBCFCBCFCFCBD0D0CFD0CFD0D0AAAA + AA868286F7F7F7F7F75DF7818185818585A9AD89AE89AD898589858961856160 + 5D61395C35343535301131000000A9CBD0CFCFD0D0D0CFD0D0CFD0CFCBD0CBCC + CFAACBA9CBA5A5A5A5A5A0A5A4A1A4A1A481A9AD85A4A5C6CBCFCACFCBCACFCA + CFCACBCFCBCACBCACBA8CBA8CBC6A5C6A4A4A5A4A5A4C2A5A4A57C81A5A9CBCF + CBD0CFCFCBD0CFD0AAAAAA86828686F786F786F761F75DF75D5DF7818589AE89 + 85AD89858985898585618561605D5D393535350C11300C000000A9CFCFCCCFCF + CFD0CFD0CFD0D0D0D0D0D0CBCCCBCCA9CBA9A5A5A5A5A5A1A0A5A0A5A0A985AD + A5A4A5A9CACBCFCACFCFCBCFCBCFCACBCFCBCAA9CACBCAC7A4CBA4A5C6A5A0A1 + A4A5A4C7A4A4A9A4A5CBCFCBCFCBD0D0CFD0CCAAAA82AA0886868686F7F7F7F7 + F7F75E5D075D5D5DF78989AE898986898989858585856161615D5C3935343535 + 311131000000CBCFD0CFD0D0D0D0D0D0D0D0D0CCAAAAAAAAAAAAA5A6A9A6A5A5 + A581A180A5A1A0A5A0A981A4A9A5A4CACBCECBCBCBCACBCECBCACBCFCAA8CBCB + CACBA4CBA8C6A5C6A5A4A5A4A1A0A5A0A1A5A981A5CBCFCFD0CFCFCFD0AEAA08 + AA088686828682828686F75E5E5E5D07625D5E5D5D858A858985898985858985 + 6161615D5D5D393534353110310C0D000000CFD0CBCFD0CFD0D0D0D0D0AAAAAA + AA86AA82AA8282868181F7A5A5A181A1A1A0A5A0A1A47D7DA580A5C7CACBCBCF + CACFCFCBCBCFCFCACBCBCBCACAA9CACBC6A5C6A5A4A5A4A1A4A5A4A4A5A4A985 + A5A9CBCFCBCFCCD0CCAA08AA8686868686098662865E5E5E5E5E07625D07615D + 5D8A89898A8986898589856161855D615C3939343535103110310C000000CCCF + D0D0D0D0D0D0D0ABAA08AA09AAAA8208828682F7F7F781818181817DA4A17CA1 + A07D7C7C81A0A4CACBCFCACBCFCACBCACFCACBCBCECBCAA9CBCAA8C6A9C6A5A4 + A5A4A1A4A1A4A1A5A0A589A9A5CBD0CFD0D0CFAEAA8608860809860986625E82 + 5E5E625E5E5E62075E3D073E5D61868985898585898561856161605D5D393535 + 11340D0D310C0D000000CBD0CFD0D0D0D0AAAA08AA08AAAA09088686868286F7 + F7F7F707077D817D7D81A0A1A4A17D7C81A5A1A8CBCACFCACBCFCBCFCBCFCACB + CBCACBCACBCBCBA4C6A9C6A5A47DA47DA0A1A4A0A5A0A985A5A5CFCBCFCFD0AA + 0808860886868662098209625E5E5E5E5E5E5E073A075D073961898689856585 + 6185856161615D395D3934350D3530100D0D30000000CFD0D0D0D0D0ABAA0808 + AB08090886860982868286F7F7F707810781077D81A17D80A17C7D7C8180A1C6 + CBCBCBCBCBCACBCACBCACBCAA9CBCACBA8CAA4CBA8A5A4A4A5A4A1A0A57CA5A5 + A0A58581A5A9CFD0CFD0AA8686860886098609868262625E625E5E5E5E3A073A + 07393A39073962898562858585616161615D395C3934353530110D310D0C0D00 + 0000CCD0D0D0D0AA08080809AA090886090982866209F7F7F7F75E07F75D0781 + 59817CA1A0818081807DA0A5CACBCAA9CACBCACBCBCBCACBCBCACBA8CBA9CBA4 + A5C6A5A5A47DA47D7CA1A0A0A57C858585A5CFCBD0AA86080808098686096209 + 62095E625E5E3A5E3A073A3A073A390739355D6185858561616161615C5D5D39 + 3535350C110C310C0C3035000000CCD0D0CCAB08090809080986090982860909 + F75E095E5EF7F70707075D07597D7D817C7D5D858180A1A4CBCACBCAA9CAA9CA + A9CAA9CAA9CBA8CBC6CAA4CBA4A5A480A17C7D7CA57CA581A081858585A5D0CF + D008868686860886098686625E625F5E5E5E5E3A5E3A36393A353A3939393561 + 616161616161615D395D383534350C11310D0C0D0D0D0D000000AAD0D0088609 + 86098609090986090962820909826282625E5E5E0707075D075D597D7D7C7D80 + 817D7CA5C6A9CACBCACBC6CBCACBCAC7CACBCAA9A9A9A4A8A4A5A5A0817C817C + 7D7D7CA1A47D858585A5A9CFAA86088608868A6286096209625E625E5E3A5E5E + 3A3A3A363A353635363535356161616161615D5D5D39393535350D300D300D0C + 0C310C000000AAD0AA09860909090909860909620909096262095E625E5E5E5E + 5D5E5D075D5959817C7D5C59817C7DA0A5CAC7A4A5A4A5A8A5A8A5A8A9A8A9A8 + A9A8A9A5A58080817C7D7C7D7C817C817D8085858685CBCF8686868A868A8686 + 86626262625E625E3A5E3A3A363A35363536353511351135355D61615D5D385D + 39393435100D300D0C0DF40D310C0D000000AACC860909860986098609098609 + 0962625E095E625F625E5E5E5E07075D075D59597D815981805D7C7DA4C7A4A5 + A4A5A4A5A4A5A4A9A8A9A9A9A8A985808081817D7C7D7D7C7D7C7D807C818561 + 8581A9AA8A8AAE8689868A868661F7625E625E3A5E3A3A363A36363635123512 + 353535110D34395D5D395D393435350D310D0C0DF50C0D0C0C0D0C0000008209 + 09860909090909096209630962096309625F625E625E5E5E5D5E39075D07595D + 595D5C595D7D807D7CA5A4A5A4A5A4A5A4A5A885A9ADA8A9A984A98581818080 + 5D7C7C597C7D807D815D8581615D85AEA98A89AE8A868A868A6262613A5D5E5E + 3A3A3A3A353635123611351111110D110D0D0C353539343535350C0D0CF40D0C + 0C0D0C0DF50CF5000000625E5E09620909620909636209626362626362626362 + 5E62625E5E5E0707595D5959595D5D035D5D597C7D7CA57C817C817D8085A9A8 + A9A9A9A984A98485808181817D5D817C597C7D807C5D5D5D8561A98AADAE8689 + 8A898A8562866262625E393A363636361236123511120D110D0D110D0D0D0D0D + 0C0D11310C0C0D0C0D0DF40DF40DF40C0DF40C0000005E09095F090962096362 + 090963096209636263626262625E623A625D625D625D5D5D5903595D5D5C5D7D + 037D7C7D7C7D7C8081818485A984AD85A98585858580815C5D80597C7D81037D + 5D615D6185A989AE898AAD8A868A868A8562615E5D3A3A07393635113611110E + 0D0D0D0D0D0D0D0D0D0C0D0C0D0C0D0C0D0D0CF50C0C0DF50CF40DF4F4F4F500 + 000063636262095E096362096263626263636263626263626362628686868685 + 8562855D5D595D5D5D5D595C7D7C7D7C7D7D8081818485A8A9AD85A885858085 + 80815D5903595D5D59037D5D8561615D898AAE85AEAD8A898A858A8562626261 + 5E3907393A35110E0D0D0E0D0D0D0D0D0D0D0D0D0D0D0C0DF4F4F50C0DF4F40D + F4F5F4F4F4F5F4F5F40DF40000005E5E63636363626309636362636363626362 + 6362626262628A8A8A8A898A8585615D5D5D5C595D5C5D5D59037D7D037C7D59 + 808185858585A985848585815D5C5D5C5D59035D0359035D61856185ADAD89AD + 898A8986898A856685616107393A393A353536110D0D0D0D0D0D0DF50D0D0D0D + F40DF5F4F5F4F5F4F5F4F5F4F5F4F5F4F5F4F5F4F5F4F500000063625E626362 + 636263626363626362636263626362628A088A8A858A85868A6185855D5D595C + 595D5839585903597D5903595D8085858485858585858485815D5D59035D3503 + 5D0359616161618589AE898AAD868989868962856262623D073939353935110D + 0D0D0D0DF50D0D0DF5F5F4F5F5F4F5F4F5F4F4F4F4F4F4F4F4F4F4F4F4F4F4F4 + F4F4F40000005E5F635F62636363626362636362636263626762638A8A8AAE8A + 8A8A8A89858661615D5D5C350359595D59035558035859585D5D858485858485 + 8461855D5C5D5C5D5935585D595D596161618589AD89A98986898A8A89868985 + 616161395D3935351135350D0D0D0DF50DF5F5F5F5F4F5F5F4F5F4F5F4F0F5F4 + F5F4F1F4F5F4F5F4F5F4F5F4F5F4F50000003A635E625F626362636363626263 + 3E63626362638A0808088A8A8A868986628561855D5D5D5959595859345D5958 + 55595959585D808585858585858580615D5D593559345959355C3538615D85AD + 85AE898AAD8A85858565856162615D5D3935353535350D0D0D0DF50DF5F5F5F4 + F5F5F5F4F5F1F4F5F4F1F4F0F4F0F4F4F400F4F0F4F4F4F4F4F4F40000005F5E + 3F63623B6263623F6263636362636263626608088A8A8AAA8A8A868989866161 + 5D5D5D34593435593559345959345958595D5D858485846184615D5D5C5D5835 + 3459353459355D5D616189898989AD8985898A898A8562616161613939353511 + 3511350D0DF5F5F5F4F5F5F5F5F4F1F5F4F4F1F0F4F0F0F5F0F4F500F5F4F4F5 + F4F5F0F5F4F5F40000003A5F5E3B62633B626362633E63626362676263080808 + 08AE8A8A8A898A8689618561615D395D355958593435353434553459345D5C5D + 85858585855D5C5D595D5935353435353459383D616185AD8589868989868985 + 85898561615D5D3939353535110D110D0DF5F5F5F5F5F4F5F5F5F4F0F1F5F4F1 + F0F500F0F500F4F0F0F1F0F0F0F4F4F0F4F4F40000003B3A3A633B5E633E5F3F + 6263633E63626362660808088A8AAE8A8A8A868962856161615D5C3558353530 + 593534353535303535595D5D5C615C5D5C5D5D5D5C3534353035313435353535 + 5D618989898989858A89858A8961616161615D39353511340D350C0DF5F4F5F4 + F5F0F5F500F5F5F5F400F1F4F000F4F000F4F1F0F4F0F4F1F400F5F4F1F4F500 + 00003A3A3B5E3E633E5F3F62633E3E63633E636609088A088AAE8A8A86898986 + 898661615D5D395935353435353035353530313530345D5C5D5D5D5D5D5D3958 + 353535303535343535343534396189858589858A89858985618561615D5D3939 + 353411310C0D0D0DF4F5F4F5F5F5F5F0F5F500F400F5F4F500F4F100F4F000F4 + 00F500F4F0F5F4F0F4F4F00000003A3B3A3B3B3A5F3E5E3F3A63633E62636262 + 080808AE8A8AAE898A868A896161615D615D3934353435313431393435303031 + 3135355D5D5D5C5D355C59353435343130313130353535393D61858989858989 + 85898565856161616139393411350C110D0D0C0DF5F5F5F4F1F400F5F400F5F0 + F500F0F40000F0F400F1F0F0F0F0F0F500F400F4F0F1F4000000363A3A3A3B3E + 3B3B3E633E3E5F3F623F6366080808088AAE8A8A8A89868A858561615D5C5D35 + 3535303531343131350D30303031343534353534353534353531310C310C310D + 30343961616185858989858985658561856161615D5D39353411310C0D0C0D0C + F400F5F4F1F5F0F0F1F500F500F500F5F0F000F5F00000F100F400F0F0F5F0F1 + F4F0F0000000123A373A3A3B3A3E3B3A5F3F3E623F623E09088A8A8AAE8A8A86 + 8A8A8589626161615D393934353435313031F40C35300D310D30313535353435 + 35343535300D300D300D0C300D3539613D61858985858985898585856161615D + 39383535350D0C0D0C0D0CF5F5F5F4F1F4F0F5F1F400F500F400F4F4F400F00D + F4F4F0F0F0F0F1F400F0F0F400F5F40000001236163A3B3A3B3B3A3F3E3A633F + 623E6362088A08AE8A8A8A898A85896261616161395D34353531300C3130F40D + 3510F50C300C31313030310D303131300D300DF40D0C2C0D0D35103539616185 + 858985618561616161615D5D3939350D0C0D0C0D0C0DF4F5F4F400F500F500F4 + 00F500F500F4F4F1F0F100F4F515F4000000F000F4F0F0F1F0F4F40000000E12 + 36123A3B3A3A3B3A3A3F3A3E3F623E8A088A8A8A8A8A8A868A618A616161615D + 5D39353510300D310C0DF4F41131F4F5F4F50C0C0D310D300D300D0C0DF40CF5 + 0CF50DF40C353539393D61858561858561856161615D5C39393510350D0C0DF4 + 0DF40DF4F0F1F5F400F5F0F1F500F400F0F1F4F4F4F400F4F4110CF4F4F1F0F0 + 00F500F4F0F5F40000000E12121236123B3A3A3B3B3A3F3A3E3F3E62088A8A8A + 8A86898A86898685616161615D343535310D300D300DF10C11F4F4F4F5F4F5F4 + F4F4F5F40DF4F4F5F4F5F4F5F4F4F40D1011343D15393D616085618561616161 + 61395D393435350C0DF40D0D0CF5F4F1F4F400F5F400F400F0F1F0F1F0F400F5 + 00F0F00DF50D0DF5F4F400F0F000F000F4F0F00000000D0E1212123A123A3B3A + 3A3A3A3A3F3A3E628A8A8A8A86898A868986656161615D5D383535300D300D30 + 0D0CF4F40D0C0DF4F4F4F0F4F5F4F4F4F4F5F4F4F4F4F4F4F4F5F4F40D350D11 + 34393D5D618561606160615D5C5D393435350C0D0C0D0CF4F5F4F5F0F500F500 + F0F100F500F400F0F0F1F4F0F4F5F00DF4000DF4F00DF40DF4F4F5F0F0F5F400 + 0000060E0E0E121236163A163A3B3A3A3A3A3E3E8A8A868A898A86658A616161 + 61615D393535340D0C0D0C0CF5F4F00D111111F4F0F5F4F5F0F4F5F4F5F4F4F5 + F0F5F4F4F1F4F40DF4390CF4F511393961616161615D5D395D393935350C0D0C + F50CF4F5F4F4F0F400F400F0F1F400F0F000F5F4F5F400F5F000F4F4F0000000 + 0015110C11110CF0F5F4F0000000F50D060E0E12121236123A3A3A3A3A3A3A3A + 628A8A8A868A858685866161615D393835340D0D2C0D0CF50CF5F0F40DF40DF4 + F0F4F0F0F5F4F4F4F0F5F0F4F4F0F5F0F4F510110D0D10391039393D3D5C5D5D + 5D395D5D393435340D0D0C0DF4F4F5F4F500F500F500F5F0F000F400F1F400F4 + 00F0F400F4F0F5150CF0F0F5F00DF5F41115F400F000F40000000DF5F50D060E + 1212123612163A163A3A163A5E89868986658A6561616161395D3935350D300D + 0D0CF5F4F40C110C0D0D10F1F4F5F4F4F0F0F1F0F4F0F0F1F0F0F0F0F40D11F4 + 0C11113D1539393D1539395C5D5C39343535310D0C0DF4F5F4F5F4F400F4F0F4 + 00F400F0F100F1F0F0F0F5F0F4F1F4F0F100F40D0DF4F0F40CF4F40D1111F5F0 + F4F5F0000000F5F5DBF50A060E0E12121236121636163A3A15628A628A866186 + 6161615D5D393534350C0D0C0CF5F4F40D0D11F50C0D0DF0F4F4F500F4F0F0F0 + F1F0F0F4F00CF40DF0F4F41111110C0D35153915113511393935353535300D0C + F5F4F5F4F4F400F5F0F100F000F1F000F0F4F0F4F1F400F400F400F4F400F40D + 0000000D110DF40DF40CF000F100F4000000F5F5F5F5DBF5060E060E0E121212 + 36123611363A62896161616161613D5D383534350D0C0DF4F5F4F40D0CF4F4F4 + 0CF0F400F4F1F0F0F50D10110CF40D0C11110D150C0D0D0D0C0DF40D15391539 + 101110391138350C0C0DF4F4F4F4F00C0DF0F5F000F0F0F1F0F400F5F0F0F100 + F400F0F5F0F1F0F100F0F10C000000F4F5F4F0F4F4F5F0F0F0F4F0000000F5F5 + F5F5F5F50DF50E0D060E0E110E1112121111396261626161615D5D393935350D + 0CF50CF4F4F5F40C0DF50DF50DF40DF1F4F4F400F411110C0D110C0D0C0DF4F5 + F4F0F00C11F40D15101539153915111511391115110C110DF40D110D0CF400F4 + F4F5F4F4F4F1F400F400F4F0F1F0F400F400F4F0F0F0F4F5F4F4F4F5000DF40D + F4F5F500F400F0000000F0F1F5F5F5F5F50DF506F5060E060E060D0611110D39 + 6161615D5D5D393935300D0C0DF4F5F4F4F4F100F4F4F4F4F5F4F4F000F5F0F1 + F0100DF40C11110D11110C0DF4F5F40DF5F40C11153915391539393D11153D3D + 110C15110C0C0D0DF5F0F000F400F5F0F4F4F1F4F0F1F0F0F400F5F0F0F400F0 + 000C0DF40D0D0DF000F4F00DF4F40C00F0F1F0000000F1F4F500F5F5F5F5F5F5 + 0D0D0DF5DB0D0D0D0D0D0D0D11395D39393935340D0D0CF5F4F5F4F40D11F4F0 + F5F4F5F40CF0F5F0F0F4F000F4F511150D0C0D0C0D100D0DF0F0F000F0F500F4 + 1111101111111015111015111111110D11F5F4F4F000F4F1F0F0F4F4F5F0F400 + F4F0F0F100F4F000F500F5F00011F5F4F4F0F0F4F00DF4DB11150DF000F00000 + 0000F0F500F5F5F0F5F5F5F5F5F5F50D0D0DF50D0D0D110D1539393935340C0D + 0DF4F5F4F4F4F00D110CF0000CF5F4F4F5F4F400F5F000F0F01110110C0D0C0D + 0C0D0D0C0000000DF4F4F40D151515151515153915111110111515F4F00CF4F5 + F40D15F400F0F1F000F400F4F100F400F4F100F4F0F0F0000D0CF0F40D0D0C0D + 0DF4F00D0C110C00F0F0F0000000F400F5F400F5F500F4F5F1F5F4F5F5F40D15 + 110D111115393D1535110DF4F4F4F4F4F50C11F0F0DBF0F00DF4F5F50C0D0DF0 + F4F5F000F40D0DF40D0D0D0D0D0D0C0DF000F00D0DF00D110C11111110111115 + 110D0C0D0DF40DF5000D0DF40C11F5F4F400F0F0F5F0F1F0F0F0F1F400F0F0F1 + 00F000F0101111F4F0F4110C0D0DF4F411DBF50000F000000000F1F000F1F400 + F5F5F0F5F4F5F5F4F5F50C0D0D0D11113915393D15391111F40D150CF50C11F4 + F00DF100F4F4F4F4F5F40D00F0F0F500F0100DF4F40CF40CF40C0D0DF4F4F40C + F5F0F4111110151111151115100DF5F4F5F0F0F000F0F0F5F0F10000F1F000F0 + 00F0F000F400F0F0F100F0F0F000F00D11150D00F5F00000F411F5F4F5F4F4F4 + F500F000000000F400F4F0F1F400F5F0F5F0F5F4F4F40D110DF40D1115111511 + 1515110C0D0C15110C0DF000F011F0F00DF4F50C0CF5F400F5F4F000F0F51115 + 110D0D0D0D110C0D000000F5F0F000F0110D111011111015110DF4F4F4000000 + 000000F400F000F0F4F4F000F0F000F100F0F000F4F0F00000F00D0C110D0C0D + 0CF4F5F0F411F4F400F4F50DF400F0000000F0F1F0F100F400F0F1F0F4F1F4F1 + F511DB0D0CF40D10110D0C0D110C0D15151111110D10110CF5F4F0F0F5F4F5F0 + F500F4F0F00000F0F0110CF5F4F4F4F4F4F4F5F4F0F40DF4F4F50C1110111011 + 11111111110CF4F4F500F0F0F000F4F5F00000F4F5DB0DF40000F0F0F0F000F0 + 000000F0F5DA0DF4DB0C1511F0000DF4F511F40D0C0DF40C0D0000000000F000 + F0F0F1F0F5F0F4F1F4F0F0F40CF5F0F41111150D11F411F40D0D0C11110C0DF4 + F0F5110D0C110CDBF4F0F4F4F4F0F500F4F1F000F50CF5F40D11110D11111111 + 110D0CF5F4F4111511111111DBF4F00C0DF500F5F4F0F4F1F4F1F00D00F00000 + F4F0F4F5F0F4F0000000F000F1F4F0F40DF50CF40D11110D0CF5F000F40DF40D + 1111F50D11F0F0000000F0F400F0F0000000000000F011111111F000F5F50C0D + 10111515F40C0D10F500F4F5F4F0F40000F5F4F0F1F4F5F4F5F40C0000F0F000 + F00D100D0CF40DF4F4F40CF5F4F500F4F500F5F40D0C110D0CF50C0DF40C0DF4 + F5000000F00000F0000000F0F5F4F5F4111100F4F0F500F010150DF4F4F4F5F0 + 0C1511000DF4F000F00DF4F400F4F4F4F40000000000F50CF100F0F0F4F5F4F4 + F5F4F5F4F511F400F4F4F5F4DB111515F40D0D110CF40DF5F4F511000000F0F1 + F4F4F000F40DF500F0F00000F0F41111110D0C0D111111F400F4F0F5F4F4F0F4 + 111110110DF4F40D0C0DF0F5F400F0000000F00000F000F40DF4F4F5F4F400F4 + F50C00F0F50D0DF40DF50DF4110DF400F5F0F500F511F50DF0F4F5DB0D00F000 + 000000F0F4F000F40D11F4F0F5F4000DF40000000DF40D0C0D15F5F4F5F4F4F5 + 0D150CF4F4F4F4F4F5F40DF4F40D0DF4F5F0F400F0F500F0F111F4F4F5F40DF4 + F4F4F5F4F50D0DF4F4F10D110C111111100D0C11110DF4F4000000F000F00000 + F00000F5F4F0F5F4F4F500F5F40DF00000F4F40CF0F00CF0F5F00000F4F4F400 + 00F4F4F400F5F4F1F000F00000000C110DF4110DDAF5F40DF4F5F4F40DF400F0 + DB0C110D0C0DF400F40DF400F011150D0CF500F5F400F0F000F40DF0F400F500 + F000F000F40DF5F40D0C0D110D11110DF400F0F0F0F00CDB1111101111111111 + 0CF4F4F5F000F000F000F000000000F4F5F4F4F4110C00F4F411F400000D110D + F50CF50C11F400000D0DF500F00DF5F4F0F4F4F4F400F0000000F50CF5F40DF4 + F5F4F5F4F5F40DF40DF50D0CF5F4F50C0D0DF4F40D0C0DF4F40D10F5F5F40CF5 + F40DF4F50DF4F5F4F5F0F4F000F400F0000C100DF4F5F4F5F4F4F4F5F00000F5 + 0000F40D100D110D101111150DF500F0F0000000000000F000F00000F000F1F0 + 0DF500F5F4000000F4110D0CF40DF4F5150DF00000F0F400F4DB0CF500F5F411 + 0D00F0000000F000F50C0D0D0DF4F00000F0F500F4F0F4F5F000F40D0D0CF40D + 10111111F4DB0DF400F51100F40DF0F4F0F4F0F4F0F4F500F0F50000F00D0D11 + 0CF40D0C0D0D0DF4000000F0F4F5F4F5111110111111141511F4F0F50000F000 + F000F000F00000F0F00D0CF4000000110D0000000D0CF4110D1011F4F4DBF500 + 00F011F000F0F0F400F4F4F5F000F4000000F0F4F4F50CF4F0F400F0F0F4F400 + 0000F5F4F0F4F50D0C0C0D11DB1115110C0D0DF4F0F4F400F4F5000000F5F4F5 + 0CDBF4F0F5F400F0F10DF4F40D0D0D0C0DF000F0F0F100F4F5F4F500F40C0D0D + 0C0D0D110CF500F000F0000000F000000000F000F5F4F5F00DF4000CF40000F0 + F50C0D110C0D110C110CF00000F5110000F0F50D0CDBF5000000110000001111 + F0F4110DF4F5F40D11F5F5F4F4F40D0D00F5F4F4F5F50C0CF4F5F410F5F40CF5 + F0F50D00F0F4F5F4F0F0F0F4F1F4F500F0F40000F40DF4F0F50CF4F50CF400F0 + 000C0DF0F000F0F4110D1110111011100DF4F0F4000000F00000F000F00000F0 + F00C0DF00DF5F0110D0000F011110CDB0D0CDB1111110C0000F00DF0F4DBF4F4 + F5F4F00DF400F40000000DDBF0F00DF4F40DF4F50CF4F5F4F5F0F4F0F0F0F5F4 + F411110DF4F40D1110110DF4F0F40DF0F1F40C0DF5F4F5F0F400F4F000F5F0F0 + 00F411150D0D0D0D0D0D0DF400F1F4F00000F5F40D0C11111111111111F400F1 + F000000000F0000000F00000F4F50CF00CF4000DF40000F00CF5F40DF40D0CF5 + F40DF50000F011F0F00DF0F50CF5F4F4F5F011000000F0F0000D110DF4F00D0C + 110D0C0DF4000000F4F4F4F5F4F41111F4F5F4150D0D0CF0F50000F40CF40D0C + F5F40DF4F5F0F500F0F00000F50CF5F4F4F4F4F40CF40DF4000000F5F000F4F0 + F00C1110111011150DF4F5F4F000F000F000F000F00000F0F5F4F5F011F5000D + F500F00000F0F0F4F0F0F500F400F00000F40D00F00DF4F4F4F5F40DF000F400 + 00000C0DF0F40DF4F5F4F5F4F5F4F50CF50000F00D0D0D0CF5F00D0CF5F4F40D + F4F4110D0CF000110D0D110D0CF000F4F0F0F400F0F000F0F40DF4F411111111 + 1111150D00F4F0F40000F40D0D111111111111110CF50CF0000000F000000000 + 000000F0F0F0F4F4F5F4F4F4F0000000F0F50CF5F4F5F4F40DF0000000F00DF0 + F411F4F0F5F4F411F4000D000000F50000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 000000000000F500000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 000000000000000000000000000000000000000000000000000000000000F500 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 00000000000000000000000000000000000000000000F5000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000F50000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 000000000000F100000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 000000000000000000000000000000000000F000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 00000000000000000000000000000024ECECEC24000000000000000000000000 + 00000000000000000000F1000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 000000000000000000000000000000000000000000000000000048F9F9F9F9F9 + EC00000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 000000000000ECF9F9F9F9F94800000000000000000000000000000000000000 + 0000F00000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 00000000000000000000000000000000000000F9F9F9F9F96C00000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000090 + F9F9F9F9F9000000000000000000000000000000000000000000F10000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 00000000000000000000006CF9F9F9F9F9000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 00000000000000000008FFFF0700000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 000000000000000000000000000000000000000000000048F9F9F9F9F9EC0000 + 000000000000000000000000000000000000F000000000000000000000000000 + 00000000000000000000000000000000000000000008FFFF0700000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 000000ECF9F9F9F9F94800000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0008FFFF07000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 00000000000000000000000000000000F9F9F9F9F96C00000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 00000000000000000000000000AAFFF607000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000090F9F9F9 + F9900000000000000000000000000000000000000000F0000000000000000000 + 0000000000000000000000000000000000000000000000000008FFFF07000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 00000000000000006CF9F9F9F9F9000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 000000000008D1FF070000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 000000000000000000000000000000000000000048F9F9F9F9F9EC0000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 000000000000000000000000000000000008FFFF070000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + ECF9F9F9F9F94800000000000000000000000000000000000000F00000000000 + 0000000000000000002DF500000000000000000000000000000000000008FFFF + 070000F0F5000000000000000000000000000000000000000000000000000000 + F0F5F5000000000000000000F0F5000000000000000000002DF5000000000000 + 00000000000000000000000000F9F9F9F9F96C00000000000000000000000000 + 0000000000000000000000000000000000000007FFFFFFFFF631000000000000 + 08FFFF070000000000AAFFFF55F0FFFFFFFF07000000000008FFFF0700000000 + 0007FFFF08000000000007F6FFFFFFFFFF820000000007FFFFFFFFF700F5F6FF + 8607F6FFFFFFFF082D00000000000000000000000000000000F9F9F9F9F99000 + 00000000000000000000000000000000000000000000000000000000000008FF + FFFFF6FFFFFFF7000000000008FFFF07000000000008FFFF07FFFFFFFFFFFF86 + 0000000008FFFF07000000000007FFFF0800000000AFF6FFFFF6F6F6F6FF0000 + 0031FFFFFFFFF6FF082DFFFF55FFFFFFF6F6F6FFFF3100000000000000000000 + 00000000006CF9F9F9F9F9000000000000000000000000000000000000000000 + 000000000000000000AFFFFFFFF70708FFFFFF070000000008FFFF0700000000 + 0008FFFFFFFF860782FFFFFF0700000008FFFF07000000000007FFFF08000000 + AFFFFFFFF72DF5F50708000000F6FFFFFFF707F6FFFFFFFF3107FF59F5F5F7FF + FFF6F5000000000000000000000000000048F9F9F9F9F9EC0000000000000000 + 00000000000000000000F000000000000000000007FFFFFFF000000031FFFFFF + 00000000AAFFF607000000000008FFFFFFF700000007FFFFFF00000008FFF607 + 000000000007FFD108000007FFFFFFF00000000000000000F5FFFFFF31000000 + 86FFFFF60700000000ECEC07FFFF82ECECECECECECECECECECECECECEC24F9F9 + F9F9F948ECECECECECEC00000000000000000000000000000000000000000000 + FFFFFF07000000000082FFFFF700000008FFFF070000000000AAFFFFFF000000 + 0000F6FFFF070000AAFFFF07000000000007FFFF080000F6FFFF070000000000 + 0000000007FFFFF60000000000FFFFFF0700000048F9F9F9FFFFF6F9F9F9F9F9 + F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F96C000000000000000000 + 00000000000000000000002DFFFFFF000000000000F5F6FFFF00000008D1FF07 + 000000000008FFFF86000000000007FFFF86000008FFFF07000000000007F6FF + 0800F0FFFFFF00000000000000000000F7FFFF820000000000D1FFFF07000000 + ECF9F9F9FFFFFFF9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9 + F9F9F90000000000000000000000000000000000000000F7FFFF070000000000 + 0000F6FFFF31000008FFFF07000000000008FFFF070000000000F5FFFFFF0000 + 08FFFF07000000000007FFFFAA0007FFFF080000000000000000000008FFFF07 + 000000000008FFFF07000000006CF9B6FFFFFFF9F9F9F9F9F9F9F9F9F9F9F9F9 + F9F9F9F9F9F9F9F9F9F9F9F9F9F9F94800000000000000000000000000000000 + 000000F6FFFF310000000000000082FFFFF7000008FFF6070000000000AAFFF6 + 07000000000000FFFFFF0000AAFFF607000000000007FFFF080007FFFF070000 + 000000000000000008FFF6070000000000AAFFF607000000000001CCFFFFAA24 + 48484848484848484848484848486CF9F9F9F9F9014848484848482400000000 + 000000000000F00000000000000000FFFFFF000000000000000007FFFF080000 + AAFFFF07000000000008FFFF07000000000000FFFFF6F50008FFFF0700000000 + 0007FFFF8600AAFFFF5500000000000000000000AAFFFF07000000000008FFFF + 07000000000082FFFFFF5100000000000000000000000000000024F9F9F9F9F9 + EC00000000000000000000000000000000002800000000000000F5F6FFFF0000 + 000000000000F5F6FFFF000008FFFF07000000000008D1FF07000000000000FF + FFFFF50008FFFF07000000000007F6FF080008FFFFF7F1F4F5F5F5F5F52DF500 + 08FFFF07000000000008D1FF07000000F5F6FFFFFFC8F9240000000000000000 + 00000000000000F9F9F9F9F9480000000000000000000000000000000000F000 + 000000000000F5FFF6AF0000000000000000F5FFFFFF000008FFFF0700000000 + 0008FFFF07000000000000FFFFF6F500AAFFFF07000000000007FFFFAA0008FF + FFFFFFFFFFFFFFFFFFFFFF0008FFFF07000000000008FFFF07000031FFFFFFFF + F790F9F9240000000000000000000000000000F9F9F9F9F99000000000000000 + 00000000000000000000000000000000000007FFFFAA000000000000000000FF + FFFF0000AAFFFF07000000000008FFF607000000000000FFFFFFF50008FFF607 + 000000000007FFFF080082FFFFFFF6F6F6F6FFFFFFFFFF00AAFFF60700000000 + 0008FFF6070031FFFFFFFF07000090F9F9240000000000000000000000000090 + F9F9F9F9F90000000000000000000000000000000000F00000000000000007FF + FF08000000000000000000FFFFFFF50008FFFF070000000000AAFFFF07000000 + 000000FFFFFF000008FFFF07000000000007FFFFAA0007FFFF07F5F5F5F5F5F0 + FFFFFF0086FFFF070000000000AAFFFF0700FFFFFF08F00000000090F9F9EC00 + 000000000000000000000048F9F9F9F9F9000000000000000000000000000000 + 0000000000000000000007F6FF08000000000000000000FFFFFFF100AAFFFF82 + 000000000008FFFF070000000000F5F6FFF60000AAFFFF07000000000007FFFF + 080031FFFFF7000000000000FFFFAF0008FFFF07000000000008FFFF5531FFFF + F600000000000000F9F9F9EC000000000000000000000024F9F9F9F9F9EC0000 + 0000000000000000000000000000000000000000000007FFFFAA000000000000 + 000000FFFFFFF40008FFFFFF000000000008FFFF86000000000007FFF6AF0000 + 08FFFFF7000000000007FFFF080000FFFF080000000000F0FFFF0800AAFFFF07 + 000000000008FFFF3108FFFF3100000000000000ECF9F9F9EC00000000000000 + 00000000F9F9F9F9F94800000000000000000000000000000000000000000000 + 000007FFFF08000000000000000000FFFFF6F50008FFFFFF0700000000AAFFFF + FF000000000008FFFF07000008FFFFF6000000000008FFFF07000008FFFF0000 + 00000007FFFF070008FFF607000000000008FFFF3186FFF6F100000000000000 + 00ECF9F9F90000000000000000000000F9F9F9F9F96C00000000000000000000 + 000000000000000000000000000007FFFF08000000000000000000FFFFFFF500 + AAFFFFFFFF0700000008FFFFFF0700000031FFFFFFF50000AAFFFFFF07000000 + F0FFFFFF31000007FFFFF700000000F6FFFFF000AAFFFF070000000000AAFFFF + 5507FFFF07000000000000000000ECF9F9900000000000000000000090F9F9F9 + F990000000000000000000000000000000000000000000000000F5F6FF080000 + 000000000000F5F6FFFF000008FFFF07FFFFFF08F186FFFFFFFF07F159FFFFFF + 0800000008FFFFFFFF07F531FFFFFFFF00000000FFFFFF070000F7FFFF080000 + 08FFFF07000000000008FFFF3100FFFFFF31000031820000000000ECF9F99000 + 000000000000000048F9F9F9F9F900000000000000000000000000000000F000 + 000000000000F5FFFFFF0000000000000000F5FFFFFF000008FFFF00FFFFFFFF + F4AAFFFFF0FFFFFFFFFFFFFFF000000008FFFF07FFFFFFFFFFFFFF0700000000 + F0F6FFFFFFFFFFFFFFF1000008FFFF07000000000008FFFF070007FFFFFFFFFF + FFFFF0000000000024F9F990000000000000000024F9F9F9F9F9EC0000000000 + 00000000000000000000000000000000000000FFFFFF000000000000000007FF + FFF60000F6F6FF00F0F6FFFFF108F6FF0031FFFFFFFFFF2D00000000AAFFFF31 + F0F6F6FFFFFFF7000000000000F108FFFFFFFFFFF000000008F6FF0700000000 + 0008F6FF07000007FFFFFFFFF6FF2D00000000000024F9F96C00000000000000 + 00F9F9F9F9F948000000000000000000000000000000000000000000000000F6 + FFFF2D00000000000000F7FFFF8200002DF52D0000003107F0F52DF500000031 + 073100000000000008FFFF550000F50707F0000000000000000000F007072D00 + 00000000F52DF5F00000000000F52DF5F000000000310707F500000000000000 + 000024F9F96C00000000000000F9F9F9F9F96C00000000000000000000000000 + 0000000000000000000000F7FFFF0700000000000000F6FFFF07000000000000 + 000000000000000000000000000000000000000008D1FF070000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 00000000000000000000000000000024F9F96C00000000000090F9F9F9F99000 + 00000000000000000000000000000000000000000000002DFFFFF60000000000 + 0000FFFFFFF00000000000000000000000000000000000000000000000000000 + 08FFFF0700000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000024F9F948 + 000000000048F9F9F9F9F9000000000000000000000000000000000000000000 + 00000000F6FFF6F50000000000F7FFFFAF000000000000000000000000000000 + 00000000000000000000000008FFF60700000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 00000000000000000001F9F9240000000024F9F9F9F9F9EC0000000000000000 + 000000000000F000000000000000000031FFFFF600000000F5F6FFF631000000 + 000000000000000000000000000000000000000000000000AAFFFF0700000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000007312D07318200D1000000006CF9F92400000000F9F9 + F9F9F92400000000000000000000000000000000000000000000000000AFF6FF + F631F555FFFFFFAF000000000000000000000000000000000000000000000000 + 0000000008FFFF07000000000000000000000000000000000000000000000000 + 00000000000000000000000000000000000000000000072DF0AA07F6F5080000 + 0000006CF9F924000000F9F9F9F9F90100000000000000000000000000000000 + 00000000000000000000AFFFFFFFFFFFFFFFFFF0000000000000000000000000 + 0000000000000000000000000000000008FFFF07000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 000007F50008AF3107070000000000006CF9F9EC000090F9F9F9F99000000000 + 0000000000000000000000000000000000000000000000F7FFFFFFFFFF080000 + 0000000000000000000000000000000000000000000000000000000008FFFF07 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000072D00FFF700AF07000000000000006CF9F9 + EC0001F9F9F9F9F9000000000000000000000000000000000000000000000000 + 0000000000310707F00000000000000000000000000000000000000000000000 + 000000000000000008FFFF070000000000000000000000000000000000000000 + 00000000000000000000000000000000000000000000000000F7AF0807082D00 + F707000000000000000090F9F9EC24F9F9F9F9F9000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 000000000000000000000000000000000000000000000090F9F9ECF9F9F9F9F9 + 2400000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000090F990F9F9F9F9F94800000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 000000000000000000000000000000000090F9F9F9F9F9F99000000000000000 + 000000000000F000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 00000000000000000000000000000000000000000000000000000000000090F9 + F9F9F9F9F9000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000F9F9F9F9F9F9000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000ECF9F9F9F9F9EC0000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 00000000ECF9F9F9F94800000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000ECF9F9F96C00000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 000000000000000000000000000000000000000000000000000000000000ECF9 + F9F9000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000F00000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 00000000000000000000000000000000000000000000F0000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 00000000000000000000000000000000000000000000F0000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000EC0000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 000000000000000000000000000000000000F000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 000000000000000000000000000000000000000000000000000000000000EC00 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 00000000000000000000EC000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 00000000000000000000000000000000000000000000F0000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000EC0000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000} + end + end + object btnOK: TButton + Left = 367 + Top = 277 + Width = 88 + Height = 25 + Cancel = True + Caption = 'OK' + ModalResult = 2 + TabOrder = 1 + OnClick = btnOKClick + end +end diff --git a/components/orpheus/ovcabot0.lrs b/components/orpheus/ovcabot0.lrs new file mode 100644 index 000000000..28e07d573 --- /dev/null +++ b/components/orpheus/ovcabot0.lrs @@ -0,0 +1,1323 @@ +LazarusResources.Add('TOvcfrmAboutForm','FORMDATA',[ + 'TPF0'#16'TOvcfrmAboutForm'#15'OvcfrmAboutForm'#4'Left'#3#202#0#3'Top'#3#223#0 + +#11'BorderStyle'#7#8'bsDialog'#7'Caption'#6#13'About Orpheus'#12'ClientHeigh' + +'t'#3'7'#1#6'Height'#3'7'#1#11'ClientWidth'#3#216#1#5'Width'#3#216#1#5'Color' + +#7#9'clBtnFace'#12'Font.Charset'#7#15'DEFAULT_CHARSET'#10'Font.Color'#7#12'c' + +'lWindowText'#11'Font.Height'#2#245#10'Font.Style'#11#0#8'OnCreate'#7#10'For' + +'mCreate'#13'PixelsPerInch'#2'`'#10'TextHeight'#2#13#0#6'TBevel'#0#4'Left'#2 + +#6#3'Top'#3#9#1#5'Width'#3#195#1#6'Height'#2#17#5'Shape'#7#9'bsTopLine'#0#0#6 + +'TLabel'#0#4'Left'#3#152#0#3'Top'#2#8#5'Width'#2';'#6'Height'#2#16#7'Caption' + +#6#7'Orpheus'#12'Font.Charset'#7#15'DEFAULT_CHARSET'#10'Font.Color'#7#12'clW' + +'indowText'#11'Font.Height'#2#243#10'Font.Style'#11#6'fsBold'#0#10'ParentFon' + +'t'#8#0#0#6'TLabel'#0#4'Left'#2#7#3'Top'#3#17#1#5'Width'#3#232#0#6'Height'#2 + +#13#7'Caption'#6',Copyright '#169' 1995-2003 TurboPower Software Co'#0#0#6'T' + +'Label'#0#4'Left'#2#7#3'Top'#3'!'#1#5'Width'#2'V'#6'Height'#2#13#7'Caption'#6 + +#20'All rights reserved.'#0#0#6'TLabel'#6'Label1'#4'Left'#3#151#0#3'Top'#2'(' + +#5'Width'#3'"'#1#6'Height'#2'1'#8'AutoSize'#8#7'Caption'#6#144'Orpheus was r' + +'eleased under the Mozilla 1.1 license in January, 2003. The project is host' + +'ed on SourceForge at sourceforge.net/projects/tporpheus.'#8'WordWrap'#9#0#0 + +#6'TLabel'#12'VisitUsLabel'#4'Left'#3#153#0#3'Top'#2'l'#5'Width'#3#194#0#6'H' + +'eight'#2#13#7'Caption'#6'(Visit the Orpheus project on SourceForge'#0#0#6'T' + +'Label'#12'lblTurboLink'#4'Left'#3#161#0#3'Top'#2'|'#5'Width'#3#204#0#6'Heig' + +'ht'#2#13#6'Cursor'#7#11'crHandPoint'#7'Caption'#6'*http://sourceforge.net/p' + +'rojects/tporpheus/'#12'Font.Charset'#7#15'DEFAULT_CHARSET'#10'Font.Color'#7 + +#6'clBlue'#11'Font.Height'#2#245#10'Font.Style'#11#11'fsUnderline'#0#10'Pare' + +'ntFont'#8#7'OnClick'#7#17'lblTurboLinkClick'#0#0#6'TBevel'#6'Bevel3'#4'Left' + +#3#152#0#3'Top'#3#160#0#5'Width'#3'1'#1#6'Height'#2'`'#5'Shape'#7#7'bsFrame' + +#0#0#6'TLabel'#22'GeneralNewsgroupsLabel'#4'Left'#3#160#0#3'Top'#3#168#0#5'W' + +'idth'#2'q'#6'Height'#2#13#7'Caption'#6#22'Orpheus support groups'#0#0#6'TLa' + +'bel'#7'lblHelp'#4'Left'#3#168#0#3'Top'#3#198#0#5'Width'#3#20#1#6'Height'#2 + +#13#6'Cursor'#7#11'crHandPoint'#7'Caption'#6'6http://sourceforge.net/forum/f' + +'orum.php?forum_id=241874'#12'Font.Charset'#7#15'DEFAULT_CHARSET'#10'Font.Co' + +'lor'#7#6'clBlue'#11'Font.Height'#2#245#10'Font.Style'#11#11'fsUnderline'#0 + +#10'ParentFont'#8#7'OnClick'#7#12'lblHelpClick'#0#0#6'TLabel'#20'lblGeneralD' + +'iscussion'#4'Left'#3#168#0#3'Top'#3#230#0#5'Width'#3#20#1#6'Height'#2#13#6 + +'Cursor'#7#11'crHandPoint'#7'Caption'#6'6http://sourceforge.net/forum/forum.' + +'php?forum_id=241873'#12'Font.Charset'#7#15'DEFAULT_CHARSET'#10'Font.Color'#7 + +#6'clBlue'#11'Font.Height'#2#245#10'Font.Style'#11#11'fsUnderline'#0#10'Pare' + +'ntFont'#8#7'OnClick'#7#25'lblGeneralDiscussionClick'#0#0#6'TLabel'#6'Label3' + +#4'Left'#3#168#0#3'Top'#3#217#0#5'Width'#2'^'#6'Height'#2#13#7'Caption'#6#19 + +'General Discussion:'#0#0#6'TLabel'#6'Label2'#4'Left'#3#168#0#3'Top'#3#186#0 + +#5'Width'#2#25#6'Height'#2#13#7'Caption'#6#5'Help:'#0#0#6'TPanel'#6'Panel1'#4 + +'Left'#2#6#3'Top'#2#6#5'Width'#3#139#0#6'Height'#3#251#0#10'BevelOuter'#7#9 + +'bvLowered'#8'TabOrder'#2#0#0#6'TImage'#6'Image1'#4'Left'#2#1#3'Top'#2#1#5'W' + +'idth'#3#137#0#6'Height'#3#249#0#5'Align'#7#8'alClient'#12'Picture.Data'#10 + +'n'#140#0#0#7'TBitmapb'#140#0#0'BMb'#140#0#0#0#0#0#0'6'#4#0#0'('#0#0#0#137#0 + +#0#0#249#0#0#0#1#0#8#0#0#0#0#0','#136#0#0#0#0#0#0#0#0#0#0#0#1#0#0#0#1#0#0#0#0 + +#0#0#0#0#128#0#0#128#0#0#0#128#128#0#128#0#0#0#128#0#128#0#128#128#0#0#128 + +#128#128#0#192#220#192#0#240#202#166#0#170'?*'#0#255'?*'#0#0'_*'#0'U_*'#0#170 + +'_*'#0#255'_*'#0#0'*'#0'U*'#0#170'*'#0#255'*'#0#0#159'*'#0'U'#159'*'#0 + +#170#159'*'#0#255#159'*'#0#0#191'*'#0'U'#191'*'#0#170#191'*'#0#255#191'*'#0#0 + +#223'*'#0'U'#223'*'#0#170#223'*'#0#255#223'*'#0#0#255'*'#0'U'#255'*'#0#170 + +#255'*'#0#255#255'*'#0#0#0'U'#0'U'#0'U'#0#170#0'U'#0#255#0'U'#0#0#31'U'#0'U' + +#31'U'#0#170#31'U'#0#255#31'U'#0#0'?U'#0'U?U'#0#170'?U'#0#255'?U'#0#0'_U'#0 + +'U_U'#0#170'_U'#0#255'_U'#0#0'U'#0'UU'#0#170'U'#0#255'U'#0#0#159'U'#0'U' + +#159'U'#0#170#159'U'#0#255#159'U'#0#0#191'U'#0'U'#191'U'#0#170#191'U'#0#255 + +#191'U'#0#0#223'U'#0'U'#223'U'#0#170#223'U'#0#255#223'U'#0#0#255'U'#0'U'#255 + +'U'#0#170#255'U'#0#255#255'U'#0#0#0''#0'U'#0''#0#170#0''#0#255#0''#0#0#31 + +''#0'U'#31''#0#170#31''#0#255#31''#0#0'?'#0'U?'#0#170'?'#0#255'?'#0#0 + +'_'#0'U_'#0#170'_'#0#255'_'#0#0''#0'U'#0#170''#0#255''#0#0#159'' + +#0'U'#159''#0#170#159''#0#255#159''#0#0#191''#0'U'#191''#0#170#191''#0 + +#255#191''#0#0#223''#0'U'#223''#0#170#223''#0#255#223''#0#0#255''#0'U' + +#255''#0#170#255''#0#255#255''#0#0#0#170#0'U'#0#170#0#170#0#170#0#255#0 + +#170#0#0#31#170#0'U'#31#170#0#170#31#170#0#255#31#170#0#0'?'#170#0'U?'#170#0 + +#170'?'#170#0#255'?'#170#0#0'_'#170#0'U_'#170#0#170'_'#170#0#255'_'#170#0#0 + +''#170#0'U'#170#0#170''#170#0#255''#170#0#0#159#170#0'U'#159#170#0#170 + ,#159#170#0#255#159#170#0#0#191#170#0'U'#191#170#0#170#191#170#0#255#191#170#0 + +#0#223#170#0'U'#223#170#0#170#223#170#0#255#223#170#0#0#255#170#0'U'#255#170 + +#0#170#255#170#0#255#255#170#0#0#0#212#0'U'#0#212#0#170#0#212#0#255#0#212#0#0 + +#31#212#0'U'#31#212#0#170#31#212#0#255#31#212#0#0'?'#212#0'U?'#212#0#170'?' + +#212#0#255'?'#212#0#0'_'#212#0'U_'#212#0#170'_'#212#0#255'_'#212#0#0''#212#0 + +'U'#212#0#170''#212#0#255''#212#0#0#159#212#0'U'#159#212#0#170#159#212#0 + +#255#159#212#0#0#191#212#0'U'#191#212#0#170#191#212#0#255#191#212#0#0#223#212 + +#0'U'#223#212#0#170#223#212#0#255#223#212#0#0#255#212#0'U'#255#212#0#170#255 + +#212#0#255#255#212#0'U'#0#255#0#170#0#255#0#0#31#255#0'U'#31#255#0#170#31#255 + +#0#255#31#255#0#0'?'#255#0'U?'#255#0#170'?'#255#0#255'?'#255#0#0'_'#255#0'U_' + +#255#0#170'_'#255#0#255'_'#255#0#0''#255#0'U'#255#0#170''#255#0#255''#255 + +#0#0#159#255#0'U'#159#255#0#170#159#255#0#255#159#255#0#0#191#255#0'U'#191 + +#255#0#170#191#255#0#255#191#255#0#0#223#255#0'U'#223#255#0#170#223#255#0#255 + +#223#255#0'U'#255#255#0#170#255#255#0#255#204#204#0#255#204#255#0#255#255'3' + +#0#255#255'f'#0#255#255#153#0#255#255#204#0#0''#0#0'U'#0#0#170''#0#0#255 + +''#0#0#0#159#0#0'U'#159#0#0#170#159#0#0#255#159#0#0#0#191#0#0'U'#191#0#0#170 + +#191#0#0#255#191#0#0#0#223#0#0'U'#223#0#0#170#223#0#0#255#223#0#0'U'#255#0#0 + +#170#255#0#0#0#0'*'#0'U'#0'*'#0#170#0'*'#0#255#0'*'#0#0#31'*'#0'U'#31'*'#0 + +#170#31'*'#0#255#31'*'#0#0'?*'#0'U?*'#0#240#251#255#0#164#160#160#0#128#128 + +#128#0#0#0#255#0#0#255#0#0#0#255#255#0#255#0#0#0#255#0#255#0#255#255#0#0#255 + +#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#247#0#0#0#0#0#0#245#240#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'U'#255 + +#240#0#0'-'#240#7#255#240#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'1'#245#255'1'#0'1'#255 + +'-'#8#175#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#245'-'#0#0'1'#255#240#246#246'-'#7#255#0#255#7 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#7#255#240#0#245#255'1'#247#255'-'#7#8#245#255#246#240 + +#247#246#245#245'Y'#241#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#246#255#7'-'#170#134'-'#255#240#134#7#7#246 + +#245'-'#255#7#240#255#255#240#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'-'#0#175#255#130#245#255#241#255#240#171 + +'1'#8#247#0#255'^'#240#255#8#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#247#0#8#255#236#8'1'#8'U'#8'-' + +#255#236#175#130#240#255#255#7#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#247#255#247#0#8#134'U'#130#7#134 + +#134'1'#8#247#8#240#255#255#7#240#245'-'#0#0#0#0#0#0#0#0#0#0#7'-'#0#0#0#0#0 + +#245#130#175#8'1'#0#0#0'1'#7#0#0#0#240#247#245'-'#7#247#7'1'#0#0#0#0#0#0#7 + +#170#175#170#7#0#0#0#0'-'#247#0#0#0#0#0#0#0#0#0#7#170#175#8#7#0#0#0#0#0#0#0 + +'1'#241#0#0#0#0#0'1'#0#0#0#0#240#7#7#7#247#7#247#0'-'#7#0#0#0#240#247'-'#0#0 + +#0#0#0#0#0#0#0#0#240#245#0#0#240#245#255#170#0#212#8#8'1'#255#130#247#246#134 + +#241#255#7#0#245#170#255#255#245#0#0#0#0#0#0#0#0#0#255#130#0#0#0#0#7#255#255 + +#170#175#255#134#0#0#8#255#0#0#0#175#255#240#175#255#246#255#255#246#240#0#0 + +'1'#255#255#175#8#175#255#246'-'#0#0#7#255#0#0#0#0#0#0#0'-'#255#255#175#170 + ,#175#255#255'1'#0#0#0#0#0#8#7#0#0#0#0#0#255#245#0#0#0#245#255#255#255#255#255 + +#255#240#8#255#0#0#0#175#255#240#0#0#0#0#0#0#0#0#0#0#245#246#246#247#246'1'#0 + +#8#175#0#170#255#7#8'1'#134#209#245#246#7'1'#175#246#134'1'#240#245'U'#0#0#0 + +#0#0#0#0#0#255#247#0#0#0#240#255#130#0#0#0'1'#255'U'#0#170#255#0#0#247#246 + +#245#0#8#8#0#0#240#255#175#0'-'#246#8#240#0#0#0#240#175#246#245#0#7#255#0#0#0 + +#0#0#0'-'#255#8#240#0#0#0#240#8#246'1'#0#0#0#0#255#246#0#0#0#0'U'#255#7#0#0#0 + +#240#255'1'#0#0#0#0#0#134#246#0#0#7#255#245#0#0#0#0#0#0#0#0#0#0#0#0#7#134#255 + +#255#255#130#240'Z'#8#241#134'-'#0#0#0#0#246#255#134#134'U'#241'-'#7#246#255 + +#255#7#0#0#0#0#0#0#0#255#247#0#0#0'Z'#255#0#0#0#0#0#175#8#0#134#246#0#240#255 + +#247#0#0#175#170#0#0#0#7#255#0#255#175#0#0#0#0#0#0#0#246#246#0#7#255#0#0#0#0 + +#0#0#255#246#0#0#0#0#0#0#0#175#246#0#0#0#7#255#255#245#0#0#0#8#255#246#0#0#0 + +#245#255'1'#0#0#0#0#0#134#209#0#240#255#247#0#0#0#0#0#0#0#0#0#0#0#0#0#240'-' + +#240#245'U'#134#209#8#246#246#0#0#0#0#0#0'-'#7'U'#247#8#255#255#246#175'1' + +#240#0#0#0#0#0#0#0#0#255#247#0#0#0#170#255#0#0#0#0#0#247#255#0#134#175#0#209 + +#8#0#0#0#175#170#0#0#0#247#246#7#255#240#0#0#0#0#0#0#0#245#255'-1'#255#0#0#0 + +#0#0'1'#255#245#0#0#0#0#0#0#0#241#255'1'#0#0#255#134#175#247#0#0#241#255#247 + +#255'-'#0#0#240#255'1'#0#0#0#0#0#170#8#0#209#8#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#245#255#255#175#247'1-1'#247#247#0#0#0#0#0#0#0#8#255#130#7#240#241'11'#0#0#0 + +#0#0#0#0#0#0#0#246#247#0#0#0#134#246#0#0#0#0#0#7#255#0#130#255#8#255'1'#0#0#0 + +#175#8#0#240#7#255#7#247#255#0#0#0#0#0#0#0#0#0#255#7'1'#246#247#247'1'#0#0 + +#247#255#0#0#0#0#0#0#0#0#0#255#134#0'-'#255#240#7#255#0#0#247#255#0#209#8#0#0 + +#241#246'1'#0#0#0#0#0#134#209#8#255'1'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'1U'#7 + +#130#170#134#170#130'1'#0#0#0#0#0#0#0#7#130#134#134#134#247'11-'#0#0#0#0#0#0 + +#0#0#0#255#247#0#0#0#8#209#0#0#0#0#0#7#255#0#247#255#8#8#255#134#0#0#8#255 + +#255#255#255#7#0#8#209#0#0#0#0#0#0#0#0#0#255#247'1'#255#175#246#255#246#0#130 + +#246#0#0#0#0#0#0#0#0#0#175#170#0#8#255#0#0#255'1'#0#255#247#0#7#255#240#0#240 + +#255#175#134#170#212#134#0#130#255#8#8#255#170#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +'11'#245#245#7#134#255#134#0#0#0#0#0#0#0#134#7'1-'#7#130#246#255#255#245#0#0 + +#0#0#0#0#0#0#255#247#0#0#0#134#246#0#0#0#0#0#247#255#0#130#246#0#0#245#255#7 + +#0#8#170#0'-'#255'1'#0#130#255#0#0#0#0#0#0#0#0#0#255#7'1'#255#0#0#240#255#134 + +#7#255#0#0#0#0#0#0#0#0#0#255#247#0#255#7#0#0#175#8'-'#246#240#0#0#255#7#0#241 + +#255#175#170#8#8#170#0#130#209#0#0#245#255#7#0#0#0#0#0#0#0#0#0#0#0#240#241'1' + +#246#255#246#246#170#7'1'#7'-'#0#0#0#0#0#0#255#246#8#209#134'1'#245#240'-' + +#240#0#0#0#0#0#0#0#0#255#247#0#0#0#8#209#0#0#0#0#0#7#255#0#134#255#0#0#0#170 + +#171#0#175#8#0#0#7#255#0'1'#246#245#0#0#0#0#0#0#0'1'#255#240'1'#255#0#0#0'U' + +#255#245#255'1'#0#0#0#0#0#0#0'-'#246#245'1'#255#240#0#0'1'#255#246#175#0#0#0 + +#8#255#0#240#255'1'#0#0#0#0#0#134#246#0#0#0#130#175#0#0#0#0#0#0#0#0#0#0#0#130 + +#255#246#175#7'-'#241#7#134#170#255#8#0#0#0#0'-'#8'-'#170#7#240#134#255#255 + +#255#8'1'#0#0#0#0#0#0#0#0#255#7#0#0#0#134#246#0#0#0#0#0#7#255#0#130#246#0#0#0 + +#8#8#0#8#170#0#0#7#255#0#0#246#246#0#0#0#0#0#0#0#255#175#0#7#255#0#0#0#7#255 + +#0#8#255#0#0#0#0#0#0#0#255#175#0#255#8#0#0#0#0#255#255'1'#0#0#0'-'#255#245#0 + +#255'1'#0#0#0#0#0#134#175#0#0#0#8#8#240'-'#245#0#0#0#0#0#0#0#0#0'1'#245#240 + +'1'#8#246#8'-'#247#8'-'#246#247'1'#134#7#255#8#245#175#130#0'Y'#255#247#246 + +#246#0#0#0#0#0#0#0#0#255#247#0#0#0#170#246#0#0#0#0#0#7#255#0#134#246#0#240#7 + +#255'1'#0#209#8#0#245#255#8#0#0#241#255#246#245#0#0#0'-'#255#255#240#0#7#255 + +#0#0'1'#255#170#0#240#255#255'-'#0#0#0'-'#246#255#240#245#246'1'#0#0#0#0#247 + +#255#0#0#0#0#0#255#134#236#255'1'#0#0#0#0#0#134#246#0#240#7#255#7'-'#247#7#0 + +#0#0#0#0#0#0#0#0#0'1'#255#246#134#241#0#247#175'-'#8#209#7#8#209'1'#134#247 + +#175#240#8#255#241#240#0#0#245#240#0#0#0#0#8#255#255#255#255#255#255'-'#134 + +#246#0#0#0#0#0#247#246#0#134#255#255#255#255#247#0#0#8#255#255#255#8#0#0#0#0 + +#240#175#246#255#255#255#255#8#240#0#0#7#255#255#255#255#8#0#0#0#240#8#255 + +#255#246#255#255#8#240#0#175#246#0#0#0#0#0'-'#247#0#0#0#0#0#7#255'1'#246#255 + +#255#255#255#255#240#130#246#255#255#255'^'#0'-'#7#7#0#0#0#0#0#0#0#0#0#0#0'1' + +#241#240#247#255#255#240#171#7#8'-'#170#8#7#134'-'#130#246#0#134#255#7#0#0#0 + +#0#0#0#0#0'-11-111'#0#245'-'#0#0#0#0#0#241'1'#0#241'11-'#0#0#0#0#245'1-'#240 + +#0#0#0#0#0#0#0'-'#7#247#7#245#0#0#0#0#240'11-'#240#0#0#0#0#0#0#245#7#130#7 + +#245#0#0#0'1'#245#0#0#0#0#0#0#240#0#0#0#0#0#0'1'#245'-11111'#0#241'11-'#240#0 + +#0#0#245#0#0#0#0#0#0#0#0#0#0#0#0#0#0#7#255#246#240#8#8#240#175'1'#134#7#170#7 + +#8#0#255#175#0#130#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#240#175#246#0#130#246#0#8#130#7#130#245#246 + +#245#246#240#247#255#246#0'1'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + ,#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#245#255#255#240'Z'#255#241'1'#255'U'#134 + +#247'-'#255#245#175#247#240#7#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#240#7#240'1'#255#7#240#255#255 + +#245#255#7'1'#255#7'U'#255#240#0#240#255'1'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#7#255#240 + +#255'1U'#246#8#241#255'-'#0#0#245#240#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#246#134'-'#255'-' + +#0'1'#255#240'1'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#245#246'1'#240#245#0#0#241#246 + +'1'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#240#245#0#0#0#0#0#0#247#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#13#244#244#244#13#13#12#245#244#244#244#13#13#13#13 + +#240#0#0#240#244#0#244#244#240#245#12#245#0#245#17#17#21#16#17#17#245#240#0 + +#240#240#244#0#240#13#12#13#245#244#245#17#12#0#240#241#0#240#240#0#0#245#245 + +#12#17#13#244#240#0#240#0#240#17#244#13#13#244#244#13#17#244#245#244#245#244 + +#13#17#12#245#240#245#240#0#240#244#240#0#241#240#240#244#240#13#12'-5'#244 + +#245#244','#244')'#244'5,,(UX,UTLLLytqpq'#148#187#152#187#152#187#149#186#187 + +#0#0#0#12#240#0#0#244#13#244#240#245#240#241#0#0#0#0#240#0#240#0#245#244#0 + +#245#244#0#241#244#0#240#12#17#13#13#240#240#244#0#240#0#240#245#0#0#240#245 + +#240#244#240#244#13#245#240#0#240#245#0#240#0#240#240#12#13#21#244#0#0#240#0 + +#0#240#245#240#0#0#240#245#240#240#0#244#244#240#0#240#13#17#244#244#244#0 + +#240#240#245#244#240#240#240#240#241#244'10'#244'5,'#244'-'#240',,,1,((0U,UT' + +'(MLxLqp'#152#149#182#153#148#187#148#186#149#148#0#0#0#13#241#0#0#245#12#13 + +#0#244#240#244#0#0#240#0#0#240#0#0#240#240#241#244#245#244#244#240#245#244 + +#245#244#12#13#245#12#13#245#0#0#0#244#0#240#0#0#0#245#240#244#0#240#240#240 + +#0#240#240#240#0#244#13#240#0#245#240#0#0#0#240#0#0#244#0#240#0#240#244#0#0 + +#240#13#25#240#0#240#244#13#245#240#245#240#0#240#12#241#240#240#240#244#240 + +#244#13#13#244'5'#244'('#244'-'#244'),4-,(0UPXQLLLyLL'#149#186#153#152#148 + +#153#148#153#153#152#153#0#0#0#12#244#240#240#244#13#12#240#245#244#0#240#0#0 + +#240#0#0#240#0#244#245#244#240#0#245#0#245#13#240#244#245#12#17#12#13#12#244 + +#240#0#240#244#0#0#0#240#244#17#244#245#240#241#0#0#244#240#0#0#13#13#244#240 + +#0#0#236#0#240#240#0#0#240#17#240#0#0#240#245#0#240#244#17#17#244#241#244#17 + +#12#244#244#244#0#240#240#13#244#240#240#241#240#240#244'0014-'#244',,,,,1,(' + +'(UT,UTLLM|M'#148#148#149#152#149#152#152#153#148#152#149#152#0#0#0#17#245 + +#244#17#17#12#245#240#244#0#245#17#244#0#240#0#240#0#240#240#0#244#13#244#240 + +#244#244#0#244#245#12#13#240#13#12#21#17#12#245#240#240#245#244#13#17#13#240 + +#245#244#0#240#240#240#241#240#0#240#13#244#0#13#17#13#17#17#13#17#12#240#241 + +#13#244#244#0#240#244#240#245#17#16#17#17#240#244#17#17#244#245#244#240#0#241 + +#12#240#240#240#244',1011010,,,-,,Y,((TUPUTMLLyp'#152#153#152#153#152#153#153 + +#148#152#153#152#153#0#0#0#244#240#240#240#245#13#12#240#245#240#240#245#240 + +#0#0#240#0#0#240#245#245#240#244#0#240#241#240#240#240#244#13#12#240#244#13 + +#17#21#13#244#240#244#13#245#244#244#240#240#244#12#244#244#0#0#240#241#0#240 + +#13#17#240#244#12#12#245#12#13#244#13#244#240#240#244#245#0#240#245#240#244 + ,#21#21#16#13#244#13#12#13#244#244#245#240#240#240#13#244#244'110Y1X4U0U1,,,,' + +'PY,P(UTPYPLLux'#153#148#153#148#152#153#148#152#153#149#186#149#152#0#0#0 + +#245#240#0#240#244#12#245#240#244#240#240#244#240#0#240#0#240#0#0#240#244#245 + +#244#241#244#244#240#245#240#245#12#13#245#244#12#13#17#245#12#245#240#240 + +#244#17#240#0#13#13#13#17#13#240#0#240#240#0#240#0#245#21#17#13#17#13#12#13 + +#17#13#0#240#0#245#12#245#240#244#16'5'#17#17#17#244#244#17#13#17#244#245#244 + +#240#240#240#12'-0X4Y4YYYYXTUTUP,,Y,)PTYP|ULLPy'#152#153#148#153#149#152#187 + +#152#152#153#152#153#152#0#0#0#244#240#240#0#13#17#244#241#244#241#244#245#0 + +#240#0#0#240#0#240#0#240#240#244#240#0#245#244#0#244#244#245#12#13#244#13#13 + +#12#240#245#240#240#244#245#244#13#12#244#240#0#245#240#240#0#240#244#0#240#0 + +#240#244#244#244#244#244#245#244#244#244#0#0#0#240#244#17#12#13#21#21#17#17 + +#17#245#240#12#12'1'#244#244#245#240#240#244'1055YYYXY'#3#3'YYXU'#3'UTUYPPPU' + +'UPYtLqt'#156#149#152#153#152#152#153#148#153#152#148#153#152#153#0#0#0#244 + +#245#244#244#244#13#12#244#240#244#0#244#0#0#0#240#0#240#0#0#240#241#244#240 + +#244#244#0#244#240#13#244#13#12#17#21#12#244#245#12#12#13#244#0#0#13#12#245#0 + +#240#240#240#0#0#241#0#0#240#0#244#0#13#17#13#13#16#17#17#17#240#245#244#240 + +#0#241#244#13#240#245#12'9'#12#244#240#245#17#17#244#245#244#240#240'-05TYXY' + +'XY'#3'YY}'#3'YTUTYY'#3'QPPU|P}xMLt'#153#152#187#152#148#153#186#153#152#153 + +#187#152#153#148#0#0#0#12#244#244#17#17#12#245#240#245#240#244#241#244#245 + +#240#0#240#0#240#241#244#240#245#0#241#244#241#240#241#244#244#13#12#17#17#0 + +#245#244#13#245#244#13#244#240#13#13#244#240#245#244#245#244#244#244#245#240 + +#240#0#245'4'#13#12#13#12#13#244#13#12#240#240#13#0#244#244#12#17#244#12#13 + +#16#245#240#244#13'0'#17#244'0'#245#240',14U5XY'#3']'#3'Y}'#3#3'Y|YT}TT]T'#3 + +'U|UP}Tppu'#152#153#152#152#153#152#153#152#153#148#152#152#153#152#0#0#0#245 + +#12'5'#21#17#244#244#240#244#241#240#244#244#13#240#240#240#241#244#13#244 + +#240#244#244#240#244#240#244#240#13#244#13#13#12#17#240#240#244#240#240#17 + +#244#245#244#12#244#245#0#240#244#244#241#0#240#244#240#240'1'#17#17#12#13#12 + +#13#17#12#17#13#0#240#244#244#13'95'#17'999'#17#12#13#240#12#21'9'#245#12#245 + +#244'001XYY'#3'YYY\Y}Y|Y|}TyxY}'#3'}'#3'}T}yPqt'#153#152#153#153#152#153#152 + +#153#186#153#153#186#149#152#0#0#0'0-'#12#245#12#245#17#13#240#244#240#245#0 + +#0#13#240#240#240#240#0#244#13#244#241#240#244#245#240#240#12#245#16#17'9'#21 + +#245#13#244#245#240#17#13#240#13#17#17#12#240#245#13#240#240#240#245#240#0 + +#245#17#16#13#13#12#13#13#244#13#12#245#240#244#241#240#244#17#12'5'#17#13 + +#244#13#244#17#12'995'#12'1'#244',15T5XYY'#3#128'}Y'#128'Y'#128'}|Y|}|}'#160 + +'xyx}xy|xttt'#187#152#152#152#153#186#152#152#153#152#152#153#152#153#0#0#0 + +#13#12#13#12#13#244#13#12#244#244#241#244#0#240#17#240#0#0#0#0#13#13#244#240 + +#240#245#244#240#244#245#244#17#16#13#17#244#240#240#244#0#245#21#244#244#13 + +#244#13#240#240#244#244#0#240#240#240#240#240#244#245#13#12#13#12#12#13#12#13 + +#12#244#13#12#0#240#13#244#13#12#244#240#244#240#13'599'#17','#13#244',1TYXY' + +'Y'#3'Y]Y'#128'}'#128'}|}'#164#165#165#160#161#160#161#160#161#160#157'xyytu' + +#153#152#153#152#153#152#153#153#153#152#152#187#148#153#152#0#0#0'01'#12#17 + +#244#244#241#240#245#240#244#244#240#0#244#240#0#240#240#0#240#240#244#245 + +#244#244#241#244#245#12#13#17#17#244#244#240#244#13#13#244#240#12#13#21'5'#12 + +#13#244#241#244#245#240#240#245#240#0#240#245#244#12#17#13#17#13'0'#17#17#13 + +#240#245#244#245#12#17#13#244#13#245#244'51'#12#240#16'55'#12'01014YY'#3'Y' + +#129'Y||]}'#128'}'#165#164#165#198#164#198#165#164#165#160#160#161#160#161 + +#156#156'ytt'#153#152#153#152#153#152#152#186#153#153#152#153#152#148#0#0#0 + +'1459'#13#12#244#244#244#245#240#245#0#240#245#240#240#0#240#0#0#240#244#240 + +#240#244#244#240#244#13#16'9'#17#244#245#240#13#244#240#13'5'#244#12#13#244 + +#245#244#244#12#17#12#0#240#240#245#240#240#244#17#21#244#244#244#245#245#244 + +#12#245#240#244'50'#245#244#244#12#240'0=9'#17'5'#12'545'#13'001T1TXY'#3#3 + +#129'Y'#129'|}'#165#164#198#165#198#165#164#165#198#165#160#199#160#161#160 + +#161#161#156#156#157#156#152'u'#152#149#152#153#153#152#152#153#152#148#153 + +#153#0#0#0'05'#12#245#244#245#245#244#17#244#244#244#240#0#244#244#13#240#0 + +#240#240#240#245#244#245#245#244#245#244#13#17'9'#17'9'#244#240#244#245#0#244 + +#244#245#13'9'#17#12#13#13'9'#21#13#236#240#244#240#0#244#13#13#244'559'#12 + +#244#245#240#240#0#245#244#245#244#240#245'59'#17'5'#12',11'#17'5501101TYU'#3 + +'Y}'#3'}|'#129#164#164#199#164#199#164#198#199#199#164#164#199#164#161#164 + +#160#160#160#157#160#157#156#157#152#153't'#153#148#152#153#152#148#153#153 + +#152#148#0#0#0'15'#13#244#13#12#244#244#245#244#244#245#0#240#245#245#13#236 + +#240#240#0#240#244#244#240#12#244#244#244#13#244'1'#12'5'#13#240#13#244#236 + +#12#245#244#240#240#240#245#12#240#245#244#13#0#244#245#240#240#241#244#244 + +#12#17#12#13#244#245#12#13'1'#240#240#240#12#13'5'#12'995'#12'5'#13#244#244 + +'1450100UXUXY}'#3#129'|'#129#164#165#203#164#199#168#198#169#164#164#164#199 + ,#164#199#164#160#195#161#161#160#157#156#157#156#157#152#152#149#152#153#148 + +#153#152#153#152#148#153#0#0#0'05'#12'0'#17'4'#13#244#0#244#245#244#240#240 + +#244#240#244#0#0#240#240#240#245#244#245#244#13'5'#245#244#240#13#13#244#244 + +#244#244#245#244#245#244#12#245#12#0#240#13#0#240#240#244#240#240#244#241#240 + +#244#244#17'9955'#244#240#13'00'#240#244#244'-,01001010101,5010UTUXY'#3'}'#3 + +'}}'#164#199#164#198#203#164#202#165#198#203#198#199#164#198#164#199#165#160 + +#160#160#161#160#157#160#157#156#156'u'#152'q'#148#153#148#153#148#152#153 + +#148#0#0#0'5559999'#245#240#245#244#245#0#240#245#244#245#244#240#236#13'0' + +#13#244#244'1'#244#244#12#13#244'0'#244'-,1,,-'#244#245#244'15'#240#240#12 + +#240#245#244#245#240#245#244#240#240#240#244'1'#244#245#240#245#244#244'9'#13 + +#245',,101001010101055410101TUTY'#3'}|'#165#165#164#203#164#202#199#202#164 + +#203#164#169#198#169#199#164#198#164#199#161#160#161#160#160#157#156#157#156 + +#153#152#153't'#148'u'#148#153#149#148#153#0#0#0'50'#13','#17'5'#240#240#240 + +#244#244#244#240#240#244#244#244'5'#245#240#12#13#240#244#245'9'#13#240'1001' + +'100010,0,,'#13#244'0'#13#13#240#240#244#244#240#240#244#241#240#245'5'#13#12 + +#244#244#244'1'#240#241',,01010U1T1T10101451050UTUXY|}|}'#164#164#199#198#168 + +#199#168#199#202#203#198#202#199#198#164#199#164#199#164#164#194#161#160#157 + +#160#157#156#157#156#152'u'#148#153'q'#148'p'#148#153#148#0#0#0'010'#13'54' + +#244#241#240#13#244'-'#240#240#13#244#245'0'#240#240#245#245'45'#12',,'#240 + +'1010401101010-,,1'#13#12#240#245#244'1'#240#244#245#240#240#244'50'#13'5450' + +#244',0-10U0Y0T5T501T105Y\5]Y0TU'#3'y'#3'Y|'#165#164#199#202#169#198#203#198 + +#202#203#164#202#165#198#168#199#202#165#198#164#195#165#160#161#160#157#160 + +#157#156#157#157't'#152'qp'#152'q'#153#148#149#0#0#0'101015'#244#240#240#12 + +#245#12#240#240'1'#244#244#13#240#240'0'#244'5'#244'-'#244#245'005XYU5T01010' + +'100-,,1'#240#244#245#12#240#245','#244#240#245#12#13'095950-,00U0YTYYXYTYT5' + +'TY055'#3']\YUTUXy|}'#198#164#203#164#199#202#164#202#165#202#202#199#202#202 + +#199#164#198#165#198#165#164#160#165#160#161#160#157#156#157#156#156#153'qt' + +#152'qppqp'#0#0#0'X1X105'#244#240#240'1'#12#245#240#240#12#245#244'1'#244#240 + +'101,'#244',,YXYY'#3'XYYYXU41T10010-'#240','#12'1'#240#244#245#244#244#244'1' + +'10'#244'-,1,010UTY'#3'Y'#3'Y'#3'YYXUTUTUX]]]Y\YTU|Y|'#165#165#198#164#202 + +#164#203#203#202#202#165#202#168#199#168#202#199#168#198#165#198#165#194#160 + +#161#160#157#160#157#156#157#156#152'upqtqppq'#0#0#0'Y501T1,'#244#245'0'#244 + +'1'#240#244'-'#244',1'#240#244'105,,-XYY|YYY'#3#3'YYXUX10U10,0,'#244'-1'#240 + +#244','#241#244',001,01,01TUXU'#3'YY'#3'YY|'#3'YYXYTY'#3']a\]'#133'YT'#3'Ux}' + +#160#198#165#198#199#202#198#168#202#203#202#202#199#202#203#198#168#199#164 + +#198#165#198#165#160#160#161#160#161#156'}'#156#157'xtutqtqpp'#0#0#0'YXY010,' + +'54550'#240#244'5014'#244',51Y01T]]\]\]\YYY'#3'YYTUT1T01U,100,,1,,-19a]]40UT' + +'UTYY'#3'Y|'#129'Y|]YY'#3'}TUTU]\]Y\YTUy|}'#164#165#198#169#202#169#202#203 + +#203#164#203#203#168#203#198#169#198#199#202#199#164#199#160#199#161#160#161 + +'x'#157#156#157'x'#157'tuppqppq'#0#0#0#3'YYXT10Y5050'#240'1541Y,,]4]00Y'#128 + +#129#129#129#129#129#129#128']|YY'#3'YYTU0U00Q055,100100]]05TUTU'#3'Y}'#3#129 + +'Y'#128'Y'#128'Y}'#3'|Y'#3'YX}T]]]'#3'YTUx'#3'}'#160#165#198#203#198#198#202 + +#165#202#202#203#202#202#203#164#202#199#202#164#199#164#198#165#164#160#160 + +#161#160#161'|'#157'x'#157'xutpuLqLp'#0#0#0']'#3'YU4U014]51(,0104-,Y5\]]'#129 + +#129#128#129#128#129#128#129#129#128']|'#3'Y'#3#3'YXUTU00U45,15,01X5Y1TUTUTY' + +'|'#3'}|}'#129'|'#129'|'#129'}'#3'}Y|UXU|YYU'#3'QTUxy|'#165#164#164#203#164 + +#203#202#169#202#202#169#198#202#203#168#202#203#202#164#199#164#198#199#164 + +#165#160#161#156#161'x'#161'x'#157'xQtLupqL'#0#0#0#128'Y'#3'YUX1T1a41,1Y0U5,' + +'TYTYa'#133#128#129#133#128#133#164#129#129#128#129#129#129#129#3'}YXU'#3'UX' + +'UT,1Y,T1,105YXXUTUXY|}}|'#129#128#129#129#128#129'|'#129'}|}Y'#3'}|U'#3'Y'#3 + +#129#3'}XU|'#161#164#199#198#164#199#202#199#202#203#202#203#202#203#202#203 + +#198#164#199#202#164#199#164#164#161#160#161#160#161'x'#161'x'#157'xxtMtLPLL' + +#0#0#0#129'YY'#3'TUT10,10,0011X,U\U]'#133#128#129#133#168#133#169#133#133#132 + +#129#129#128#129'|'#129'}'#3'}XUTUTUTY'#3',50,TYY\]'#133#129'TY|}}'#129#128 + +#129#128#165#165#164#165#165#164#165'|}||}|U|Y|Y}Y'#128#129'xy|'#161#198#164 + +#203#202#202#169#202#164#203#202#203#168#203#198#169#202#203#164#199#198#165 + +#199#164#161#160#161'|'#161'x'#157'xyyyTPMLML'#0#0#0#128'}'#3'YYTUT1XY1,1Y0T' + +'YTU]'#3']'#133#133#128#168#169#169#168#168#164#165#164#164#165#160#165#161 + +'|}|}|UTUTTYY,UY,UX'#129']'#3'U'#3'}|}|'#129'|'#165#164#165#164#164#165#198 + +#164#165#164#165#164#161'}|}|y'#3'YTTT}|U|}'#164#199#202#164#168#199#202#202 + +#203#198#169#202#203#202#202#203#198#164#202#199#164#164#198#161#164#161#160 + +#161'x'#161'xyxx|YPPPLL'#0#0#0#129#128'}'#3'Y'#3'UTY]XY,TYYTYTTa}'#128#129 + +#129#169#169#168#169#169#165#164#165#165#165#164#165#164#164#161#160'}|}|UTU' + +'U\YPXYQXY'#3']]TY|}|}|'#165#168#165#198#203#202#168#165#198#165#198#165#164 + ,#160#165#160'}|}|'#129'yxU'#3'}xy'#160#165#164#199#198#199#202#165#202#202 + +#203#202#202#198#169#198#164#203#199#164#164#199#164#165#164#161#160#161'|' + +#161'x'#161'xyy'#3'UPYTYT'#0#0#0#128'}|}|UXUTYYTPUXYY'#3'yTy'#3#133#133#168 + +#169#168#165#164#198#164#169#198#202#164#169#198#165#165#164#165#160#161#160 + +'}|yTTYYPYXPYTY'#133#128#129#128'}|}'#164#165#202#199#202#169#198#169#199#198 + +#169#198#164#164#199#164#160#161#160#161'|}|TUx}}xy|'#161#198#164#165#198#164 + +#202#199#168#198#169#202#169#202#203#202#202#164#203#202#164#199#164#165#160 + +#165#160#161'|'#161'|y|xYTQX-T-'#0#0#0#165#161'|}|}xU'#3'YXYY'#3'U'#3#3'Y'#3 + +'UT}'#128#129#129#168#199#168#202#169#203#202#165#168#165#198#165#198#164#164 + +#165#164#161'|}|'#157'|U'#3'}TY'#3'U|Y'#3#133#133#129#133'|}'#164#165#202#202 + +#164#202#198#203#198#202#168#198#168#165#199#164#165#165#160#161'|'#161#160 + +'}}xy||y|}'#160#198#165#198#199#164#199#164#199#203#202#203#202#203#202#169 + +#198#203#168#199#165#198#165#198#164#161#160'}'#160'}xyxy'#3'UTYT(('#0#0#0 + +#164#164#161'|}|}xY'#3'Y'#3#133'Y'#3'Y}|Yxy|'#129#132#165#202#168#202#203#202 + +#168#203#202#203#202#203#168#198#169#199#164#165#164#161#160'}|'#161'x}\U'#3 + +'}TY'#3'}'#129#128'y'#128#129#160#199#202#203#202#203#168#203#202#169#202#199 + +#168#199#202#164#199#164#164#165#160#161#160'}'#160'|}|'#129'}xy|'#161#164 + +#165#164#164#199#164#198#168#202#203#202#203#168#203#202#169#202#199#164#202 + +#164#199#164#165#164#161#160#161#160'}|yxYT0U0,('#0#0#0#199#164#165#160'}x}x' + +'}}'#3'YY|Y'#3'Y'#129'|}x}'#128#169#202#203#202#169#202#203#202#203#168#203 + +#202#168#199#168#198#164#199#164#161#164#161#160'}|'#161'|}X'#129'YX}|'#129 + +#132#129'x'#129#169#202#202#202#202#169#202#203#168#203#202#203#202#203#164 + +#199#168#165#198#199#164#161#164#161#160#161#161#160'}|'#129'xy|'#161#164#161 + +#164#161#164#165#202#203#202#169#202#202#203#202#203#202#169#202#203#198#169 + +#198#164#199#164#165#160'}|'#161'|}'#3'YYT1P-,'#0#0#0#164#165#164#161#160'}|' + +'}'#160'x}'#3'TY|}|'#129#129'|}|'#165#202#203#202#203#203#202#169#203#202#203 + +#202#203#202#202#203#165#202#164#165#198#165#160#161#160#161'|'#161'xy'#3'}x' + +'}|'#129#129#133'|'#161#198#203#168#203#202#203#202#202#203#202#202#169#202 + +#164#203#202#198#198#165#164#165#164#161#160#161#160#160#161#160#129'|y|y|' + +#161#164#161#164#165#202#169#202#203#202#203#203#202#169#202#203#202#202#164 + +#203#164#198#165#164#164#165#160#165#160'}|}T]\]Y0,,'#0#0#0#199#164#199#164 + +#161'|}'#160'y}|}'#129#129'|'#129'|y'#128'}|'#165#202#203#168#203#202#206#203 + +#202#202#203#202#203#168#203#203#164#202#198#165#198#165#164#161#160#161'|' + +#161#160#161'|}'#128'U'#128'}'#128#133#168#165#164#202#202#203#202#169#202 + +#203#202#203#202#169#202#202#203#202#164#203#165#164#199#164#164#161#160#161 + +#160#161#161#160#165'|}|}'#160#161#160#165#160#199#202#203#202#203#202#203 + +#202#203#202#202#203#202#169#203#198#168#199#168#199#165#164#165#160'}'#128 + +#161'}|]YY0101'#0#0#0#164#165#164#165#160#161#160'}'#160#156#161'|'#133'|}}|' + +'y'#128#129#169#202#203#202#207#202#203#203#206#203#203#168#203#202#203#168 + +#202#203#202#165#198#164#199#164#161#160#160#161#160#161#160#161'|}x}|'#129 + +#169#133#165#202#203#202#203#202#203#202#203#169#202#203#202#203#203#168#199 + +#202#164#202#198#165#198#165#164#161#160#161#160#160#161#160#161#128#129#164 + +#165'|'#161#160#165#202#202#203#202#203#202#203#168#202#203#203#168#203#202 + +#168#203#169#198#165#168#198#165#164#165#160'}||}|Y0Y0]9'#0#0#0#198#165#198 + +#160#165#160#161'|}}'#160#161'|}|'#128#129#160'}'#160#169#202#203#202#203#203 + +#202#203#202#203#202#207#202#203#202#203#202#168#199#202#169#198#164#165#164 + +#165#160#161#160#161#160#160#161'|}|}'#128#169#164#165#202#168#203#202#203 + +#202#203#202#202#203#202#203#202#202#203#202#203#198#169#198#164#199#164#165 + +#164#161#160#161#160#161#160#160#165'|}|'#165#160#165#164#203#202#203#202#203 + +#168#203#203#203#202#203#202#203#203#202#198#202#169#198#165#164#165#164#165 + +#128#161#129'|}}XUX100'#0#0#0#168#198#165#164#165#160#160#161#160#160#161#160 + +#161'|'#129'}'#128#129#128#165#164#203#202#203#202#203#207#202#207#203#206 + +#203#203#202#203#202#203#202#203#164#198#165#198#164#199#160#161#160#161#160 + +#161#160#160#161'x'#129'}'#168#133#165#198#202#203#202#169#202#203#202#203 + +#203#202#203#202#203#202#169#202#168#203#198#164#199#165#164#198#161#160#161 + +#164#161#160#161#160#165#128#165#164#165#164#161#202#202#169#202#203#202#203 + +#202#203#202#203#202#203#202#168#203#168#203#198#203#168#199#164#165#164#165 + +#128#128'}'#128#128#129'\'#129#3'Y5'#0#0#0#198#165#198#165#160#161#161#160 + +#161#161#160#161#160#165#129#164#129#164#165#164#203#202#203#202#203#206#202 + +#203#203#202#203#203#202#203#168#203#168#199#168#198#169#198#165#199#164#161 + +#164#161#160#161#160#161#161#161'x'#165#128#169#165#164#198#203#202#203#202 + +#207#203#202#207#202#203#202#169#202#203#202#203#198#203#164#203#198#164#198 + +#165#160#165#160#161#160#165#160#195#160#129#160'}'#164#165#164#198#203#202 + +#203#203#202#203#207#202#203#168#203#168#203#203#202#203#198#169#168#198#165 + ,#164#164#165#128'}'#165#133#133#129#129']]]Y'#3#0#0#0#203#164#199#164#165#160 + +#160#161#160#160#161#160#161#160'|'#129#164#165#169#168#203#202#203#202#207 + +#203#203#207#202#207#203#206#203#202#203#202#203#202#198#203#198#164#198#164 + +#165#164#161#164#161#160#161#160#160#160'}'#128#161#168#165#164#169#202#203 + +#202#203#203#206#203#203#202#207#202#203#203#202#203#168#203#164#202#199#164 + +#199#165#160#165#160#165#160#161#160#165#160#161#160#129#164#165#164#199#202 + +#203#202#203#206#203#203#202#203#203#203#202#203#202#202#169#202#169#202#198 + +#169#168#165#165#164#129#132#133#132#133#132#133#128']\]Y'#0#0#0#198#165#198 + +#165#198#165#164#161#161#160#160#199#160#161#161#164#129#164#160#165#202#207 + +#202#207#202#207#202#203#207#202#203#203#202#203#202#203#202#169#202#168#199 + +#202#165#198#198#160#161#160#161#164#161#165#161#160#160#165#128#165#164#161 + +#202#202#203#203#202#202#203#206#203#203#202#203#202#203#202#203#202#202#203 + +#198#168#198#164#198#165#164#199#160#165#160#161#160#165#160#165#160#165#164 + +#161#164#169#202#203#202#203#202#207#203#202#206#203#203#202#203#203#202#203 + +#202#169#202#165#164#168#169#128#169#173#168#133#133#133#133#133#129']\]'#0#0 + +#0#169#198#164#198#165#160#161#160#160#161#160#161#160#160#160#165#164#165 + +#161#168#203#202#203#202#203#202#203#206#203#203#206#202#207#203#202#203#202 + +#202#203#199#168#199#198#165#164#199#164#164#160#161#194#160#160#199#160#165 + +#160#169#164#165#198#203#202#202#203#207#202#203#202#207#203#202#203#202#169 + +#202#203#202#198#169#198#165#198#165#198#160#164#161#160#195#164#160#199#160 + +#161#164#129#164#165#198#202#203#202#203#202#203#202#203#207#203#203#202#203 + +#168#203#202#203#168#202#203#168#203#165#164#169#172#133#133#169#132#133#132 + +#129'`'#129']]'#0#0#0#198#164#199#165#198#160#165#160#161#160#161#160#165#194 + +#165#169#164#165#168#198#203#206#203#207#203#207#207#203#203#206#203#203#203 + +#202#203#202#169#203#198#168#198#198#165#164#199#164#161#195#161#164#160#161 + +#195#160#161#164#129#168#169#194#202#203#202#203#203#202#203#203#206#203#202 + +#203#202#203#202#203#168#199#169#198#203#198#165#198#164#199#161#164#161#164 + +#160#165#160#194#165#164#165#164#195#164#203#202#207#203#207#202#207#203#202 + +#203#202#203#202#203#202#169#203#202#169#165#168#165#168#169#173#169#133#168 + +#133#133#133#133#133'a]\]'#0#0#0#202#199#164#198#164#199#160#165#160#161#164 + +#194#161#161#164#169#169#164#165#164#203#202#203#202#206#203#202#207#202#203 + +#207#202#202#169#202#203#202#202#202#199#202#165#198#198#164#195#164#164#160 + +#160#199#160#164#161#164#161#164#169#165#165#202#203#202#207#202#203#206#203 + +#203#203#202#203#202#203#202#203#202#202#202#202#165#202#164#199#165#160#198 + +#161#164#161#164#195#160#165#164#161#160#165#164#198#203#202#203#202#203#203 + +#202#203#207#202#203#207#169#202#203#203#168#203#168#202#169#168#169#168#169 + +#136#169#137#133#133#133#132#133'\'#133']]'#0#0#0#165#202#199#164#199#164#161 + +#164#195#164#161#164#194#164#161#160#173#164#165#203#202#207#203#203#203#206 + +#203#207#207#202#203#207#203#202#203#202#203#168#203#164#203#198#165#198#165 + +#164#195#165#194#165#160#199#160#194#165#164#161#168#164#194#168#203#202#203 + +#202#207#203#202#207#202#207#203#203#168#203#202#203#202#165#202#198#165#198 + +#164#198#165#160#198#161#198#161#164#195#160#165'|'#161#160#165#164#202#203 + +#202#203#206#203#207#202#203#203#202#203#203#203#168#202#203#168#203#168#203 + +#168#169#173#169#173#169#173#133#136#133#133'a'#133'a\]'#0#0#0#202#198#164 + +#199#164#199#164#194#164#165#194#165#161#198#160#165#168#169#164#164#203#202 + +#202#207#202#203#207#202#203#203#206#202#203#203#202#203#202#199#202#202#198 + +#165#198#165#198#165#160#164#165#161#198#160#165#199#160#161#164#169#199#165 + +#198#202#203#202#203#203#202#203#202#203#202#203#202#203#202#203#168#199#202 + +#199#168#198#165#198#165#198#165#164#160#165#198#161#164#198#160#161#160#165 + +#164#199#202#203#203#202#203#203#202#203#207#202#207#202#202#203#203#203#168 + +#203#168#203#169#168#173#173#169#173#133#137#169#133#133#133#133#132'a]]'#0#0 + +#0#199#164#199#164#164#199#160#165#161#194#165#160#198#164#199#164#165#165 + +#164#199#202#203#207#203#203#207#202#203#207#202#203#203#203#202#203#202#169 + +#202#169#198#165#202#164#198#165#198#164#199#160#198#160#165#198#160#164#165 + +#164#169#164#164#198#203#202#203#206#202#207#202#207#202#203#202#203#202#203 + +#202#203#202#165#202#198#165#198#199#164#199#164#195#164#199#160#164#198#165 + +#161#160#165#160#199#164#203#203#206#203#203#202#207#203#202#203#203#203#203 + +#203#202#168#203#168#203#169#202#169#173#169#173#173#133#173#133#133#137#132 + +#133'a'#129'`]'#0#0#0#202#199#168#199#198#164#199#160#198#164#161#199#164#195 + +#164#165#164#164#165#198#202#203#202#207#202#207#203#207#202#207#202#203#202 + +#203#202#203#202#198#202#199#202#198#165#199#198#164#199#160#199#160#165#194 + +#165#194#161#164#165#173#165#198#165#202#203#202#203#203#202#203#203#202#203 + +#202#202#203#202#169#198#202#202#165#198#198#165#164#198#165#164#198#161#164 + +#164#199#161#198#160'}'#160#165#164#198#202#203#203#203#206#203#202#203#207 + ,#202#169#202#203#168#203#203#168#203#168#169#168#169#173#173#137#169#173#133 + +#137#133#133#133#132'aa]]'#0#0#0#168#198#199#164#199#164#198#165#161#198#164 + +#194#165#164#198#169#169#165#164#165#203#202#203#202#203#202#203#202#203#203 + +#203#168#203#202#169#202#203#169#198#168#199#164#198#164#199#164#198#165#164 + +#199#164#199#164#199#160#165#164#168#169#164#198#203#202#203#202#203#202#202 + +#203#202#203#203#203#168#203#202#203#164#203#202#165#202#198#165#198#198#165 + +#165#198#165#198#164#199#164#165#160#161#160#165#165#168#202#202#203#203#203 + +#207#202#203#203#206#203#202#203#168#203#203#168#203#169#168#173#169#173#169 + +#137#169#137#133#137#133'a'#133#133'`]]'#0#0#0#199#198#168#199#164#199#164 + +#198#198#165#198#165#198#195#164#169#164#164#169#198#168#203#207#202#207#203 + +#206#203#207#202#203#202#203#202#203#202#202#198#203#198#198#203#165#198#164 + +#199#165#198#198#164#199#164#194#164#165#164#165#169#203#164#165#202#203#202 + +#203#202#203#203#202#169#202#202#202#203#202#203#202#203#198#164#202#165#198 + +#198#165#164#198#198#165#198#199#164#198#165#160#161#164#165#164#198#199#203 + +#203#202#202#203#202#203#202#203#203#203#203#202#203#169#202#169#168#169#169 + +#169#173#173#173#173#137#169#137#132#133#133#133'a]]]'#0#0#0#198#168#199#198 + +#199#164#199#164#165#164#199#164#199#164#165#203#164#165#165#164#203#203#202 + +#203#203#202#203#203#202#203#202#203#202#203#202#203#164#203#198#164#203#164 + +#198#164#199#164#198#164#165#199#198#164#199#165#160#165#164#203#173#165#198 + +#203#202#202#203#202#203#202#202#203#202#203#203#202#203#168#198#202#165#203 + +#198#199#198#169#198#199#198#165#164#199#164#165#165#164#165#198#165#164#165 + +#165#202#203#202#203#203#203#203#203#203#203#202#203#168#203#169#202#169#168 + +#203#169#168#173#173#169#137#133#133#137#133#133#133'aa\a\9'#0#0#0#202#199 + +#164#202#165#198#164#199#198#198#165#198#164#199#164#169#165#198#169#164#199 + +#202#203#203#202#203#203#202#203#203#203#168#203#202#169#202#203#164#203#198 + +#164#199#198#165#198#199#164#199#198#198#164#199#164#198#164#165#164#164#168 + +#199#164#164#203#203#202#203#202#203#203#202#203#202#202#169#202#198#169#199 + +#202#198#165#202#164#199#164#198#165#198#199#164#199#202#202#199#202#169#202 + +#199#164#202#165#202#165#203#202#203#202#203#202#203#169#202#203#203#202#169 + +#203#169#168#169#169#169#132#133#133#133#133']'#133#133#133#132#133'a]]]'#0#0 + +#0#165#202#199#198#199#164#203#164#199#164#198#165#198#168#203#168#199#168 + +#199#202#165#202#203#202#203#202#203#203#202#203#202#203#202#199#202#199#202 + +#198#168#203#198#168#199#198#164#199#198#164#199#164#199#164#199#164#203#202 + +#199#203#198#168#199#202#164#202#203#202#168#202#203#202#169#202#203#198#203 + +#202#198#202#165#202#203#198#203#198#199#164#199#168#203#202#203#169#202#169 + +#203#198#169#203#203#165#202#165#202#165#203#198#169#202#165#202#203#169#203 + +#168#203#168#169#169#173#169#137#169#133#137#133#133#132'a`]]aa`]9]'#0#0#0 + +#202#199#168#199#168#199#198#199#164#203#169#202#203#203#202#203#202#203#202 + +#169#198#199#168#199#202#169#202#198#203#198#203#202#202#203#168#202#165#202 + +#199#198#165#198#198#165#198#198#164#199#198#169#202#202#202#203#202#164#202 + +#168#199#202#198#165#202#199#164#202#199#199#198#198#198#203#198#202#202#165 + +#202#165#202#198#164#199#164#199#164#203#202#203#202#203#168#203#203#203#202 + +#169#203#198#169#202#165#203#164#165#164#169#198#165#168#165#164#169#168#165 + +#169#169#169#173#169#137#173#133#173#133#133#133#133#133']]\]]]]\9'#0#0#0#198 + +#169#198#199#198#164#199#164#203#203#202#203#203#202#203#203#203#169#203#199 + +#168#203#164#199#164#199#198#165#164#199#164#198#199#164#198#199#198#199#198 + +#165#198#198#165#198#199#164#199#198#168#202#203#202#203#168#203#203#202#199 + +#202#202#165#202#199#164#198#165#198#164#198#165#199#164#198#165#199#198#203 + +#198#198#169#199#202#199#164#199#202#203#203#169#203#203#203#203#203#169#203 + +#203#169#203#165#203#164#199#169#203#164#165#168#165#164#169#164#165#132#169 + +#169#173#173#173#169#169#137#133#133#133#132#133'a\]]9Y\]9Y'#0#0#0#203#198 + +#203#164#203#199#202#207#203#203#203#207#203#203#203#169#202#203#168#203#198 + +#169#199#202#165#198#165#198#199#164#198#161#198#198#165#198#164#199#164#198 + +#164#199#198#164#198#198#169#202#203#203#202#169#202#203#202#202#169#202#169 + +#198#203#164#202#165#203#164#199#198#165#198#164#198#165#198#164#198#164#199 + +#165#198#198#165#198#203#206#203#203#207#203#203#203#203#169#203#203#169#203 + +#203#169#203#169#203#169#164#165#165#169#165#169#165#129#169#129#169#173#173 + +#173#169#137#173#137#169#137#133#133#133'aaa]]\95Y85'#0#0#0#198#169#198#203 + +#164#203#203#203#207#207#203#203#203#169#203#203#203#203#203#169#203#199#168 + +#199#169#198#165#164#199#164#165#164#161#161#198#161#198#164#199#164#199#164 + +#199#198#165#202#202#203#202#203#202#203#202#203#203#202#203#202#203#202#168 + +#199#202#198#164#199#164#165#198#165#198#161#198#161#198#161#198#164#198#165 + +#198#199#168#203#203#207#203#203#207#203#207#203#203#203#203#203#169#203#203 + +#165#203#165#203#165#169#168#165#168#169#168#169#164#129#169#173#173#173#173 + ,#169#137#169#137#133#137#133#133#133#132']\9]'#3'9555'#0#0#0#164#199#164#199 + +#203#207#203#207#203#203#207#207#203#203#207#203#203#169#203#203#203#168#199 + +#169#198#165#198#165#164#199#198#161#164#160#161#164#161#198#160#199#164#198 + +#164#165#202#203#203#202#207#202#203#202#203#202#169#202#203#202#168#203#198 + +#202#165#165#202#164#199#198#164#198#165#164#165#164#161#164#165#194#165#198 + +#165#164#203#203#207#203#207#203#203#207#203#203#207#203#203#169#203#169#203 + +#169#203#169#165#169#165#165#169#165#165#169#169#129#133#173#173#173#173#169 + +#137#173#137#133#137#133#133#133'aaa]]995450'#0#0#0#199#198#199#203#207#203 + +#207#207#203#207#207#203#203#207#203#203#207#203#203#203#169#199#203#164#199 + +#164#165#198#165#198#165#164#160#161#164#160#165#160#165#164#195#164#199#202 + +#203#206#202#203#202#203#202#203#202#203#202#203#168#203#202#203#202#169#198 + +#202#198#165#198#164#165#199#164#199#160#161#164#161#160#165#164#165#198#203 + +#207#203#207#203#203#207#207#204#203#207#204#169#207#203#203#203#169#203#169 + +#165#169#169#165#169#165#165#169#165#169#169#173#173#173#133#173#173#137#173 + +#133#137#133#133#133'a'#132'a]\9\54555'#0#0#0#164#199#169#203#207#207#203#207 + +#204#207#203#207#207#203#207#169#203#203#169#203#203#169#203#165#165#198#165 + +#165#160#165#160#199#160#161#160#161#160#165#160#161#164#161#164#203#202#203 + +#207#202#203#206#203#207#202#203#203#202#203#202#203#164#203#198#168#199#165 + +#198#164#165#198#164#194#165#198#160#161#164#165#160#165#164#165#207#203#207 + +#203#207#208#203#203#207#208#203#207#203#203#170#203#170#203#170#169#169#165 + +#165#165#129#165#169#133#169#169#133#173#169#173#173#137#169#173#133#137#133 + +#133#133#133#133'aa]]595554'#13#0#0#0#165#165#203#207#203#207#207#207#207#203 + +#208#203#207#208#203#208#203#203#203#169#203#203#165#203#165#165#164#164#165 + +#164#165#160#165#160#161'|'#161#160#161#164#160#165#202#202#207#202#203#207 + +#203#203#206#203#203#206#203#203#202#203#202#203#202#165#202#164#198#165#199 + +#198#165#199#164#198#165#164#161#160#161#164#161#164#203#203#207#203#207#203 + +#207#207#207#203#207#208#203#208#203#207#203#203#169#203#203#170#169#169#169 + +#165#133#165#129#169#133#169#173#173#173#137#173#138#173#137#137#133#137'a' + +#133'a'#133'`]]\554550'#0#0#0#165#203#207#207#207#203#208#203#207#208#207#207 + +#208#203#207#203#203#208#203#203#203#169#203#165#203#165#165#165#160#165#160 + +#165#164#161#160#161#160#161#160#161#165#164#203#207#202#203#207#202#207#202 + +#203#202#207#203#202#207#202#169#202#203#168#202#203#199#168#198#164#165#160 + +#164#165#164#198#165#160#165#164#165#164#165#203#207#203#207#203#207#203#208 + +#203#208#203#207#208#203#204#170#170#170#169#134#129#133#129#165#129#133#129 + +#129#133#165#133#173#138#173#133#173#134#173#137#133#137#133#133#133#133#133 + +'a]]995455'#12#13#0#0#0#165#207#207#203#208#207#207#207#208#207#203#208#203 + +#208#208#203#208#169#203#203#169#204#165#203#165#165#165#164#161#164#161#164 + +#161#164#161#164'|'#165#164#165#164#164#203#202#203#203#206#203#203#207#203 + +#207#203#202#203#202#203#203#202#203#202#199#164#164#198#165#165#198#164#199 + +#160#199#165#198#161'|'#161#164#165#203#207#203#207#207#203#208#208#207#208 + +#207#208#208#170#170#170#134#130#134#247#247#247#247#247']'#247#129#129#133 + +#129#133#133#169#173#137#174#137#173#137#133#137#133#137'a'#133'a`]a9\54550' + +#17'1'#0#0#0#169#203#208#207#207#208#208#208#207#208#208#207#208#207#203#208 + +#203#204#207#170#203#169#203#165#165#165#165#165#160#165#164#161#164#161#164 + +#129#169#173#133#164#165#198#203#207#202#207#203#202#207#202#207#202#203#207 + +#203#202#203#202#203#168#203#168#203#198#165#198#164#164#165#164#165#164#194 + +#165#164#165'|'#129#165#169#203#207#203#208#207#207#203#208#207#208#170#170 + +#170#134#130#134#134#247#134#247#134#247'a'#247']'#247']]'#247#129#133#137 + +#174#137#133#173#137#133#137#133#137#133#133'a'#133'a`]]9555'#12#17'0'#12#0#0 + +#0#169#207#207#204#207#207#207#208#207#208#207#208#208#208#208#208#208#203 + +#204#203#204#169#203#169#165#165#165#165#165#161#160#165#160#165#160#169#133 + +#173#165#164#165#169#202#203#207#202#207#207#203#207#203#207#202#203#207#203 + +#202#169#202#203#202#199#164#203#164#165#198#165#160#161#164#165#164#199#164 + +#164#169#164#165#203#207#203#207#203#208#208#207#208#204#170#170#130#170#8 + +#134#134#134#134#247#247#247#247#247#247'^]'#7']]]'#247#137#137#174#137#137 + +#134#137#137#137#133#133#133#133'aaa]\954551'#17'1'#0#0#0#203#207#208#207#208 + +#208#208#208#208#208#208#208#208#204#170#170#170#170#170#170#165#166#169#166 + +#165#165#165#129#161#128#165#161#160#165#160#169#129#164#169#165#164#202#203 + +#206#203#203#203#202#203#206#203#202#203#207#202#168#203#203#202#203#164#203 + +#168#198#165#198#165#164#165#164#161#160#165#160#161#165#169#129#165#203#207 + +#207#208#207#207#207#208#174#170#8#170#8#134#134#130#134#130#130#134#134#247 + +'^^^]'#7'b]^]]'#133#138#133#137#133#137#137#133#133#137#133'aaa]]]95451'#16 + +'1'#12#13#0#0#0#207#208#203#207#208#207#208#208#208#208#208#170#170#170#170 + +#134#170#130#170#130#130#134#129#129#247#165#165#161#129#161#161#160#165#160 + ,#161#164'}}'#165#128#165#199#202#203#203#207#202#207#207#203#203#207#207#202 + +#203#203#203#202#202#169#202#203#198#165#198#165#164#165#164#161#164#165#164 + +#164#165#164#169#133#165#169#203#207#203#207#204#208#204#170#8#170#134#134 + +#134#134#134#9#134'b'#134'^^^^^'#7'b]'#7'a]]'#138#137#137#138#137#134#137#133 + +#137#133'aa'#133']a\99455'#16'1'#16'1'#12#0#0#0#204#207#208#208#208#208#208 + +#208#208#171#170#8#170#9#170#170#130#8#130#134#130#247#247#247#129#129#129 + +#129#129'}'#164#161'|'#161#160'}||'#129#160#164#202#203#207#202#203#207#202 + +#203#202#207#202#203#203#206#203#202#169#203#202#168#198#169#198#165#164#165 + +#164#161#164#161#164#161#165#160#165#137#169#165#203#208#207#208#208#207#174 + +#170#134#8#134#8#9#134#9#134'b^'#130'^^b^^^b'#7'^='#7'>]a'#134#137#133#137 + +#133#133#137#133'a'#133'aa`]]955'#17'4'#13#13'1'#12#13#0#0#0#203#208#207#208 + +#208#208#208#170#170#8#170#8#170#170#9#8#134#134#134#130#134#247#247#247#247 + +#7#7'}'#129'}}'#129#160#161#164#161'}|'#129#165#161#168#203#202#207#202#203 + +#207#203#207#203#207#202#203#203#202#203#202#203#203#203#164#198#169#198#165 + +#164'}'#164'}'#160#161#164#160#165#160#169#133#165#165#207#203#207#207#208 + +#170#8#8#134#8#134#134#134'b'#9#130#9'b^^^^^^^'#7':'#7']'#7'9a'#137#134#137 + +#133'e'#133'a'#133#133'aaa]9]945'#13'50'#16#13#13'0'#0#0#0#207#208#208#208 + +#208#208#171#170#8#8#171#8#9#8#134#134#9#130#134#130#134#247#247#247#7#129#7 + +#129#7'}'#129#161'}'#128#161'|}|'#129#128#161#198#203#203#203#203#203#202#203 + +#202#203#202#203#202#169#203#202#203#168#202#164#203#168#165#164#164#165#164 + +#161#160#165'|'#165#165#160#165#133#129#165#169#207#208#207#208#170#134#134 + +#134#8#134#9#134#9#134#130'bb^b^^^^:'#7':'#7'9:9'#7'9b'#137#133'b'#133#133 + +#133'aaaa]9\94550'#17#13'1'#13#12#13#0#0#0#204#208#208#208#208#170#8#8#8#9 + +#170#9#8#134#9#9#130#134'b'#9#247#247#247#247'^'#7#247']'#7#129'Y'#129'|'#161 + +#160#129#128#129#128'}'#160#165#202#203#202#169#202#203#202#203#203#203#202 + +#203#203#202#203#168#203#169#203#164#165#198#165#165#164'}'#164'}|'#161#160 + +#160#165'|'#133#133#133#165#207#203#208#170#134#8#8#8#9#134#134#9'b'#9'b'#9 + +'^b^^:^:'#7'::'#7':9'#7'95]a'#133#133#133'aaaaa\]]9555'#12#17#12'1'#12#12'05' + +#0#0#0#204#208#208#204#171#8#9#8#9#8#9#134#9#9#130#134#9#9#247'^'#9'^^'#247 + +#247#7#7#7']'#7'Y}}'#129'|}]'#133#129#128#161#164#203#202#203#202#169#202#169 + +#202#169#202#169#202#169#203#168#203#198#202#164#203#164#165#164#128#161'|}|' + +#165'|'#165#129#160#129#133#133#133#165#208#207#208#8#134#134#134#134#8#134#9 + +#134#134'b^b_^^^^:^:69:5:9995aaaaaaaa]9]8545'#12#17'1'#13#12#13#13#13#13#0#0 + +#0#170#208#208#8#134#9#134#9#134#9#9#9#134#9#9'b'#130#9#9#130'b'#130'b^^^'#7 + +#7#7']'#7']Y}}|}'#128#129'}|'#165#198#169#202#203#202#203#198#203#202#203#202 + +#199#202#203#202#169#169#169#164#168#164#165#165#160#129'|'#129'|}}|'#161#164 + +'}'#133#133#133#165#169#207#170#134#8#134#8#134#138'b'#134#9'b'#9'b^b^^:^^::' + +':6:5656555aaaaaa]]]99555'#13'0'#13'0'#13#12#12'1'#12#0#0#0#170#208#170#9#134 + +#9#9#9#9#9#134#9#9'b'#9#9#9'bb'#9'^b^^^^]^]'#7']YY'#129'|}\Y'#129'|}'#160#165 + +#202#199#164#165#164#165#168#165#168#165#168#169#168#169#168#169#168#169#165 + +#165#128#128#129'|}|}|'#129'|'#129'}'#128#133#133#134#133#203#207#134#134#134 + +#138#134#138#134#134#134'bbbb^b^:^::6:565655'#17'5'#17'55]aa]]8]9945'#16#13 + +'0'#13#12#13#244#13'1'#12#13#0#0#0#170#204#134#9#9#134#9#134#9#134#9#9#134#9 + +#9'bb^'#9'^b_b^^^^'#7#7']'#7']YY}'#129'Y'#129#128']|}'#164#199#164#165#164 + +#165#164#165#164#165#164#169#168#169#169#169#168#169#133#128#128#129#129'}|}' + +'}|}|}'#128'|'#129#133'a'#133#129#169#170#138#138#174#134#137#134#138#134#134 + +'a'#247'b^b^:^::6:6665'#18'5'#18'555'#17#13'49]]9]9455'#13'1'#13#12#13#245#12 + +#13#12#12#13#12#0#0#0#130#9#9#134#9#9#9#9#9#9'b'#9'c'#9'b'#9'c'#9'b_b^b^^^]^' + +'9'#7']'#7'Y]Y]\Y]}'#128'}|'#165#164#165#164#165#164#165#164#165#168#133#169 + +#173#168#169#169#132#169#133#129#129#128#128']||Y|}'#128'}'#129']'#133#129'a' + +']'#133#174#169#138#137#174#138#134#138#134#138'bba:]^^::::565'#18'6'#17'5' + +#17#17#17#13#17#13#13#12'5594555'#12#13#12#244#13#12#12#13#12#13#245#12#245#0 + +#0#0'b^^'#9'b'#9#9'b'#9#9'cb'#9'bcbbcbbcb^bb^^^'#7#7'Y]YYY]]'#3']]Y|}|'#165 + +'|'#129'|'#129'}'#128#133#169#168#169#169#169#169#132#169#132#133#128#129#129 + +#129'}]'#129'|Y|}'#128'|]]]'#133'a'#169#138#173#174#134#137#138#137#138#133 + +'b'#134'bbb^9:6666'#18'6'#18'5'#17#18#13#17#13#13#17#13#13#13#13#13#12#13#17 + +'1'#12#12#13#12#13#13#244#13#244#13#244#12#13#244#12#0#0#0'^'#9#9'_'#9#9'b'#9 + +'cb'#9#9'c'#9'b'#9'cbcbbbb^b:b]b]b]]]Y'#3'Y]]\]}'#3'}|}|}|'#128#129#129#132 + +#133#169#132#173#133#169#133#133#133#133#128#129'\]'#128'Y|}'#129#3'}]a]a' + +#133#169#137#174#137#138#173#138#134#138#134#138#133'ba^]::'#7'965'#17'6'#17 + +#17#14#13#13#13#13#13#13#13#13#13#12#13#12#13#12#13#12#13#13#12#245#12#12#13 + +#245#12#244#13#244#244#244#245#0#0#0'ccbb'#9'^'#9'cb'#9'bcbbccbcbbcbcbb'#134 + +#134#134#134#133#133'b'#133']]Y]]]]Y\}|}|}}'#128#129#129#132#133#168#169#173 + +#133#168#133#133#128#133#128#129']Y'#3'Y]]Y'#3'}]'#133'aa]'#137#138#174#133 + ,#174#173#138#137#138#133#138#133'bbba^9'#7'9:5'#17#14#13#13#14#13#13#13#13#13 + +#13#13#13#13#13#13#12#13#244#244#245#12#13#244#244#13#244#245#244#244#244#245 + +#244#245#244#13#244#0#0#0'^^ccccbc'#9'ccbcccbcbcbbbbb'#138#138#138#138#137 + +#138#133#133'a]]]\Y]\]]Y'#3'}}'#3'|}Y'#128#129#133#133#133#133#169#133#132 + +#133#133#129']\]\]Y'#3']'#3'Y'#3']a'#133'a'#133#173#173#137#173#137#138#137 + +#134#137#138#133'f'#133'aa'#7'9:9:556'#17#13#13#13#13#13#13#13#245#13#13#13 + +#13#244#13#245#244#245#244#245#244#245#244#245#244#245#244#245#244#245#244 + +#245#244#245#244#245#0#0#0'cb^bcbcbcbccbcbcbcbcbb'#138#8#138#138#133#138#133 + +#134#138'a'#133#133']]Y\Y]X9XY'#3'Y}Y'#3'Y]'#128#133#133#132#133#133#133#133 + +#133#132#133#129']]Y'#3']5'#3']'#3'Yaaaa'#133#137#174#137#138#173#134#137#137 + +#134#137'b'#133'bbb='#7'99595'#17#13#13#13#13#13#245#13#13#13#245#245#244#245 + +#245#244#245#244#245#244#244#244#244#244#244#244#244#244#244#244#244#244#244 + +#244#244#244#244#0#0#0'^_c_bcccbcbccbcbcbgbc'#138#138#138#174#138#138#138#138 + +#137#133#134'aa]]\5'#3'YY]Y'#3'UX'#3'XYX]]'#133#132#133#133#132#133#132'a' + +#133']\]\]Y5X]Y]Yaaa'#133#137#173#137#169#137#134#137#138#138#137#134#137#133 + +'aaa9]955'#17'55'#13#13#13#13#245#13#245#245#245#245#244#245#245#244#245#244 + +#245#244#240#245#244#245#244#241#244#245#244#245#244#245#244#245#244#245#244 + +#245#0#0#0':c^b_bcbcccbbc>cbcbc'#138#8#8#8#138#138#138#134#137#134'b'#133'a' + +#133']]]YYYXY4]YXUYYYX]'#128#133#133#133#133#133#133#133#128'a]]Y5Y4YY5\58a]' + +#133#173#133#174#137#138#173#138#133#133#133'e'#133'aba]]955555'#13#13#13#13 + +#245#13#245#245#245#244#245#245#245#244#245#241#244#245#244#241#244#240#244 + +#240#244#244#244#0#244#240#244#244#244#244#244#244#244#0#0#0'_^?cb;bcb?bcccb' + +'cbcbf'#8#8#138#138#138#170#138#138#134#137#137#134'aa]]]4Y45Y5Y4YY4YXY]]' + +#133#132#133#132'a'#132'a]]\]X54Y54Y5]]aa'#137#137#137#137#173#137#133#137 + +#138#137#138#133'baaaa9955'#17'5'#17'5'#13#13#245#245#245#244#245#245#245#245 + +#244#241#245#244#244#241#240#244#240#240#245#240#244#245#0#245#244#244#245 + +#244#245#240#245#244#245#244#0#0#0':_^;bc;bcbc>cbcbgbc'#8#8#8#8#174#138#138 + +#138#137#138#134#137'a'#133'aa]9]5YXY45544U4Y4]\]'#133#133#133#133#133']\]Y]' + +'Y554554Y8=aa'#133#173#133#137#134#137#137#134#137#133#133#137#133'aa]]99555' + +#17#13#17#13#13#245#245#245#245#245#244#245#245#245#244#240#241#245#244#241 + +#240#245#0#240#245#0#244#240#240#241#240#240#240#244#244#240#244#244#244#0#0 + +#0';::c;^c>_?bcc>cbcbf'#8#8#8#138#138#174#138#138#138#134#137'b'#133'aaa]\5X' + +'550Y54555055Y]]\a\]\]]]\54505145555]a'#137#137#137#137#137#133#138#137#133 + +#138#137'aaaaa]955'#17'4'#13'5'#12#13#245#244#245#244#245#240#245#245#0#245 + +#245#245#244#0#241#244#240#0#244#240#0#244#241#240#244#240#244#241#244#0#245 + +#244#241#244#245#0#0#0'::;^>c>_?bc>>cc>cf'#9#8#138#8#138#174#138#138#134#137 + +#137#134#137#134'aa]]9Y55455055501504]\]]]]]]9X5550554554549a'#137#133#133 + +#137#133#138#137#133#137#133'a'#133'aa]]9954'#17'1'#12#13#13#13#244#245#244 + +#245#245#245#245#240#245#245#0#244#0#245#244#245#0#244#241#0#244#240#0#244#0 + +#245#0#244#240#245#244#240#244#244#240#0#0#0':;:;;:_>^?:cc>bcbb'#8#8#8#174 + +#138#138#174#137#138#134#138#137'aaa]a]94545141945001155]]]\]5\Y545410110555' + +'9=a'#133#137#137#133#137#137#133#137#133'e'#133'aaaa994'#17'5'#12#17#13#13 + +#12#13#245#245#245#244#241#244#0#245#244#0#245#240#245#0#240#244#0#0#240#244 + +#0#241#240#240#240#240#240#245#0#244#0#244#240#241#244#0#0#0'6:::;>;;>c>>_?b' + +'?cf'#8#8#8#8#138#174#138#138#138#137#134#138#133#133'aa]\]5550514115'#13'00' + +'014545545545511'#12'1'#12'1'#13'049aaa'#133#133#137#137#133#137#133'e'#133 + +'a'#133'aaa]]954'#17'1'#12#13#12#13#12#244#0#245#244#241#245#240#240#241#245 + +#0#245#0#245#0#245#240#240#0#245#240#0#0#241#0#244#0#240#240#245#240#241#244 + +#240#240#0#0#0#18':7::;:>;:_?>b?b>'#9#8#138#138#138#174#138#138#134#138#138 + +#133#137'baaa]994545101'#244#12'50'#13'1'#13'015554554550'#13'0'#13'0'#13#12 + +'0'#13'59a=a'#133#137#133#133#137#133#137#133#133#133'aaa]98555'#13#12#13#12 + +#13#12#245#245#245#244#241#244#240#245#241#244#0#245#0#244#0#244#244#244#0 + +#240#13#244#244#240#240#240#240#241#244#0#240#240#244#0#245#244#0#0#0#18'6' + +#22':;:;;:?>:c?b>cb'#8#138#8#174#138#138#138#137#138#133#137'baaaa9]45510'#12 + +'10'#244#13'5'#16#245#12'0'#12'11001'#13'0110'#13'0'#13#244#13#12','#13#13'5' + +#16'59aa'#133#133#137#133'a'#133'aaaaa]]995'#13#12#13#12#13#12#13#244#245#244 + +#244#0#245#0#245#0#244#0#245#0#245#0#244#244#241#240#241#0#244#245#21#244#0#0 + +#0#240#0#244#240#240#241#240#244#244#0#0#0#14#18'6'#18':;::;::?:>?b>'#138#8 + +#138#138#138#138#138#138#134#138'a'#138'aaaa]]955'#16'0'#13'1'#12#13#244#244 + +#17'1'#244#245#244#245#12#12#13'1'#13'0'#13'0'#13#12#13#244#12#245#12#245#13 + +#244#12'5599=a'#133#133'a'#133#133'a'#133'aaa]\995'#16'5'#13#12#13#244#13#244 + +#13#244#240#241#245#244#0#245#240#241#245#0#244#0#240#241#244#244#244#244#0 + +#244#244#17#12#244#244#241#240#240#0#245#0#244#240#245#244#0#0#0#14#18#18#18 + +'6'#18';::;;:?:>?>b'#8#138#138#138#138#134#137#138#134#137#134#133'aaaa]4551' + ,#13'0'#13'0'#13#241#12#17#244#244#244#245#244#245#244#244#244#245#244#13#244 + +#244#245#244#245#244#245#244#244#244#13#16#17'4='#21'9=a`'#133'a'#133'aaaaa9' + +']9455'#12#13#244#13#13#12#245#244#241#244#244#0#245#244#0#244#0#240#241#240 + +#241#240#244#0#245#0#240#240#13#245#13#13#245#244#244#0#240#240#0#240#0#244 + +#240#240#0#0#0#13#14#18#18#18':'#18':;:::::?:>b'#138#138#138#138#134#137#138 + +#134#137#134'eaaa]]8550'#13'0'#13'0'#13#12#244#244#13#12#13#244#244#244#240 + +#244#245#244#244#244#244#245#244#244#244#244#244#244#244#245#244#244#13'5'#13 + +#17'49=]a'#133'a`a`a]\]9455'#12#13#12#13#12#244#245#244#245#240#245#0#245#0 + +#240#241#0#245#0#244#0#240#240#241#244#240#244#245#240#13#244#0#13#244#240#13 + +#244#13#244#244#245#240#240#245#244#0#0#0#6#14#14#14#18#18'6'#22':'#22':;:::' + +':>>'#138#138#134#138#137#138#134'e'#138'aaaaa]9554'#13#12#13#12#12#245#244 + +#240#13#17#17#17#244#240#245#244#245#240#244#245#244#245#244#244#245#240#245 + +#244#244#241#244#244#13#244'9'#12#244#245#17'99aaaaa]]9]9955'#12#13#12#245#12 + +#244#245#244#244#240#244#0#244#0#240#241#244#0#240#240#0#245#244#245#244#0 + +#245#240#0#244#244#240#0#0#0#0#21#17#12#17#17#12#240#245#244#240#0#0#0#245#13 + +#6#14#14#18#18#18'6'#18'::::::::b'#138#138#138#134#138#133#134#133#134'aaa]9' + +'854'#13#13','#13#12#245#12#245#240#244#13#244#13#244#240#244#240#240#245#244 + +#244#244#240#245#240#244#244#240#245#240#244#245#16#17#13#13#16'9'#16'99==\]' + +']]9]]9454'#13#13#12#13#244#244#245#244#245#0#245#0#245#0#245#240#240#0#244#0 + +#241#244#0#244#0#240#244#0#244#240#245#21#12#240#240#245#240#13#245#244#17#21 + +#244#0#240#0#244#0#0#0#13#245#245#13#6#14#18#18#18'6'#18#22':'#22'::'#22':^' + +#137#134#137#134'e'#138'eaaaa9]955'#13'0'#13#13#12#245#244#244#12#17#12#13#13 + +#16#241#244#245#244#244#240#240#241#240#244#240#240#241#240#240#240#240#244 + +#13#17#244#12#17#17'='#21'99='#21'99\]\94551'#13#12#13#244#245#244#245#244 + +#244#0#244#240#244#0#244#0#240#241#0#241#240#240#240#245#240#244#241#244#240 + +#241#0#244#13#13#244#240#244#12#244#244#13#17#17#245#240#244#245#240#0#0#0 + +#245#245#219#245#10#6#14#14#18#18#18'6'#18#22'6'#22'::'#21'b'#138'b'#138#134 + +'a'#134'aaa]]9545'#12#13#12#12#245#244#244#13#13#17#245#12#13#13#240#244#244 + +#245#0#244#240#240#240#241#240#240#244#240#12#244#13#240#244#244#17#17#17#12 + +#13'5'#21'9'#21#17'5'#17'9955550'#13#12#245#244#245#244#244#244#0#245#240#241 + +#0#240#0#241#240#0#240#244#240#244#241#244#0#244#0#244#0#244#244#0#244#13#0#0 + +#0#13#17#13#244#13#244#12#240#0#241#0#244#0#0#0#245#245#245#245#219#245#6#14 + +#6#14#14#18#18#18'6'#18'6'#17'6:b'#137'aaaaaa=]8545'#13#12#13#244#245#244#244 + +#13#12#244#244#244#12#240#244#0#244#241#240#240#245#13#16#17#12#244#13#12#17 + +#17#13#21#12#13#13#13#12#13#244#13#21'9'#21'9'#16#17#16'9'#17'85'#12#12#13 + +#244#244#244#244#240#12#13#240#245#240#0#240#240#241#240#244#0#245#240#240 + +#241#0#244#0#240#245#240#241#240#241#0#240#241#12#0#0#0#244#245#244#240#244 + +#244#245#240#240#240#244#240#0#0#0#245#245#245#245#245#245#13#245#14#13#6#14 + +#14#17#14#17#18#18#17#17'9babaaa]]9955'#13#12#245#12#244#244#245#244#12#13 + +#245#13#245#13#244#13#241#244#244#244#0#244#17#17#12#13#17#12#13#12#13#244 + +#245#244#240#240#12#17#244#13#21#16#21'9'#21'9'#21#17#21#17'9'#17#21#17#12#17 + +#13#244#13#17#13#12#244#0#244#244#245#244#244#244#241#244#0#244#0#244#240#241 + +#240#244#0#244#0#244#240#240#240#244#245#244#244#244#245#0#13#244#13#244#245 + +#245#0#244#0#240#0#0#0#240#241#245#245#245#245#245#13#245#6#245#6#14#6#14#6 + +#13#6#17#17#13'9aaa]]]9950'#13#12#13#244#245#244#244#244#241#0#244#244#244 + +#244#245#244#244#240#0#245#240#241#240#16#13#244#12#17#17#13#17#17#12#13#244 + +#245#244#13#245#244#12#17#21'9'#21'9'#21'99='#17#21'=='#17#12#21#17#12#12#13 + +#13#245#240#240#0#244#0#245#240#244#244#241#244#240#241#240#240#244#0#245#240 + +#240#244#0#240#0#12#13#244#13#13#13#240#0#244#240#13#244#244#12#0#240#241#240 + +#0#0#0#241#244#245#0#245#245#245#245#245#245#13#13#13#245#219#13#13#13#13#13 + +#13#13#17'9]99954'#13#13#12#245#244#245#244#244#13#17#244#240#245#244#245#244 + +#12#240#245#240#240#244#240#0#244#245#17#21#13#12#13#12#13#16#13#13#240#240 + +#240#0#240#245#0#244#17#17#16#17#17#17#16#21#17#16#21#17#17#17#17#13#17#245 + +#244#244#240#0#244#241#240#240#244#244#245#240#244#0#244#240#240#241#0#244 + +#240#0#245#0#245#240#0#17#245#244#244#240#240#244#240#13#244#219#17#21#13#240 + +#0#240#0#0#0#0#240#245#0#245#245#240#245#245#245#245#245#245#245#13#13#13#245 + +#13#13#13#17#13#21'99954'#12#13#13#244#245#244#244#244#240#13#17#12#240#0#12 + +#245#244#244#245#244#244#0#245#240#0#240#240#17#16#17#12#13#12#13#12#13#13#12 + +#0#0#0#13#244#244#244#13#21#21#21#21#21#21#21'9'#21#17#17#16#17#21#21#244#240 + +#12#244#245#244#13#21#244#0#240#241#240#0#244#0#244#241#0#244#0#244#241#0#244 + +#240#240#240#0#13#12#240#244#13#13#12#13#13#244#240#13#12#17#12#0#240#240#240 + +#0#0#0#244#0#245#244#0#245#245#0#244#245#241#245#244#245#245#244#13#21#17#13 + +#17#17#21'9='#21'5'#17#13#244#244#244#244#244#245#12#17#240#240#219#240#240 + +#13#244#245#245#12#13#13#240#244#245#240#0#244#13#13#244#13#13#13#13#13#13#12 + ,#13#240#0#240#13#13#240#13#17#12#17#17#17#16#17#17#21#17#13#12#13#13#244#13 + +#245#0#13#13#244#12#17#245#244#244#0#240#240#245#240#241#240#240#240#241#244 + +#0#240#240#241#0#240#0#240#16#17#17#244#240#244#17#12#13#13#244#244#17#219 + +#245#0#0#240#0#0#0#0#241#240#0#241#244#0#245#245#240#245#244#245#245#244#245 + +#245#12#13#13#13#17#17'9'#21'9='#21'9'#17#17#244#13#21#12#245#12#17#244#240 + +#13#241#0#244#244#244#244#245#244#13#0#240#240#245#0#240#16#13#244#244#12#244 + +#12#244#12#13#13#244#244#244#12#245#240#244#17#17#16#21#17#17#21#17#21#16#13 + +#245#244#245#240#240#240#0#240#240#245#240#241#0#0#241#240#0#240#0#240#240#0 + +#244#0#240#240#241#0#240#240#240#0#240#13#17#21#13#0#245#240#0#0#244#17#245 + +#244#245#244#244#244#245#0#240#0#0#0#0#244#0#244#240#241#244#0#245#240#245 + +#240#245#244#244#244#13#17#13#244#13#17#21#17#21#17#21#21#17#12#13#12#21#17 + +#12#13#240#0#240#17#240#240#13#244#245#12#12#245#244#0#245#244#240#0#240#245 + +#17#21#17#13#13#13#13#17#12#13#0#0#0#245#240#240#0#240#17#13#17#16#17#17#16 + +#21#17#13#244#244#244#0#0#0#0#0#0#244#0#240#0#240#244#244#240#0#240#240#0#241 + +#0#240#240#0#244#240#240#0#0#240#13#12#17#13#12#13#12#244#245#240#244#17#244 + +#244#0#244#245#13#244#0#240#0#0#0#240#241#240#241#0#244#0#240#241#240#244#241 + +#244#241#245#17#219#13#12#244#13#16#17#13#12#13#17#12#13#21#21#17#17#17#13#16 + +#17#12#245#244#240#240#245#244#245#240#245#0#244#240#240#0#0#240#240#17#12 + +#245#244#244#244#244#244#244#245#244#240#244#13#244#244#245#12#17#16#17#16#17 + +#17#17#17#17#17#12#244#244#245#0#240#240#240#0#244#245#240#0#0#244#245#219#13 + +#244#0#0#240#240#240#240#0#240#0#0#0#240#245#218#13#244#219#12#21#17#240#0#13 + +#244#245#17#244#13#12#13#244#12#13#0#0#0#0#0#240#0#240#240#241#240#245#240 + +#244#241#244#240#240#244#12#245#240#244#17#17#21#13#17#244#17#244#13#13#12#17 + +#17#12#13#244#240#245#17#13#12#17#12#219#244#240#244#244#244#240#245#0#244 + +#241#240#0#245#12#245#244#13#17#17#13#17#17#17#17#17#13#12#245#244#244#17#21 + +#17#17#17#17#219#244#240#12#13#245#0#245#244#240#244#241#244#241#240#13#0#240 + +#0#0#244#240#244#245#240#244#240#0#0#0#240#0#241#244#240#244#13#245#12#244#13 + +#17#17#13#12#245#240#0#244#13#244#13#17#17#245#13#17#240#240#0#0#0#240#244#0 + +#240#240#0#0#0#0#0#0#240#17#17#17#17#240#0#245#245#12#13#16#17#21#21#244#12 + +#13#16#245#0#244#245#244#240#244#0#0#245#244#240#241#244#245#244#245#244#12#0 + +#0#240#240#0#240#13#16#13#12#244#13#244#244#244#12#245#244#245#0#244#245#0 + +#245#244#13#12#17#13#12#245#12#13#244#12#13#244#245#0#0#0#240#0#0#240#0#0#0 + +#240#245#244#245#244#17#17#0#244#240#245#0#240#16#21#13#244#244#244#245#240 + +#12#21#17#0#13#244#240#0#240#13#244#244#0#244#244#244#244#0#0#0#0#0#245#12 + +#241#0#240#240#244#245#244#244#245#244#245#244#245#17#244#0#244#244#245#244 + +#219#17#21#21#244#13#13#17#12#244#13#245#244#245#17#0#0#0#240#241#244#244#240 + +#0#244#13#245#0#240#240#0#0#240#244#17#17#17#13#12#13#17#17#17#244#0#244#240 + +#245#244#244#240#244#17#17#16#17#13#244#244#13#12#13#240#245#244#0#240#0#0#0 + +#240#0#0#240#0#244#13#244#244#245#244#244#0#244#245#12#0#240#245#13#13#244#13 + +#245#13#244#17#13#244#0#245#240#245#0#245#17#245#13#240#244#245#219#13#0#240 + +#0#0#0#0#240#244#240#0#244#13#17#244#240#245#244#0#13#244#0#0#0#13#244#13#12 + +#13#21#245#244#245#244#244#245#13#21#12#244#244#244#244#244#245#244#13#244 + +#244#13#13#244#245#240#244#0#240#245#0#240#241#17#244#244#245#244#13#244#244 + +#244#245#244#245#13#13#244#244#241#13#17#12#17#17#17#16#13#12#17#17#13#244 + +#244#0#0#0#240#0#240#0#0#240#0#0#245#244#240#245#244#244#245#0#245#244#13#240 + +#0#0#244#244#12#240#240#12#240#245#240#0#0#244#244#244#0#0#244#244#244#0#245 + +#244#241#240#0#240#0#0#0#12#17#13#244#17#13#218#245#244#13#244#245#244#244#13 + +#244#0#240#219#12#17#13#12#13#244#0#244#13#244#0#240#17#21#13#12#245#0#245 + +#244#0#240#240#0#244#13#240#244#0#245#0#240#0#240#0#244#13#245#244#13#12#13 + +#17#13#17#17#13#244#0#240#240#240#240#12#219#17#17#16#17#17#17#17#17#12#244 + +#244#245#240#0#240#0#240#0#240#0#0#0#0#244#245#244#244#244#17#12#0#244#244#17 + +#244#0#0#13#17#13#245#12#245#12#17#244#0#0#13#13#245#0#240#13#245#244#240#244 + +#244#244#244#0#240#0#0#0#245#12#245#244#13#244#245#244#245#244#245#244#13#244 + +#13#245#13#12#245#244#245#12#13#13#244#244#13#12#13#244#244#13#16#245#245#244 + +#12#245#244#13#244#245#13#244#245#244#245#240#244#240#0#244#0#240#0#12#16#13 + +#244#245#244#245#244#244#244#245#240#0#0#245#0#0#244#13#16#13#17#13#16#17#17 + +#21#13#245#0#240#240#0#0#0#0#0#0#240#0#240#0#0#240#0#241#240#13#245#0#245#244 + +#0#0#0#244#17#13#12#244#13#244#245#21#13#240#0#0#240#244#0#244#219#12#245#0 + +#245#244#17#13#0#240#0#0#0#240#0#245#12#13#13#13#244#240#0#0#240#245#0#244 + +#240#244#245#240#0#244#13#13#12#244#13#16#17#17#17#244#219#13#244#0#245#17#0 + +#244#13#240#244#240#244#240#244#240#244#245#0#240#245#0#0#240#13#13#17#12#244 + +#13#12#13#13#13#244#0#0#0#240#244#245#244#245#17#17#16#17#17#17#20#21#17#244 + +#240#245#0#0#240#0#240#0#240#0#240#0#0#240#240#13#12#244#0#0#0#17#13#0#0#0#13 + +#12#244#17#13#16#17#244#244#219#245#0#0#240#17#240#0#240#240#244#0#244#244 + ,#245#240#0#244#0#0#0#240#244#244#245#12#244#240#244#0#240#240#244#244#0#0#0 + +#245#244#240#244#245#13#12#12#13#17#219#17#21#17#12#13#13#244#240#244#244#0 + +#244#245#0#0#0#245#244#245#12#219#244#240#245#244#0#240#241#13#244#244#13#13 + +#13#12#13#240#0#240#240#241#0#244#245#244#245#0#244#12#13#13#12#13#13#17#12 + +#245#0#240#0#240#0#0#0#240#0#0#0#0#240#0#245#244#245#240#13#244#0#12#244#0#0 + +#240#245#12#13#17#12#13#17#12#17#12#240#0#0#245#17#0#0#240#245#13#12#219#245 + +#0#0#0#17#0#0#0#17#17#240#244#17#13#244#245#244#13#17#245#245#244#244#244#13 + +#13#0#245#244#244#245#245#12#12#244#245#244#16#245#244#12#245#240#245#13#0 + +#240#244#245#244#240#240#240#244#241#244#245#0#240#244#0#0#244#13#244#240#245 + +#12#244#245#12#244#0#240#0#12#13#240#240#0#240#244#17#13#17#16#17#16#17#16#13 + +#244#240#244#0#0#0#240#0#0#240#0#240#0#0#240#240#12#13#240#13#245#240#17#13#0 + +#0#240#17#17#12#219#13#12#219#17#17#17#12#0#0#240#13#240#244#219#244#244#245 + +#244#240#13#244#0#244#0#0#0#13#219#240#240#13#244#244#13#244#245#12#244#245 + +#244#245#240#244#240#240#240#245#244#244#17#17#13#244#244#13#17#16#17#13#244 + +#240#244#13#240#241#244#12#13#245#244#245#240#244#0#244#240#0#245#240#240#0 + +#244#17#21#13#13#13#13#13#13#13#244#0#241#244#240#0#0#245#244#13#12#17#17#17 + +#17#17#17#17#244#0#241#240#0#0#0#0#240#0#0#0#240#0#0#244#245#12#240#12#244#0 + +#13#244#0#0#240#12#245#244#13#244#13#12#245#244#13#245#0#0#240#17#240#240#13 + +#240#245#12#245#244#244#245#240#17#0#0#0#240#240#0#13#17#13#244#240#13#12#17 + +#13#12#13#244#0#0#0#244#244#244#245#244#244#17#17#244#245#244#21#13#13#12#240 + +#245#0#0#244#12#244#13#12#245#244#13#244#245#240#245#0#240#240#0#0#245#12#245 + +#244#244#244#244#244#12#244#13#244#0#0#0#245#240#0#244#240#240#12#17#16#17#16 + +#17#21#13#244#245#244#240#0#240#0#240#0#240#0#240#0#0#240#245#244#245#240#17 + +#245#0#13#245#0#240#0#0#240#240#244#240#240#245#0#244#0#240#0#0#244#13#0#240 + +#13#244#244#244#245#244#13#240#0#244#0#0#0#12#13#240#244#13#244#245#244#245 + +#244#245#244#245#12#245#0#0#240#13#13#13#12#245#240#13#12#245#244#244#13#244 + +#244#17#13#12#240#0#17#13#13#17#13#12#240#0#244#240#240#244#0#240#240#0#240 + +#244#13#244#244#17#17#17#17#17#17#21#13#0#244#240#244#0#0#244#13#13#17#17#17 + +#17#17#17#17#12#245#12#240#0#0#0#240#0#0#0#0#0#0#0#240#240#240#244#244#245 + +#244#244#244#240#0#0#0#240#245#12#245#244#245#244#244#13#240#0#0#0#240#13#240 + +#244#17#244#240#245#244#244#17#244#0#13#0#0#0#245#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#245#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#245#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#245#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#245#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + ,#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#241#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#240#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'$' + +#236#236#236'$'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#241#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'H'#249#249#249#249 + +#249#236#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#236#249#249#249#249#249'H'#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#240#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#249#249#249#249#249'l'#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#144#249#249#249#249#249#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#241#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0'l'#249#249#249#249#249#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#8 + +#255#255#7#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0'H'#249#249#249#249#249#236#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#240 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#8#255 + +#255#7#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#236#249#249#249#249#249'H'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#8#255#255#7#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#249 + +#249#249#249#249'l'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#170#255#246#7#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#144#249#249 + +#249#249#144#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#240#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#8#255#255#7#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'l'#249#249#249#249 + +#249#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#8#209#255#7#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'H'#249#249#249#249#249#236#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#8#255#255#7#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#236#249#249#249#249#249'H'#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#240#0#0#0#0#0#0#0#0#0#0#0#0#0#0'-'#245#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#8#255#255#7#0#0#240#245#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#240#245#245#0#0#0#0#0#0#0#0#0#240#245#0#0#0#0#0 + ,#0#0#0#0#0'-'#245#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#249#249#249#249#249 + +'l'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#7#255#255 + +#255#255#246'1'#0#0#0#0#0#0#8#255#255#7#0#0#0#0#0#170#255#255'U'#240#255#255 + +#255#255#7#0#0#0#0#0#8#255#255#7#0#0#0#0#0#7#255#255#8#0#0#0#0#0#7#246#255 + +#255#255#255#255#130#0#0#0#0#7#255#255#255#255#247#0#245#246#255#134#7#246 + +#255#255#255#255#8'-'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#249#249#249#249#249#144 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#8#255#255#255 + +#246#255#255#255#247#0#0#0#0#0#8#255#255#7#0#0#0#0#0#8#255#255#7#255#255#255 + +#255#255#255#134#0#0#0#0#8#255#255#7#0#0#0#0#0#7#255#255#8#0#0#0#0#175#246 + +#255#255#246#246#246#246#255#0#0#0'1'#255#255#255#255#246#255#8'-'#255#255'U' + +#255#255#255#246#246#246#255#255'1'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'l'#249#249 + +#249#249#249#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#175 + +#255#255#255#247#7#8#255#255#255#7#0#0#0#0#8#255#255#7#0#0#0#0#0#8#255#255 + +#255#255#134#7#130#255#255#255#7#0#0#0#8#255#255#7#0#0#0#0#0#7#255#255#8#0#0 + +#0#175#255#255#255#247'-'#245#245#7#8#0#0#0#246#255#255#255#247#7#246#255#255 + +#255#255'1'#7#255'Y'#245#245#247#255#255#246#245#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +'H'#249#249#249#249#249#236#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#240#0#0#0#0#0 + +#0#0#0#0#7#255#255#255#240#0#0#0'1'#255#255#255#0#0#0#0#170#255#246#7#0#0#0#0 + +#0#8#255#255#255#247#0#0#0#7#255#255#255#0#0#0#8#255#246#7#0#0#0#0#0#7#255 + +#209#8#0#0#7#255#255#255#240#0#0#0#0#0#0#0#0#245#255#255#255'1'#0#0#0#134#255 + +#255#246#7#0#0#0#0#236#236#7#255#255#130#236#236#236#236#236#236#236#236#236 + +#236#236#236#236#236'$'#249#249#249#249#249'H'#236#236#236#236#236#236#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#7#0#0#0#0#0#130#255#255 + +#247#0#0#0#8#255#255#7#0#0#0#0#0#170#255#255#255#0#0#0#0#0#246#255#255#7#0#0 + +#170#255#255#7#0#0#0#0#0#7#255#255#8#0#0#246#255#255#7#0#0#0#0#0#0#0#0#0#7 + +#255#255#246#0#0#0#0#0#255#255#255#7#0#0#0'H'#249#249#249#255#255#246#249#249 + +#249#249#249#249#249#249#249#249#249#249#249#249#249#249#249#249#249#249#249 + +#249#249#249#249#249#249'l'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'-'#255 + +#255#255#0#0#0#0#0#0#245#246#255#255#0#0#0#8#209#255#7#0#0#0#0#0#8#255#255 + +#134#0#0#0#0#0#7#255#255#134#0#0#8#255#255#7#0#0#0#0#0#7#246#255#8#0#240#255 + +#255#255#0#0#0#0#0#0#0#0#0#0#247#255#255#130#0#0#0#0#0#209#255#255#7#0#0#0 + +#236#249#249#249#255#255#255#249#249#249#249#249#249#249#249#249#249#249#249 + +#249#249#249#249#249#249#249#249#249#249#249#249#249#249#249#249#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#247#255#255#7#0#0#0#0#0#0#0#246#255#255'1'#0#0#8 + +#255#255#7#0#0#0#0#0#8#255#255#7#0#0#0#0#0#245#255#255#255#0#0#8#255#255#7#0 + +#0#0#0#0#7#255#255#170#0#7#255#255#8#0#0#0#0#0#0#0#0#0#0#8#255#255#7#0#0#0#0 + +#0#8#255#255#7#0#0#0#0'l'#249#182#255#255#255#249#249#249#249#249#249#249#249 + +#249#249#249#249#249#249#249#249#249#249#249#249#249#249#249#249#249#249#249 + +#249'H'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#246#255#255'1'#0#0#0#0#0#0#0 + +#130#255#255#247#0#0#8#255#246#7#0#0#0#0#0#170#255#246#7#0#0#0#0#0#0#255#255 + +#255#0#0#170#255#246#7#0#0#0#0#0#7#255#255#8#0#7#255#255#7#0#0#0#0#0#0#0#0#0 + +#0#8#255#246#7#0#0#0#0#0#170#255#246#7#0#0#0#0#0#1#204#255#255#170'$HHHHHHHH' + +'HHHHHHl'#249#249#249#249#249#1'HHHHHH$'#0#0#0#0#0#0#0#0#0#0#240#0#0#0#0#0#0 + +#0#0#255#255#255#0#0#0#0#0#0#0#0#7#255#255#8#0#0#170#255#255#7#0#0#0#0#0#8 + +#255#255#7#0#0#0#0#0#0#255#255#246#245#0#8#255#255#7#0#0#0#0#0#7#255#255#134 + +#0#170#255#255'U'#0#0#0#0#0#0#0#0#0#0#170#255#255#7#0#0#0#0#0#8#255#255#7#0#0 + +#0#0#0#130#255#255#255'Q'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'$'#249#249#249#249 + +#249#236#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'('#0#0#0#0#0#0#0#245#246#255#255#0 + +#0#0#0#0#0#0#0#245#246#255#255#0#0#8#255#255#7#0#0#0#0#0#8#209#255#7#0#0#0#0 + +#0#0#255#255#255#245#0#8#255#255#7#0#0#0#0#0#7#246#255#8#0#8#255#255#247#241 + +#244#245#245#245#245#245'-'#245#0#8#255#255#7#0#0#0#0#0#8#209#255#7#0#0#0#245 + +#246#255#255#255#200#249'$'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#249#249#249#249#249 + +'H'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#240#0#0#0#0#0#0#0#245#255#246#175#0#0#0 + +#0#0#0#0#0#245#255#255#255#0#0#8#255#255#7#0#0#0#0#0#8#255#255#7#0#0#0#0#0#0 + +#255#255#246#245#0#170#255#255#7#0#0#0#0#0#7#255#255#170#0#8#255#255#255#255 + +#255#255#255#255#255#255#255#255#0#8#255#255#7#0#0#0#0#0#8#255#255#7#0#0'1' + +#255#255#255#255#247#144#249#249'$'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#249#249#249 + +#249#249#144#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#7#255#255#170 + +#0#0#0#0#0#0#0#0#0#255#255#255#0#0#170#255#255#7#0#0#0#0#0#8#255#246#7#0#0#0 + +#0#0#0#255#255#255#245#0#8#255#246#7#0#0#0#0#0#7#255#255#8#0#130#255#255#255 + +#246#246#246#246#255#255#255#255#255#0#170#255#246#7#0#0#0#0#0#8#255#246#7#0 + +'1'#255#255#255#255#7#0#0#144#249#249'$'#0#0#0#0#0#0#0#0#0#0#0#0#0#144#249 + +#249#249#249#249#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#240#0#0#0#0#0#0#0#7#255 + +#255#8#0#0#0#0#0#0#0#0#0#255#255#255#245#0#8#255#255#7#0#0#0#0#0#170#255#255 + ,#7#0#0#0#0#0#0#255#255#255#0#0#8#255#255#7#0#0#0#0#0#7#255#255#170#0#7#255 + +#255#7#245#245#245#245#245#240#255#255#255#0#134#255#255#7#0#0#0#0#0#170#255 + +#255#7#0#255#255#255#8#240#0#0#0#0#144#249#249#236#0#0#0#0#0#0#0#0#0#0#0#0'H' + +#249#249#249#249#249#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#7#246 + +#255#8#0#0#0#0#0#0#0#0#0#255#255#255#241#0#170#255#255#130#0#0#0#0#0#8#255 + +#255#7#0#0#0#0#0#245#246#255#246#0#0#170#255#255#7#0#0#0#0#0#7#255#255#8#0'1' + +#255#255#247#0#0#0#0#0#0#255#255#175#0#8#255#255#7#0#0#0#0#0#8#255#255'U1' + +#255#255#246#0#0#0#0#0#0#0#249#249#249#236#0#0#0#0#0#0#0#0#0#0#0'$'#249#249 + +#249#249#249#236#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#7#255#255 + +#170#0#0#0#0#0#0#0#0#0#255#255#255#244#0#8#255#255#255#0#0#0#0#0#8#255#255 + +#134#0#0#0#0#0#7#255#246#175#0#0#8#255#255#247#0#0#0#0#0#7#255#255#8#0#0#255 + +#255#8#0#0#0#0#0#240#255#255#8#0#170#255#255#7#0#0#0#0#0#8#255#255'1'#8#255 + +#255'1'#0#0#0#0#0#0#0#236#249#249#249#236#0#0#0#0#0#0#0#0#0#0#0#249#249#249 + +#249#249'H'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#7#255#255#8#0#0#0 + +#0#0#0#0#0#0#255#255#246#245#0#8#255#255#255#7#0#0#0#0#170#255#255#255#0#0#0 + +#0#0#8#255#255#7#0#0#8#255#255#246#0#0#0#0#0#8#255#255#7#0#0#8#255#255#0#0#0 + +#0#0#7#255#255#7#0#8#255#246#7#0#0#0#0#0#8#255#255'1'#134#255#246#241#0#0#0#0 + +#0#0#0#0#236#249#249#249#0#0#0#0#0#0#0#0#0#0#0#249#249#249#249#249'l'#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#7#255#255#8#0#0#0#0#0#0#0#0#0#255 + +#255#255#245#0#170#255#255#255#255#7#0#0#0#8#255#255#255#7#0#0#0'1'#255#255 + +#255#245#0#0#170#255#255#255#7#0#0#0#240#255#255#255'1'#0#0#7#255#255#247#0#0 + +#0#0#246#255#255#240#0#170#255#255#7#0#0#0#0#0#170#255#255'U'#7#255#255#7#0#0 + +#0#0#0#0#0#0#0#236#249#249#144#0#0#0#0#0#0#0#0#0#0#144#249#249#249#249#144#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#245#246#255#8#0#0#0#0#0#0#0#0 + +#245#246#255#255#0#0#8#255#255#7#255#255#255#8#241#134#255#255#255#255#7#241 + +'Y'#255#255#255#8#0#0#0#8#255#255#255#255#7#245'1'#255#255#255#255#0#0#0#0 + +#255#255#255#7#0#0#247#255#255#8#0#0#8#255#255#7#0#0#0#0#0#8#255#255'1'#0#255 + +#255#255'1'#0#0'1'#130#0#0#0#0#0#236#249#249#144#0#0#0#0#0#0#0#0#0'H'#249#249 + +#249#249#249#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#240#0#0#0#0#0#0#0#245#255#255 + +#255#0#0#0#0#0#0#0#0#245#255#255#255#0#0#8#255#255#0#255#255#255#255#244#170 + +#255#255#240#255#255#255#255#255#255#255#240#0#0#0#8#255#255#7#255#255#255 + +#255#255#255#255#7#0#0#0#0#240#246#255#255#255#255#255#255#255#241#0#0#8#255 + +#255#7#0#0#0#0#0#8#255#255#7#0#7#255#255#255#255#255#255#255#240#0#0#0#0#0'$' + +#249#249#144#0#0#0#0#0#0#0#0'$'#249#249#249#249#249#236#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#0#0#0#0#0#0#0#0#7#255#255#246#0#0#246 + +#246#255#0#240#246#255#255#241#8#246#255#0'1'#255#255#255#255#255'-'#0#0#0#0 + +#170#255#255'1'#240#246#246#255#255#255#247#0#0#0#0#0#0#241#8#255#255#255#255 + +#255#240#0#0#0#8#246#255#7#0#0#0#0#0#8#246#255#7#0#0#7#255#255#255#255#246 + +#255'-'#0#0#0#0#0#0'$'#249#249'l'#0#0#0#0#0#0#0#0#249#249#249#249#249'H'#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#246#255#255'-'#0#0#0#0#0#0#0#247 + +#255#255#130#0#0'-'#245'-'#0#0#0'1'#7#240#245'-'#245#0#0#0'1'#7'1'#0#0#0#0#0 + +#0#8#255#255'U'#0#0#245#7#7#240#0#0#0#0#0#0#0#0#0#240#7#7'-'#0#0#0#0#0#245'-' + +#245#240#0#0#0#0#0#245'-'#245#240#0#0#0#0'1'#7#7#245#0#0#0#0#0#0#0#0#0'$'#249 + +#249'l'#0#0#0#0#0#0#0#249#249#249#249#249'l'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#247#255#255#7#0#0#0#0#0#0#0#246#255#255#7#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#8#209#255#7#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0'$'#249#249'l'#0#0#0#0#0#0#144#249#249#249#249#144#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0'-'#255#255#246#0#0#0#0#0#0#0#255#255#255#240#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#8#255#255#7#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0'$'#249#249'H'#0#0#0#0#0'H'#249#249#249#249#249#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#246#255#246#245#0#0#0#0#0#247#255#255 + +#175#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#8#255#246#7#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1#249#249'$'#0#0#0#0'$'#249#249#249#249#249 + +#236#0#0#0#0#0#0#0#0#0#0#0#0#0#0#240#0#0#0#0#0#0#0#0#0'1'#255#255#246#0#0#0#0 + +#245#246#255#246'1'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#170 + +#255#255#7#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#7'1-'#7'1'#130#0#209#0#0#0#0'l'#249#249'$'#0#0#0#0 + +#249#249#249#249#249'$'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#175 + +#246#255#246'1'#245'U'#255#255#255#175#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#8#255#255#7#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#7'-'#240#170#7#246#245#8#0#0#0 + ,#0#0'l'#249#249'$'#0#0#0#249#249#249#249#249#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#175#255#255#255#255#255#255#255#255#240#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#8#255#255#7#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#7#245 + +#0#8#175'1'#7#7#0#0#0#0#0#0'l'#249#249#236#0#0#144#249#249#249#249#144#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#247#255#255#255#255#255#8#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#8#255#255#7#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#7'-'#0#255#247#0#175#7#0#0#0#0#0#0#0'l'#249#249#236#0#1#249#249 + +#249#249#249#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'1'#7#7 + +#240#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#8#255#255 + +#7#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#247#175#8#7#8'-'#0#247#7#0#0#0#0#0#0#0#0#144#249#249#236'$' + +#249#249#249#249#249#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#144#249#249#236#249 + +#249#249#249#249'$'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#144#249#144#249#249#249 + +#249#249'H'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#144#249#249#249#249#249#249 + +#144#0#0#0#0#0#0#0#0#0#0#0#0#0#240#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#144#249#249#249#249#249#249#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#249#249#249#249#249#249#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#236#249#249#249#249#249#236#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#236#249#249#249#249'H'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#236#249#249#249'l'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#236#249 + +#249#249#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + ,#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#240#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#240#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + ,#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#240#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#236#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#240#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#236#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#236#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#240#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#236#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#7'TButton'#5'btnOK'#4'Left' + +#3'o'#1#3'Top'#3#21#1#5'Width'#2'X'#6'Height'#2#25#6'Cancel'#9#7'Caption'#6#2 + +'OK'#11'ModalResult'#2#2#8'TabOrder'#2#1#7'OnClick'#7#10'btnOKClick'#0#0#0 +]); diff --git a/components/orpheus/ovcabot0.pas b/components/orpheus/ovcabot0.pas new file mode 100644 index 000000000..6826365b1 --- /dev/null +++ b/components/orpheus/ovcabot0.pas @@ -0,0 +1,197 @@ +{*********************************************************} +{* OVCABOT0.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit Ovcabot0; + +interface + +uses + {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, LclType, LResources, MyMisc, Buttons, {$ENDIF} + SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, + {$IFNDEF LCL} {$IFDEF VERSION6} DesignIntf, DesignEditors, {$ELSE} DsgnIntf, {$ENDIF} {$ELSE} PropEdits, {$ENDIF} + ExtCtrls, OvcVer, OvcURL, {$IFDEF MSWINDOWS} ShellAPI; {$ELSE} Unix; {$ENDIF} + +type + TOvcfrmAboutForm = class(TForm) + Panel1: TPanel; + Image1: TImage; + btnOK: TButton; + Label1: TLabel; + VisitUsLabel: TLabel; + lblTurboLink: TLabel; + Bevel3: TBevel; + GeneralNewsgroupsLabel: TLabel; + lblHelp: TLabel; + lblGeneralDiscussion: TLabel; + Label3: TLabel; + Label2: TLabel; + procedure btnOKClick(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure lblTurboLinkClick(Sender: TObject); + procedure lblHelpClick(Sender: TObject); + procedure lblGeneralDiscussionClick(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + + TOvcAboutProperty = class(TStringProperty) + public + function GetAttributes: TPropertyAttributes; + override; + procedure Edit; + override; + end; + +implementation +{$IFNDEF LCL} +{$R *.DFM} +{$ENDIF} + + +{*** TOrAboutProperty ***} + +function TOvcAboutProperty.GetAttributes: TPropertyAttributes; +begin + Result := [paDialog, paReadOnly]; +end; + +procedure TOvcAboutProperty.Edit; +begin + with TOvcfrmAboutForm.Create(Application) do begin + try + ShowModal; + finally + Free; + end; + end; +end; + +{*** TEsAboutForm ***} + +procedure TOvcfrmAboutForm.btnOKClick(Sender: TObject); +begin + Close; +end; + +procedure TOvcfrmAboutForm.FormCreate(Sender: TObject); +begin + Top := (Screen.Height - Height) div 3; + Left := (Screen.Width - Width) div 2; + + lblTurboLink.Cursor := crHandPoint; + lblHelp.Cursor := crHandPoint; + lblGeneralDiscussion.Cursor := crHandPoint; + +{$IFDEF LCL} + Image1.Transparent := False; //Default is True with Laz, False with Delphi +{$ENDIF} +end; + +procedure TOvcfrmAboutForm.lblTurboLinkClick(Sender: TObject); +begin +{$IFDEF MSWINDOWS} + {$IFNDEF LCL} + if ShellExecute(0, 'open', 'http://sourceforge.net/projects/tporpheus/', + {$ELSE} + if ShellExecute(0, 'open', PChar('http://sourceforge.net/projects/tporpheus/'), + {$ENDIF} + '', '', SW_SHOWNORMAL) <= 32 +{$ELSE} + {$IFDEF DARWIN} + if Shell('Open http://sourceforge.net/projects/tporpheus/') = 127 + {$ELSE} + if (GetBrowserPath = '') or + (Shell(GetBrowserPath + ' http://sourceforge.net/projects/tporpheus/') = 127) + {$ENDIF} +{$ENDIF} + then + ShowMessage('Error launching browser.'); +end; + +procedure TOvcfrmAboutForm.lblHelpClick(Sender: TObject); +begin +{$IFDEF MSWINDOWS} + if ShellExecute(0, 'open', + {$IFNDEF LCL} + 'http://sourceforge.net/forum/forum.php?forum_id=241874', '', '', + {$ELSE} + PChar('http://sourceforge.net/forum/forum.php?forum_id=241874'), '', '', + {$ENDIF} + SW_SHOWNORMAL) <= 32 +{$ELSE} + {$IFDEF DARWIN} + if Shell('Open http://sourceforge.net/forum/forum.php?forum_id=241874') = 127 + {$ELSE} + if (GetBrowserPath = '') or + (Shell(GetBrowserPath + ' http://sourceforge.net/forum/forum.php?forum_id=241874') = 127) + {$ENDIF} +{$ENDIF} + then + ShowMessage('Error launching browser.'); +end; + +procedure TOvcfrmAboutForm.lblGeneralDiscussionClick(Sender: TObject); +begin +{$IFDEF MSWINDOWS} + if ShellExecute(0, 'open', + {$IFNDEF LCL} + 'http://sourceforge.net/forum/forum.php?forum_id=241873', '', '', + {$ELSE} + PChar('http://sourceforge.net/forum/forum.php?forum_id=241873'), '', '', + {$ENDIF} + SW_SHOWNORMAL) <= 32 +{$ELSE} + {$IFDEF DARWIN} + if Shell('Open http://sourceforge.net/forum/forum.php?forum_id=241873') = 127 + {$ELSE} + if (GetBrowserPath = '') or + (Shell(GetBrowserPath + ' http://sourceforge.net/forum/forum.php?forum_id=241873') = 127) + {$ENDIF} +{$ENDIF} + then + ShowMessage('Error launching browser.'); +end; + +initialization +{$IFDEF LCL} +{$I Ovcabot0.lrs} {Include form's resource file} +{$ENDIF} + +end. + diff --git a/components/orpheus/ovcbase.lrs b/components/orpheus/ovcbase.lrs new file mode 100644 index 000000000..ac8d0e660 --- /dev/null +++ b/components/orpheus/ovcbase.lrs @@ -0,0 +1,66 @@ +LazarusResources.Add('ORTCCOMBOARROW','BMP',[ + 'BM'#162#0#0#0#0#0#0#0'v'#0#0#0'('#0#0#0#7#0#0#0#11#0#0#0#1#0#4#0#0#0#0#0','#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#128#0#0#128#0#0#0#128#128#0 + +#128#0#0#0#128#0#128#0#128#128#0#0#128#128#128#0#192#192#192#0#0#0#255#0#0 + +#255#0#0#0#255#255#0#255#0#0#0#255#0#255#0#255#255#0#0#255#255#255#0#136#136 + +#136#128#136#136#136#128#136#136#136#128#136#128#136#128#136#0#8#128#128#0#0 + +#128#0#0#0#0#136#136#136#128#136#136#136#128#136#136#136#128#136#136#136#128 +]); +LazarusResources.Add('ORTCCHECKGLYPHS','BMP',[ + 'BM'#198#1#0#0#0#0#0#0'v'#0#0#0'('#0#0#0'*'#0#0#0#14#0#0#0#1#0#4#0#0#0#0#0'P' + +#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#128#0#0#128#0#0#0#128#128 + +#0#128#0#0#0#128#0#128#0#128#128#0#0#128#128#128#0#192#192#192#0#0#0#255#0#0 + +#255#0#0#0#255#255#0#255#0#0#0#255#0#255#0#255#255#0#0#255#255#255#0#215'www' + +'www'#215'wwwwww'#215'wwwwww'#0#0#0#15#255#255#255#255#255#247#15#255#255#255 + +#255#255#247#15#255#255#255#255#255#247#0#0#0#7#136#136#136#136#136#247#7#136 + +#136#136#136#136#247#7#8#128#8#128#8#247#0#0#0#7#136#136#136#136#136#247#7 + +#128#8#136#128#8#247#7#128#8#128#8#128#247#0#0#0#7#136#136#136#136#136#247#7 + +#128#0#136#0#8#247#7#128#8#128#8#128#247#0#0#0#7#136#136#136#136#136#247#7 + +#136#0#0#0#136#247#7#8#128#8#128#8#247#0#0#0#7#136#136#136#136#136#247#7#136 + +#128#0#8#136#247#7#8#128#8#128#8#247#0#0#0#7#136#136#136#136#136#247#7#136 + +#128#0#8#136#247#7#128#8#128#8#128#247#0#0#0#7#136#136#136#136#136#247#7#136 + +#0#0#0#136#247#7#128#8#128#8#128#247#0#0#0#7#136#136#136#136#136#247#7#128#0 + +#136#0#8#247#7#8#128#8#128#8#247#0#0#0#7#136#136#136#136#136#247#7#128#8#136 + +#128#8#247#7#8#128#8#128#8#247#0#0#0#7#136#136#136#136#136#247#7#136#136#136 + +#136#136#247#7#128#8#128#8#128#247#0#0#0#7'wwwww'#247#7'wwwww'#247#7'wwwww' + +#247#0#0#0#0#0#0#0#0#0#7#0#0#0#0#0#0#7#0#0#0#0#0#0#7#0#0#0 +]); +LazarusResources.Add('ORBTNCLC','BMP',[ + 'BM'#206#0#0#0#0#0#0#0'v'#0#0#0'('#0#0#0#11#0#0#0#11#0#0#0#1#0#4#0#0#0#0#0'X' + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#128#0#0#128#0#0#0#128#128 + +#0#128#0#0#0#128#0#128#0#128#128#0#0#128#128#128#0#192#192#192#0#0#0#255#0#0 + +#255#0#0#0#255#255#0#255#0#0#0#255#0#255#0#255#255#0#0#255#255#255#0'0'#0#0#0 + +#0'0'#0#0#8#136#136#136#136#0#0#0#8#8#8#153#152#0#0#0#8#136#136#136#136#0#0#0 + +#8#8#8#8#8#0#0#0#8#136#136#136#136#0#0#0#8#0#0#0#8#0#0#0#8#0#14#14#8#0#0#0#8 + +#0#0#0#8#0#0#0#8#136#136#136#136#0#0#0'0'#0#0#0#0'0'#0#0 +]); +LazarusResources.Add('ORCOLUMNMOVECURSOR','CUR',[ + #0#0#2#0#1#0' '#0#0#0#0#0#0'0'#1#0#0#22#0#0#0'('#0#0#0' '#0#0#0'@'#0#0#0#1#0 + +#1#0#0#0#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#31#224#0#0#31#224#0#0#31#224 + +#0#0#31#224#0#0#31#224#0#0'_'#224#0#0#223#224#0#0#223#224#0#1#159#224#0#1#159 + +#224#0#3#0#0#0#3#31#224#0'F'#31#224#0'f'#0#0#0'|'#0#0#0'|'#0#0#0''#192#0#0 + +''#128#0#0''#0#0#0'~'#0#0#0'|'#0#0#0'x'#0#0#0'p'#0#0#0'`'#0#0#0'@'#0#0#0#0 + +#0#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#192#15#255#255#223#239#255#255#223#239#255#255#223#239#255 + +#255#223#239#255#255#159#239#255#255#31#239#255#254#31#239#255#254#31#239#255 + +#252#31#239#255#252#31#239#255#248'@'#15#255'8@'#15#255#16#192#15#255#0#192 + +#15#255#1#255#255#255#0#31#255#255#0#31#255#255#0'?'#255#255#0''#255#255#0 + +#255#255#255#1#255#255#255#3#255#255#255#7#255#255#255#15#255#255#255#31#255 + +#255#255'?'#255#255#255 +]); +LazarusResources.Add('ORROWMOVECURSOR','CUR',[ + #0#0#2#0#1#0' '#0#0#0#0#0#0'0'#1#0#0#22#0#0#0'('#0#0#0' '#0#0#0'@'#0#0#0#1#0 + +#1#0#0#0#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#29#255#240#0 + +#29#255#240#0#29#255#240#0#0#0#0#0#0#192#0#0#0#192#0#0#1#128#0#0#1#128#0#0#3 + +#0#0#0#3#0#0#0'F'#0#0#0'f'#0#0#0'|'#0#0#0'|'#0#0#0''#192#0#0''#128#0#0''#0 + +#0#0'~'#0#0#0'|'#0#0#0'x'#0#0#0'p'#0#0#0'`'#0#0#0'@'#0#0#0#0#0#0#0#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#192#0#7#255#193#255#247#255#193#255#247#255#193 + +#255#247#255#192#0#7#255#254#31#255#255#254#31#255#255#252'?'#255#255#252'?' + +#255#255#248''#255#255'8'#255#255#16#255#255#255#0#255#255#255#1#255#255 + +#255#0#31#255#255#0#31#255#255#0'?'#255#255#0''#255#255#0#255#255#255#1#255 + +#255#255#3#255#255#255#7#255#255#255#15#255#255#255#31#255#255#255'?'#255#255 + +#255 +]); diff --git a/components/orpheus/ovcbase.pas b/components/orpheus/ovcbase.pas new file mode 100644 index 000000000..c55750774 --- /dev/null +++ b/components/orpheus/ovcbase.pas @@ -0,0 +1,2747 @@ +{*********************************************************} +{* OVCBASE.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.$W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +{$IFNDEF VERSION3} +!! Error - not for Delphi versions 1 and 2 or C++ Builder version 1 +{$ENDIF} + +{$IFNDEF LCL} +{$R OVCBASE.RES} +{$ENDIF} + +unit ovcbase; + {-Base unit for Orpheus visual components} + +interface + +uses + {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, LclType, LResources, MyMisc, {$ENDIF} + Classes, Controls, Dialogs, Forms, StdCtrls, SysUtils, + OvcCmd, OvcData, OvcMisc, OvcConst, OvcExcpt, {$IFNDEF LCL} OvcTimer, {$ENDIF} OvcDate; + +type + TOvcLabelPosition = (lpTopLeft, lpBottomLeft); {attached label types} + + TOvcAttachEvent = procedure(Sender : TObject; Value : Boolean) + of object; + + TOvcAttachedLabel = class(TLabel) + protected {private} + FControl : TWinControl; + + protected + procedure SavePosition; + procedure Loaded; + override; + + public + constructor Create(AOwner : TComponent); + override; + constructor CreateEx(AOwner : TComponent; AControl : TWinControl); + virtual; + procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); + override; + + published + property Control : TWinControl + read FControl write FControl; + end; + + TO32ContainerList = class(TList) + FOwner: TComponent; + public + constructor Create(AOwner: TComponent); virtual; + destructor Destroy; override; + end; + + TOvcLabelInfo = class(TPersistent) + protected {private} + {property variables} + FOffsetX : Integer; + FOffsetY : Integer; + + {event variables} + FOnChange : TNotifyEvent; + FOnAttach : TOvcAttachEvent; + + {internal methods} + procedure DoOnAttach; + procedure DoOnChange; + function IsVisible : Boolean; + + {property methods} + procedure SetOffsetX(Value : Integer); + procedure SetOffsetY(Value : Integer); + procedure SetVisible(Value : Boolean); + + public + ALabel : TOvcAttachedLabel; + FVisible : Boolean; + + property OnAttach : TOvcAttachEvent + read FOnAttach write FOnAttach; + property OnChange : TNotifyEvent + read FOnChange write FOnChange; + + procedure SetOffsets(X, Y : Integer); + + published + property OffsetX: Integer + read FOffsetX write SetOffsetX stored IsVisible; + property OffsetY: Integer + read FOffsetY write SetOffsetY stored IsVisible; + property Visible : Boolean + read FVisible write SetVisible + default False; + end; + + {event method types} + TMouseWheelEvent = procedure(Sender : TObject; Shift : TShiftState; + Delta, XPos, YPos : Word) of object; + + TDataErrorEvent = + procedure(Sender : TObject; ErrorCode : Word; const ErrorMsg : string) + of object; + TPostEditEvent = + procedure(Sender : TObject; GainingControl : TWinControl) + of object; + TPreEditEvent = + procedure(Sender : TObject; LosingControl : TWinControl) + of object; + TDelayNotifyEvent = + procedure(Sender : TObject; NotifyCode : Word) + of object; + TIsSpecialControlEvent = + procedure(Sender : TObject; Control : TWinControl; + var Special : Boolean) + of object; + TGetEpochEvent = + procedure (Sender : TObject; var Epoch : Integer) + of object; + + {options which will be the same for all fields attached to the same controller} + TOvcBaseEFOption = ( + efoAutoAdvanceChar, + efoAutoAdvanceLeftRight, + efoAutoAdvanceUpDown, + efoAutoSelect, + efoBeepOnError, + efoInsertPushes); + TOvcBaseEFOptions = set of TOvcBaseEFOption; + +type + TOvcCollectionStreamer = class; + TOvcCollection = class; + TO32Collection = class; + + {implements the About property and collection streaming} + TOvcComponent = class(TComponent) + protected {private} + FCollectionStreamer : TOvcCollectionStreamer; + FInternal : Boolean; {flag to suppress name generation + on collection items} + function GetAbout : string; + procedure SetAbout(const Value : string); + + protected + {OrCollection streaming hooks:} + procedure GetChildren(Proc: TGetChildProc; Root : TComponent); override; + function GetChildOwner: TComponent; override; + procedure Loaded; override; + + public + constructor Create(AOwner: TComponent); + override; + destructor Destroy; + override; + + property CollectionStreamer : TOvcCollectionStreamer + read FCollectionStreamer + write FCollectionStreamer; + property Internal : Boolean read FInternal write FInternal; + published + {properties} + property About : string + read GetAbout + write SetAbout + stored False; + end; + + {implements the About property} + TO32Component = class(TComponent) + protected {private} + FInternal : Boolean; {flag to suppress name generation + on collection items} + function GetAbout : string; + procedure SetAbout(const Value : string); + public + constructor Create(AOwner: TComponent); override; + property Internal : Boolean read FInternal write FInternal; + published + {properties} + property About : string read GetAbout write SetAbout stored False; + end; + + TOvcController = class(TOvcComponent) + protected {private} + FBaseEFOptions : TOvcBaseEFOptions; {options common to all entry fields} + FEntryCommands : TOvcCommandProcessor; {command processor} + FEpoch : Integer; {combined epoch year and century} + FErrorPending : Boolean; {an error is pending for an ef} + FErrorText : string; {text of last error} + +{ - HWnd changed to TOvcHWnd for BCB Compatibility } + FHandle : TOvcHWnd{hWnd}; {our window handle} + + FInsertMode : Boolean; {global insert mode flag} +{$IFNDEF LCL} //Currently not implemented + FTimerPool : TOvcTimerPool; {general timer pool} +{$ENDIF} + + {events} + FOnDelayNotify : TDelayNotifyEvent; + FOnError : TDataErrorEvent; + FOnGetEpoch : TGetEpochEvent; + FOnIsSpecialControl : TIsSpecialControlEvent; + FOnPostEdit : TPostEditEvent; + FOnPreEdit : TPreEditEvent; +{$IFNDEF LCL} + FOnTimerTrigger : TTriggerEvent; +{$ENDIF} + + {property methods} + function GetEpoch : Integer; + +{ - HWnd changed to TOvcHWnd for BCB Compatibility } + function GetHandle : TOvcHWnd{hWnd}; + procedure SetEpoch(Value : Integer); + + {internal methods} + procedure cWndProc(var Msg : TMessage); + {-window procedure} + + public + constructor Create(AOwner: TComponent); + override; + destructor Destroy; + override; + + procedure DestroyHandle; + +{$IFDEF LCL} + function PostMessage(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): BOOL; +{$ENDIF} + {wrappers for event handlers} + procedure DoOnPostEdit(Sender : TObject; GainingControl : TWinControl); + {-call the method assigned to the OnPostEdit event} + procedure DoOnPreEdit(Sender : TObject; LosingControl : TWinControl); + {-call the method assigned to the OnPreEdit event} + procedure DoOnTimerTrigger(Sender : TObject; Handle : Integer; + Interval : Cardinal; ElapsedTime : LongInt); + + procedure DelayNotify(Sender : TObject; NotifyCode : Word); + {-start the chain of events that will fire the OnDelayNotify event} + procedure DoOnError(Sender : TObject; ErrorCode : Word; const ErrorMsg : string); + {-call the method assigned to the OnError event} + +{ - HWnd changed to TOvcHWnd for BCB Compatibility } + function IsSpecialButton(H : TOvcHWnd{hWnd}) : Boolean; + dynamic; + {-return true if H is btnCancel, btnHelp, or btnRestore} + procedure MarkAsUninitialized(Uninitialized : Boolean); + {-mark all entry fields on form as uninitialized} + function ValidateEntryFields : TComponent; + {-ask each entry field to validate its contents. Return nil + if no error, else return pointer to field with error} + function ValidateEntryFieldsEx(ReportError, ChangeFocus : Boolean) : TComponent; + {-ask each entry field to validate its contents. Return nil + if no error, else return pointer to field with error. + Conditionally move focus and report error} + function ValidateTheseEntryFields(const Fields : array of TComponent) : TComponent; + {-ask the specified entry fields to validate their contents. Return nil + if no error, else return pointer to field with error} + + property ErrorPending : Boolean + read FErrorPending write FErrorPending; + property ErrorText : string + read FErrorText write FErrorText; + +{ - HWnd changed to TOvcHWnd for BCB Compatibility } + property Handle : TOvcHWnd{hWnd} + read GetHandle; + property InsertMode : Boolean + read FInsertMode write FInsertMode; +{$IFNDEF LCL} + property TimerPool : TOvcTimerPool + read FTimerPool; +{$ENDIF} + + published + {properties} + property EntryCommands : TOvcCommandProcessor + read FEntryCommands write FEntryCommands stored True; + property EntryOptions : TOvcBaseEFOptions + read FBaseEFOptions write FBaseEFOptions + default [efoAutoSelect, efoBeepOnError, efoInsertPushes]; + property Epoch : Integer + read GetEpoch write SetEpoch; + + {events} + property OnError : TDataErrorEvent + read FOnError write FOnError; + property OnGetEpoch : TGetEpochEvent + read FOnGetEpoch write FOnGetEpoch; + property OnDelayNotify : TDelayNotifyEvent + read FOnDelayNotify write FOnDelayNotify; + property OnIsSpecialControl : TIsSpecialControlEvent + read FOnIsSpecialControl write FOnIsSpecialControl; + property OnPostEdit : TPostEditEvent + read FOnPostEdit write FOnPostEdit; + property OnPreEdit : TPreEditEvent + read FOnPreEdit write FOnPreEdit; +{$IFNDEF LCL} + property OnTimerTrigger : TTriggerEvent + read FOnTimerTrigger write FOnTimerTrigger; +{$ENDIF} + end; + + TOvcGraphicControl = class(TGraphicControl) + protected {private} + FCollectionStreamer : TOvcCollectionStreamer; + {property methods} + function GetAbout : string; + procedure SetAbout(const Value : string); + protected + {Collection streaming hooks:} + procedure GetChildren(Proc: TGetChildProc; Root : TComponent); override; + function GetChildOwner: TComponent; override; + procedure Loaded; override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + property CollectionStreamer : TOvcCollectionStreamer + read FCollectionStreamer write FCollectionStreamer; + published + property About : string + read GetAbout write SetAbout stored False; + end; + + {Replacement for the TOvcCustomControl except with standard VCL streaming} + TO32CustomControl = class(TCustomControl) + protected {private} + {property variables} + FAfterEnter : TNotifyEvent; + FAfterExit : TNotifyEvent; + FOnMouseWheel : TMouseWheelEvent; + FLabelInfo : TOvcLabelInfo; + FInternal : Boolean; {flag to suppress name generation + on collection items} + + {property methods} + function GetAttachedLabel : TOvcAttachedLabel; + function GetAbout : string; + procedure SetAbout(const Value : string); + + {internal methods} + procedure LabelAttach(Sender : TObject; Value : Boolean); + procedure LabelChange(Sender : TObject); + procedure PositionLabel; + + {private message methods} + procedure OMAssignLabel(var Msg : TMessage); + message OM_ASSIGNLABEL; + procedure OMPositionLabel(var Msg : TMessage); + message OM_POSITIONLABEL; + procedure OMRecordLabelPosition(var Msg : TMessage); + message OM_RECORDLABELPOSITION; + procedure OMAfterEnter(var Msg : TMessage); + message OM_AFTERENTER; + procedure OMAfterExit(var Msg : TMessage); + message OM_AFTEREXIT; + + {VCL message methods} + procedure CMVisibleChanged(var Msg : TMessage); + message CM_VISIBLECHANGED; + + {windows message methods} + procedure WMKillFocus(var Msg : TWMKillFocus); + message WM_KILLFOCUS; + procedure WMMouseWheel(var Msg : TMessage); + message WM_MOUSEWHEEL; + procedure WMSetFocus(var Msg : TWMSetFocus); + message WM_SETFOCUS; + + protected + DefaultLabelPosition : TOvcLabelPosition; + + procedure DoOnMouseWheel(Shift : TShiftState; + Delta, XPos, YPos : SmallInt); + dynamic; + procedure CreateWnd; + override; + procedure Notification(AComponent : TComponent; Operation : TOperation); + override; + + property AfterEnter : TNotifyEvent + read FAfterEnter write FAfterEnter; + property AfterExit : TNotifyEvent + read FAfterExit write FAfterExit; + property OnMouseWheel : TMouseWheelEvent + read FOnMouseWheel write FOnMouseWheel; + property LabelInfo : TOvcLabelInfo + read FLabelInfo write FLabelInfo; + + public + property Internal : Boolean read FInternal write FInternal; + constructor Create(AOwner : TComponent); + override; + destructor Destroy; + override; + procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); + override; + property AttachedLabel : TOvcAttachedLabel + read GetAttachedLabel; + + published + property About : string + read GetAbout write SetAbout stored False; + end; + {End - TO32CustomControl} + + + TOvcCustomControl = class(TCustomControl) + protected {private} + {property variables} + FAfterEnter : TNotifyEvent; + FAfterExit : TNotifyEvent; + FCollectionStreamer : TOvcCollectionStreamer; + FOnMouseWheel : TMouseWheelEvent; + FLabelInfo : TOvcLabelInfo; + FInternal : Boolean; {flag to suppress name generation + on collection items} + + {property methods} + function GetAttachedLabel : TOvcAttachedLabel; + function GetAbout : string; + procedure SetAbout(const Value : string); + + {internal methods} + procedure LabelAttach(Sender : TObject; Value : Boolean); + procedure LabelChange(Sender : TObject); + procedure PositionLabel; + + {private message methods} + procedure OMAssignLabel(var Msg : TMessage); + message OM_ASSIGNLABEL; + procedure OMPositionLabel(var Msg : TMessage); + message OM_POSITIONLABEL; + procedure OMRecordLabelPosition(var Msg : TMessage); + message OM_RECORDLABELPOSITION; + procedure OMAfterEnter(var Msg : TMessage); + message OM_AFTERENTER; + procedure OMAfterExit(var Msg : TMessage); + message OM_AFTEREXIT; + + {VCL message methods} + procedure CMVisibleChanged(var Msg : TMessage); + message CM_VISIBLECHANGED; + + {windows message methods} + procedure WMKillFocus(var Msg : TWMKillFocus); + message WM_KILLFOCUS; + procedure WMMouseWheel(var Msg : TMessage); + message WM_MOUSEWHEEL; + procedure WMSetFocus(var Msg : TWMSetFocus); + message WM_SETFOCUS; + + protected + {descendants can set the value of this variable after calling inherited } + {create to set the default location and point-of-reference (POR) for the} + {attached label. if dlpTopLeft, the default location and POR will be at } + {the top left of the control. if dlpBottomLeft, the default location and} + {POR will be at the bottom left} + DefaultLabelPosition : TOvcLabelPosition; + + procedure DoOnMouseWheel(Shift : TShiftState; + Delta, XPos, YPos : SmallInt); + dynamic; + procedure CreateWnd; + override; + procedure Notification(AComponent : TComponent; Operation : TOperation); + override; + + {Collection streaming hooks:} + procedure GetChildren(Proc: TGetChildProc; Root : TComponent); override; + function GetChildOwner: TComponent; override; + procedure Loaded; override; + + property AfterEnter : TNotifyEvent + read FAfterEnter write FAfterEnter; + property AfterExit : TNotifyEvent + read FAfterExit write FAfterExit; + property OnMouseWheel : TMouseWheelEvent + read FOnMouseWheel write FOnMouseWheel; + property LabelInfo : TOvcLabelInfo + read FLabelInfo write FLabelInfo; + + public + property Internal : Boolean read FInternal write FInternal; + constructor Create(AOwner : TComponent); + override; + destructor Destroy; + override; + procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); + override; + property AttachedLabel : TOvcAttachedLabel + read GetAttachedLabel; + property CollectionStreamer : TOvcCollectionStreamer + read FCollectionStreamer write FCollectionStreamer; + + published + property About : string + read GetAbout write SetAbout stored False; + end; + + TOvcCollectible = class(TOvcComponent) + protected {private} + FCollection : TOvcCollection; + InChanged : Boolean; + + function GetIndex : Integer; + procedure SetCollection(Value : TOvcCollection); + procedure SetIndex(Value : Integer); virtual; + + protected + procedure Changed; dynamic; + function GenerateName : string; + dynamic; + function GetBaseName : string; + dynamic; + function GetDisplayText : string; + virtual; + procedure SetName(const NewName : TComponentName); + override; + + public + constructor Create(AOwner : TComponent); + override; + destructor Destroy; + override; + property Collection : TOvcCollection + read FCollection; + property DisplayText : string + read GetDisplayText; + property Index : Integer + read GetIndex + write SetIndex; + + property Name; + end; + + TO32CollectionItem = class(TCollectionItem) + protected {private} + FName: String; + FDisplayText: String; + function GetAbout: String; + procedure SetAbout(const Value: String); + procedure SetName(Value: String); virtual; + public + property DisplayText : string read FDisplayText write FDisplayText; + property Name: String read FName write SetName; + published + property About : String read GetAbout write SetAbout; + end; + + + TOvcCollectibleControl = class(TOvcCustomControl) + protected {private} + FCollection : TOvcCollection; + FInternal : Boolean; {flag to suppress name generation + on collection items} + InChanged : Boolean; + + function GetIndex : Integer; + procedure SetCollection(Value : TOvcCollection); + procedure SetIndex(Value : Integer); + + protected + procedure Changed; dynamic; + function GenerateName : string; + dynamic; + function GetBaseName : string; + dynamic; + function GetDisplayText : string; + virtual; + procedure SetName(const NewName : TComponentName); + override; + + public + constructor Create(AOwner : TComponent); + override; + destructor Destroy; + override; + + property Internal : Boolean read FInternal write FInternal; + + property Collection : TOvcCollection + read FCollection; + + property DisplayText : string + read GetDisplayText; + + property Index : Integer + read GetIndex + write SetIndex; + + property Name; + end; + + TOvcCollectibleClass = class of TComponent; + TO32CollectibleClass = class of TPersistent; + + TOvcItemSelectedEvent = + procedure(Sender : TObject; Index : Integer) of object; + TOvcGetEditorCaption = + procedure(var Caption : string) of object; + TO32GetEditorCaption = + procedure(var Caption : string) of object; + + TOvcCollection = class(TPersistent) + protected {private} + {property variables} + FItemClass : TOvcCollectibleClass; + FItemEditor : TForm; + FItems : TList; + FOwner : TComponent; + FReadOnly : Boolean; + FStored : Boolean; + FStreamer : TOvcCollectionStreamer; + + {event variables} + FOnChanged : TNotifyEvent; + FOnItemSelected : TOvcItemSelectedEvent; + FOnGetEditorCaption : TOvcGetEditorCaption; + + {Internal variables} + InLoaded : Boolean; + IsLoaded : Boolean; + InChanged : Boolean; + + protected + function GetCount : Integer; + function GetItem(Index: Integer): TComponent; + procedure SetItem(Index: Integer; Value: TComponent); + + procedure Changed; + virtual; + procedure Loaded; + + public + constructor Create(AOwner : TComponent; ItemClass : TOvcCollectibleClass); + destructor Destroy; + override; + property ItemEditor : TForm + read FItemEditor write FItemEditor; + + function Add : TComponent; + procedure Clear; virtual; + procedure Delete(Index : Integer); + procedure DoOnItemSelected(Index : Integer); + function GetEditorCaption : string; + function ItemByName(const Name : string) : TComponent; + function Insert(Index : Integer) : TComponent; + function ParentForm : TForm; + + property Count: Integer + read GetCount; + property ItemClass : TOvcCollectibleClass + read FItemClass; + property Item[Index: Integer] : TComponent + read GetItem write SetItem; default; + property OnGetEditorCaption : TOvcGetEditorCaption + read FOnGetEditorCaption write FOnGetEditorCaption; + property Owner : TComponent + read FOwner; + property ReadOnly : Boolean + read FReadOnly write FReadOnly default False; + property Stored : Boolean + read FStored write FStored default True; + property OnChanged : TNotifyEvent + read FOnChanged write FOnChanged; + property OnItemSelected : TOvcItemSelectedEvent + read FOnItemSelected write FOnItemSelected; + end; + + TO32Collection = class(TCollection) + protected {private} + {property variables} + FItemEditor : TForm; + FReadOnly : Boolean; + + FOwner: TPersistent; + + {event variables} + FOnChanged : TNotifyEvent; + FOnItemSelected : TOvcItemSelectedEvent; + FOnGetEditorCaption : TO32GetEditorCaption; + + {Internal variables} + InLoaded : Boolean; + IsLoaded : Boolean; + InChanged : Boolean; + + protected + function GetCount : Integer; + procedure Loaded; + public + constructor Create(AOwner : TPersistent; + ItemClass : TCollectionItemClass); virtual; + destructor Destroy; override; + property ItemEditor : TForm read FItemEditor write FItemEditor; + + function Add : TO32CollectionItem; dynamic; + + {$IFNDEF VERSION4} + function Insert(Index: Integer): TO32CollectionItem; dynamic; + {$ENDIF} + + function GetItem(Index: Integer): TO32CollectionItem; + function GetOwner: TPersistent; override; + procedure SetItem(Index: Integer; Value: TO32CollectionItem); + procedure DoOnItemSelected(Index : Integer); + function GetEditorCaption : string; + function ItemByName(const Name : string) : TO32CollectionItem; + function ParentForm : TForm; + + property Count: Integer + read GetCount; + property Item[Index: Integer] : TO32CollectionItem + read GetItem write SetItem; default; + property OnGetEditorCaption : TO32GetEditorCaption + read FOnGetEditorCaption write FOnGetEditorCaption; + property ReadOnly : Boolean + read FReadOnly write FReadOnly default False; + property OnChanged : TNotifyEvent + read FOnChanged write FOnChanged; + property OnItemSelected : TOvcItemSelectedEvent + read FOnItemSelected write FOnItemSelected; + end; + + TOvcCollectionStreamer = class + protected {private} + FCollectionList : TList; + FOwner : TComponent; + + protected + procedure Loaded; + procedure GetChildren(Proc: TGetChildProc; Root : TComponent); + + public + constructor Create(AOwner : TComponent); + destructor Destroy; + override; + + procedure Clear; + function CollectionFromType(Component : TComponent) : TOvcCollection; + + property Owner : TComponent + read FOwner; + end; + + +type + {base class for Orpheus components. Provides controller access} + TOvcCustomControlEx = class(TOvcCustomControl) + protected {private} + FController : TOvcController; + + function ControllerAssigned : Boolean; + function GetController: TOvcController; + procedure SetController(Value : TOvcController); virtual; + + protected + procedure CreateWnd; + override; + procedure Notification(AComponent : TComponent; Operation : TOperation); + override; + + public + property Controller : TOvcController + read GetController + write SetController; + end; + + +function FindController(Form : TWinControl) : TOvcController; + {-search for an existing controller component} +function GetImmediateParentForm(Control : TControl) : TWinControl; + {-return first form found while searching Parent} +procedure ResolveController(AForm : TWinControl; var AController : TOvcController); + {-find or create a controller on this form} + +function DefaultController : TOvcController; + +implementation + +{.$DEFINE Logging} +uses + OvcVer, + TypInfo, + ExtCtrls, +{$IFNDEF LCL} + Consts, +{$ELSE} + LclStrConsts, +{$ENDIF} + OvcEF + {$IFDEF Logging} + ,LogAPI + {$ENDIF} + ; + +type + TLocalEF = class(TOvcBaseEntryField); +var + FDefaultController : TOvcController = nil; + +{===== TO32ContainerList =============================================} + +constructor TO32ContainerList.Create(AOwner: TComponent); +begin + inherited Create; + FOwner := TComponent(AOwner); +end; +{=====} + +destructor TO32ContainerList.Destroy; +var + I: Integer; +begin + for I := 0 to Count - 1 do + TPanel(Items[I]).Free; + inherited; +end; + + +{*** TOvcLabelInfo ***} + +procedure TOvcLabelInfo.DoOnAttach; +begin + if Assigned(FOnAttach) then + FOnAttach(Self, FVisible); +end; + +procedure TOvcLabelInfo.DoOnChange; +begin + if Assigned(FOnChange) then + FOnChange(Self); +end; + +function TOvcLabelInfo.IsVisible : Boolean; +begin + Result := FVisible; +end; + +procedure TOvcLabelInfo.SetOffsets(X, Y : Integer); +begin + if (X <> FOffsetX) or (Y <> FOffsetY) then begin + FOffsetX := X; + FOffsetY := Y; + DoOnChange; + end; +end; + +procedure TOvcLabelInfo.SetOffsetX(Value : Integer); +begin + if Value <> FOffsetX then begin + FOffsetX := Value; + DoOnChange; + end; +end; + +procedure TOvcLabelInfo.SetOffsetY(Value : Integer); +begin + if Value <> FOffsetY then begin + FOffsetY := Value; + DoOnChange; + end; +end; + +procedure TOvcLabelInfo.SetVisible(Value : Boolean); +begin + if Value <> FVisible then begin + FVisible := Value; + DoOnAttach; + end; +end; + + +{*** TOvcAttachedLabel ***} + +constructor TOvcAttachedLabel.Create(AOwner : TComponent); +begin + inherited Create(AOwner); + + {set new defaults} + AutoSize := True; + ParentFont := True; + Transparent := False; +end; + +constructor TOvcAttachedLabel.CreateEx(AOwner : TComponent; AControl : TWinControl); +begin + FControl := AControl; + + Create(AOwner); + + {set attached control property} + FocusControl := FControl; +end; + +procedure TOvcAttachedLabel.Loaded; +begin + inherited Loaded; + + SavePosition; +end; + +procedure TOvcAttachedLabel.SavePosition; +var + PF : TWinControl; + I : Integer; +begin + if (csLoading in ComponentState) or (csDestroying in ComponentState) then + Exit; + + {see if our associated control is on the form - save position} + PF := GetImmediateParentForm(Self); + if Assigned(PF) then begin + for I := 0 to Pred(PF.ComponentCount) do begin + if PF.Components[I] = FControl then begin + SendMessage(FControl.Handle, OM_ASSIGNLABEL, 0, LongInt(Self)); + PostMessage(FControl.Handle, OM_RECORDLABELPOSITION, 0, 0); + Break; + end; + end; + end; +end; + +procedure TOvcAttachedLabel.SetBounds(ALeft, ATop, AWidth, AHeight: Integer); +begin + inherited SetBounds(ALeft, ATop, AWidth, AHeight); + SavePosition; + + { The following line causes the IDE to mark the form dirty, requiring it } + { to be saved. Not sure what this was supposed to do, but commenting it } + { out seems to solve the problem. } + {Application.ProcessMessages;} +end; + +function FindController(Form : TWinControl) : TOvcController; + {-search for an existing controller component} +var + I : Integer; +begin + Result := nil; + for I := 0 to Form.ComponentCount-1 do begin + if Form.Components[I] is TOvcController then begin + Result := TOvcController(Form.Components[I]); + Break; + end; + end; +end; + +function GetImmediateParentForm(Control : TControl) : TWinControl; + {return first form found while searching Parent} +var + ParentCtrl : TControl; +begin + ParentCtrl := Control.Parent; +{$IFDEF VERSION5} + while Assigned(ParentCtrl) and + not ((ParentCtrl is TCustomForm) or + (ParentCtrl is TCustomFrame)) do +{$ELSE} + while Assigned(ParentCtrl) and (not (ParentCtrl is TCustomForm)) do +{$ENDIF} + ParentCtrl := ParentCtrl.Parent; + Result := TWinControl(ParentCtrl); +end; + +procedure ResolveController(AForm : TWinControl; var AController : TOvcController); + {-find or create a controller on this form} +begin + if not Assigned(AController) then begin + {search for an existing controller. If not found,} + {create the controller as a child of the form} + {and assign it as our controller} + AController := FindController(AForm); + (* + if not Assigned(AController) then begin + AController := TOvcController.Create(AForm); + try + AController.Name := 'OvcController1'; + except + AController.Free; + AController := nil; + raise; + end; + end; + *) + end; +end; + +{*** TOvcComponent ***} + +constructor TOvcComponent.Create(AOwner: TComponent); +begin + inherited Create(AOwner); +end; + +destructor TOvcComponent.Destroy; +begin + FCollectionStreamer.Free; + FCollectionStreamer := nil; + + inherited Destroy; +end; + +function TOvcComponent.GetAbout : string; +begin + Result := OrVersionStr; +end; + +procedure TOvcComponent.SetAbout(const Value : string); +begin +end; + + +{Logic for streaming collections of sub-components} + +function TOvcComponent.GetChildOwner: TComponent; +begin + if assigned(FCollectionStreamer) then + Result := FCollectionStreamer.Owner + else + Result := inherited GetChildOwner; +end; + +procedure TOvcComponent.GetChildren(Proc: TGetChildProc; Root : TComponent); +begin + if assigned(FCollectionStreamer) then + CollectionStreamer.GetChildren(Proc, Root) + else + inherited GetChildren(Proc,Root); +end; + +procedure TOvcComponent.Loaded; +begin + if assigned(FCollectionStreamer) then + FCollectionStreamer.Loaded; + + inherited Loaded; +end; + +{*** TO32Component ***} +constructor TO32Component.Create(AOwner: TComponent); +begin + inherited Create(AOwner); +end; + +function TO32Component.GetAbout : string; +begin + Result := OrVersionStr; +end; + +procedure TO32Component.SetAbout(const Value : string); +begin +end; + + +{*** TOvcCollectible ***} +constructor TOvcCollectible.Create(AOwner : TComponent); +begin + inherited Create(AOwner); + + if (AOwner is TOvcComponent) then begin + if TOvcComponent(AOwner).CollectionStreamer = nil then + raise Exception.Create(GetOrphStr(SCNoCollection)); + SetCollection(TOvcComponent(AOwner).CollectionStreamer.CollectionFromType(Self)); + end else + if (AOwner is TOvcCustomControl) then begin + if TOvcCustomControl(AOwner).CollectionStreamer = nil then + raise Exception.Create(GetOrphStr(SCNoCollection)); + SetCollection(TOvcCustomControl(AOwner).CollectionStreamer.CollectionFromType(Self)); + end else + raise Exception.Create(GetOrphStr(SCNotOvcDescendant)); + + if (csDesigning in ComponentState) + and (AOwner <> nil) then + if ((AOwner is TOvcComponent) and not TOvcComponent(AOwner).FInternal) + or ((AOwner is TOvcCollectibleControl) and not TOvcCollectibleControl(AOwner).FInternal) + or ((AOwner is TOvcCustomControl) and not TOvcCustomControl(AOwner).FInternal) then +{$IFDEF VERSION5} + if not (csLoading in AOwner.ComponentState) then +{$ELSE} + if not (csLoading in AOwner.ComponentState) then +{$ENDIF} + Name := GenerateName; +end; + +destructor TOvcCollectible.Destroy; +var + OldCollection : TOvcCollection; +begin + OldCollection := Collection; + SetCollection(nil); + inherited Destroy; + {mark dirty} + if (csDesigning in ComponentState) + and (OldCollection <> nil) + and not (csDestroying in + OldCollection.Owner.ComponentState) then begin + OldCollection.Changed; + end; +end; + +function TOvcCollectible.GenerateName : string; +var + PF : TWinControl; + I : Integer; + S : string; + + function SearchSubComponents(C : TComponent; const S : string) : TComponent; + var + I : Integer; + begin + Result := C; + if CompareText(S, Result.Name) = 0 then + Exit; + for I := 0 to C.ComponentCount-1 do begin + Result := SearchSubComponents(C.Components[I], S); + if Result <> nil then + Exit; + end; + Result := nil; + end; + + function FindComponentName(const S : string) : TComponent; + begin + Result := SearchSubComponents(PF, S); + end; + +begin + I := 1; + S := GetBaseName; + Result := Format('%s%d', [S, I]); + PF := Collection.ParentForm; + if not Assigned(PF) then + Exit; + + while FindComponentName(Result) <> nil do begin + Inc(I); + Result := Format('%s%d', [S, I]); + end; +end; + +procedure TOvcCollectible.SetName(const NewName : TComponentName); +begin + inherited SetName(NewName); + if not (csLoading in ComponentState) then +{$IFDEF VERSION5} + if (csInLine in ComponentState) then + Changed; +{$ENDIF} + if (Collection <> nil) + and (Collection.ItemEditor <> nil) then + SendMessage(Collection.ItemEditor.Handle, OM_PROPCHANGE, 0, 0); +end; + +function TOvcCollectible.GetBaseName : string; +begin + Result := 'CollectionItem'; +end; + +function TOvcCollectible.GetDisplayText : string; +begin + Result := ClassName; +end; + +procedure TOvcCollectible.Changed; +begin + if InChanged then exit; + InChanged := True; + try + {$IFDEF Logging} + LogMsg('TOvcCollectible.Changed'); + LogBoolean('assigned(FCollection)', assigned(FCollection)); + LogBoolean('(csInline in ComponentState)', (csInline in ComponentState)); + LogBoolean('csAncestor in Owner.ComponentState', csAncestor in Owner.ComponentState); + {$ENDIF} + if assigned(FCollection) then + {$IFDEF Version5} + if not (csInline in ComponentState) then + {$ENDIF} + FCollection.Changed; + finally + InChanged := False; + end; +end; + +function TOvcCollectible.GetIndex : Integer; +begin + if assigned(FCollection) then + Result := FCollection.FItems.IndexOf(Self) + else + Result := -1; +end; + +procedure TOvcCollectible.SetIndex(Value : Integer); +begin + if Value <> Index then begin + if assigned(FCollection) then begin + FCollection.FItems.Remove(Self); + FCollection.FItems.Insert(Value,Self); + end; + Changed; + end; +end; + +procedure TOvcCollectible.SetCollection(Value : TOvcCollection); +begin + if Collection <> Value then begin + if Collection <> nil then + Collection.FItems.Remove(Self); + if Value <> nil then begin + if not (Self is Value.ItemClass) then + raise Exception.Create(GetOrphStr(SCItemIncompatible)); + Value.FItems.Add(Self); + end; + FCollection := Value; + end; +end; + + + +{===== TO32CollectionItem ============================================} + +function TO32CollectionItem.GetAbout: String; +begin + Result := OrVersionStr; +end; + +procedure TO32CollectionItem.SetAbout(const Value: String); +begin +end; + +procedure TO32CollectionItem.SetName(Value: String); +begin + FName := Value; +end; +{=====} + +{*** TOvcCollectibleControl ***} +constructor TOvcCollectibleControl.Create(AOwner : TComponent); +begin + inherited Create(AOwner); + + if (AOwner is TOvcComponent) then begin + if TOvcComponent(AOwner).CollectionStreamer = nil then + raise Exception.Create(GetOrphStr(SCNoCollection)); + SetCollection(TOvcComponent(AOwner).CollectionStreamer.CollectionFromType(Self)); + end else + if (AOwner is TOvcCustomControl) then begin + if TOvcCustomControl(AOwner).CollectionStreamer = nil then + raise Exception.Create(GetOrphStr(SCNoCollection)); + SetCollection(TOvcCustomControl(AOwner).CollectionStreamer.CollectionFromType(Self)); + end else + raise Exception.Create(GetOrphStr(SCNotOvcDescendant)); + + if (csDesigning in ComponentState) + and (AOwner <> nil) then + if ((AOwner is TOvcComponent) and not TOvcComponent(AOwner).FInternal) + or ((AOwner is TOvcCollectibleControl) and not TOvcCollectibleControl(AOwner).FInternal) + or ((AOwner is TOvcCustomControl) and not TOvcCustomControl(AOwner).FInternal) then + if not (csLoading in AOwner.ComponentState) + {$IFDEF Version5} + and not (csInLine in AOwner.ComponentState) + {$ENDIF} + then Name := GenerateName; +end; + +destructor TOvcCollectibleControl.Destroy; +var + OldCollection : TOvcCollection; +begin + OldCollection := Collection; + SetCollection(nil); + inherited Destroy; + {mark dirty} + if (csDesigning in ComponentState) + and (OldCollection <> nil) + and not (csDestroying in + OldCollection.Owner.ComponentState) then begin + OldCollection.Changed; + end; +end; + +function TOvcCollectibleControl.GenerateName : string; +var + PF : TWinControl; + I : Integer; + S : string; + + function SearchSubComponents(C : TComponent; const S : string) : TComponent; + var + I : Integer; + begin + Result := C; + if CompareText(S, Result.Name) = 0 then + Exit; + for I := 0 to C.ComponentCount-1 do begin + Result := SearchSubComponents(C.Components[I], S); + if Result <> nil then + Exit; + end; + Result := nil; + end; + + function FindComponentName(const S : string) : TComponent; + begin + Result := SearchSubComponents(PF, S); + end; + +begin + I := 1; + S := GetBaseName; + Result := Format('%s%d', [S, I]); + PF := Collection.ParentForm; + if not Assigned(PF) then + Exit; + + while FindComponentName(Result) <> nil do begin + Inc(I); + Result := Format('%s%d', [S, I]); + end; +end; + +procedure TOvcCollectibleControl.SetName(const NewName : TComponentName); +begin + inherited SetName(NewName); + if not (csLoading in ComponentState) then + {$IFDEF Version5} + if not (csInLine in ComponentState) then + {$ENDIF} + Changed; +end; + +function TOvcCollectibleControl.GetBaseName : string; +begin + Result := 'CollectionItem'; +end; + +function TOvcCollectibleControl.GetDisplayText : string; +begin + Result := ClassName; +end; + +procedure TOvcCollectibleControl.Changed; +begin + if InChanged then exit; + InChanged := True; + try + if assigned(FCollection) then + {$IFDEF Version5} + if not (csInline in ComponentState) then + {$ENDIF} + FCollection.Changed; + finally + InChanged := False; + end; +end; + +function TOvcCollectibleControl.GetIndex : Integer; +begin + if Collection <> nil then + Result := Collection.FItems.IndexOf(Self) + else + Result := -1; +end; + +procedure TOvcCollectibleControl.SetIndex(Value : Integer); +begin + if Value <> Index then begin + if Collection <> nil then begin + Collection.FItems.Remove(Self); + Collection.FItems.Insert(Value,Self); + end; + Changed; + end; +end; + +procedure TOvcCollectibleControl.SetCollection(Value : TOvcCollection); +begin + if Collection <> Value then begin + if Collection <> nil then + Collection.FItems.Remove(Self); + if Value <> nil then begin + if not (Self is Value.ItemClass) then + raise Exception.Create(GetOrphStr(SCItemIncompatible)); + Value.FItems.Add(Self); + end; + FCollection := Value; + end; +end; + +{*** TOvcController ***} +constructor TOvcController.Create(AOwner : TComponent); +begin + inherited Create(AOwner); + + {create the command processor} + FEntryCommands := TOvcCommandProcessor.Create; + FBaseEFOptions := [efoAutoSelect, efoBeepOnError, efoInsertPushes]; + FEpoch := DefaultEpoch; + FErrorPending := False; + FInsertMode := True; + +{$IFNDEF LCL} + {create the general use timer pool} + FTimerPool := TOvcTimerPool.Create(Self); + FTimerPool.OnAllTriggers := DoOnTimerTrigger; +{$ENDIF} +end; + +procedure TOvcController.cWndProc(var Msg : TMessage); + {-window procedure} +var + C : TWinControl; +begin + C := TWinControl(Msg.lParam); + try + with Msg do begin + case Msg of + OM_SETFOCUS : + begin + C.Show; + if C.CanFocus then + C.SetFocus; + end; + OM_PREEDIT : + if Assigned(FOnPreEdit) then + FOnPreEdit(TWinControl(lParam), FindControl(wParam)); + OM_POSTEDIT : + if Assigned(FOnPostEdit) then + FOnPostEdit(TWinControl(lParam), FindControl(wParam)); + OM_DELAYNOTIFY : + if Assigned(FOnDelayNotify) then + FOnDelayNotify(TObject(lParam), wParam); + else + Result := DefWindowProc(Handle, Msg, wParam, lParam); + end; + end; + except + Application.HandleException(Self); + end; +end; + +{$IFDEF LCL} +function TOvcController.PostMessage(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): BOOL; +var + AMsg : TMessage; +begin + if hWnd = Handle then + begin + AMsg.Msg := Msg; + AMsg.WParam := wParam; + AMsg.LParam := lParam; + cWndProc(AMsg); + end + else +{$IFDEF MSWINDOWS} + Result := MyMisc.PostMessage(hWnd, Msg, wParam, lParam); +{$ELSE} + Result := LclIntf.PostMessage(hWnd, Msg, wParam, lParam); +{$ENDIF} +end; +{$ENDIF} + +procedure TOvcController.DelayNotify(Sender : TObject; NotifyCode : Word); +begin + if Assigned(FOnDelayNotify) then + PostMessage(Handle, OM_DELAYNOTIFY, NotifyCode, LongInt(Sender)); +end; + +destructor TOvcController.Destroy; +begin + {destroy the command processor} + FEntryCommands.Free; + FEntryCommands := nil; + +{$IFNDEF LCL} + FTimerPool.Free; + FTimerPool := nil; +{$ENDIF} + + {destroy window handle, if created} + DestroyHandle; + + inherited Destroy; +end; + +procedure TOvcController.DestroyHandle; +begin +{$IFNDEF LCL} + if FHandle <> 0 then + {$IFDEF VERSION6} + Classes.DeallocateHWnd(FHandle); + {$ELSE} + DeallocateHWnd(FHandle); + {$ENDIF} +{$ENDIF} + + FHandle := 0; +end; + +procedure TOvcController.DoOnError(Sender : TObject; ErrorCode : Word; + const ErrorMsg : string); +begin + if Assigned(FOnError) then + FOnError(Sender, ErrorCode, ErrorMsg) + else + MessageDlg(ErrorMsg, mtError, [mbOK], 0); +end; + +procedure TOvcController.DoOnPostEdit(Sender : TObject; GainingControl : TWinControl); +var + H : hWnd; +begin + if Assigned(GainingControl) then + H := GainingControl.Handle + else + H := 0; + + PostMessage(Handle, OM_POSTEDIT, H, LongInt(Sender)); +end; + +procedure TOvcController.DoOnPreEdit(Sender : TObject; LosingControl : TWinControl); +var + H : hWnd; +begin + if Assigned(LosingControl) then + H := LosingControl.Handle + else + H := 0; + + PostMessage(Handle, OM_PREEDIT, H, LongInt(Sender)); +end; + +procedure TOvcController.DoOnTimerTrigger(Sender : TObject; Handle : Integer; + Interval : Cardinal; ElapsedTime : LongInt); +begin +{$IFNDEF LCL} + if Assigned(FOnTimerTrigger) then + FOnTimerTrigger(Sender, Handle, Interval, ElapsedTime); +{$ENDIF} +end; + +function TOvcController.GetEpoch : Integer; +begin + Result := FEpoch; + if Assigned(FOnGetEpoch) then + FOnGetEpoch(Self, Result); +end; + +{ - HWnd changed to TOvcHWnd for BCB Compatibility } +function TOvcController.GetHandle : TOvcHWnd{hWnd}; +begin +// AllocateHWnd not available in LCL to create non-visual window that +// responds to messages sent to controller. But shouldn't be needed +// with controller's PostMessage method that intercepts messages. +{$IFNDEF LCL} + if FHandle = 0 then + {$IFDEF VERSION6} + FHandle := Classes.AllocateHWnd(cWndProc); + {$ELSE} + FHandle := AllocateHWnd(cWndProc); + {$ENDIF} +{$ENDIF} + Result := FHandle; +end; + +{ - HWnd changed to TOvcHWnd for BCB Compatibility } +function TOvcController.IsSpecialButton(H : TOvcHWnd{hWnd}) : Boolean; +begin + Result := False; + if Assigned(FOnIsSpecialControl) then + FOnIsSpecialControl(Self, FindControl(H), Result); +end; + +procedure TOvcController.MarkAsUninitialized(Uninitialized : Boolean); + {-mark all entry fields on form as uninitialized} +var + I : Integer; + + procedure MarkField(C : TComponent); + var + J : Integer; + begin + {first, see if this component is an entry field} + if C is TOvcBaseEntryField then + TOvcBaseEntryField(C).Uninitialized := Uninitialized; + + {recurse through all child components} + for J := 0 to C.ComponentCount-1 do + MarkField(C.Components[J]); + end; + +begin +{$IFDEF VERSION5} + if (Owner is TCustomForm) or (Owner is TCustomFrame) then + with TWinControl(Owner) do +{$ELSE} + if Owner is TForm then + with TForm(Owner) do +{$ENDIF} + for I := 0 to ComponentCount-1 do + MarkField(Components[I]); +end; + +procedure TOvcController.SetEpoch(Value : Integer); +begin + if Value <> FEpoch then + if (Value >= MinYear) and (Value <= MaxYear) then + FEpoch := Value; +end; + +function TOvcController.ValidateEntryFields : TComponent; +begin + {if error, report it and send focus to field with error} + Result := ValidateEntryFieldsEx(True, True); +end; + +function TOvcController.ValidateEntryFieldsEx(ReportError, ChangeFocus : Boolean) : TComponent; +var + I : Integer; + + procedure ValidateEF(C : TComponent); + var + J : Integer; + EF : TLocalEF absolute C; + begin + {see if this component is an entry field} + if (C is TOvcBaseEntryField) then begin + + {don't validate invisible or disabled fields} + if not EF.Visible or not EF.Enabled then + Exit; + + {ask entry field to validate itself} + if (EF.ValidateContents(False) <> 0) then begin + {remember only the first invalid field found} + if not Assigned(Result) then + Result := EF; + + {tell the entry field to report the error} + if ReportError and not ErrorPending then + PostMessage(EF.Handle, OM_REPORTERROR, EF.LastError, 0); + + {ask the controller to give the focus back to this field} + if ChangeFocus and not ErrorPending then begin + PostMessage(Handle, OM_SETFOCUS, 0, LongInt(EF)); + ErrorPending := True; + end; + + {exit if we are reporting the error or changing the focus} + if (ReportError or ChangeFocus) then + Exit; + end; + end; + + {recurse through all child components} + for J := 0 to C.ComponentCount-1 do begin + ValidateEf(C.Components[J]); + + {exit if we've already found an error and should stop} + if Assigned(Result) and (ReportError or ChangeFocus) then + Break; + end; + end; + +begin + Result := nil; +{$IFDEF VERSION5} + if ((Owner is TCustomForm) or (Owner is TCustomFrame)) then + with TWinControl(Owner) do +{$ELSE} + if Owner is TForm then + with TForm(Owner) do +{$ENDIF} + for I := 0 to ComponentCount-1 do begin + ValidateEf(Components[I]); + + {stop checking if reporting the error or changing focus} + if Assigned(Result) and (ReportError or ChangeFocus) then + Break ; + end; +end; + +function TOvcController.ValidateTheseEntryFields(const Fields : array of TComponent) : TComponent; + {-ask the specified entry fields to validate their contents. Return nil + if no error, else return pointer to field with error} +var + I : Integer; + EF : TLocalEF; +begin + Result := nil; + + for I := Low(Fields) to High(Fields) do begin + if Fields[I] is TOvcBaseEntryField then begin + EF := TLocalEF(Fields[I]); + + {ask entry field to validate itself} + if (EF.ValidateContents(False) <> 0) then begin + Result := EF; + + {tell the entry field to report the error} + if not ErrorPending then + PostMessage(EF.Handle, OM_REPORTERROR, EF.LastError, 0); + + {ask the controller to give the focus back to this field} + if not ErrorPending then begin + PostMessage(Handle, OM_SETFOCUS, 0, LongInt(EF)); + ErrorPending := True; + end; + + Exit; + end; + + end; + end; +end; + +{*** TOvcGraphicControl ***} + +constructor TOvcGraphicControl.Create(AOwner: TComponent); +begin + inherited Create(AOwner); +end; + +destructor TOvcGraphicControl.Destroy; +begin + FCollectionStreamer.Free; + FCollectionStreamer := nil; + inherited Destroy; +end; + + +procedure TOvcGraphicControl.Loaded; +begin + if Assigned(FCollectionStreamer) then + FCollectionStreamer.Loaded; + inherited Loaded; +end; + +{Logic for streaming collections of sub-components} + +function TOvcGraphicControl.GetChildOwner: TComponent; +begin + if Assigned(FCollectionStreamer) then + Result := FCollectionStreamer.Owner + else + Result := inherited GetChildOwner; +end; + +procedure TOvcGraphicControl.GetChildren(Proc: TGetChildProc; Root : TComponent); +begin + if Assigned(FCollectionStreamer) then + CollectionStreamer.GetChildren(Proc, Root) + else + inherited GetChildren(Proc, Root); +end; + +function TOvcGraphicControl.GetAbout : string; +begin + Result := OrVersionStr; +end; + + +procedure TOvcGraphicControl.SetAbout(const Value : string); +begin +end; + + +{*** TO32CustomControl ***} + +procedure TO32CustomControl.CMVisibleChanged(var Msg : TMessage); +begin + inherited; + + if csLoading in ComponentState then + Exit; + + if LabelInfo.Visible then + AttachedLabel.Visible := Visible; +end; + +constructor TO32CustomControl.Create(AOwner : TComponent); +begin + inherited Create(AOwner); + + DefaultLabelPosition := lpTopLeft; + + FLabelInfo := TOvcLabelInfo.Create; + FLabelInfo.OnChange := LabelChange; + FLabelInfo.OnAttach := LabelAttach; +end; + +procedure TO32CustomControl.CreateWnd; +begin + inherited CreateWnd; +end; + +destructor TO32CustomControl.Destroy; +begin + FLabelInfo.Visible := False; + FLabelInfo.Free; + FLabelInfo := nil; + inherited Destroy; +end; + +procedure TO32CustomControl.DoOnMouseWheel(Shift : TShiftState; + Delta, XPos, YPos : SmallInt); +begin + if Assigned(FOnMouseWheel) then + FOnMouseWheel(Self, Shift, Delta, XPos, YPos); +end; + +function TO32CustomControl.GetAttachedLabel : TOvcAttachedLabel; +begin + if not FLabelInfo.Visible then + raise Exception.Create(GetOrphStr(SCLabelNotAttached)); + + Result := FLabelInfo.ALabel; +end; + +function TO32CustomControl.GetAbout : string; +begin + Result := OrVersionStr; +end; + +procedure TO32CustomControl.LabelAttach(Sender : TObject; Value : Boolean); +var +{$IFDEF VERSION5} + PF : TWinControl; +{$ELSE} + PF : TForm; +{$ENDIF} + S : string; +begin + if (csLoading in ComponentState) then + Exit; + +{$IFDEF VERSION5} + PF := GetImmediateParentForm(Self); +{$ELSE} + PF := TForm(GetParentForm(Self)); +{$ENDIF} + if Value then begin + if Assigned(PF) then begin + FLabelInfo.ALabel.Free; + FLabelInfo.ALabel := TOvcAttachedLabel.CreateEx(PF, Self); + FLabelInfo.ALabel.Parent := Parent; + + S := GenerateComponentName(PF, Name + 'Label'); + FLabelInfo.ALabel.Name := S; + FLabelInfo.ALabel.Caption := S; + + FLabelInfo.SetOffsets(0, 0); + PositionLabel; + FLabelInfo.ALabel.BringToFront; + + {force auto size} + FLabelInfo.ALabel.AutoSize := True; + end; + end else begin + if Assigned(PF) then begin + FLabelInfo.ALabel.Free; + FLabelInfo.ALabel := nil; + end; + end; +end; + +procedure TO32CustomControl.LabelChange(Sender : TObject); +begin + if not (csLoading in ComponentState) then + PositionLabel; +end; + +procedure TO32CustomControl.Notification(AComponent : TComponent; Operation : TOperation); +var +{$IFDEF VERSION5} + PF : TWinControl; +{$ELSE} + PF : TForm; +{$ENDIF} +begin + inherited Notification(AComponent, Operation); + + if Operation = opRemove then + if Assigned(FLabelInfo) and (AComponent = FLabelInfo.ALabel) then begin +{$IFDEF VERSION5} + PF := GetImmediateParentForm(Self); +{$ELSE} + PF := TForm(GetParentForm(Self)); +{$ENDIF} + if Assigned(PF) and not (csDestroying in PF.ComponentState) then begin + FLabelInfo.FVisible := False; + FLabelInfo.ALabel := nil; + end; + end; +end; + +procedure TO32CustomControl.OMAfterEnter(var Msg : TMessage); +begin + if Assigned(FAfterEnter) then + FAfterEnter(Self); +end; + +procedure TO32CustomControl.OMAfterExit(var Msg : TMessage); +begin + if Assigned(FAfterExit) then + FAfterExit(Self); +end; + +procedure TO32CustomControl.OMAssignLabel(var Msg : TMessage); +begin + FLabelInfo.ALabel := TOvcAttachedLabel(Msg.lParam); +end; + +procedure TO32CustomControl.OMPositionLabel(var Msg : TMessage); +const + DX : Integer = 0; + DY : Integer = 0; +begin + if FLabelInfo.Visible and + Assigned(FLabelInfo.ALabel) and + (FLabelInfo.ALabel.Parent <> nil) and + not (csLoading in ComponentState) then begin + if DefaultLabelPosition = lpTopLeft then begin + DX := FLabelInfo.ALabel.Left - Left; + DY := FLabelInfo.ALabel.Top + FLabelInfo.ALabel.Height - Top; + end else begin + DX := FLabelInfo.ALabel.Left - Left; + DY := FLabelInfo.ALabel.Top - Top - Height; + end; + if (DX <> FLabelInfo.OffsetX) or (DY <> FLabelInfo.OffsetY) then + PositionLabel; + end; +end; + +procedure TO32CustomControl.OMRecordLabelPosition(var Msg : TMessage); +begin + if Assigned(FLabelInfo.ALabel) and + (FLabelInfo.ALabel.Parent <> nil) then begin + {if the label was cut and then pasted, this will complete the re-attachment} + FLabelInfo.FVisible := True; + + if DefaultLabelPosition = lpTopLeft then + FLabelInfo.SetOffsets(FLabelInfo.ALabel.Left - Left, + FLabelInfo.ALabel.Top + FLabelInfo.ALabel.Height - Top) + else + FLabelInfo.SetOffsets(FLabelInfo.ALabel.Left - Left, + FLabelInfo.ALabel.Top - Top - Height); + end; +end; + +procedure TO32CustomControl.PositionLabel; +begin + if FLabelInfo.Visible and Assigned(FLabelInfo.ALabel) and + (FLabelInfo.ALabel.Parent <> nil) and + not (csLoading in ComponentState) then begin + + if DefaultLabelPosition = lpTopLeft then begin + FLabelInfo.ALabel.SetBounds(Left + FLabelInfo.OffsetX, + FLabelInfo.OffsetY - FLabelInfo.ALabel.Height + Top, + FLabelInfo.ALabel.Width, FLabelInfo.ALabel.Height); + end else begin + FLabelInfo.ALabel.SetBounds(Left + FLabelInfo.OffsetX, + FLabelInfo.OffsetY + Top + Height, + FLabelInfo.ALabel.Width, FLabelInfo.ALabel.Height); + end; + end; +end; + +procedure TO32CustomControl.SetBounds(ALeft, ATop, AWidth, AHeight : Integer); +begin + inherited SetBounds(ALeft, ATop, AWidth, AHeight); + + if HandleAllocated then + PostMessage(Handle, OM_POSITIONLABEL, 0, 0); +end; + +procedure TO32CustomControl.SetAbout(const Value : string); +begin +end; + +procedure TO32CustomControl.WMKillFocus(var Msg : TWMKillFocus); +begin + inherited; + + PostMessage(Handle, OM_AFTEREXIT, 0, 0); +end; + +procedure TO32CustomControl.WMMouseWheel(var Msg : TMessage); +begin + with Msg do + DoOnMouseWheel(KeysToShiftState(LOWORD(wParam)) {fwKeys}, + HIWORD(wParam) {zDelta}, + LOWORD(lParam) {xPos}, HIWORD(lParam) {yPos}); +end; + +procedure TO32CustomControl.WMSetFocus(var Msg : TWMSetFocus); +begin + inherited; + + PostMessage(Handle, OM_AFTERENTER, 0, 0); +end; + +{*** End - TO32CustomCOntrol ***} + + +{*** TOvcCustomControl ***} +procedure TOvcCustomControl.CMVisibleChanged(var Msg : TMessage); +begin + inherited; + + if csLoading in ComponentState then + Exit; + + if LabelInfo.Visible then + AttachedLabel.Visible := Visible; +end; + +constructor TOvcCustomControl.Create(AOwner : TComponent); +begin + inherited Create(AOwner); + + DefaultLabelPosition := lpTopLeft; + + FLabelInfo := TOvcLabelInfo.Create; + FLabelInfo.OnChange := LabelChange; + FLabelInfo.OnAttach := LabelAttach; +end; + +procedure TOvcCustomControl.CreateWnd; +begin + inherited CreateWnd; +end; + +destructor TOvcCustomControl.Destroy; +begin + FLabelInfo.Visible := False; + FLabelInfo.Free; + FLabelInfo := nil; + FCollectionStreamer.Free; + FCollectionStreamer := nil; + inherited Destroy; +end; + +procedure TOvcCustomControl.DoOnMouseWheel(Shift : TShiftState; + Delta, XPos, YPos : SmallInt); +begin + if Assigned(FOnMouseWheel) then + FOnMouseWheel(Self, Shift, Delta, XPos, YPos); +end; + +function TOvcCustomControl.GetAttachedLabel : TOvcAttachedLabel; +begin + if not FLabelInfo.Visible then + raise Exception.Create(GetOrphStr(SCLabelNotAttached)); + + Result := FLabelInfo.ALabel; +end; + +function TOvcCustomControl.GetAbout : string; +begin + Result := OrVersionStr; +end; + +procedure TOvcCustomControl.LabelAttach(Sender : TObject; Value : Boolean); +var +{$IFDEF VERSION5} + PF : TWinControl; +{$ELSE} + PF : TForm; +{$ENDIF} + S : string; +begin + if (csLoading in ComponentState) then + Exit; + +{$IFDEF VERSION5} + PF := GetImmediateParentForm(Self); +{$ELSE} + PF := TForm(GetParentForm(Self)); +{$ENDIF} + if Value then begin + if Assigned(PF) then begin + FLabelInfo.ALabel.Free; + FLabelInfo.ALabel := TOvcAttachedLabel.CreateEx(PF, Self); + FLabelInfo.ALabel.Parent := Parent; + + S := GenerateComponentName(PF, Name + 'Label'); + FLabelInfo.ALabel.Name := S; + FLabelInfo.ALabel.Caption := S; + + FLabelInfo.SetOffsets(0, 0); + PositionLabel; + FLabelInfo.ALabel.BringToFront; + + {force auto size} + FLabelInfo.ALabel.AutoSize := True; + end; + end else begin + if Assigned(PF) then begin + FLabelInfo.ALabel.Free; + FLabelInfo.ALabel := nil; + end; + end; +end; + +procedure TOvcCustomControl.LabelChange(Sender : TObject); +begin + if not (csLoading in ComponentState) then + PositionLabel; +end; + +procedure TOvcCustomControl.Notification(AComponent : TComponent; Operation : TOperation); +var +{$IFDEF VERSION5} + PF : TWinControl; +{$ELSE} + PF : TForm; +{$ENDIF} +begin + inherited Notification(AComponent, Operation); + + if Operation = opRemove then + if Assigned(FLabelInfo) and (AComponent = FLabelInfo.ALabel) then begin +{$IFDEF VERSION5} + PF := GetImmediateParentForm(Self); +{$ELSE} + PF := TForm(GetParentForm(Self)); +{$ENDIF} + if Assigned(PF) and not (csDestroying in PF.ComponentState) then begin + FLabelInfo.FVisible := False; + FLabelInfo.ALabel := nil; + end; + end; +end; + +procedure TOvcCustomControl.OMAfterEnter(var Msg : TMessage); +begin + if Assigned(FAfterEnter) then + FAfterEnter(Self); +end; + +procedure TOvcCustomControl.OMAfterExit(var Msg : TMessage); +begin + if Assigned(FAfterExit) then + FAfterExit(Self); +end; + +procedure TOvcCustomControl.OMAssignLabel(var Msg : TMessage); +begin + FLabelInfo.ALabel := TOvcAttachedLabel(Msg.lParam); +end; + +procedure TOvcCustomControl.OMPositionLabel(var Msg : TMessage); +const + DX : Integer = 0; + DY : Integer = 0; +begin + if FLabelInfo.Visible and + Assigned(FLabelInfo.ALabel) and + (FLabelInfo.ALabel.Parent <> nil) and + not (csLoading in ComponentState) then begin + if DefaultLabelPosition = lpTopLeft then begin + DX := FLabelInfo.ALabel.Left - Left; + DY := FLabelInfo.ALabel.Top + FLabelInfo.ALabel.Height - Top; + end else begin + DX := FLabelInfo.ALabel.Left - Left; + DY := FLabelInfo.ALabel.Top - Top - Height; + end; + if (DX <> FLabelInfo.OffsetX) or (DY <> FLabelInfo.OffsetY) then + PositionLabel; + end; +end; + +procedure TOvcCustomControl.OMRecordLabelPosition(var Msg : TMessage); +begin + if Assigned(FLabelInfo.ALabel) and + (FLabelInfo.ALabel.Parent <> nil) then begin + {if the label was cut and then pasted, this will complete the re-attachment} + FLabelInfo.FVisible := True; + + if DefaultLabelPosition = lpTopLeft then + FLabelInfo.SetOffsets(FLabelInfo.ALabel.Left - Left, + FLabelInfo.ALabel.Top + FLabelInfo.ALabel.Height - Top) + else + FLabelInfo.SetOffsets(FLabelInfo.ALabel.Left - Left, + FLabelInfo.ALabel.Top - Top - Height); + end; +end; + +procedure TOvcCustomControl.PositionLabel; +begin + if FLabelInfo.Visible and Assigned(FLabelInfo.ALabel) and + (FLabelInfo.ALabel.Parent <> nil) and + not (csLoading in ComponentState) then begin + + if DefaultLabelPosition = lpTopLeft then begin + FLabelInfo.ALabel.SetBounds(Left + FLabelInfo.OffsetX, + FLabelInfo.OffsetY - FLabelInfo.ALabel.Height + Top, + FLabelInfo.ALabel.Width, FLabelInfo.ALabel.Height); + end else begin + FLabelInfo.ALabel.SetBounds(Left + FLabelInfo.OffsetX, + FLabelInfo.OffsetY + Top + Height, + FLabelInfo.ALabel.Width, FLabelInfo.ALabel.Height); + end; + end; +end; + +procedure TOvcCustomControl.SetBounds(ALeft, ATop, AWidth, AHeight : Integer); +begin + inherited SetBounds(ALeft, ATop, AWidth, AHeight); + + if HandleAllocated then + PostMessage(Handle, OM_POSITIONLABEL, 0, 0); +end; + +procedure TOvcCustomControl.SetAbout(const Value : string); +begin +end; + +procedure TOvcCustomControl.WMKillFocus(var Msg : TWMKillFocus); +begin + inherited; + + PostMessage(Handle, OM_AFTEREXIT, 0, 0); +end; + +procedure TOvcCustomControl.WMMouseWheel(var Msg : TMessage); +begin + with Msg do + DoOnMouseWheel(KeysToShiftState(LOWORD(wParam)) {fwKeys}, + HIWORD(wParam) {zDelta}, + LOWORD(lParam) {xPos}, HIWORD(lParam) {yPos}); +end; + +procedure TOvcCustomControl.WMSetFocus(var Msg : TWMSetFocus); +begin + inherited; + + PostMessage(Handle, OM_AFTERENTER, 0, 0); +end; + + +{Logic for streaming collections of sub-components} + +function TOvcCustomControl.GetChildOwner: TComponent; +begin + if Assigned(FCollectionStreamer) then + Result := FCollectionStreamer.Owner + else + Result := inherited GetChildOwner; +end; + +procedure TOvcCustomControl.GetChildren(Proc: TGetChildProc; Root : TComponent); +begin + if Assigned(FCollectionStreamer) then + CollectionStreamer.GetChildren(Proc, Root) + else + inherited GetChildren(Proc, Root); +end; + +procedure TOvcCustomControl.Loaded; +begin + if Assigned(FCollectionStreamer) then + FCollectionStreamer.Loaded; + inherited Loaded; +end; + +{*** TOvcCustomControlEx ***} + +function TOvcCustomControlEx.ControllerAssigned : Boolean; +begin + Result := Assigned(FController); +end; + +procedure TOvcCustomControlEx.CreateWnd; +var + OurForm : TWinControl; + +begin + OurForm := GetImmediateParentForm(Self); + + {do this only when the component is first dropped on the form, not during loading} + if (csDesigning in ComponentState) and not (csLoading in ComponentState) then + ResolveController(OurForm, FController); + + if not Assigned(FController) and not (csLoading in ComponentState) then begin + {try to find a controller on this form that we can use} + FController := FindController(OurForm); + + {if not found and we are not designing, use default controller} + if not Assigned(FController) and not (csDesigning in ComponentState) then + FController := DefaultController; + end; + + inherited CreateWnd; +end; + +function TOvcCustomControlEx.GetController: TOvcController; +begin + if FController = nil then + Result := DefaultController + else + Result := FController; +end; + +procedure TOvcCustomControlEx.Notification(AComponent : TComponent; Operation : TOperation); +begin + inherited Notification(AComponent, Operation); + + if Operation = opRemove then begin + if (AComponent = FController) then + FController := nil; + end else if (Operation = opInsert) and (FController = nil) and + (AComponent is TOvcController) then + FController := TOvcController(AComponent); +end; + +procedure TOvcCustomControlEx.SetController(Value : TOvcController); +begin + if not (TObject(Value) is TOvcController) then + Value := nil; + FController := Value; + if Value <> nil then + Value.FreeNotification(Self); +end; + +function TOvcCollection.Add : TComponent; +begin + if not Assigned(FItemClass) then + raise Exception.Create(GetOrphStr(SCClassNotSet)); + Result := FItemClass.Create(Owner); + Changed; + if ItemEditor <> nil then + SendMessage(ItemEditor.Handle, OM_PROPCHANGE, 0, 0); +end; + +procedure TOvcCollection.Changed; +var + Parent : TForm; +begin + {$IFDEF Logging} + LogMsg('TOvcCollection.Changed'); + LogBoolean('InChanged', InChanged); + {$ENDIF} + if InChanged then exit; + InChanged := True; + try + Parent := ParentForm; + if Parent <> nil then begin + {$IFDEF Logging} + LogString('Parent.ClassName', Parent.ClassName); + LogBoolean('(csLoading in Parent.ComponentState)', (csLoading in Parent.ComponentState)); + {$ENDIF} + if not (csLoading in Parent.ComponentState) + and (csDesigning in Parent.ComponentState) then begin + {$IFDEF Logging} + LogBoolean('TForm(Parent).Designer <> nil', TForm(Parent).Designer <> nil); + LogBoolean('InLoaded', InLoaded); + LogBoolean('IsLoaded', IsLoaded); + LogBoolean('(csAncestor in Owner.ComponentState)', (csAncestor in Owner.ComponentState)); + LogBoolean('Stored', Stored); + {$ENDIF} + {$IFDEF VERSION5} + if (TForm(Parent).Designer <> nil) + {$ELSE} + if (Parent.Designer <> nil) + {$ENDIF} + and not InLoaded + and IsLoaded + and not (csAncestor in Owner.ComponentState) + and Stored then + {$IFDEF VERSION5} + TForm(Parent).Designer.Modified; + {$ELSE} + Parent.Designer.Modified; + {$ENDIF} + if (ItemEditor <> nil) + and not (csAncestor in Owner.ComponentState) + then + SendMessage(ItemEditor.Handle, OM_PROPCHANGE, 0, 0); + end; + if Assigned(FOnChanged) then + FOnChanged(Self); + end; + finally + InChanged := False; + end; +end; + +procedure TOvcCollection.Clear; +{$IFDEF Version5} +var + i : Integer; +{$ENDIF} +begin + {$IFDEF Version5} + for i := Count - 1 downto 0 do + if not (csAncestor in Item[i].ComponentState) then + Item[i].Free; + {$ELSE} + while Count > 0 do + Item[0].Free; + {$ENDIF} + if ItemEditor <> nil then + SendMessage(ItemEditor.Handle, OM_PROPCHANGE, 0, 0); +end; + +constructor TOvcCollection.Create(AOwner : TComponent; + ItemClass : TOvcCollectibleClass); +begin + inherited Create; + FStored := True; + FItemClass := ItemClass; + FItems := TList.Create; + FOwner := AOwner; + + if (AOwner is TOvcComponent) then + begin + if TOvcComponent(AOwner).CollectionStreamer = nil then + TOvcComponent(AOwner).CollectionStreamer := TOvcCollectionStreamer.Create(AOwner); + FStreamer := TOvcComponent(AOwner).CollectionStreamer; + FStreamer.FCollectionList.Add(Self); + end + else + if (AOwner is TOvcCustomControl) then + begin + if TOvcCustomControl(AOwner).CollectionStreamer = nil then + TOvcCustomControl(AOwner).CollectionStreamer := TOvcCollectionStreamer.Create(AOwner); + FStreamer := TOvcCustomControl(AOwner).CollectionStreamer; + FStreamer.FCollectionList.Add(Self); + end + else + raise Exception.Create(GetOrphStr(SCNotOvcDescendant)); +end; + +procedure TOvcCollection.Delete(Index : Integer); +begin + if (Index > -1) and (Index < Count) then + Item[Index].Free; + Changed; +end; + +destructor TOvcCollection.Destroy; +begin + ItemEditor.Free; + if (Owner is TOvcComponent) then + TOvcComponent(Owner).CollectionStreamer.FCollectionList.Remove(Self) + else + TOvcCustomControl(Owner).CollectionStreamer.FCollectionList.Remove(Self); + Clear; + FItems.Free; + inherited Destroy; +end; + +procedure TOvcCollection.DoOnItemSelected(Index : Integer); +begin + if Assigned(FOnItemSelected) then + FOnItemSelected(Self, Index); +end; + +function TOvcCollection.GetCount : Integer; +begin + Result := FItems.Count; +end; + +function TOvcCollection.GetEditorCaption : string; +begin + Result := 'Editing ' + ClassName; + if Assigned(FOnGetEditorCaption) then + FOnGetEditorCaption(Result); +end; + +function TOvcCollection.GetItem(Index : Integer) : TComponent; +begin + Result := TComponent(FItems[Index]); +end; + +function TOvcCollection.Insert(Index : Integer) : TComponent; +begin + if (Index < 0) or (Index > Count) then + Index := Count; + Result := Add; + if Result is TOvcCollectible then + TOvcCollectible(Item[Count-1]).Index := Index + else + if Result is TOvcCollectibleControl then + TOvcCollectibleControl(Item[Count-1]).Index := Index + else + Result := nil; +end; + +function TOvcCollection.ItemByName(const Name : string) : TComponent; +var + i : Integer; +begin + for i := 0 to pred(Count) do + if Item[i].Name = Name then begin + Result := Item[i]; + exit; + end; + Result := nil; +end; + +procedure TOvcCollection.Loaded; +begin + InLoaded := True; + try + Changed; + finally + InLoaded := False; + end; + IsLoaded := True; +end; + +function TOvcCollection.ParentForm : TForm; +var + Temp : TObject; +begin + Temp := Owner; + while (Temp <> nil) and not (Temp is TForm) do + Temp := TComponent(Temp).Owner; + Result := TForm(Temp); +end; + +procedure TOvcCollection.SetItem(Index : Integer; Value : TComponent); +begin + TOvcCollectible(FItems[Index]).Assign(Value); +end; + +procedure TOvcCollectionStreamer.Clear; +var + I : Integer; +begin + for I := 0 to pred(FCollectionList.Count) do + TOvcCollection(FCollectionList[I]).Clear; +end; + + +{===== TO32Collection ================================================} + +constructor TO32Collection.Create(AOwner : TPersistent; + ItemClass : TCollectionItemClass); +begin + FOwner := AOwner; + Inherited Create(ItemClass); +end; + +destructor TO32Collection.Destroy; +begin + ItemEditor.Free; + Clear; + inherited Destroy; +end; + +procedure TO32Collection.DoOnItemSelected(Index : Integer); +begin + if Assigned(FOnItemSelected) then + FOnItemSelected(Self, Index); +end; + +function TO32Collection.GetCount : Integer; +begin + Result := inherited Count; +end; + +function TO32Collection.GetEditorCaption : string; +begin + Result := 'Editing ' + ClassName; + if Assigned(FOnGetEditorCaption) then + FOnGetEditorCaption(Result); +end; + +function TO32Collection.Add : TO32CollectionItem; +begin + Result := TO32CollectionItem(inherited Add); + if ItemEditor <> nil then + SendMessage(ItemEditor.Handle, OM_PROPCHANGE, 0, 0); +end; + +{$IFNDEF VERSION4} +function TO32Collection.Insert(Index: Integer): TO32CollectionItem; +var + I: Integer; +begin + result := Add; + for I := Index to Count - 2 do + Items[I].Index := I + 1; + Items[Count - 1].Index := Index; +end; +{$ENDIF} + +function TO32Collection.GetItem(Index : Integer) : TO32CollectionItem; +begin + Result := TO32CollectionItem(inherited GetItem(Index)); +end; + +function TO32Collection.GetOwner: TPersistent; +begin + result := FOwner; +end; + +procedure TO32Collection.SetItem(Index : Integer; Value : TO32CollectionItem); +begin + inherited SetItem(Index, Value); +end; + +function TO32Collection.ItemByName(const Name : string) : TO32CollectionItem; +var + i : Integer; +begin + for i := 0 to pred(Count) do + if Item[i].Name = Name then begin + Result := Item[i]; + exit; + end; + Result := nil; +end; + +procedure TO32Collection.Loaded; +begin + InLoaded := True; + try + Changed; + finally + InLoaded := False; + end; + IsLoaded := True; +end; + +function TO32Collection.ParentForm : TForm; +var + Temp : TObject; +begin + Temp := GetOwner; + while (Temp <> nil) and not (Temp is TForm) do + Temp := TComponent(Temp).Owner; + Result := TForm(Temp); +end; + +{End - TO32Collection } + +{===== TOvcCollectionStreamer ========================================} +function TOvcCollectionStreamer.CollectionFromType(Component : TComponent) : TOvcCollection; +var + I : Integer; +begin + for I := 0 to pred(FCollectionList.Count) do + if Component is TOvcCollection(FCollectionList[I]).ItemClass then begin + Result := TOvcCollection(FCollectionList[I]); + exit; + end; + raise Exception.Create(GetOrphStr(SCCollectionNotFound)); +end; + +constructor TOvcCollectionStreamer.Create(AOwner : TComponent); +begin + inherited Create; + + FOwner := AOwner; + FCollectionList := TList.Create; +end; + +destructor TOvcCollectionStreamer.Destroy; +begin + FCollectionList.Free; + FCollectionList := nil; + + inherited Destroy; +end; + +procedure TOvcCollectionStreamer.GetChildren(Proc: TGetChildProc; Root : TComponent); +var + I,J: Integer; +begin + for I := 0 to pred(FCollectionList.Count) do + with TOvcCollection(FCollectionList[I]) do + if Stored then + for J := 0 to Count - 1 do + Proc(Item[J]); +end; + +procedure TOvcCollectionStreamer.Loaded; +var + I : Integer; +begin + for I := 0 to pred(FCollectionList.Count) do + TOvcCollection(FCollectionList[I]).Loaded; +end; + +function DefaultController : TOvcController; +begin + if FDefaultController = nil then + FDefaultController := TOvcController.Create(nil); + Result := FDefaultController; +end; + +initialization + {register the attached label class} + if Classes.GetClass(TOvcAttachedLabel.ClassName) = nil then + Classes.RegisterClass(TOvcAttachedLabel); +{$IFDEF LCL} + {$I ovcbase.lrs} +{$ENDIF} +finalization + FDefaultController.Free; + FDefaultController := nil; +end. diff --git a/components/orpheus/ovcbase.res b/components/orpheus/ovcbase.res new file mode 100644 index 000000000..98a1f316d Binary files /dev/null and b/components/orpheus/ovcbase.res differ diff --git a/components/orpheus/ovcbcalc.pas b/components/orpheus/ovcbcalc.pas new file mode 100644 index 000000000..473e5883c --- /dev/null +++ b/components/orpheus/ovcbcalc.pas @@ -0,0 +1,1510 @@ +{*********************************************************} +{* OVCBCALC.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +{$J+} {Writable constants} + + +unit ovcbcalc; + {-base edit field class w/ label and borders} + +interface + +uses + {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, LclType, MyMisc, {$ENDIF} + Buttons, Classes, Controls, ExtCtrls, Forms, Graphics, Menus, + {$IFDEF VERSION4}{$IFNDEF LCL} MultiMon, {$ENDIF}{$ENDIF} + StdCtrls, SysUtils, OvcBase, OvcVer, OvcMisc, + OvcEditF, OvcBordr, OvcEdClc, ovcCalc, ovcEdPop; + +const + BorderMsgClose = WM_USER+10; + BorderMsgOpen = WM_USER+11; + +type + TOvcPopupEvent = + procedure(Sender : TObject) of object; + + TOvcPopupAnchor = (paLeft, paRight); + + + TOvcBorderEdPopup = class; + + TOvcNumberEditEx = class(TOvcNumberEdit) + protected + BorderParent : TOvcBorderEdPopup; + end; + + TOvcBorderEdPopup = class(TOvcBorderParent) + protected {private} + {new property variables} + FEdit : TOvcCustomEdit; + FButton : TOvcEdButton; + + FButtonGlyph : TBitmap; + FController : TOvcController; + FPopupActive : Boolean; + FPopupAnchor : TOvcPopupAnchor; + FOnPopupClose : TOvcPopupEvent; + FOnPopupOpen : TOvcPopupEvent; + FShowButton : Boolean; + + + protected + {property methods} + function GetButtonGlyph : TBitmap; + + procedure SetButtonGlyph(Value : TBitmap); + procedure SetShowButton(Value : Boolean); + + {internal methods} + function GetButtonWidth : Integer; + +{$IFDEF VERSION4} + procedure CMDialogKey(var Msg : TCMDialogKey); + message CM_DIALOGKEY; +{$ENDIF} + + procedure CreateParams(var Params : TCreateParams); + override; + procedure CreateWnd; + override; + + function GetButtonEnabled : Boolean; + dynamic; + procedure GlyphChanged; + dynamic; + procedure Loaded; + override; + + procedure OnMsgClose(var M : TMessage); + message BorderMsgClose; + procedure OnMsgOpen(var M : TMessage); + message BorderMsgOpen; + + public + constructor Create(AOwner : TComponent); + override; + destructor Destroy; + override; + + procedure PopupClose(Sender : TObject); + dynamic; + procedure PopupOpen; + dynamic; + + procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); + override; + + procedure SetEditControl(EC : TOvcCustomEdit); override; + + property Canvas; + + property PopupActive : Boolean + read FPopupActive; + + property PopupAnchor : TOvcPopupAnchor + read FPopupAnchor + write FPopupAnchor; + + published + property ButtonGlyph : TBitmap + read GetButtonGlyph + write SetButtonGlyph; + end; + + + TOvcBorderedNumberEdit = class(TOvcBorderEdPopup) + protected + {base property values} + FOvcEdit : TOvcNumberEditEx; + + {$IFDEF VERSION4} +{$IFNDEF LCL} + FBiDiMode : TBiDiMode; +{$ENDIF} + FConstraints : TSizeConstraints; + FParentBiDiMode: Boolean; + FDragKind : TDragKind; + {$ENDIF} + FAbout : string; +{$IFNDEF LCL} + FAutoSelect : Boolean; +{$ENDIF} + FAutoSize : Boolean; + FBorderStyle : TBorderStyle; + FCharCase : TEditCharCase; + FController : TOvcController; + FCursor : TCursor; + FDragCursor : TCursor; + FDragMode : TDragMode; + FEnabled : Boolean; + FFont : TFont; + FHeight : integer; +{$IFNDEF LCL} + FHideSelection : Boolean; + FImeMode : TImeMode; +{$ENDIF} + FImeName : string; + FMaxLength : Integer; +{$IFNDEF LCL} + FOEMConvert : Boolean; +{$ENDIF} + FParentFont : Boolean; + FParentShowHint: Boolean; + FPasswordChar : Char; + FPopupMenu : TPopupMenu; + FReadOnly : Boolean; + FShowHint : Boolean; + FTabOrder : TTabOrder; + FVisible : Boolean; + FWidth : integer; + + {events} + FOnChange : TNotifyEvent; + FOnClick : TNotifyEvent; + FOnDblClick : TNotifyEvent; + FOnDragDrop : TDragDropEvent; + FOnDragOver : TDragOverEvent; + + FOnEndDrag : TEndDragEvent; + FOnEnter : TNotifyEvent; + FOnExit : TNotifyEvent; + FOnKeyDown : TKeyEvent; + FOnKeyPress : TKeyPressEvent; + FOnKeyUp : TKeyEvent; + FOnMouseDown : TMouseEvent; + FOnMouseMove : TMouseMoveEvent; + FOnMouseUp : TMouseEvent; + FOnStartDrag : TStartDragEvent; + + + FAllowIncDec : Boolean; + FCalculator : TOvcCalculator; + + {internal variables} + PopupClosing : Boolean; + HoldCursor : TCursor; + WasAutoScroll : Boolean; + + {base property methods} + {$IFDEF VERSION4} + {$IFNDEF LCL} + function GetBiDiMode : TBiDiMode; + {$ENDIF} + function GetDragKind : TDragKind; + {$IFNDEF LCL} + function GetParentBiDiMode : Boolean; + {$ENDIF} + +{$IFNDEF LCL} + procedure SetBiDiMode(Value : TBiDiMode); override; +{$ENDIF} + procedure SetDragKind(Value : TDragKind); +{$IFNDEF LCL} + procedure SetParentBiDiMode(Value : Boolean); override; +{$ENDIF} + {$ENDIF} + + function GetAbout : string; +{$IFNDEF LCL} + function GetAutoSelect : Boolean; +{$ENDIF} + function GetAutoSize : Boolean; + function GetCharCase : TEditCharCase; + function GetController : TOvcController; + function GetCursor : TCursor; + function GetDragCursor : TCursor; + function GetDragMode : TDragMode; + function GetEditEnabled : Boolean; + function GetFont : TFont; +{$IFNDEF LCL} + function GetHideSelection : Boolean; + function GetImeMode : TImeMode; + function GetImeName : string; +{$ENDIF} + function GetMaxLength : Integer; +{$IFNDEF LCL} + function GetOEMConvert : Boolean; +{$ENDIF} + function GetParentShowHint : Boolean; + function GetPasswordChar : Char; + function GetReadOnly : Boolean; + function GetEditShowButton : Boolean; + + function GetParentFont : Boolean; + function GetEditParentShowHint : Boolean; + + function GetOnChange : TNotifyEvent; + function GetOnClick : TNotifyEvent; + function GetOnDblClick : TNotifyEvent; + function GetOnDragDrop : TDragDropEvent; + function GetOnDragOver : TDragOverEvent; + function GetOnEndDrag : TEndDragEvent; + function GetOnKeyDown : TKeyEvent; + function GetOnKeyPress : TKeyPressEvent; + function GetOnKeyUp : TKeyEvent; + function GetOnMouseDown: TMouseEvent; + function GetOnMouseMove: TMouseMoveEvent; + function GetOnMouseUp : TMouseEvent; + + function GetOnPopupClose : TOvcPopupEvent; + function GetOnPopupOpen : TOvcPopupEvent; + function GetPopupAnchor : TOvcPopupAnchor; + + procedure SetAbout(const Value : string); +{$IFNDEF LCL} + procedure SetAutoSelect(Value : Boolean); +{$ENDIF} + procedure SetAutoSize(Value : Boolean); {$IFDEF VERSION6}{$IFNDEF LCL} override;{$ENDIF}{$ENDIF} + procedure SetCharCase(Value : TEditCharCase); + procedure SetCursor(Value : TCursor); + procedure SetDragCursor(Value : TCursor); + procedure SetEditController(Value : TOvcController); + procedure SetEditDragMode(Value : TDragMode); + procedure SetEditEnabled(Value : Boolean); + procedure SetFont(Value : TFont); +{$IFNDEF LCL} + procedure SetHideSelection(Value : Boolean); + procedure SetImeMode(Value : TImeMode); + procedure SetImeName(const Value : string); +{$ENDIF} + procedure SetMaxLength(Value : Integer); +{$IFNDEF LCL} + procedure SetOEMConvert(Value : Boolean); +{$ENDIF} + procedure SetParentShowHint(Value : Boolean); + procedure SetPasswordChar(Value : Char); + procedure SetReadOnly(Value : Boolean); + procedure SetEditShowButton(Value : Boolean); + + procedure SetOnChange(Value : TNotifyEvent); + procedure SetOnClick(Value : TNotifyEvent); + procedure SetOnDblClick(Value : TNotifyEvent); + procedure SetOnDragDrop(Value : TDragDropEvent); + procedure SetOnDragOver(Value : TDragOverEvent); + procedure SetOnEndDrag(Value : TEndDragEvent); + procedure SetOnKeyDown(Value : TKeyEvent); + procedure SetOnKeyPress(Value : TKeyPressEvent); + procedure SetOnKeyUp(Value : TKeyEvent); + procedure SetOnMouseDown(Value : TMouseEvent); + procedure SetOnMouseMove(Value : TMouseMoveEvent); + procedure SetOnMouseUp(Value : TMouseEvent); + + procedure SetOnPopupClose(Value : TOvcPopupEvent); + procedure SetOnPopupOpen(Value : TOvcPopupEvent); + procedure SetPopupAnchor(Value : TOvcPopupAnchor); + + + {property methods} + function GetAsFloat : Double; + function GetAsInteger : LongInt; + function GetAsString : string; + function GetPopupColors : TOvcCalcColors; + function GetPopupDecimals : Integer; + function GetPopupFont : TFont; + function GetPopupHeight : Integer; + function GetPopupWidth : Integer; + procedure SetAsFloat(Value : Double); + procedure SetAsInteger(Value : LongInt); + procedure SetAsString(const Value : string); + procedure SetPopupColors(Value : TOvcCalcColors); + procedure SetPopupDecimals(Value : Integer); + procedure SetPopupFont(Value : TFont); + procedure SetPopupHeight(Value : Integer); + procedure SetPopupWidth(Value : Integer); + + procedure SetParentFont(Value : Boolean); + procedure SetEditParentShowHint(Value : Boolean); + + protected + procedure GlyphChanged; + override; + + public + constructor Create(AOwner : TComponent); + override; + + destructor Destroy; override; + + property AsInteger : LongInt + read GetAsInteger + write SetAsInteger; + + property AsFloat : Double + read GetAsFloat + write SetAsFloat; + + property AsString : string + read GetAsString + write SetAsString; + + property Calculator : TOvcCalculator + read FCalculator; + + property EditControl : TOvcNumberEditEx + read FOvcEdit; + + + published + {$IFDEF VERSION4} + property Anchors; + +{$IFNDEF LCL} + property BiDiMode : TBiDiMode + read GetBiDiMode + write SetBiDiMode; +{$ENDIF} + + property Constraints; + +{$IFNDEF LCL} + property ParentBiDiMode : Boolean + read GetParentBiDiMode + write SetParentBiDiMode; +{$ENDIF} + + property DragKind : TDragKind + read GetDragKind + write SetDragKind; + {$ENDIF} + + property About : string + read GetAbout + write SetAbout; + + property AllowIncDec : Boolean + read FAllowIncDec + write FAllowIncDec; + +{$IFNDEF LCL} + property AutoSelect : Boolean + read GetAutoSelect + write SetAutoSelect; +{$ENDIF} + + property AutoSize : Boolean + read GetAutoSize + write SetAutoSize; + + property CharCase : TEditCharCase + read GetCharCase + write SetCharCase; + + property Controller : TOvcController + read GetController + write SetEditController; + + property Cursor : TCursor + read GetCursor + write SetCursor; + + property DragCursor : TCursor + read GetDragCursor + write SetDragCursor; + + {$IFDEF VERSION4} + property DragMode : TDragMode + read GetDragMode + write SetDragMode; + {$ENDIF} + + property Enabled : Boolean + read FEnabled + write FEnabled; + + property Font : TFont + read GetFont + write SetFont; + +{$IFNDEF LCL} + property HideSelection : Boolean + read GetHideSelection + write SetHideSelection; + + property ImeMode : TImeMode + read GetImeMode + write SetImeMode; + + property ImeName; +{$ENDIF} + + property MaxLength : integer + read GetMaxLength + write SetMaxLength; + +{$IFNDEF LCL} + property OEMConvert : Boolean + read GetOEMConvert + write SetOEMConvert; +{$ENDIF} + + property ParentFont : Boolean + read GetParentFont + write SetParentFont; + + property ParentShowHint : Boolean + read GetParentShowHint + write SetParentShowHint; + + property PasswordChar : Char + read GetPasswordChar + write SetPasswordChar; + + property PopupAnchor : TOvcPopupAnchor + read GetPopupAnchor + write SetPopupAnchor; + + property PopupColors : TOvcCalcColors + read GetPopupColors + write SetPopupColors; + + property PopupDecimals : Integer + read GetPopupDecimals + write SetPopupDecimals; + + property PopupFont : TFont + read GetPopupFont + write SetPopupFont; + + property PopupHeight : Integer + read GetPopupHeight + write SetPopupHeight; + + property PopupMenu; + + property PopupWidth : Integer + read GetPopupWidth + write SetPopupWidth; + + property ReadOnly : Boolean + read GetReadOnly + write SetReadOnly; + + property ShowButton : Boolean + read GetEditShowButton + write SetEditShowButton; + + property ShowHint; + property TabOrder; + property TabStop; + property Visible; + + {events} + property OnChange : TNotifyEvent + read GetOnChange + write SetOnChange; + + property OnClick : TNotifyEvent + read GetOnClick + write SetOnClick; + + property OnDblClick : TNotifyEvent + read GetOnDblClick + write SetOnDblClick; + + property OnDragDrop : TDragDropEvent + read GetOnDragDrop + write SetOnDragDrop; + + property OnDragOver : TDragOverEvent + read GetOnDragOver + write SetOnDragOver; + + property OnEndDrag : TEndDragEvent + read GetOnEndDrag + write SetOnEndDrag; + + property OnEnter; + property OnExit; + + property OnKeyDown : TKeyEvent + read GetOnKeyDown + write SetOnKeyDown; + + property OnKeyPress : TKeyPressEvent + read GetOnKeyPress + write SetOnKeyPress; + + property OnKeyUp : TKeyEvent + read GetOnKeyUp + write SetOnKeyUp; + + property OnMouseDown : TMouseEvent + read GetOnMouseDown + write SetOnMouseDown; + + property OnMouseMove : TMouseMoveEvent + read GetOnMouseMove + write SetOnMouseMove; + + property OnMouseUp : TMouseEvent + read GetOnMouseUp + write SetOnMouseUp; + property OnStartDrag; + + property OnPopupClose : TOvcPopupEvent + read GetOnPopupClose + write SetOnPopupClose; + + property OnPopupOpen : TOvcPopupEvent + read GetOnPopupOpen + write SetOnPopupOpen; + end; + + +implementation + +constructor TOvcBorderEdPopup.Create(AOwner : TComponent); +begin + inherited Create(AOwner); + + ControlStyle := ControlStyle - [csSetCaption]; + + ButtonWidth := ButtonGlyph.Width; + DoShowButton := FShowButton; +end; + + +procedure TOvcBorderEdPopup.CreateParams(var Params : TCreateParams); +begin + inherited CreateParams(Params); + + Params.Style := Params.Style or WS_CLIPCHILDREN; +end; + +procedure TOvcBorderEdPopup.CreateWnd; +begin + inherited CreateWnd; + + {force button placement} + SetBounds(Left, Top, Width, Height); + + if (Assigned(FButton)) then + FButton.Enabled := GetButtonEnabled; +end; + +destructor TOvcBorderEdPopup.Destroy; +begin + { Freeing the button glyph throws access violation for some reason } + { we'll just let it leak for now. } +// if FButtonGlyph <> nil then +// FButtonGlyph.Free; + inherited Destroy; +end; + + + +function TOvcBorderEdPopup.GetButtonEnabled : Boolean; +begin + Result := not TOvcEdit(FEdit).ReadOnly; +end; + + +function TOvcBorderEdPopup.GetButtonWidth : Integer; +begin + if FShowButton then begin + Result := GetSystemMetrics(SM_CXHSCROLL); + if Assigned(FButtonGlyph) and not FButtonGlyph.Empty then + if FButtonGlyph.Width + 4 > Result then + Result := FButtonGlyph.Width + 4; + end else + Result := 0; +end; + +function TOvcBorderEdPopup.GetButtonGlyph : TBitmap; +begin + if not Assigned(FButtonGlyph) then + FButtonGlyph := TBitmap.Create; + + Result := FButtonGlyph +end; + +procedure TOvcBorderEdPopup.GlyphChanged; +begin +end; + +procedure TOvcBorderEdPopup.Loaded; +begin + inherited Loaded; + + if Assigned(FButtonGlyph) then + FButton.Glyph.Assign(FButtonGlyph); +end; + + +procedure TOvcBorderEdPopup.OnMsgClose(var M : TMessage); +begin + if (Assigned(FOnPopupClose)) then + FOnPopupClose(Self); +end; + +procedure TOvcBorderEdPopup.OnMsgOpen(var M : TMessage); +begin + if (Assigned(FOnPopupOpen)) then + FOnPopupOpen(Self); +end; + + +procedure TOvcBorderEdPopup.PopupClose; +begin + FPopupActive := False; + PostMessage(Handle, BorderMsgClose, 0, 0); +end; + +procedure TOvcBorderEdPopup.PopupOpen; +begin + FPopupActive := True; + PostMessage(Handle, BorderMsgOpen, 0, 0); +end; + + +procedure TOvcBorderEdPopup.SetEditControl(EC : TOvcCustomEdit); +begin + inherited SetEditControl(EC); + FEdit := EC; +end; + +procedure TOvcBorderEdPopup.SetButtonGlyph(Value : TBitmap); +begin + if not Assigned(FButtonGlyph) then + FButtonGlyph := TBitmap.Create; + + if not Assigned(Value) then begin + FButtonGlyph.Free; + FButtonGlyph := TBitmap.Create; + end else + FButtonGlyph.Assign(Value); + + GlyphChanged; + + FButton.Glyph.Assign(FButtonGlyph); + SetBounds(Left, Top, Width, Height); +end; + +procedure TOvcBorderEdPopup.SetShowButton(Value : Boolean); +begin + FShowButton := Value; + {force resize and redisplay of button} + SetBounds(Left, Top, Width, Height); +end; + +{$IFDEF VERSION4} +procedure TOvcBorderEdPopup.CMDialogKey(var Msg : TCMDialogKey); +begin +(* + if PopupActive then begin + with Msg do begin + if ((CharCode = VK_RETURN) or (CHarCode = VK_ESCAPE)) then begin + PopupClose(Self); + Result := 1; + end; + end; + end else + inherited; +*) +end; +{$ENDIF} + + +procedure TOvcBorderEdPopup.SetBounds(ALeft, ATop, AWidth, AHeight : Integer); +begin + inherited SetBounds(ALeft, ATop, AWidth, AHeight); +end; + + +{******************************************************************************} +{ TOvcBorderedNumberEdit } +{******************************************************************************} + +constructor TOvcBorderedNumberEdit.Create(AOwner : TComponent); +begin + inherited Create(AOwner); + + FOvcEdit := TOvcNumberEditEx.Create(Self); + SetEditControl(TOvcCustomEdit(FOvcEdit)); + + FOvcEdit.Ctl3D := False; + FOvcEdit.BorderStyle := bsNone; + FOvcEdit.ParentColor := True; + FOvcEdit.Parent := Self; + FOvcEdit.Top := 0; + FOvcEdit.Left := 0; + FOvcEdit.TabStop := TabStop; + FOvcEdit.BorderParent := Self; + + DoShowButton := FOvcEdit.ShowButton; + ButtonWidth := FOvcEdit.ButtonGlyph.Width + 4; + + Height := FEdit.Height; + Width := FEdit.Width; + Borders.BottomBorder.Enabled := True; + + FController := FOvcEdit.Controller; + FButton := FOvcEdit.FButton; + FButtonGlyph := FOvcEdit.FButtonGlyph; + FPopupActive := FOvcEdit.FPopupActive; + FOnPopupClose := FOvcEdit.FOnPopupClose; + FShowButton := FOvcEdit.FShowButton; + + {$IFDEF VERSION4} + {$IFNDEF LCL} + FBiDiMode := FOvcEdit.BiDiMode; + {$ENDIF} + FDragKind := FOvcEdit.DragKind; + {$IFNDEF LCL} + FParentBiDiMode:= FOvcEdit.ParentBiDiMode; + {$ENDIF} + {$ENDIF} + FAbout := FOvcEdit.About; + {$IFNDEF LCL} + FAutoSelect := FOvcEdit.AutoSelect; + {$ENDIF} + FAutoSize := FOvcEdit.AutoSize; + FBorderStyle := FOvcEdit.BorderStyle; + FCharCase := FOvcEdit.CharCase; + FCursor := FOvcEdit.Cursor; + FDragCursor := FOvcEdit.DragCursor; + FDragMode := FOvcEdit.DragMode; + FEnabled := True; + FFont := FOvcEdit.Font; + {$IFNDEF LCL} + FHideSelection := FOvcEdit.HideSelection; + FImeMode := FOvcEdit.ImeMode; + FImeName := FOvcEdit.ImeName; + {$ENDIF} + FMaxLength := FOvcEdit.MaxLength; + {$IFNDEF LCL} + FOEMConvert := FOvcEdit.OEMConvert; + {$ENDIF} + FParentFont := FOvcEdit.ParentFont; + FParentShowHint:= FOvcEdit.ParentShowHint; + FPasswordChar := FOvcEdit.PasswordChar; + FPopupMenu := FOvcEdit.PopupMenu; + FReadOnly := FOvcEdit.ReadOnly; + FShowHint := FOvcEdit.ShowHint; + FTabOrder := FOvcEdit.TabOrder; + FVisible := True; + + FOnChange := FOvcEdit.OnChange; + FOnClick := FOvcEdit.OnClick; + FOnDblClick := FOvcEdit.OnDblClick; + FOnDragDrop := FOvcEdit.OnDragDrop; + FOnDragOver := FOvcEdit.OnDragOver; + + FOnEndDrag := FOvcEdit.OnEndDrag; + FOnEnter := FOvcEdit.OnEnter; + FOnExit := FOvcEdit.OnExit; + FOnKeyDown := FOvcEdit.OnKeyDown; + FOnKeyPress := FOvcEdit.OnKeyPress; + FOnKeyUp := FOvcEdit.OnKeyUp; + FOnMouseDown := FOvcEdit.OnMouseDown; + FOnMouseMove := FOvcEdit.OnMouseMove; + FOnMouseUp := FOvcEdit.OnMouseUp; + FOnStartDrag := FOvcEdit.OnStartDrag; + + {load button glyph} +{$IFNDEF LCL} + FButtonGlyph.Handle := LoadBaseBitmap('ORBTNCLC'); +{$ELSE} + FButtonGlyph.LoadFromLazarusResource('ORBTNCLC'); +{$ENDIF} + FButton.Glyph.Assign(FButtonGlyph); + + FCalculator := FOvcEdit.Calculator; +end; + +destructor TOvcBorderedNumberEdit.Destroy; +begin + FOvcEdit.Free; + FOvcEdit := nil; + + inherited Destroy; +end; + + +function TOvcBorderedNumberEdit.GetAsFloat : Double; +var + I : Integer; + S : string; +begin + S := Text; + for I := Length(S) downto 1 do + if not (S[I] in ['0'..'9', '+', '-', DecimalSeparator]) then + Delete(S, I, 1); + Result := StrToFloat(S); +end; + +function TOvcBorderedNumberEdit.GetAsInteger : LongInt; +begin + Result := Round(GetAsFloat); +end; + +function TOvcBorderedNumberEdit.GetAsString : string; +begin + Result := Text; +end; + +function TOvcBorderedNumberEdit.GetPopupColors : TOvcCalcColors; +begin + Result := FCalculator.Colors; +end; + +function TOvcBorderedNumberEdit.GetPopupDecimals : Integer; +begin + Result := FCalculator.Decimals; +end; + +function TOvcBorderedNumberEdit.GetPopupFont : TFont; +begin + Result := FCalculator.Font; +end; + +function TOvcBorderedNumberEdit.GetPopupHeight : Integer; +begin + Result := FCalculator.Height; +end; + +function TOvcBorderedNumberEdit.GetPopupWidth : Integer; +begin + Result := FCalculator.Width; +end; + +function TOvcBorderedNumberEdit.GetReadOnly : Boolean; +begin + Result := FOvcEdit.ReadOnly; + FReadOnly := Result; +end; + +function TOvcBorderedNumberEdit.GetParentFont : Boolean; +begin + Result := FOvcEdit.ParentFont; + FParentFont := Result; +end; + +function TOvcBorderedNumberEdit.GetEditParentShowHint : Boolean; +begin + Result := FOvcEdit.ParentShowHint; + FParentShowHint := Result; +end; + + +procedure TOvcBorderedNumberEdit.GlyphChanged; +begin + inherited GlyphChanged; + + if FButtonGlyph.Empty then +{$IFNDEF LCL} + FButtonGlyph.Handle := LoadBaseBitmap('ORBTNCLC'); +{$ELSE} + FButtonGlyph.LoadFromLazarusResource('ORBTNCLC'); +{$ENDIF} +end; + + +procedure TOvcBorderedNumberEdit.SetAsFloat(Value : Double); +begin + Text := FloatToStr(Value); +end; + +procedure TOvcBorderedNumberEdit.SetAsInteger(Value : LongInt); +begin + Text := IntToStr(Value); +end; + +procedure TOvcBorderedNumberEdit.SetAsString(const Value : string); +begin + Text := Value; +end; + +procedure TOvcBorderedNumberEdit.SetPopupColors(Value : TOvcCalcColors); +begin + FCalculator.Colors := Value; +end; + +procedure TOvcBorderedNumberEdit.SetPopupDecimals(Value : Integer); +begin + FCalculator.Decimals := Value; +end; + +procedure TOvcBorderedNumberEdit.SetPopupFont(Value : TFont); +begin + if Assigned(Value) then + FCalculator.Font.Assign(Value); +end; + +procedure TOvcBorderedNumberEdit.SetPopupHeight(Value : Integer); +begin + FCalculator.Height := Value; +end; + +procedure TOvcBorderedNumberEdit.SetPopupWidth(Value : Integer); +begin + FCalculator.Width := Value; +end; + +procedure TOvcBorderedNumberEdit.SetReadOnly(Value : Boolean); +begin + FReadOnly := Value; + FOvcEdit.ReadOnly := Value; +end; + +procedure TOvcBorderedNumberEdit.SetParentFont(Value : Boolean); +begin + FParentFont := Value; + FOvcEdit.ParentFont := Value; +end; + +procedure TOvcBorderedNumberEdit.SetEditParentShowHint(Value : Boolean); +begin + FOvcEdit.ParentShowHint := Value; + FParentShowHint := Value; +end; + + +function TOvcBorderedNumberEdit.GetOnPopupClose : TOvcPopupEvent; +begin + Result := FOvcEdit.OnPopupClose; + FOnPopupClose := Result; +end; + +function TOvcBorderedNumberEdit.GetOnPopupOpen : TOvcPopupEvent; +begin + Result := FOvcEdit.OnPopupOpen; + FOnPopupOpen := Result; +end; + +function TOvcBorderedNumberEdit.GetPopupAnchor : TOvcPopupAnchor; +begin + Result := FOvcEdit.BorderParent.PopupAnchor; + FPopupAnchor := Result; +end; + +function TOvcBorderedNumberEdit.GetEditShowButton : Boolean; +begin + Result := FOvcEdit.ShowButton; + FShowButton := Result; +end; + + +procedure TOvcBorderedNumberEdit.SetOnPopupClose(Value : TOvcPopupEvent); +begin + FOvcEdit.OnPopupClose := Value; + FOnPopupClose := Value; +end; + +procedure TOvcBorderedNumberEdit.SetOnPopupOpen(Value : TOvcPopupEvent); +begin + FOvcEdit.OnPopupOpen := Value; + FOnPopupOpen := Value; +end; + +procedure TOvcBorderedNumberEdit.SetPopupAnchor(Value : TOvcPopupAnchor); +begin + FOvcEdit.BorderParent.PopupAnchor := Value; + FPopupAnchor := Value; +end; + +procedure TOvcBorderedNumberEdit.SetEditShowButton(Value : Boolean); +begin + FOvcEdit.ShowButton := Value; + FShowButton := Value; +end; + + +{base property methods} +{$IFDEF VERSION4} + {$IFNDEF LCL} +function TOvcBorderedNumberEdit.GetBiDiMode : TBiDiMode; +begin + Result := FOvcEdit.BiDiMode; + FBiDiMode := Result; +end; + {$ENDIF} + +function TOvcBorderedNumberEdit.GetDragKind : TDragKind; +begin + Result := FOvcEdit.DragKind; + FDragKind := Result; +end; + +(* +function TOvcBorderedNumberEdit.GetEditConstraints : TSizeConstraints; +begin + Result := FOvcEdit.Constraints; + FConstraints := Result; +end; +*) + +{$IFNDEF LCL} +function TOvcBorderedNumberEdit.GetParentBiDiMode : Boolean; +begin + Result := FOvcEdit.ParentBiDiMode; + FParentBiDiMode := Result; +end; + +procedure TOvcBorderedNumberEdit.SetBiDiMode(Value : TBiDiMode); +begin + if (Value <> FBiDiMode) then begin + inherited; + FBiDiMode := Value; + FOvcEdit.BiDiMode := Value; + end; +end; +{$ENDIF} + +(* +procedure TOvcBorderedNumberEdit.SetEditConstraints(Value : TSizeConstraints); +begin + FConstraints := Value; + FOvcEdit.Constraints := Value; +end; +*) + +{$IFNDEF LCL} +procedure TOvcBorderedNumberEdit.SetParentBiDiMode(Value : Boolean); +begin + if (Value <> FParentBiDiMode) then begin + inherited; + FParentBiDiMode := Value; + FOvcEdit.ParentBiDiMode := Value; + end; +end; +{$ENDIF} + +procedure TOvcBorderedNumberEdit.SetDragKind(Value : TDragKind); +begin + if (Value <> FDragKind) then begin + FDragKind := Value; + FOvcEdit.DragKind := Value; + end; +end; +{$ENDIF} + + +function TOvcBorderedNumberEdit.GetAbout : string; +begin + Result := OrVersionStr; +end; + +{$IFNDEF LCL} +function TOvcBorderedNumberEdit.GetAutoSelect : Boolean; +begin + Result := FOvcEdit.AutoSelect; + FAutoSelect := FOvcEdit.AutoSelect; +end; +{$ENDIF} + +function TOvcBorderedNumberEdit.GetAutoSize : Boolean; +begin + Result := FOvcEdit.AutoSize; + FAutoSize := FOvcEdit.AutoSize; +end; + +function TOvcBorderedNumberEdit.GetCharCase : TEditCharCase; +begin + Result := FOvcEdit.CharCase; + FCharCase := Result; +end; + +function TOvcBorderedNumberEdit.GetController : TOvcController; +begin + Result := FOvcEdit.Controller; + FController := Result; +end; + +function TOvcBorderedNumberEdit.GetCursor : TCursor; +begin + Result := FOvcEdit.Cursor; + FCursor := Result; +end; + + +function TOvcBorderedNumberEdit.GetDragCursor : TCursor; +begin + Result := FOvcEdit.DragCursor; + FDragCursor := Result; +end; + + +function TOvcBorderedNumberEdit.GetDragMode : TDragMode; +begin + Result := FOvcEdit.DragMode; + FDragMode := Result; +end; + + +function TOvcBorderedNumberEdit.GetEditEnabled : Boolean; +begin + Result := FOvcEdit.Enabled; + FEnabled := FOvcEdit.Enabled; +end; + +function TOvcBorderedNumberEdit.GetFont : TFont; +begin + Result := FOvcEdit.Font; + FFont := Result; +end; + +{$IFNDEF LCL} +function TOvcBorderedNumberEdit.GetHideSelection : Boolean; +begin + Result := FOvcEdit.HideSelection; + FHideSelection := Result; +end; + +function TOvcBorderedNumberEdit.GetImeMode : TImeMode; +begin + Result := FOvcEdit.ImeMode; + FImeMode := Result; +end; + +function TOvcBorderedNumberEdit.GetImeName : string; +begin + Result := FOvcEdit.ImeName; + FImeName := Result; +end; +{$ENDIF} + +function TOvcBorderedNumberEdit.GetMaxLength : Integer; +begin + Result := FOvcEdit.MaxLength; + FMaxLength := Result; +end; + +{$IFNDEF LCL} +function TOvcBorderedNumberEdit.GetOEMConvert : Boolean; +begin + Result := FOvcEdit.OEMConvert; + FOEMConvert := Result; +end; +{$ENDIF} + +function TOvcBorderedNumberEdit.GetParentShowHint : Boolean; +begin + Result := FOvcEdit.ParentShowHint; + FParentShowHint := Result; +end; + +function TOvcBorderedNumberEdit.GetPasswordChar : Char; +begin + Result := FOvcEdit.PasswordChar; + FPasswordChar := Result; +end; + +function TOvcBorderedNumberEdit.GetOnChange : TNotifyEvent; +begin + Result := FOvcEdit.OnChange; + FOnChange := Result; +end; + +function TOvcBorderedNumberEdit.GetOnClick : TNotifyEvent; +begin + Result := FOvcEdit.OnClick; + FOnClick := Result; +end; + +function TOvcBorderedNumberEdit.GetOnDblClick : TNotifyEvent; +begin + Result := FOvcEdit.OnDblClick; + FOnDblClick := Result; +end; + +function TOvcBorderedNumberEdit.GetOnDragDrop : TDragDropEvent; +begin + Result := FOvcEdit.OnDragDrop; + FOnDragDrop := Result; +end; + +function TOvcBorderedNumberEdit.GetOnDragOver : TDragOverEvent; +begin + Result := FOvcEdit.OnDragOver; + FOnDragOver := Result; +end; + +function TOvcBorderedNumberEdit.GetOnEndDrag : TEndDragEvent; +begin + Result := FOvcEdit.OnEndDrag; + FOnEndDrag := Result; +end; + +function TOvcBorderedNumberEdit.GetOnKeyDown : TKeyEvent; +begin + Result := FOvcEdit.OnKeyDown; + FOnKeyDown := Result; +end; + +function TOvcBorderedNumberEdit.GetOnKeyPress : TKeyPressEvent; +begin + Result := FOvcEdit.OnKeyPress; + FOnKeyPress := Result; +end; + +function TOvcBorderedNumberEdit.GetOnKeyUp : TKeyEvent; +begin + Result := FOvcEdit.OnKeyUp; + FOnKeyUp := Result; +end; + +function TOvcBorderedNumberEdit.GetOnMouseDown : TMouseEvent; +begin + Result := FOvcEdit.OnMouseDown; + FOnMouseDown := Result; +end; + +function TOvcBorderedNumberEdit.GetOnMouseMove : TMouseMoveEvent; +begin + Result := FOvcEdit.OnMouseMove; + FOnMouseMove := Result; +end; + +function TOvcBorderedNumberEdit.GetOnMouseUp : TMouseEvent; +begin + Result := FOvcEdit.OnMouseUp; + FOnMouseUp := Result; +end; + + + +procedure TOvcBorderedNumberEdit.SetAbout(const Value : string); +begin +end; + + +{$IFNDEF LCL} +procedure TOvcBorderedNumberEdit.SetAutoSelect(Value : Boolean); +begin + if (Value <> FAutoSelect) then begin + FAutoSelect := Value; + FOvcEdit.AutoSelect := Value; + end; +end; +{$ENDIF} + + +procedure TOvcBorderedNumberEdit.SetAutoSize(Value : Boolean); +begin + FAutoSize := Value; + FOvcEdit.AutoSize := Value; +end; + + +procedure TOvcBorderedNumberEdit.SetCharCase(Value : TEditCharCase); +begin + FCharCase := Value; + FOvcEdit.CharCase := Value; +end; + +procedure TOvcBorderedNumberEdit.SetEditController(Value : TOvcController); +begin + FController := Value; + FOvcEdit.Controller := Value; +end; + +procedure TOvcBorderedNumberEdit.SetCursor(Value : TCursor); +begin + FCursor := Value; + FOvcEdit.Cursor := Value; +end; + + +procedure TOvcBorderedNumberEdit.SetDragCursor(Value : TCursor); +begin + if (Value <> FDragCursor) then begin + FDragCursor := Value; + FOvcEdit.DragCursor := Value; + end; +end; + + +procedure TOvcBorderedNumberEdit.SetEditDragMode(Value : TDragMode); +begin + if (Value <> FDragMode) then begin + FDragMode := Value; + FOvcEdit.DragMode := Value; + end; +end; + +procedure TOvcBorderedNumberEdit.SetEditEnabled(Value : Boolean); +begin + if (Value <> FEnabled) then begin + FEnabled := Value; + Enabled := Value; + FOvcEdit.Enabled := Value; + end; +end; + +procedure TOvcBorderedNumberEdit.SetFont(Value : TFont); +begin + if (Value <> FFont) then begin + FFont := Value; + FOvcEdit.Font := Value; + end; +end; + +{$IFNDEF LCL} +procedure TOvcBorderedNumberEdit.SetHideSelection(Value : Boolean); +begin + if (Value <> FHideSelection) then begin + FHideSelection := Value; + FOvcEdit.HideSelection := Value; + end; +end; + +procedure TOvcBorderedNumberEdit.SetImeMode(Value : TImeMode); +begin + if (Value <> FImeMode) then begin + FImeMode := Value; + FOvcEdit.ImeMode := Value; + end; +end; + +procedure TOvcBorderedNumberEdit.SetImeName(const Value : string); +begin + if (Value <> FImeName) then begin + FImeName := Value; + FOvcEdit.ImeName := Value; + end; +end; +{$ENDIF} + +procedure TOvcBorderedNumberEdit.SetMaxLength(Value : Integer); +begin + if (Value <> FMaxLength) then begin + FMaxLength := Value; + FOvcEdit.MaxLength := Value; + end; +end; + +{$IFNDEF LCL} +procedure TOvcBorderedNumberEdit.SetOEMConvert(Value : Boolean); +begin + if (Value <> FOEMConvert) then begin + FOEMConvert := Value; + FOvcEdit.OEMConvert := Value; + end; +end; +{$ENDIF} + +procedure TOvcBorderedNumberEdit.SetParentShowHint(Value : Boolean); +begin + if (Value <> FParentShowHint) then begin + FParentShowHint := Value; + FOvcEdit.ParentShowHint := Value; + end; +end; + +procedure TOvcBorderedNumberEdit.SetPasswordChar(Value : Char); +begin + if (Value <> FPasswordChar) then begin + FPasswordChar := Value; + FOvcEdit.PasswordChar := Value; + end; +end; + +procedure TOvcBorderedNumberEdit.SetOnChange(Value : TNotifyEvent); +begin + FOnChange := Value; + FOvcEdit.OnChange := Value; +end; + +procedure TOvcBorderedNumberEdit.SetOnClick(Value : TNotifyEvent); +begin + FOnClick := Value; + FOvcEdit.OnClick := Value; +end; + +procedure TOvcBorderedNumberEdit.SetOnDblClick(Value : TNotifyEvent); +begin + FOnDblClick := Value; + FOvcEdit.OnDblClick := Value; +end; + +procedure TOvcBorderedNumberEdit.SetOnDragDrop(Value : TDragDropEvent); +begin + FOnDragDrop := Value; + FOvcEdit.OnDragDrop := Value; +end; + +procedure TOvcBorderedNumberEdit.SetOnDragOver(Value : TDragOverEvent); +begin + FOnDragOver := Value; + FOvcEdit.OnDragOver := Value; +end; + +procedure TOvcBorderedNumberEdit.SetOnEndDrag(Value : TEndDragEvent); +begin + FOnEndDrag := Value; + FOvcEdit.OnEndDrag := Value; +end; + +procedure TOvcBorderedNumberEdit.SetOnKeyDown(Value : TKeyEvent); +begin + FOnKeyDown := Value; + FOvcEdit.OnKeyDown := Value; +end; + +procedure TOvcBorderedNumberEdit.SetOnKeyPress(Value : TKeyPressEvent); +begin + FOnKeyPress := Value; + FOvcEdit.OnKeyPress := Value; +end; + +procedure TOvcBorderedNumberEdit.SetOnKeyUp(Value : TKeyEvent); +begin + FOnKeyUp := Value; + FOvcEdit.OnKeyUp := Value; +end; + +procedure TOvcBorderedNumberEdit.SetOnMouseDown(Value : TMouseEvent); +begin + FOnMouseDown := Value; + FOvcEdit.OnMouseDown := Value; +end; + +procedure TOvcBorderedNumberEdit.SetOnMouseMove(Value : TMouseMoveEvent); +begin + FOnMouseMove := Value; + FOvcEdit.OnMouseMove := Value; +end; + +procedure TOvcBorderedNumberEdit.SetOnMouseUp(Value : TMouseEvent); +begin + FOnMouseUp := Value; + FOvcEdit.OnMouseUp := Value; +end; + +end. diff --git a/components/orpheus/ovcbordr.pas b/components/orpheus/ovcbordr.pas new file mode 100644 index 000000000..858a7e647 --- /dev/null +++ b/components/orpheus/ovcbordr.pas @@ -0,0 +1,735 @@ +{*********************************************************} +{* OVCBORDR.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovcbordr; + {Old style, To be deprecated - simple, single, solid borders for entry + controls} + +interface + +uses + {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, MyMisc, {$ENDIF} + Buttons, Classes, Controls, ExtCtrls, Forms, Graphics, Menus, + StdCtrls, SysUtils, OvcBase, OvcConst, OvcData, + OvcMisc, OvcEditF; + +type + TOvcBorderStyle = (bpsSolid); + + TOvcBorderEdButton = class(TBitBtn) + public + procedure Click; override; + end; + + TOvcBorder = class(TPersistent) + protected {private} + FEnabled : Boolean; {is border used} + FBorderStyle : TOvcBorderStyle; {bpsSolid only for now} + FPenColor : TColor; {color of pen} + FPenStyle : TPenStyle; {Windows pen style} + FPenWidth : integer; {width of pen} + + FOnChange : TNotifyEvent; {notify owner of changes} + + protected + procedure DoOnChange; + procedure SetDefaults; + + procedure SetEnabled(Value : Boolean); + procedure SetBorderStyle(Value : TOvcBorderStyle); + procedure SetPenColor(Value : TColor); + procedure SetPenStyle(Value : TPenStyle); + procedure SetPenWidth(Value : integer); + + public + procedure Assign(Value : TPersistent); override; + constructor Create; + + published + property BorderStyle : TOvcBorderStyle + read FBorderStyle + write SetBorderStyle + stored FEnabled + default bpsSolid; + + property Enabled : Boolean + read FEnabled + write SetEnabled + default False; + + property OnChange : TNotifyEvent + read FOnChange + write FOnChange; + + property PenColor : TColor + read FPenColor + write SetPenColor + stored FEnabled + default clBlack; + + property PenStyle : TPenStyle + read FPenStyle + write SetPenStyle + stored FEnabled + default psSolid; + + property PenWidth : integer + read FPenWidth + write SetPenWidth + stored FEnabled + default 2; + end; + + + TOvcBorders = class(TPersistent) + protected {private} + FLeftBorder : TOvcBorder; + FRightBorder : TOvcBorder; + FTopBorder : TOvcBorder; + FBottomBorder : TOvcBorder; + + public + procedure Assign(Source : TPersistent); override; + constructor Create; + destructor Destroy; override; + + published + property BottomBorder : TOvcBorder + read FBottomBorder + write FBottomBorder; + + property LeftBorder : TOvcBorder + read FLeftBorder + write FLeftBorder; + + property RightBorder : TOvcBorder + read FRightBorder + write FRightBorder; + + property TopBorder : TOvcBorder + read FTopBorder + write FTopBorder; + end; + + TOvcBorderParent = class(TOvcCustomControl) + {.Z+} + protected {private} + {property variables} + FBorders : TOvcBorders; + FEdit : TOvcCustomEdit; + FLabelInfo : TOvcLabelInfo; + + FOrgHeight : integer; + + protected + DefaultLabelPosition : TOvcLabelPosition; + DoingBorders : Boolean; + + procedure BorderChanged(ABorder : TObject); + function GetAttachedLabel : TOvcAttachedLabel; + procedure Paint; override; + procedure PaintBorders; virtual; + + procedure WMSetFocus(var Msg : TWMSetFocus); + message WM_SETFOCUS; + procedure WMKillFocus(var Msg : TWMKillFocus); + message WM_KillFOCUS; + + {internal methods} + procedure LabelChange(Sender : TObject); + procedure LabelAttach(Sender : TObject; Value : Boolean); + procedure PositionLabel; + + {VCL message methods} + procedure CMVisibleChanged(var Msg : TMessage); + message CM_VISIBLECHANGED; + + procedure OrAssignLabel(var Msg : TMessage); + message OM_ASSIGNLABEL; + procedure OrPositionLabel(var Msg : TMessage); + message OM_POSITIONLABEL; + procedure OrRecordLabelPosition(var Msg : TMessage); + message OM_RECORDLABELPOSITION; + + + procedure CreateWnd; + override; + procedure Notification(AComponent : TComponent; Operation: TOperation); + override; + + public + ButtonWidth : integer; + DoShowButton : Boolean; + + constructor Create(AOwner : TComponent); + override; + destructor Destroy; + override; + procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); + override; + procedure SetEditControl(EC : TOvcCustomEdit); virtual; + + property AttachedLabel : TOvcAttachedLabel + read GetAttachedLabel; + + property Canvas; + + property EditControl : TOvcCustomEdit + read FEdit + write FEdit; + + published + property Borders : TOvcBorders + read FBorders + write FBorders; + + property LabelInfo : TOvcLabelInfo + read FLabelInfo + write FLabelInfo; + end; + +implementation + +uses + OvcBCalc; + +procedure TOvcBorderEdButton.Click; +begin + TOvcBorderEdPopup(Parent).PopupOpen; +end; + +{******************************************************************************} +{ TOvcBorder } +{******************************************************************************} +constructor TOvcBorder.Create; +begin + inherited Create; + SetDefaults; +end; + + +procedure TOvcBorder.Assign(Value : TPersistent); +var + B : TOvcBorder absolute Value; +begin + if (Value <> nil) and (Value is TOvcBorder) then begin + Enabled := B.Enabled; + PenColor := B.PenColor; + PenStyle := B.PenStyle; + PenWidth := B.PenWidth; + end else + inherited Assign(Value); +end; + + +procedure TOvcBorder.DoOnChange; +begin + if (Assigned(FOnChange)) then + FOnChange(Self); +end; + + +procedure TOvcBorder.SetDefaults; +begin + FEnabled := False; + FPenColor := clBlack; + FPenStyle := psSolid; + FPenWidth := 2; +end; + +procedure TOvcBorder.SetBorderStyle(Value : TOvcBorderStyle); +begin + if (FBorderStyle <> Value) then begin + FBorderStyle := Value; + DoOnChange; + end; +end; + + +procedure TOvcBorder.SetEnabled(Value : Boolean); +begin + if (FEnabled <> Value) then begin + FEnabled := Value; + DoOnChange; + end; +end; + + +procedure TOvcBorder.SetPenColor(Value : TColor); +begin + if (FPenColor <> Value) then begin + FPenColor := Value; + DoOnChange; + end; +end; + + +procedure TOvcBorder.SetPenStyle(Value : TPenStyle); +begin + if (FPenStyle <> Value) then begin + FPenStyle := Value; + DoOnChange; + end; +end; + + +procedure TOvcBorder.SetPenWidth(Value : integer); +begin + if (FPenWidth <> Value) and (Value > 0) then begin + FPenWidth := Value; + DoOnChange; + end; +end; + +{******************************************************************************} +{ TOvcBorders } +{******************************************************************************} + +constructor TOvcBorders.Create; +begin + inherited Create; + + FBottomBorder := TOvcBorder.Create; + FLeftBorder := TOvcBorder.Create; + FRightBorder := TOvcBorder.Create; + FTopBorder := TOvcBorder.Create; +end; + +destructor TOvcBorders.Destroy; +begin + FBottomBorder.Free; + FBottomBorder := nil; + + FLeftBorder.Free; + FLeftBorder := nil; + + FRightBorder.Free; + FRightBorder := nil; + + FTopBorder.Free; + FTopBorder := nil; + + inherited Destroy; +end; + +procedure TOvcBorders.Assign(Source : TPersistent); +var + B : TOvcBorders absolute Source; +begin + if (Source <> nil) and (Source is TOvcBorders) then begin + FBottomBorder.Assign(B.BottomBorder); + FLeftBorder.Assign(B.LeftBorder); + FRightBorder.Assign(B.RightBorder); + FTopBorder.Assign(B.TopBorder); + end else + inherited Assign(Source); +end; + + +{******************************************************************************} +{ TOvcBorderParent } +{******************************************************************************} + +procedure TOvcBorderParent.BorderChanged(ABorder : TObject); +begin + PaintBorders; +end; + + +procedure TOvcBorderParent.CMVisibleChanged(var Msg : TMessage); +begin + inherited; + + if csLoading in ComponentState then + Exit; + + if LabelInfo.Visible then + AttachedLabel.Visible := Visible; +end; + + +constructor TOvcBorderParent.Create(AOwner : TComponent); +begin + inherited Create(AOwner); + + Parent := TWinControl(AOwner); + + Height := 21; + Width := 121; + + FOrgHeight := 21; + + ControlStyle := ControlStyle - [csSetCaption]; + + ParentColor := True; + Ctl3D := False; + + + {set default position and reference point} + DefaultLabelPosition := lpTopLeft; + + FLabelInfo := TOvcLabelInfo.Create; + FLabelInfo.OnChange := LabelChange; + FLabelInfo.OnAttach := LabelAttach; + + {create borders class and assign notifications} + FBorders := TOvcBorders.Create; + + FBorders.LeftBorder.OnChange := BorderChanged; + FBorders.RightBorder.OnChange := BorderChanged; + FBorders.TopBorder.OnChange := BorderChanged; + FBorders.BottomBorder.OnChange := BorderChanged; +end; + +destructor TOvcBorderParent.Destroy; +begin + {detatch and destroy label, if any} + FLabelInfo.Visible := False; + + {dispose the borders object} + FBorders.Free; + FLabelInfo.Free; + FBorders := nil; + FLabelInfo := nil; + + inherited Destroy; +end; + +function TOvcBorderParent.GetAttachedLabel : TOvcAttachedLabel; +begin + if not FLabelInfo.Visible then + raise Exception.Create(GetOrphStr(SCLabelNotAttached)); + + Result := FLabelInfo.ALabel; +end; + + +procedure TOvcBorderParent.WMSetFocus(var Msg : TWMSetFocus); +begin + inherited; + if (Assigned(FEdit)) then + FEdit.SetFocus; +end; + +procedure TOvcBorderParent.WMKillFocus(var Msg : TWMKillFocus); +begin + inherited; +end; + +procedure TOvcBorderParent.LabelAttach(Sender : TObject; Value : Boolean); +var +{$IFDEF VERSION5} + PF : TWinControl; +{$ELSE} + PF : TForm; +{$ENDIF} + S :string; +begin + if csLoading in ComponentState then + Exit; + +{$IFDEF VERSION5} + PF := GetImmediateParentForm(Self); +{$ELSE} + PF := TForm(GetParentForm(Self)); +{$ENDIF} + if Value then begin + if Assigned(PF) then begin + FLabelInfo.ALabel.Free; + FLabelInfo.ALabel := TOvcAttachedLabel.CreateEx(PF, Self); + FLabelInfo.ALabel.Parent := Parent; + + S := GenerateComponentName(PF, Name + 'Label'); + FLabelInfo.ALabel.Name := S; + FLabelInfo.ALabel.Caption := S; + + FLabelInfo.SetOffsets(0, 0); + PositionLabel; + FLabelInfo.ALabel.BringToFront; + {turn off auto size} + TLabel(FLabelInfo.ALabel).AutoSize := False; + end; + end else begin + if Assigned(PF) then begin + FLabelInfo.ALabel.Free; + FLabelInfo.ALabel := nil; + end; + end; +end; + + +procedure TOvcBorderParent.LabelChange(Sender : TObject); +begin + if not (csLoading in ComponentState) then + PositionLabel; +end; + + +procedure TOvcBorderParent.CreateWnd; +begin + inherited CreateWnd; +end; + +procedure TOvcBorderParent.Notification(AComponent : TComponent; Operation: TOperation); +var +{$IFDEF VERSION5} + PF : TWinControl; +{$ELSE} + PF : TForm; +{$ENDIF} +begin + inherited Notification(AComponent, Operation); + + if Operation = opRemove then begin + if Assigned(FLabelInfo) and (AComponent = FLabelInfo.ALabel) then begin + {$IFDEF VERSION5} + PF := GetImmediateParentForm(Self); + {$ELSE} + PF := TForm(GetParentForm(Self)); + {$ENDIF} + if Assigned(PF) and not (csDestroying in PF.ComponentState) then begin + FLabelInfo.FVisible := False; + FLabelInfo.ALabel := nil; + end + end; + end; +end; + + +procedure TOvcBorderParent.OrAssignLabel(var Msg : TMessage); +begin + FLabelInfo.ALabel := TOvcAttachedLabel(Msg.lParam); +end; + + +procedure TOvcBorderParent.OrPositionLabel(var Msg : TMessage); +const + DX : Integer = 0; + DY : Integer = 0; +begin + if FLabelInfo.Visible and Assigned(FLabelInfo.ALabel) and + (FLabelInfo.ALabel.Parent <> nil) and + not (csLoading in ComponentState) then begin + if DefaultLabelPosition = lpTopLeft then begin + DX := FLabelInfo.ALabel.Left - Left; + DY := FLabelInfo.ALabel.Top + FLabelInfo.ALabel.Height - Top; + end else begin + DX := FLabelInfo.ALabel.Left - Left; + DY := FLabelInfo.ALabel.Top - Top - Height; + end; + if (DX <> FLabelInfo.OffsetX) or (DY <> FLabelInfo.OffsetY) then + PositionLabel; + end; +end; + + +procedure TOvcBorderParent.OrRecordLabelPosition(var Msg : TMessage); +begin + if Assigned(FLabelInfo.ALabel) and (FLabelInfo.ALabel.Parent <> nil) then begin + {if the label was cut and then pasted, this will complete the reattachment} + FLabelInfo.FVisible := True; + + if DefaultLabelPosition = lpTopLeft then + FLabelInfo.SetOffsets(FLabelInfo.ALabel.Left - Left, + FLabelInfo.ALabel.Top + FLabelInfo.ALabel.Height - Top) + else + FLabelInfo.SetOffsets(FLabelInfo.ALabel.Left - Left, + FLabelInfo.ALabel.Top - Top - Height); + end; +end; + + +procedure TOvcBorderParent.PositionLabel; +begin + if FLabelInfo.Visible and Assigned(FLabelInfo.ALabel) and + (FLabelInfo.ALabel.Parent <> nil) and + not (csLoading in ComponentState) then begin + + if DefaultLabelPosition = lpTopLeft then begin + FLabelInfo.ALabel.SetBounds(Left + FLabelInfo.OffsetX, + FLabelInfo.OffsetY - FLabelInfo.ALabel.Height + Top, + FLabelInfo.ALabel.Width, FLabelInfo.ALabel.Height); + end else begin + FLabelInfo.ALabel.SetBounds(Left + FLabelInfo.OffsetX, + FLabelInfo.OffsetY + Top + Height, + FLabelInfo.ALabel.Width, FLabelInfo.ALabel.Height); + end; + end; +end; + + +procedure TOvcBorderParent.SetBounds(ALeft, ATop, AWidth, AHeight : Integer); +begin + inherited SetBounds(ALeft, ATop, AWidth, AHeight); + + if not HandleAllocated then + Exit; + + if HandleAllocated then + PostMessage(Handle, OM_POSITIONLABEL, 0, 0); +end; + + +procedure TOvcBorderParent.SetEditControl(EC : TOvcCustomEdit); +begin + FEdit := EC; +end; + + +procedure TOvcBorderParent.Paint; +begin + PaintBorders; +end; + +procedure TOvcBorderParent.PaintBorders; +var + R : TRect; + C : TCanvas; + W : integer; + BW : integer; +begin + Height := FOrgHeight; + + + C := Canvas; + if DoShowButton then + W := ButtonWidth + 4 + else + W := 0; + + if (FBorders.LeftBorder.Enabled) then + FEdit.Left := FBorders.LeftBorder.PenWidth + else + FEdit.Left := 0; + + if (FBorders.TopBorder.Enabled) then + FEdit.Top := FBorders.TopBorder.PenWidth + else + FEdit.Top := 0; + + if (not (FBorders.LeftBorder.Enabled or FBorders.RightBorder.Enabled)) then + FEdit.Width := Width + else begin + BW := W; + if (FBorders.LeftBorder.Enabled) then + BW := FBorders.LeftBorder.PenWidth; + if (FBorders.RightBorder.Enabled) then + BW := BW + FBorders.RightBorder.PenWidth; + FEdit.Width := Width - BW; + end; + + if (not (FBorders.TopBorder.Enabled or FBorders.BottomBorder.Enabled)) then +{ Height := FEdit.Height} + FEdit.Height := Height + else begin + BW := 0; + if (FBorders.TopBorder.Enabled) then + BW := FBorders.TopBorder.PenWidth; + if (FBorders.BottomBorder.Enabled) then + BW := BW + FBorders.BottomBorder.PenWidth; + + FEdit.Height := Height - BW; + end; + + R.Left := 0; + R.Top := 0; + R.Right := Width; + R.Bottom := Height; + + if (Assigned(FBorders.FLeftBorder)) then begin + if (FBorders.LeftBorder.Enabled) then begin + C.Pen.Color := FBorders.LeftBorder.PenColor; + C.Pen.Width := FBorders.LeftBorder.PenWidth; + C.Pen.Style := FBorders.LeftBorder.PenStyle; + + C.MoveTo(R.Left + (FBorders.LeftBorder.PenWidth div 2), R.Top); + C.LineTo(R.Left + (FBorders.LeftBorder.PenWidth div 2), R.Bottom); + end; + end; + + if (Assigned(FBorders.FRightBorder)) then begin + if (FBorders.RightBorder.Enabled) then begin + C.Pen.Color := FBorders.RightBorder.PenColor; + C.Pen.Width := FBorders.RightBorder.PenWidth; + C.Pen.Style := FBorders.RightBorder.PenStyle; + + if ((FBorders.RightBorder.PenWidth mod 2) = 0) then begin + C.MoveTo(R.Right - (FBorders.RightBorder.PenWidth div 2), R.Top); + C.LineTo(R.Right - (FBorders.RightBorder.PenWidth div 2), R.Bottom); + end else begin + C.MoveTo(R.Right - (FBorders.RightBorder.PenWidth div 2) - 1, R.Top); + C.LineTo(R.Right - (FBorders.RightBorder.PenWidth div 2) - 1, R.Bottom); + end; + end; + end; + + if (Assigned(FBorders.FTopBorder)) then begin + if (FBorders.TopBorder.Enabled) then begin + C.Pen.Color := FBorders.TopBorder.PenColor; + C.Pen.Width := FBorders.TopBorder.PenWidth; + C.Pen.Style := FBorders.TopBorder.PenStyle; + + C.MoveTo(R.Left, R.Top + (FBorders.TopBorder.PenWidth div 2)); + C.LineTo(R.Right, R.Top + (FBorders.TopBorder.PenWidth div 2)); + end; + end; + + if (Assigned(FBorders.FBottomBorder)) then begin + if (FBorders.BottomBorder.Enabled) then begin + C.Pen.Color := FBorders.BottomBorder.PenColor; + C.Pen.Width := FBorders.BottomBorder.PenWidth; + C.Pen.Style := FBorders.BottomBorder.PenStyle; + + if ((FBorders.BottomBorder.PenWidth mod 2) = 0) then begin + C.MoveTo(R.Left, R.Bottom - (FBorders.BottomBorder.PenWidth div 2)); + C.LineTo(R.Right - (FBorders.BottomBorder.PenWidth div 2), + R.Bottom - (FBorders.BottomBorder.PenWidth div 2)); + end else begin + C.MoveTo(R.Left, R.Bottom - (FBorders.BottomBorder.PenWidth div 2) - 1); + C.LineTo(R.Right, R.Bottom - (FBorders.BottomBorder.PenWidth div 2) - 1); + end; + end; + end; + if (Assigned(FEdit)) then + FEdit.Refresh; + ValidateRect(Handle, @R); +end; + +end. + + + diff --git a/components/orpheus/ovccal.pas b/components/orpheus/ovccal.pas new file mode 100644 index 000000000..30715bfa4 --- /dev/null +++ b/components/orpheus/ovccal.pas @@ -0,0 +1,1758 @@ +{*********************************************************} +{* OVCCAL.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovccal; + {-Calendar component} + +interface + +uses + {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, LclType, MyMisc, {$ENDIF} + Buttons, Classes, Controls, Forms, Graphics, Menus, + SysUtils, OvcBase, OvcConst, OvcData, OvcIntl, + OvcMisc, OvcDate; + +type + TOvcDateFormat = (dfShort, dfLong); + TOvcDayNameWidth = 1..3; + TOvcDayType = (dtSunday, dtMonday, dtTuesday, dtWednesday, + dtThursday, dtFriday, dtSaturday); + TOvcCalDisplayOption = (cdoShortNames, cdoShowYear, cdoShowInactive, + cdoShowRevert, cdoShowToday, cdoShowNavBtns, + cdoHideActive); + TOvcCalDisplayOptions = set of TOvcCalDisplayOption; + +type + TOvcCalColorArray = array[0..5] of TColor; + TOvcCalColorScheme = (cscalCustom, cscalClassic, cscalWindows, + cscalGold, cscalOcean, cscalRose); + TOvcCalSchemeArray = array[TOvcCalColorScheme] of TOvcCalColorArray; + +const + {ActiveDay, DayNames, Days, InactiveDays, MonthAndYear, Weekend} + CalScheme : TOvcCalSchemeArray = + ((0, 0, 0, 0, 0, 0), + (clHighlight, clWindow, clWindow, clWindow, clWindow, clWindow), + (clRed, clMaroon, clBlack, clGray, clBlue, clRed), + (clBlack, clBlack, clYellow, clGray, clBlack, clTeal), + (clBlack, clBlack, clAqua, clGray, clBlack, clNavy), + (clRed, clRed, clFuchsia, clGray, clBlue, clTeal) + ); + +type + TOvcCalColors = class(TPersistent) + {.Z+} + protected {private} + {property variables} + FUpdating : Boolean; + FOnChange : TNotifyEvent; + + {internal variables} + SettingScheme : Boolean; + + {property methods} + function GetColor(Index : Integer) : TColor; + procedure SetColor(Index : Integer; Value : TColor); + procedure SetColorScheme(Value : TOvcCalColorScheme); + + {internal methods} + procedure DoOnChange; + + public + {public property variables} + FCalColors : TOvcCalColorArray; + FColorScheme : TOvcCalColorScheme; + + procedure Assign(Source : TPersistent); + override; + procedure BeginUpdate; + procedure EndUpdate; + + property OnChange : TNotifyEvent + read FOnChange write FOnChange; + {.Z-} + + published + property ActiveDay : TColor index 0 + read GetColor write SetColor; + property ColorScheme : TOvcCalColorScheme + read FColorScheme write SetColorScheme; + property DayNames : TColor index 1 + read GetColor write SetColor; + property Days : TColor index 2 + read GetColor write SetColor; + property InactiveDays : TColor index 3 + read GetColor write SetColor; + property MonthAndYear : TColor index 4 + read GetColor write SetColor; + property Weekend : TColor index 5 + read GetColor write SetColor; + end; + +type + TDateChangeEvent = procedure(Sender : TObject; Date : TDateTime) + of object; + TCalendarDateEvent = + procedure(Sender : TObject; ADate : TDateTime; const Rect : TRect) + of object; + TGetHighlightEvent = + procedure(Sender : TObject; ADate : TDateTime; var Color : TColor) + of object; + TGetDateEnabledEvent = + procedure(Sender : TObject; ADate : TDateTime; var Enabled : Boolean) + of object; + + + TOvcCustomCalendar = class(TOvcCustomControl) + {.Z+} + protected {private} + {property variables} + FBorderStyle : TBorderStyle; + FBrowsing : Boolean; + FColors : TOvcCalColors; + FOptions : TOvcCalDisplayOptions; + FDate : TDateTime; + FDay : Integer; {calendar day} + FDateFormat : TOvcDateFormat; + FDayNameWidth : TOvcDayNameWidth; + FDrawHeader : Boolean; {true to draw day name header} + FIntlSup : TOvcIntlSup; {international date/time support} + FMonth : Integer; {calendar month} + FReadOnly : Boolean; {true if in read only mode} + FWantDblClicks : Boolean; {true to include cs_dblclks style} + FWeekStarts : TOvcDayType; {the day that begins the week} + FYear : Integer; {calendar year} + + {event variables} + FOnChange : TDateChangeEvent; + FOnDrawDate : TCalendarDateEvent; + FOnDrawItem : TCalendarDateEvent; + FOnGetDateEnabled: TGetDateEnabledEvent; + FOnGetHighlight : TGetHighlightEvent; + + {internal variables} + clBtnLeft : TSpeedButton; + clBtnRevert : TSpeedButton; + clBtnRight : TSpeedButton; + clBtnToday : TSpeedButton; + clInPopup : Boolean; + clBtnNextYear : TSpeedButton; + clBtnPrevYear : TSpeedButton; + clCalendar : array[1..49] of Byte; {current month grid} + clDay : Word; + clFirst : Byte; {index for first day in current month} + clLast : Byte; {index for last day in current month} + clMonth : Word; + clRowCol : array[0..8, 0..6] of TRect; {cell TRect info} + cSettingScheme : Boolean; + clYear : Word; + clWidth : Integer; {client width - margins} + clMask : array[0..MaxDateLen] of AnsiChar; {default date mask} + clPopup : Boolean; {true if being created as a popup} + clRevertDate : TDateTime; {date on entry} + clRowCount : Integer; {7 if no header, otherwise 8} + clStartRow : Integer; {first row number} + + {property methods} + function GetAsDateTime : TDateTime; + function GetAsStDate : TStDate; + function GetCalendarDate : TDateTime; + function GetDay : Integer; + function GetMonth : Integer; + function GetYear : Integer; + procedure SetAsDateTime(Value : TDateTime); + procedure SetAsStDate(Value : TStDate); + procedure SetBorderStyle(Value : TBorderStyle); + procedure SetDate(Value : TDateTime); + procedure SetDateFormat(Value : TOvcDateFormat); + procedure SetDayNameWidth(Value : TOvcDayNameWidth); + procedure SetDisplayOptions(Value : TOvcCalDisplayOptions); + procedure SetDrawHeader(Value : Boolean); + procedure SetIntlSupport(Value : TOvcIntlSup); + procedure SetWantDblClicks(Value : Boolean); + procedure SetWeekStarts(Value : TOvcDayType); + + {internal methods} + procedure calChangeMonth(Sender : TObject); + procedure calColorChange(Sender : TObject); + function calGetCurrentRectangle : TRect; + {-get bounding rectangle for the current calendar day} + function calGetValidDate(ADate : TDateTime; Delta : Integer) : TDateTime; + procedure calRebuildCalArray; + {-recalculate the contents of the calendar array} + procedure calRecalcSize; + {-calcualte new sizes for rows and columns} + + {VCL control methods} + procedure CMCtl3DChanged(var Msg : TMessage); + message CM_CTL3DCHANGED; + procedure CMEnter(var Msg : TMessage); + message CM_ENTER; + procedure CMExit(var Msg : TMessage); + message CM_EXIT; + procedure CMFontChanged(var Msg : TMessage); + message CM_FONTCHANGED; + + {windows message methods} + procedure WMEraseBkgnd(var Msg : TWMEraseBkgnd); + message WM_ERASEBKGND; + procedure WMGetDlgCode(var Msg : TWMGetDlgCode); + message WM_GETDLGCODE; + procedure WMKillFocus(var Msg : TWMKillFocus); + message WM_KILLFOCUS; + + protected + procedure calBtnClick(Sender : TObject); + procedure CreateParams(var Params : TCreateParams); + override; + procedure CreateWnd; + override; + procedure DoOnChange(Value : TDateTime); + dynamic; + function DoOnGetDateEnabled(ADate : TDateTime) : Boolean; + dynamic; + procedure DoOnMouseWheel(Shift : TShiftState; Delta, XPos, YPos : SmallInt); + override; + function IsReadOnly : Boolean; + dynamic; + {-return true if the calendar is in read-only mode} + procedure KeyDown(var Key : Word; Shift : TShiftState); + override; + procedure KeyPress(var Key : Char); + override; + procedure MouseDown(Button : TMouseButton; Shift : TShiftState; X, Y : Integer); + override; + procedure MouseUp(Button : TMouseButton; Shift : TShiftState; X, Y : Integer); + override; + procedure Paint; + override; + + {virtual property methods} + procedure SetCalendarDate(Value : TDateTime); + virtual; + + public + constructor Create(AOwner : TComponent); + override; + constructor CreateEx(AOwner : TComponent; AsPopup : Boolean); + virtual; + destructor Destroy; + override; + procedure SetBounds(ALeft, ATop, AWidth, AHeight : Integer); + override; + + {.Z-} + + function DateString(const Mask : string): string; + function DayString : string; + procedure IncDay(Delta : Integer); + procedure IncMonth(Delta : Integer); + procedure IncYear(Delta : Integer); + function MonthString : string; + procedure SetToday; + + property AsDateTime : TDateTime + read GetAsDateTime write SetAsDateTime; + property AsStDate : TStDate + read GetAsStDate write SetAsStDate; + property Browsing : Boolean + read FBrowsing; + property Canvas; + property Day : Integer + read GetDay; + property Month : Integer + read GetMonth; + property Year : Integer + read GetYear; + + {properties} + property BorderStyle : TBorderStyle + read FBorderStyle write SetBorderStyle; + property CalendarDate : TDateTime + read GetCalendarDate write SetCalendarDate; + property Colors : TOvcCalColors + read FColors write FColors; + property Date : TDateTime + read FDate write SetDate; + property DateFormat : TOvcDateFormat + read FDateFormat write SetDateFormat; + property DayNameWidth : TOvcDayNameWidth + read FDayNameWidth write SetDayNameWidth; + property DrawHeader : Boolean + read FDrawHeader write SetDrawHeader; + property IntlSupport : TOvcIntlSup + read FIntlSup write SetIntlSupport; + property Options : TOvcCalDisplayOptions + read FOptions write SetDisplayOptions; + property ReadOnly : Boolean + read FReadOnly write FReadOnly; + property WantDblClicks : Boolean + read FWantDblClicks write SetWantDblClicks; + property WeekStarts : TOvcDayType + read FWeekStarts write SetWeekStarts; + + {events} + property OnChange : TDateChangeEvent + read FOnChange write FOnChange; + property OnDrawDate : TCalendarDateEvent + read FOnDrawDate write FOnDrawDate; + property OnDrawItem : TCalendarDateEvent + read FOnDrawItem write FOnDrawItem; + property OnGetDateEnabled : TGetDateEnabledEvent + read FOnGetDateEnabled write FOnGetDateEnabled; + property OnGetHighlight : TGetHighlightEvent + read FOnGetHighlight write FOnGetHighlight; + end; + + + TOvcCalendar = class(TOvcCustomCalendar) + published + {properties} + {$IFDEF VERSION4} + property Anchors; + property Constraints; + property DragKind; + {$ENDIF} + property About; + property Align; + property BorderStyle; + property Colors; + property Color; + property Ctl3D; + property Cursor; + property DateFormat default dfLong; + property DayNameWidth; + property DragCursor; + property DragMode; + property Enabled; + property Font; + property LabelInfo; + property Options; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ReadOnly default False; + property ShowHint; + property TabOrder; + property TabStop default True; + property Visible; + property WantDblClicks default True; + property WeekStarts default dtSunday; + {events} + property AfterEnter; + property AfterExit; + property OnChange; + property OnClick; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnDrawDate; + property OnDrawItem; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnGetDateEnabled; + property OnGetHighlight; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnStartDrag; + end; + + +implementation + + +const + calMargin = 4; {left, right, and top margin} + +{*** TOvcCalColors ***} + +procedure TOvcCalColors.Assign(Source : TPersistent); +begin + if Source is TOvcCalColors then begin + FCalColors := TOvcCalColors(Source).FCalColors; + FColorScheme := TOvcCalColors(Source).FColorScheme; + FOnChange := TOvcCalColors(Source).FOnChange; + end else + inherited Assign(Source); +end; + +procedure TOvcCalColors.BeginUpdate; +begin + FUpdating := True; +end; + +procedure TOvcCalColors.EndUpdate; +begin + FUpdating := False; + DoOnChange; +end; + +procedure TOvcCalColors.DoOnChange; +begin + if not FUpdating and Assigned(FOnChange) then + FOnChange(Self); + + if not SettingScheme then + FColorScheme := cscalCustom; +end; + +function TOvcCalColors.GetColor(Index : Integer) : TColor; +begin + Result := FCalColors[Index]; +end; + +procedure TOvcCalColors.SetColor(Index : Integer; Value : TColor); +begin + if Value <> FCalColors[Index] then begin + FCalColors[Index] := Value; + DoOnChange; + end; +end; + +procedure TOvcCalColors.SetColorScheme(Value : TOvcCalColorScheme); +begin + if Value <> FColorScheme then begin + SettingScheme := True; + try + FColorScheme := Value; + if Value <> cscalCustom then begin + FCalColors := CalScheme[Value]; + DoOnChange; + end; + finally + SettingScheme := False; + end; + end; +end; + + +{*** TOvcCustomCalendar ***} + +procedure TOvcCustomCalendar.calBtnClick(Sender : TObject); +var + Key : Word; +begin + SetFocus; + Key := 0; + + if Sender = clBtnLeft then begin + Key := VK_PRIOR; + KeyDown(Key, []); + end else if Sender = clBtnRevert then begin + Key := VK_ESCAPE; + KeyDown(Key, []); + end else if Sender = clBtnRight then begin + Key := VK_NEXT; + KeyDown(Key, []); + end else if Sender = clBtnToday then begin + Key := VK_BACK; + KeyDown(Key, [ssAlt]); + end else if Sender = clBtnNextYear then begin + Key := VK_NEXT; + KeyDown(Key, [ssCtrl]); + end else if Sender = clBtnPrevYear then begin + Key := VK_PRIOR; + KeyDown(Key, [ssCtrl]); + end; +end; + +procedure TOvcCustomCalendar.calChangeMonth(Sender : TObject); +var + Y, M, D : Word; + MO : Integer; + MI : TMenuItem; +begin + MI := (Sender as TMenuItem); + DecodeDate(FDate, Y, M, D); + MO := MI.Tag; + {set month and year} + if (MO > M) and (MI.HelpContext < 3) then + Dec(Y) + else if (MO < M) and (MI.HelpContext > 3) then + Inc(Y); + M := M + MO; + {set day} + if D > DaysInMonth(MO, Y, 0) then + D := DaysInMonth(MO, Y, 0); + SetDate(calGetValidDate(EncodeDate(Y, MO, D)-1, +1)); + if (Assigned(FOnChange)) then + FOnChange(Self, FDate); +end; + +procedure TOvcCustomCalendar.calColorChange(Sender : TObject); +begin + Invalidate; +end; + +function TOvcCustomCalendar.calGetCurrentRectangle : TRect; + {-get bounding rectangle for the current date} +var + Idx : Integer; + R, C : Integer; +begin + {index into the month grid} + Idx := clFirst + Pred(clDay) + 13; + R := (Idx div 7); + C := (Idx mod 7); + Result := clRowCol[R,C]; +end; + +{added} +{Modified July 9, 2001} +function TOvcCustomCalendar.calGetValidDate(ADate : TDateTime; + Delta : Integer) : TDateTime; +var + I, X : Integer; + Valid: Boolean; + Fwd: Boolean; +begin + Valid := false; + Fwd := false; + X := Delta; + I := 1; + while not Valid and (I < 1000) do begin + {If the date is valid then yay!} + if (DoOnGetDateEnabled(ADate + (X * I))) then begin + Valid := true; + Fwd := True; + end + {otherwise check the other direction} + else if (DoOnGetDateEnabled(ADate - (X * I))) then begin + valid := true; + end + else Inc(I); + end; + if Valid then + if Fwd then Result := ADate + (X * I) + else Result := ADate - (X * I) + else + raise(Exception.Create(GetOrphStr(SCInvalidDate))); +end; + +procedure TOvcCustomCalendar.calRebuildCalArray; +var + Day1 : TOvcDayType; + I, J : Integer; +begin + HandleNeeded; + DecodeDate(FDate, clYear, clMonth, clDay); + + {get the first day of the current month and year} + Day1 := TOvcDayType(SysUtils.DayOfWeek(EncodeDate(clYear, clMonth, 1)) -1); + + {find its index} + I := Byte(Day1) - Byte(WeekStarts) + 1; + if I < 1 then + Inc(I, 7); + clFirst := I; + + {find the index of the last day in the month} + clLast := clFirst + DaysInMonth(clMonth, clYear, 0) - 1; + + {initialize the first part of the calendar} + if clMonth = 1 then + J := DaysInMonth(12, clYear-1, 0) + else + J := DaysInMonth(clMonth-1, clYear, 0); + for I := clFirst-1 downto 1 do begin + clCalendar[I] := J; + Dec(J); + end; + + {initialize the rest of the calendar} + J := 1; + for I := clFirst to 49 do begin + clCalendar[I] := J; + if I = clLast then + J := 1 + else + Inc(J); + end; +end; + +procedure TOvcCustomCalendar.calRecalcSize; + {-calcualte new sizes for rows and columns} +var + R : Integer; + C : Integer; + D1 : Integer; + D2 : Integer; + CH : Integer; + RH : Integer; + Row : array[0..8] of Integer; + Col : array[0..6] of Integer; + + function SumOf(const A : array of Integer; First, Last : Integer) : Integer; + var + I : Integer; + begin + Result := 0; + for I := First to Last do + Result := Result + A[I]; + end; + +begin + if not HandleAllocated then + Exit; + + {clear row/col position structure} + FillChar(clRowCol, SizeOf(clRowCol), #0); + + {set the way the buttons should look} + clBtnLeft.Flat := not Ctl3D and not clPopup; + clBtnRevert.Flat := not Ctl3D and not clPopup; + clBtnRight.Flat := not Ctl3D and not clPopup; + clBtnToday.Flat := not Ctl3D and not clPopup; + clBtnNextYear.Flat := not Ctl3D and not clPopup; + clBtnPrevYear.Flat := not Ctl3D and not clPopup; + + clBtnRevert.Visible := cdoShowRevert in FOptions; + clBtnToday.Visible := cdoShowToday in FOptions; + clBtnLeft.Visible := (cdoShowNavBtns in FOptions); + clBtnRight.Visible := (cdoShowNavBtns in FOptions); + clBtnNextYear.Visible := (cdoShowNavBtns in FOptions); + clBtnPrevYear.Visible := (cdoShowNavBtns in FOptions); + + clWidth := ClientWidth - 2*calMargin; + {store row and column sizes} + for C := 0 to 6 do + Col[C] := clWidth div 7; + + Canvas.Font := Font; +(* + Row[0] := Round(1.3 * Canvas.TextHeight('Yy')); {button and date row} + Row[1] := Round(1.5 * Canvas.TextHeight('Yy'));; {day name row} +*) + + if (DrawHeader) then begin + {button and date row} + Row[0] := Round(1.4 * Canvas.TextHeight('Yy')); + {day name row} + Row[1] := Round(1.5 * Canvas.TextHeight('Yy')) + end else begin + {button and date row} + Row[0] := Round(1.3 * Canvas.TextHeight('Yy')); + {day name row} + Row[1] := 0; + end; + + CH := ClientHeight - 2*calMargin - Row[0] - Row[1]; + RH := CH div 7; + for R := 2 to 8 do + Row[R] := RH; + + {distribute any odd horizontal space equally among the columns} + for C := 0 to clWidth mod 7 do + Inc(Col[C]); + + {distribute odd vertical space to top 2 rows} + D1 := 0; + for R := 0 to 8 do + D1 := D1 + Row[R]; + D1 := ClientHeight - D1 - 2*calMargin; + D2 := D1 div 2; + D1 := D1 - D2; + Row[0] := Row[0] + D1; + if (DrawHeader) then + Row[1] := Row[1] + D2; + + {initialize each cells TRect structure using} + {the row heights from the Row[] array and the} + {column widths from the Col[] array} + for R := clStartRow to 7 do begin + for C := 0 to 6 do begin + clRowCol[R, C].Left := SumOf(Col, 0, C-1) + calMargin; + clRowCol[R, C].Right := SumOf(Col, 0, C) + calMargin; + clRowCol[R, C].Top := SumOf(Row, 0, R-1) + calMargin; + clRowCol[R, C].Bottom := SumOf(Row, 0, R) + calMargin; + end; + end; + + {position and size the left and right month buttons} + {position and size the next and prev year buttons} + clBtnNextYear.Height := Row[0] - calMargin; + clBtnNextYear.Width := Col[1] - calMargin; + if clBtnNextYear.Width < clBtnNextYear.Glyph.Width + 3 then + clBtnNextYear.Width := clBtnNextYear.Glyph.Width + 3; + clBtnNextYear.Top := calMargin; + clBtnNextYear.Left := ClientWidth - calMargin - clBtnNextYear.Width; + + clBtnPrevYear.Height := Row[0] - calMargin; + clBtnPrevYear.Width := Col[5] - calMargin; + if clBtnPrevYear.Width < clBtnPrevYear.Glyph.Width + 3 then + clBtnPrevYear.Width := clBtnPrevYear.Glyph.Width + 3; + clBtnPrevYear.Top := calMargin; + clBtnPrevYear.Left := calMargin; + + clBtnLeft.Height := Row[0] - calMargin; + clBtnLeft.Width := Col[0] - calMargin; + if clBtnLeft.Width < clBtnLeft.Glyph.Width + 3 then + clBtnLeft.Width := clBtnLeft.Glyph.Width + 3; + clBtnLeft.Top := calMargin; + clBtnLeft.Left := clBtnPrevYear.Left + clBtnPrevYear.Width; + + clBtnRight.Height := Row[0] - calMargin; + clBtnRight.Width := Col[6] - calMargin; + if clBtnRight.Width < clBtnRight.Glyph.Width + 3 then + clBtnRight.Width := clBtnRight.Glyph.Width + 3; + clBtnRight.Top := calMargin; + clBtnRight.Left := clBtnNextYear.Left - clBtnRight.Width; + + {position and size "today" button} + clBtnToday.Height := Row[8]; + clBtnToday.Width := Col[5] + Col[6] - calMargin; + clBtnToday.Top := ClientHeight - calMargin - clBtnToday.Height + 1; + clBtnToday.Left := ClientWidth - calMargin - clBtnToday.Width; + + + {position and size "revert" button} + clBtnRevert.Height := Row[8]; + clBtnRevert.Width := Col[5] + Col[6] - calMargin; + clBtnRevert.Top := ClientHeight - calMargin - clBtnRevert.Height + 1; + clBtnRevert.Left := clBtnToday.Left - clBtnRevert.Width - calMargin; +end; + +procedure TOvcCustomCalendar.CMCtl3DChanged(var Msg : TMessage); +begin + inherited; + + if (csLoading in ComponentState) or not HandleAllocated then + Exit; + + if NewStyleControls and (FBorderStyle = bsSingle) then +{$IFNDEF LCL} + RecreateWnd; +{$ELSE} + MyMisc.RecreateWnd(Self); +{$ENDIF} + + calReCalcSize; + + Invalidate; +end; + +procedure TOvcCustomCalendar.CMEnter(var Msg : TMessage); +var + R : TRect; +begin + inherited; + + clRevertDate := FDate; + + {invalidate the active date to ensure that the focus rect is painted} + R := calGetCurrentRectangle; + InvalidateRect(Handle, @R, False); +end; + +procedure TOvcCustomCalendar.CMExit(var Msg : TMessage); +var + R : TRect; +begin + inherited; + + {invalidate the active date to ensure that the focus rect is painted} + R := calGetCurrentRectangle; + InvalidateRect(Handle, @R, False); +end; + +procedure TOvcCustomCalendar.CMFontChanged(var Msg : TMessage); +begin + inherited; + + if csLoading in ComponentState then + Exit; + + calRecalcSize; + Invalidate; +end; + +constructor TOvcCustomCalendar.Create(AOwner : TComponent); +begin + inherited Create(AOwner); + + ControlStyle := ControlStyle + [csClickEvents, csFramed] - [csCaptureMouse]; + + Height := 140; + TabStop := True; + Width := 200; + Font.Name := 'MS Sans Serif'; + Font.Size := 8; + + FBorderStyle := bsNone; + FDayNameWidth := 3; + FDateFormat := dfLong; + FOptions := [cdoShortNames, cdoShowYear, cdoShowInactive, + cdoShowRevert, cdoShowToday, cdoShowNavBtns]; + FWantDblClicks := True; + FWeekStarts := dtSunday; + + {create navigation buttons} + clBtnLeft := TSpeedButton.Create(Self); + clBtnLeft.Parent := Self; +{$IFNDEF LCL} + clBtnLeft.Glyph.Handle := LoadBaseBitmap('ORLEFTARROW'); +{$ELSE} + clBtnLeft.Glyph.LoadFromLazarusResource('ORLEFTARROW'); +{$ENDIF} + clBtnLeft.OnClick := calBtnClick; + + clBtnRight := TSpeedButton.Create(Self); + clBtnRight.Parent := Self; +{$IFNDEF LCL} + clBtnRight.Glyph.Handle := LoadBaseBitmap('ORRIGHTARROW'); +{$ELSE} + clBtnRight.Glyph.LoadFromLazarusResource('ORRIGHTARROW'); +{$ENDIF} + clBtnRight.OnClick := calBtnClick; + + clBtnNextYear := TSpeedButton.Create(Self); + clBtnNextYear.Parent := Self; +{$IFNDEF LCL} + clBtnNextYear.Glyph.Handle := LoadBaseBitmap('ORRIGHTARROWS'); +{$ELSE} + clBtnNextYear.Glyph.LoadFromLazarusResource('ORRIGHTARROWS'); +{$ENDIF} + clBtnNextYear.OnClick := calBtnClick; + + clBtnPrevYear := TSpeedButton.Create(Self); + clBtnPrevYear.Parent := Self; +{$IFNDEF LCL} + clBtnPrevYear.Glyph.Handle := LoadBaseBitmap('ORLEFTARROWS'); +{$ELSE} + clBtnPrevYear.Glyph.LoadFromLazarusResource('ORLEFTARROWS'); +{$ENDIF} + clBtnPrevYear.OnClick := calBtnClick; + + {create "revert" button} + clBtnRevert := TSpeedButton.Create(Self); + clBtnRevert.Parent := Self; +{$IFNDEF LCL} + clBtnRevert.Glyph.Handle := LoadBaseBitmap('ORREVERT'); +{$ELSE} + clBtnRevert.Glyph.LoadFromLazarusResource('ORREVERT'); +{$ENDIF} + clBtnRevert.OnClick := calBtnClick; + + {create "today" button} + clBtnToday := TSpeedButton.Create(Self); + clBtnToday.Parent := Self; +{$IFNDEF LCL} + clBtnToday.Glyph.Handle := LoadBaseBitmap('ORTODAY'); +{$ELSE} + clBtnToday.Glyph.LoadFromLazarusResource('ORTODAY'); +{$ENDIF} + clBtnToday.OnClick := calBtnClick; + + {assign default color scheme} + FColors := TOvcCalColors.Create; + FColors.OnChange := calColorChange; + FColors.FCalColors := CalScheme[cscalWindows]; + + {assign default international support object} + FIntlSup := OvcIntlSup; + + FDrawHeader:= True; + clRowCount := 8; + clStartRow := 0; +end; + +constructor TOvcCustomCalendar.CreateEx(AOwner : TComponent; AsPopup : Boolean); +begin + clPopup := AsPopup; + Create(AOwner); +end; + +procedure TOvcCustomCalendar.CreateParams(var Params : TCreateParams); +const + BorderStyles : array[TBorderStyle] of LongInt = (0, WS_BORDER); +begin + inherited CreateParams(Params); + + with Params do begin + Style := LongInt(Style) or BorderStyles[FBorderStyle]; + if clPopup then begin + Style := WS_POPUP or WS_BORDER; + WindowClass.Style := WindowClass.Style or CS_SAVEBITS; + end; + end; + + if NewStyleControls and (Ctl3D or clPopup) and (FBorderStyle = bsSingle) then begin + if not clPopup then + Params.Style := Params.Style and not WS_BORDER; + Params.ExStyle := Params.ExStyle or WS_EX_CLIENTEDGE; + end; + + {set style to reflect desire for double clicks} + if FWantDblClicks then + ControlStyle := ControlStyle + [csDoubleClicks] + else + ControlStyle := ControlStyle - [csDoubleClicks]; + + {get windows date mask} + FIntlSup.InternationalLongDatePChar(clMask, cdoShortNames in FOptions, False); +end; + +procedure TOvcCustomCalendar.CreateWnd; +begin + inherited CreateWnd; + + calRecalcSize; + + {if not set, get current date} + if FDate = 0 then + SetDate(calGetValidDate(SysUtils.Date-1, +1)); +end; + +destructor TOvcCustomCalendar.Destroy; +begin + FColors.Free; + FColors := nil; + + inherited Destroy; +end; + +function TOvcCustomCalendar.DateString(const Mask : string): string; +var + M : string; +begin + M := Mask; + if Length(M) = 0 then + M := StrPas(clMask); + + {convert calendar month and year to a string} + Result := FIntlSup.DateToDateString(M, DateTimeToStDate(FDate), True); +end; + +function TOvcCustomCalendar.DayString: string; +begin + Result := IntlSupport.DayOfWeekToString(DayOfWeek(DateTimeToStDate(FDate))); +end; + +procedure TOvcCustomCalendar.DoOnChange(Value : TDateTime); +begin + if Assigned(FOnChange) then + FOnChange(Self, Value); +end; + + +function TOvcCustomCalendar.DoOnGetDateEnabled(ADate : TDateTime) : Boolean; +begin + Result := True; + if Assigned(FOnGetDateEnabled) then + FOnGetDateEnabled(Self, ADate, Result); +end; + +procedure TOvcCustomCalendar.DoOnMouseWheel(Shift : TShiftState; Delta, XPos, YPos : SmallInt); +var + Key : Word; +begin + inherited DoOnMouseWheel(Shift, Delta, XPos, YPos); + + if Abs(Delta) = WHEEL_DELTA then begin + {inc/dec month} + if Delta < 0 then + Key := VK_NEXT + else + Key := VK_PRIOR; + KeyDown(Key, []); + end else if Abs(Delta) > WHEEL_DELTA then begin + {inc/dec year} + if Delta < 0 then + Key := VK_NEXT + else + Key := VK_PRIOR; + KeyDown(Key, [ssCtrl]); + end else if Abs(Delta) < WHEEL_DELTA then begin + {inc/dec Week} + if Delta < 0 then + Key := VK_DOWN + else + Key := VK_UP; + KeyDown(Key, []); + end; +end; + +function TOvcCustomCalendar.GetAsDateTime : TDateTime; +begin + Result := FDate; +end; + +function TOvcCustomCalendar.GetAsStDate : TStDate; +begin + Result := DateTimeToStDate(FDate) +end; + +function TOvcCustomCalendar.IsReadOnly : Boolean; +begin + Result := ReadOnly; +end; + + {revised} +procedure TOvcCustomCalendar.KeyDown(var Key : Word; Shift : TShiftState); +var + Y : Word; + M : Word; + D : Word; + HD : TDateTime; + +begin + inherited KeyDown(Key, Shift); + + if IsReadOnly then + Exit; + + HD := FDate; + case Key of + VK_LEFT : if Shift = [] then + SetDate(calGetValidDate(FDate, -1)); + VK_RIGHT : if Shift = [] then + SetDate(calGetValidDate(FDate, +1)); + VK_UP : if Shift = [] then + SetDate(calGetValidDate(FDate, -7)); + VK_DOWN : if Shift = [] then + SetDate(calGetValidDate(FDate, +7)); + VK_HOME : + begin + if ssCtrl in Shift then begin + DecodeDate(FDate, Y, M, D); + SetDate(calGetValidDate(EncodeDate(Y, 1, 1)-1, +1)); + end else if Shift = [] then begin + DecodeDate(FDate, Y, M, D); + SetDate(calGetValidDate(EncodeDate(Y, M, 1)-1, +1)); + end; + end; + VK_END : + begin + if ssCtrl in Shift then begin + DecodeDate(FDate, Y, M, D); + SetDate(calGetValidDate(EncodeDate(Y, 12, DaysInMonth(12, Y, 0))+1, -1)); + end else if Shift = [] then begin + DecodeDate(FDate, Y, M, D); + SetDate(calGetValidDate(EncodeDate(Y, M, DaysInMonth(M, Y, 0))+1, -1)); + end; + end; + VK_PRIOR : + begin + if ssCtrl in Shift then begin + IncYear(-1); + end else if Shift = [] then begin + IncMonth(-1); + end; + end; + VK_NEXT : + begin + if ssCtrl in Shift then begin + IncYear(1); + end else if Shift = [] then begin + IncMonth(1); + end; + end; + VK_BACK : + begin + if ssAlt in Shift then + SetDate(calGetValidDate(SysUtils.Date-1, +1)); + end; + VK_ESCAPE: + begin + if Shift = [] then + SetDate(calGetValidDate(clRevertDate-1, +1)); + end; + end; + + if HD <> FDate then begin + FBrowsing := True; + try + DoOnChange(FDate); + finally + FBrowsing := False; + end; + end; +end; + +procedure TOvcCustomCalendar.KeyPress(var Key : Char); +begin + inherited KeyPress(Key); + + if IsReadOnly then + Exit; + + case Key of + '+' : SetDate(calGetValidDate(FDate, +1)); + '-' : SetDate(calGetValidDate(FDate, -1)); + #13 : DoOnChange(FDate); {date selected} + #32 : DoOnChange(FDate); {date selected} + ^Z : SetDate(calGetValidDate(SysUtils.Date-1, +1)); + end; +end; + +procedure TOvcCustomCalendar.MouseDown(Button : TMouseButton; Shift : TShiftState; X, Y : Integer); +var + Yr : Word; + M : Word; + D : Word; + Yr2 : Word; + M2 : Word; + D2 : Word; + R, C : Integer; + OldIdx : Integer; + NewIdx : Integer; + Re : TRect; + Ignore : Boolean; +begin + {exit if this click happens when the popup menu is active} + if clInPopup then + Exit; + + SetFocus; + + inherited MouseDown(Button, Shift, X, Y); + + if IsReadOnly then + Exit; + + {if we have the mouse captured, see if a button was clicked} + if GetCapture = Handle then begin + if (cdoShowNavBtns in Options) then begin + Re := clBtnLeft.ClientRect; + Re.TopLeft := ScreenToClient(clBtnLeft.ClientToScreen(Re.TopLeft)); + Re.BottomRight := ScreenToClient(clBtnLeft.ClientToScreen(Re.BottomRight)); + if PtInRect(Re, Point(X, Y)) then begin + clBtnLeft.Click; + Exit; + end; + + + Re := clBtnRight.ClientRect; + Re.TopLeft := ScreenToClient(clBtnRight.ClientToScreen(Re.TopLeft)); + Re.BottomRight := ScreenToClient(clBtnRight.ClientToScreen(Re.BottomRight)); + if PtInRect(Re, Point(X, Y)) then begin + clBtnRight.Click; + Exit; + end; + + Re := clBtnNextYear.ClientRect; + Re.TopLeft := ScreenToClient(clBtnNextYear.ClientToScreen(Re.TopLeft)); + Re.BottomRight := ScreenToClient(clBtnNextYear.ClientToScreen(Re.BottomRight)); + if PtInRect(Re, Point(X, Y)) then begin + clBtnNextYear.Click; + Exit; + end; + + Re := clBtnPrevYear.ClientRect; + Re.TopLeft := ScreenToClient(clBtnPrevYear.ClientToScreen(Re.TopLeft)); + Re.BottomRight := ScreenToClient(clBtnPrevYear.ClientToScreen(Re.BottomRight)); + if PtInRect(Re, Point(X, Y)) then begin + clBtnPrevYear.Click; + Exit; + end; + end; + + if (cdoShowRevert in Options) then begin + Re := clBtnRevert.ClientRect; + Re.TopLeft := ScreenToClient(clBtnRevert.ClientToScreen(Re.TopLeft)); + Re.BottomRight := ScreenToClient(clBtnRevert.ClientToScreen(Re.BottomRight)); + if PtInRect(Re, Point(X, Y)) then begin + clBtnRevert.Click; + Exit; + end; + end; + + if (cdoShowToday in Options) then begin + Re := clBtnToday.ClientRect; + Re.TopLeft := ScreenToClient(clBtnToday.ClientToScreen(Re.TopLeft)); + Re.BottomRight := ScreenToClient(clBtnToday.ClientToScreen(Re.BottomRight)); + if PtInRect(Re, Point(X, Y)) then begin + clBtnToday.Click; + Exit; + end; + end; + end; + + {save current date} + DecodeDate(FDate, Yr, M, D); + M2 := M; + + {calculate the row and column clicked on} + for R := 2 to 8 do begin + for C := 0 to 6 do begin + if PtInRect(clRowCol[R,C], Point(X, Y)) then begin + {convert to an index} + NewIdx := ((R-2) * 7) + Succ(C); + OldIdx := clFirst + Pred(clDay); + Ignore := False; + if NewIdx <> OldIdx then begin + + {see if this date is disabled - selection not allowed} + if not DoOnGetDateEnabled(FDate+(NewIdx-OldIdx)) then + Break; + + DecodeDate(FDate+(NewIdx-OldIdx), Yr2, M2, D2); + if not (cdoShowInactive in FOptions) then begin + {will this change the month?} + if M2 <> M then + Ignore := True; + end; + {convert to a date and redraw} + if not Ignore then + SetDate(FDate+(NewIdx-OldIdx)); + end; + + if (not Ignore) and (Button = mbLeft) then begin + if M2 <> M then begin + FBrowsing := True; + try + DoOnChange(FDate); + finally + FBrowsing := False; + end; + end else + DoOnChange(FDate); + end; + + Break; + end; + end; + end; +end; + +procedure TOvcCustomCalendar.MouseUp(Button : TMouseButton; Shift : TShiftState; X, Y : Integer); +var + P : TPoint; + M : TPopUpMenu; + MI : TMenuItem; + I : Integer; + J : Integer; + K : Integer; + MO : Integer; + YR : Word; + MM : Word; + DA : Word; + HC : Boolean; +begin + inherited MouseUp(Button, Shift, X, Y); + + if (PopUpMenu = nil) and (Button = mbRight) and + (Y < clRowCol[1,0].Top) {above day names} and + (X > clBtnPrevYear.Left + clBtnNextYear.Width) and + (X < clBtnNextYear.Left) then begin + + if not Focused and CanFocus then + SetFocus; + + M := TPopupMenu.Create(Self); + try + DecodeDate(FDate, YR, MM, DA); + MO := MM; {convert to integer to avoid wrap-around errors with words} + + {determine the starting month} + I := MO - 3; + if I < 1 then + I := MO - 3 + 12; + + {determine the ending month + 1} + J := MO + 4; + if J > 12 then + J := MO + 4 - 12; + + K := 0; + {create the menu items} + repeat + MI := TMenuItem.Create(M); + MI.Caption := LongMonthNames[I]; + MI.Enabled := Enabled; + MI.OnClick := calChangeMonth; + MI.Tag := I; + MI.HelpContext := K; + M.Items.Add(MI); + Inc(I); + Inc(K); + if I > 12 then + I := 1; + until I = J; + + HC := GetCapture = Handle; + + P.X := X-20; + P.Y := Y - ((GetSystemMetrics(SM_CYMENU)*7) div 2); + P := ClientToScreen(P); + {move the mouse to cause the menu item to highlight} + PostMessage(Handle, WM_MOUSEMOVE, 0, MAKELONG(P.X,P.Y+1)); + + clInPopup := True; + try + M.PopUp(P.X, P.Y); + + Application.ProcessMessages; + + {capture the mouse again} + if clPopup and HC then + SetCapture(Handle); + finally + clInPopup := false; + end; + finally + M.Free; + end; + end; +end; + +procedure TOvcCustomCalendar.IncDay(Delta : Integer); + {-change the day by Delta (signed) days} +begin + if Delta > 0 then + SetDate(calGetValidDate(FDate+Delta-1, +1)) + else + SetDate(calGetValidDate(FDate+Delta+1, -1)) +end; + + +procedure TOvcCustomCalendar.IncMonth(Delta : Integer); + {-change the month by Delta (signed) months} +var + Y, M, D : Word; + iY, iM, iD : Integer; +begin + DecodeDate(FDate, Y, M, D); + iY := Y; iM := M; iD := D; + Inc(iM, Delta); + if iM > 12 then begin + iM := iM - 12; + Inc(iY); + end else if iM < 1 then begin + iM := iM + 12; + Dec(iY); + end; + if iD > DaysInMonth(iM, iY, 0) then + iD := DaysInMonth(iM, iY, 0); + + SetDate(calGetValidDate(EncodeDate(iY, iM, iD)-1, +1)); +end; + + +procedure TOvcCustomCalendar.IncYear(Delta : Integer); +var + Y, M, D : Word; + iY, iM, iD : Integer; +begin + DecodeDate(FDate, Y, M, D); + iY := Y; iM := M; iD := D; + Inc(iY, Delta); + if iD > DaysInMonth(iM, iY, 0) then + iD := DaysInMonth(iM, iY, 0); + SetDate(calGetValidDate(EncodeDate(iY, iM, iD)-1, +1)); +end; + +function TOvcCustomCalendar.MonthString: string; +var + M, D, Y : Word; +begin + DecodeDate(FDate, Y, M, D); + Result := IntlSupport.MonthToString(M); +end; + +procedure TOvcCustomCalendar.Paint; +var + R, C : Integer; + I : Integer; + {CurIndex : Integer;} + SatCol : Integer; + SunCol : Integer; + DOW : TOvcDayType; + + procedure DrawDate; + var + R : TRect; + S : string; + begin + if FDateFormat = dfLong then + if cdoShowYear in FOptions then + S := FormatDateTime('mmmm yyyy', FDate) + else + S := FormatDateTime('mmmm', FDate) + else + if cdoShowYear in FOptions then + S := FormatDateTime('mmm yyyy', FDate) + else + S := FormatDateTime('mmm', FDate); + + R := clRowCol[0,1]; + R.Right := clRowCol[0,6].Left; + + {switch to short date format if string won't fit} + if FDateFormat = dfLong then + if Canvas.TextWidth(S) > R.Right-R.Left then + S := FormatDateTime('mmm yyyy', FDate); + + Canvas.Font.Color := FColors.MonthAndYear; + if Assigned(FOnDrawDate) then + FOnDrawDate(Self, FDate, R) + else + DrawText(Canvas.Handle, @S[1], Length(S), R, DT_SINGLELINE or DT_CENTER or DT_VCENTER); + end; + + procedure DrawDayNames; + var + I : Integer; + S : string[3]; + begin + {draw the day name column labels} + Canvas.Font.Color := FColors.DayNames; + I := 0; + DOW := FWeekStarts; + repeat + {record columns for weekends} + if DOW = dtSaturday then + SatCol := I; + if DOW = dtSunday then + SunCol := I; + + {get the day name} + S := Copy(ShortDayNames[Ord(DOW)+1], 1, FDayNameWidth); + + {draw the day name above each column} + DrawText(Canvas.Handle, @S[1], Length(S), clRowCol[1,I], + DT_SINGLELINE or DT_CENTER or DT_VCENTER); + + Inc(I); + if DOW < High(DOW) then + Inc(DOW) + else + DOW := Low(DOW); + until DOW = WeekStarts; + end; + + procedure DrawLine; + begin + if Ctl3D then begin + Canvas.Pen.Color := clBtnHighlight; + Canvas.MoveTo(0, clRowCol[1,0].Bottom-3); + Canvas.LineTo(ClientWidth, clRowCol[1,0].Bottom-3); + Canvas.Pen.Color := clBtnShadow; + Canvas.MoveTo(0, clRowCol[1,0].Bottom-2); + Canvas.LineTo(ClientWidth, clRowCol[1,0].Bottom-2); + end else if BorderStyle = bsSingle then begin + Canvas.Pen.Color := Font.Color; + Canvas.MoveTo(0, clRowCol[1,0].Bottom-3); + Canvas.LineTo(ClientWidth, clRowCol[1,0].Bottom-3); + end; + end; + + procedure DrawDay(R, C, I : Integer; Grayed{, Current} : Boolean); + var + Cl : TColor; + OldIdx : Integer; + NewIdx : Integer; + S : string[10]; + begin + + {avoid painting day number under buttons} + if cdoShowRevert in FOptions then + if (R = 8) {bottom} and (C >= 3) then + Exit; + if cdoShowToday in FOptions then + if (R = 8) {bottom} and (C >= 5) then + Exit; + + {convert to a string and draw it centered in its rectangle} + S := IntToStr(clCalendar[I]); + + if Grayed then + Canvas.Font.Color := FColors.InactiveDays; + + if not Grayed or (cdoShowInactive in FOptions) then begin + NewIdx := ((R-2) * 7) + Succ(C); + OldIdx := clFirst + Pred(clDay); + if Assigned(FOnGetHighlight) then begin + Cl := Canvas.Font.Color; + FOnGetHighlight(Self, FDate+(NewIdx-OldIdx), Cl); + Canvas.Font.Color := Cl; + end; + if Assigned(FOnDrawItem) then + FOnDrawItem(Self, FDate+(NewIdx-OldIdx), clRowCol[R,C]) + else + DrawText(Canvas.Handle, @S[1], Length(S), clRowCol[R,C], DT_SINGLELINE or DT_CENTER or DT_VCENTER); + end; + end; + + procedure DrawFocusBox; + var + R : TRect; + S : string[10]; + BS : TButtonStyle; + begin + S := IntToStr(clDay); + if Ctl3D then + BS := bsNew + else + BS := bsWin31; + if Focused then + R := DrawButtonFace(Canvas, calGetCurrentRectangle, 1, BS, True, True, False) + else + R := DrawButtonFace(Canvas, calGetCurrentRectangle, 1, BS, True, False, False); + DrawText(Canvas.Handle, @S[1], Length(S), R, DT_CENTER or DT_VCENTER or DT_SINGLELINE); + end; + +begin + Canvas.Font := Font; + Canvas.Brush.Color := Color;{clBtnFace;} + Canvas.FillRect(ClientRect); + + {draw the month and year at the top of the calendar} + DrawDate; + + {draw the days of the week} + DrawDayNames; + + {draw line under day names} + DrawLine; + + {draw each day} + {CurIndex := clFirst + Pred(clDay);} + I := 1; + for R := 2 to 8 do + for C := 0 to 6 do begin + if (C = SatCol) or (C = SunCol) then + Canvas.Font.Color := FColors.WeekEnd + else + Canvas.Font.Color := FColors.Days; + DrawDay(R, C, I, (I < clFirst) or (I > clLast){, I = CurIndex}); + Inc(I); + end; + + Canvas.Font.Color := FColors.ActiveDay; + if not Assigned(FOnDrawItem) then + if not (cdoHideActive in FOptions) then + DrawFocusBox; +end; + +function TOvcCustomCalendar.GetCalendarDate : TDateTime; +begin + Result := FDate; +end; + +function TOvcCustomCalendar.GetDay : Integer; +begin + Result := clDay; +end; + +function TOvcCustomCalendar.GetMonth : Integer; +begin + Result := clMonth; +end; + +function TOvcCustomCalendar.GetYear : Integer; +begin + Result := clYear; +end; + +procedure TOvcCustomCalendar.SetAsDateTime(Value : TDateTime); +begin + SetDate(calGetValidDate(Value-1, +1)); +end; + +procedure TOvcCustomCalendar.SetAsStDate(Value : TStDate); +begin + SetDate(calGetValidDate(StDateToDateTime(Value)-1, +1)); +end; + +procedure TOvcCustomCalendar.SetBorderStyle(Value : TBorderStyle); +begin + if Value <> FBorderStyle then begin + FBorderStyle := Value; +{$IFNDEF LCL} + RecreateWnd; +{$ELSE} + MyMisc.RecreateWnd(Self); +{$ENDIF} + end; +end; + +procedure TOvcCustomCalendar.SetBounds(ALeft, ATop, AWidth, AHeight : Integer); +begin + inherited Setbounds(ALeft, ATop, AWidth, AHeight); + + if csLoading in ComponentState then + Exit; + + calRecalcSize; +end; + +procedure TOvcCustomCalendar.SetCalendarDate(Value : TDateTime); +var + NewDate : TStDate; +begin + NewDate := DateTimeToStDate(Value); + if (NewDate = BadDate) or (NewDate = CalendarDate) or + (IncDateTrunc(NewDate, 1, 0) = BadDate) or + (IncDateTrunc(NewDate, -1, 0) = BadDate) then begin + Exit; + end; + SetDate(calGetValidDate(Value-1, +1)); +end; + +procedure TOvcCustomCalendar.SetDate(Value : TDateTime); +var + R : TRect; + Y : Word; + M : Word; + D : Word; +begin + if Value <> FDate then begin + {determine if the new date is in the same month} + DecodeDate(Value, Y, M, D); + if (clYear = Y) and (clMonth = M) then begin + {invalidate the old date} + R := calGetCurrentRectangle; + InvalidateRect(Handle, @R, False); + end else + Invalidate; + + DecodeDate(Value, clYear, clMonth, clDay); + FDate := Value; + calRebuildCalArray; + + {invalidate the new date} + R := calGetCurrentRectangle; + InvalidateRect(Handle, @R, False); + end; +end; + +procedure TOvcCustomCalendar.SetDateFormat(Value : TOvcDateFormat); +begin + if Value <> FDateFormat then begin + FDateFormat := Value; + Invalidate; + end; +end; + +procedure TOvcCustomCalendar.SetDayNameWidth(Value : TOvcDayNameWidth); +begin + if Value <> FDayNameWidth then begin + FDayNameWidth := Value; + Invalidate; + end; +end; + +procedure TOvcCustomCalendar.SetDisplayOptions(Value : TOvcCalDisplayOptions); +begin + if Value <> FOptions then begin + FOptions := Value; + calRecalcSize; + Invalidate; + end; +end; + +procedure TOvcCustomCalendar.SetDrawHeader(Value : Boolean); + {-set the DrawHeader property value} +begin + if Value <> FDrawHeader then begin + FDrawHeader := Value; + if FDrawHeader then begin + clStartRow := 0; + clRowCount := 8; + end else begin + clStartRow := 2; + clRowCount := 7; + end; + calRecalcSize; + Refresh; + end; +end; + +procedure TOvcCustomCalendar.SetIntlSupport(Value : TOvcIntlSup); + {-set the international support object this field will use} +begin + if Assigned(Value) then + FIntlSup := Value + else + FIntlSup := OvcIntlSup; +end; + +procedure TOvcCustomCalendar.SetToday; + {-set the calendar to todays date} +begin + SetDate(calGetValidDate(SysUtils.Date-1, +1)); +end; + +procedure TOvcCustomCalendar.SetWantDblClicks(Value : Boolean); +begin + if Value <> FWantDblClicks then begin + FWantDblClicks := Value; +{$IFNDEF LCL} + RecreateWnd; +{$ELSE} + MyMisc.RecreateWnd(Self); +{$ENDIF} + end; +end; + +procedure TOvcCustomCalendar.SetWeekStarts(Value : TOvcDayType); +begin + if Value <> FWeekStarts then begin + FWeekStarts := Value; + if csLoading in ComponentState then + Exit; + calRebuildCalArray; + Invalidate; + end; +end; + +procedure TOvcCustomCalendar.WMEraseBkgnd(var Msg : TWMEraseBkgnd); +begin + Msg.Result := 1; {don't erase background, just say we did} +end; + +procedure TOvcCustomCalendar.WMGetDlgCode(var Msg : TWMGetDlgCode); +begin + Msg.Result := DLGC_WANTARROWS; +end; + +procedure TOvcCustomCalendar.WMKillFocus(var Msg : TWMKillFocus); +begin + inherited; + + Invalidate; +end; + + +end. diff --git a/components/orpheus/ovccalc.pas b/components/orpheus/ovccalc.pas new file mode 100644 index 000000000..1d0ceafac --- /dev/null +++ b/components/orpheus/ovccalc.pas @@ -0,0 +1,2685 @@ +{*********************************************************} +{* OVCCALC.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovccalc; + {-calculator component} + +interface + +uses + {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, Types, LclType, GraphType, MyMisc, {$ENDIF} + Buttons, Classes, ClipBrd, Controls, ExtCtrls, Forms, Graphics, + Menus, StdCtrls, SysUtils, + OvcData, OvcConst, OvcBase, OvcMisc; + +type + TOvcCalculatorButton = ( + cbNone, cbTape, cbBack, cbClearEntry, cbClear, cbAdd, cbSub, cbMul, cbDiv, + cb0, cb1, cb2, cb3, cb4, cb5, cb6, cb7, cb8, cb9, + cbDecimal, cbEqual, cbInvert, cbChangeSign, cbPercent, cbSqrt, + cbMemClear, cbMemRecall, cbMemStore, cbMemAdd, cbMemSub, cbSubTotal); + + TOvcButtonInfo = packed record + Position : TRect; {position and size} + Caption : string[10]; {button text} + Visible : Boolean; {true to display button} + end; + + TOvcButtonArray = array[cbTape..cbMemSub] of TOvcButtonInfo; + +type + TOvcCalculatorOperation = ( + coNone, coAdd, coSub, coMul, coDiv, + coEqual, coInvert, coPercent, coSqrt, + coMemClear, coMemRecall, coMemStore, coMemAdd, coMemSub, coSubTotal); + + TOvcCalcState = (csValid, csLocked, csClear); + TOvcCalcStates = set of TOvcCalcState; + +type + TOvcCalcColorArray = array[0..7] of TColor; + TOvcCalcColorScheme = (cscalcCustom, cscalcWindows, cscalcDark, + cscalcOcean, cscalcPlain); + TOvcCalcSchemeArray = array[TOvcCalcColorScheme] of TOvcCalcColorArray; + TOvcCalcDisplayString = array[TOvcCalculatorButton] of string; + TOvcCalcButtonToOperation = array[cbNone..cbSubTotal] of TOvcCalculatorOperation; + + +const + {DisabledMemoryButtons, Display, DisplayTextColor, EditButtons, + FunctionButtons, MemoryButtons, NumberButtons, OperatorButtons} + CalcScheme : TOvcCalcSchemeArray = + ((0, 0, 0, 0, 0, 0, 0, 0), + (clGray, clWindow, clWindowText, clMaroon, clNavy, clRed, clBlue, clRed), + (clGray, clBlack, clAqua, clBlack, clTeal, clNavy, clMaroon, clBlue), + (clGray, clAqua, clBlack, clPurple, clNavy, clNavy, clAqua, clBlue), + (clGray, clWhite, clNavy, clBlack, clNavy, clNavy, clBlue, clBlue) + ); +{ You must set the Length of the first entry (cbNone) to the Length of the largest entry} + CalcDisplayString : TOvcCalcDisplayString = + (' ',' ',' ','CE','C' ,'+' ,'-' ,'*' ,'/', + ' ',' ',' ',' ',' ',' ',' ',' ',' ',' ', + ' ','=' ,'1/','-+','%' ,'SQ', + 'MC','MR','MS','M+','M-','*' ); + + CalcButtontoOperation : TOvcCalcButtonToOperation = + (coNone, coNone, coNone, coNone, coNone, coAdd, coSub, coMul, coDiv, + coNone, coNone, coNone, coNone, coNone, coNone, coNone, coNone, coNone, coNone, + coNone, coEqual, coInvert, coNone, coPercent, coSqrt, + coMemClear, coMemRecall, coMemStore, coMemAdd, coMemSub, coSubTotal); + +type + TOvcCalcColors = class(TPersistent) + {.Z+} + private + {property variables} + FUpdating : Boolean; + FOnChange : TNotifyEvent; + + {internal variables} + SettingScheme : Boolean; + + {internal methods} + procedure DoOnChange; + + {property methods} + function GetColor(const Index : Integer) : TColor; + procedure SetColor(const Index : Integer; const Value : TColor); + procedure SetColorScheme(const Value : TOvcCalcColorScheme); + procedure SetDisplayTextColor(const Value : TColor); + + public + {property variables} + FCalcColors : TOvcCalcColorArray; + FColorScheme : TOvcCalcColorScheme; + + procedure Assign(Source : TPersistent); + override; + procedure BeginUpdate; + procedure EndUpdate; + + property OnChange : TNotifyEvent + read FOnChange write FOnChange; + {.Z-} + + published + property ColorScheme : TOvcCalcColorScheme + read FColorScheme write SetColorScheme; + property DisabledMemoryButtons : TColor index 0 + read GetColor write SetColor; + property Display : TColor index 1 + read GetColor write SetColor; + property DisplayTextColor : TColor + read FCalcColors[2] write SetDisplayTextColor nodefault; + property EditButtons : TColor index 3 + read GetColor write SetColor; + property FunctionButtons : TColor index 4 + read GetColor write SetColor; + property MemoryButtons : TColor index 5 + read GetColor write SetColor; + property NumberButtons : TColor index 6 + read GetColor write SetColor; + property OperatorButtons : TColor index 7 + read GetColor write SetColor; + end; + +type + {.Z+} + TOvcCalcPanel = class(TPanel) + protected + procedure Click; + override; + public + end; + {.Z-} + +type + {.Z+} + TOvcCustomCalculatorEngine = class + protected {private} + {property variables} + FDecimals : Integer; + FShowSeparatePercent : Boolean; + + {internal variables} + cCalculated : Extended; + cLastOperation : TOvcCalculatorOperation; + cOperationCount : Integer; + cMemory : Extended; {value stored in memory register} + cOperands : array [0..3] of Extended; {the operand stack} + cState : TOvcCalcStates; + + public + function AddOperand(const Value : Extended; const Button : TOvcCalculatorOperation) : Boolean; + virtual; abstract; + function AddOperation(const Button : TOvcCalculatorOperation) : Boolean; + virtual; abstract; + procedure ClearAll; + procedure PushOperand(const Value : Extended); + function PopOperand : Extended; + function TopOperand : Extended; + + {public properties} + property Decimals : Integer + read FDecimals write FDecimals; + property LastOperation : TOvcCalculatorOperation + read cLastOperation write cLastOperation; + property Memory : Extended + read cMemory write cMemory; + property OperationCount : Integer + read cOperationCount write cOperationCount; + property ShowSeparatePercent : Boolean + read FShowSeparatePercent write FShowSeparatePercent; + property State : TOvcCalcStates + read cState write cState; + end; + {.Z-} + +type + {.Z+} + TOvcCalcTape = class(TObject) + protected {private} + {property variables} + FMaxPaperCount : Integer; + FShowTape : Boolean; + FTapeDisplaySpace : Integer; + FVisible : Boolean; + + {internal variables} + taListBox : TListBox; + taTapeColor : TColor; + taHeight : Integer; + taOwner : TComponent; + taOperandSize : Integer; + taFont : TFont; + taMaxTapeCount : Integer; + taTapeInitialized : Boolean; + taWidth : Integer; + + procedure ValidateListBox; + function GetFont : TFont; + procedure SetFont(const Value : TFont); + function GetHeight : Integer; + procedure SetHeight(const Value : Integer); + function GetTape : TStrings; + procedure SetTape(const Value : TStrings); + function GetTapeColor : TColor; + procedure SetTapeColor(const Value : TColor); + function GetTop : Integer; + procedure SetTop(const Value : Integer); + function GetTopIndex : Integer; + procedure SetTopIndex(const Value : Integer); + function GetVisible : Boolean; + procedure SetVisible(const Value : Boolean); + function GetWidth : Integer; + procedure SetWidth(const Value : Integer); + + protected + procedure Add(const Value : string); + procedure DeleteFirst; + procedure taOnClick(Sender : TObject); + procedure taOnDblClick(Sender : TObject); + procedure taOnDrawItem(Control: TWinControl; Index: Integer; + Rect:TRect;State: TOwnerDrawState); + procedure taTapeFontChange(Sender : TObject); + + public + constructor Create(const AOwner : TComponent; const AOperandSize : Integer); + destructor Destroy; + override; + + procedure InitializeTape; + procedure SetBounds(const ALeft, ATop, AWidth, AHeight : Integer); + function GetDisplayedItemCount : Integer; + procedure AddToTape(const Value : string; + const OpString : string); + procedure AddToTapeLeft(const Value : string); + procedure ClearTape; + procedure RefreshDisplays; + procedure SpaceTape(const Value : char); + + property Font : TFont + read GetFont write SetFont; + property Height : Integer + read GetHeight write SetHeight; + property MaxPaperCount : Integer + read FMaxPaperCount write FMaxPaperCount; + property ShowTape : Boolean + read FShowTape write FShowTape; + property Tape : TStrings + read GetTape write SetTape; + property TapeColor : TColor + read GetTapeColor write SetTapeColor; + property TapeDisplaySpace : Integer + read FTapeDisplaySpace write FTapeDisplaySpace; + property Top : Integer + read GetTop write SetTop; + property TopIndex : Integer + read GetTopIndex write SetTopIndex; + property Visible : Boolean + read GetVisible write SetVisible; + property Width : Integer + read GetWidth write SetWidth; + end; + {.Z-} + +type + TOvcCalcButtonPressedEvent = + procedure(Sender : TObject; Button : TOvcCalculatorButton) + of object; + + TOvcCalculatorOption = (coShowItemCount, coShowMemoryButtons, + coShowClearTapeButton, coShowTape, coShowSeparatePercent); + TOvcCalculatorOptions = set of TOvcCalculatorOption; + + TOvcCustomCalculator = class(TOvcCustomControl) + {.Z+} + protected {private} + {property variables} + FBorderStyle : TBorderStyle; + FColors : TOvcCalcColors; + FDisplay : Extended; {the calculated value} + FDisplayStr : string; {the string that is displayed} + FLastOperand : Extended; + FOptions : TOvcCalculatorOptions; + FTapeSeparatorChar : Char; + + {event variables} + FOnButtonPressed : TOvcCalcButtonPressedEvent; + + {internal variables} + cButtons : TOvcButtonArray; + cDecimalEntered : Boolean; + cDownButton : TOvcCalculatorButton; + cHitTest : TPoint; {location of mouse cursor} + cLastButton : TOvcCalculatorButton; + cMargin : Integer; + cMinus0 : Boolean; + cOverBar : Boolean; + cPanel : TOvcCalcPanel; + cPopup : Boolean; {true if being created as a popup} + cScrBarWidth : Integer; + cSizeOffset : Integer; { the offset of the sizing line } + cSizing : Boolean; { Are we showing the sizing cursor? } + cTabCursor : HCursor; {design-time tab slecting cursor handle} + cTape : TOvcCalcTape; + cEngine : TOvcCustomCalculatorEngine; + + {internal methods} + procedure cAdjustHeight; + procedure cCalculateLook; + procedure cClearAll; + procedure cColorChange(Sender : TObject); + procedure cDisplayError; + procedure cDrawCalcButton(const Button : TOvcButtonInfo; const Pressed : Boolean); + procedure cDrawFocusState; + procedure cDrawSizeLine; + procedure cEvaluate(const Button : TOvcCalculatorButton); + function cFormatString(const Value : Extended) : string; + function cGetFontWidth : Integer; + procedure cInvalidateIndicator; + procedure cRefreshDisplays; + procedure cSetDisplayString(const Value : string); + procedure cTapeFontChange(Sender : TObject); + + {property methods} + function GetDecimals : Integer; + function GetMaxPaperCount : Integer; + function GetMemory : Extended; + function GetOperand : Extended; + function GetTape : TStrings; + function GetTapeFont : TFont; + function GetTapeHeight : Integer; + function GetVisible : Boolean; + procedure SetBorderStyle(const Value : TBorderStyle); + procedure SetDecimals(const Value : Integer); + procedure SetDisplay(const Value : Extended); + procedure SetDisplayStr(const Value : string); + procedure SetMaxPaperCount(const Value : Integer); + procedure SetMemory(const Value : Extended); + procedure SetOperand(const Value : Extended); + procedure SetOptions(const Value : TOvcCalculatorOptions); + procedure SetTape(const Value : TStrings); + procedure SetTapeFont(const Value : TFont); + procedure SetTapeHeight(const Value : Integer); + procedure SetVisible(const Value : Boolean); + + {VCL control methods} + procedure CMCtl3DChanged(var Msg : TMessage); + message CM_CTL3DCHANGED; + procedure CMDesignHitTest(var Msg : TCMDesignHitTest); + message CM_DESIGNHITTEST; + procedure CMEnter(var Msg : TMessage); + message CM_ENTER; + procedure CMExit(var Msg : TMessage); + message CM_EXIT; + procedure CMFontChanged(var Msg : TMessage); + message CM_FONTCHANGED; + + {windows message handlers} + procedure WMCancelMode(var Msg : TMessage); + message WM_CANCELMODE; + procedure WMEraseBkgnd(var Msg : TWMEraseBkgnd); + message WM_ERASEBKGND; + procedure WMGetText(var Msg : TWMGetText); + message WM_GETTEXT; + procedure WMGetTextLength(var Msg : TWMGetTextLength); + message WM_GETTEXTLENGTH; + procedure WMKeyDown(var Msg : TWMKeyDown); + message WM_KEYDOWN; + procedure WMKillFocus(var Msg : TWMKillFocus); + message WM_KILLFOCUS; + procedure WMLButtonDown(var Msg : TWMMouse); + message WM_LBUTTONDOWN; + procedure WMLButtonUp(var Msg : TWMMouse); + message WM_LBUTTONUP; + procedure WMMouseMove(var Msg : TWMMouse); + message WM_MOUSEMOVE; + procedure WMNCHitTest(var Msg : TWMNCHitTest); + message WM_NCHITTEST; + procedure WMSetText(var Msg : TWMSetText); + message WM_SETTEXT; + procedure WMSetCursor(var Msg : TWMSetCursor); + message WM_SETCURSOR; + + protected + procedure CreateParams(var Params : TCreateParams); + override; + procedure CreateWnd; + override; + procedure KeyDown(var Key : Word; Shift : TShiftState); + override; + procedure MouseDown(Button : TMouseButton; Shift : TShiftState; X, Y : Integer); + override; + procedure MouseUp(Button : TMouseButton; Shift : TShiftState; X, Y : Integer); + override; + procedure Paint; + override; + {.Z-} + + {protected properties} + property BorderStyle : TBorderStyle + read FBorderStyle write SetBorderStyle; + property Colors : TOvcCalcColors + read FColors write FColors; + property Decimals : Integer + read GetDecimals write SetDecimals; + property MaxPaperCount : Integer + read GetMaxPaperCount write SetMaxPaperCount; + property Options : TOvcCalculatorOptions + read FOptions write SetOptions; + property TapeFont : TFont + read GetTapeFont write SetTapeFont; + property TapeHeight : Integer + read GetTapeHeight write SetTapeHeight; + property TapeSeparatorChar : Char + read FTapeSeparatorChar write FTapeSeparatorChar; + property Visible : Boolean + read GetVisible write SetVisible; + + {protected events} + property OnButtonPressed : TOvcCalcButtonPressedEvent + read FOnButtonPressed write FOnButtonPressed; + + public + {.Z+} + constructor Create(AOwner : TComponent); + override; + constructor CreateEx(AOwner : TComponent; AsPopup : Boolean); + virtual; + destructor Destroy; + override; + procedure KeyPress(var Key : Char); + override; + procedure PushOperand(const Value : Extended); + procedure SetBounds(ALeft, ATop, AWidth, AHeight : Integer); + override; + {.Z-} + + procedure CopyToClipboard; + procedure PasteFromClipboard; + procedure PressButton(Button : TOvcCalculatorButton); + + {public properties} + property LastOperand : Extended + read FLastOperand write FLastOperand; + property Memory : Extended + read GetMemory write SetMemory; + property Operand : Extended + read GetOperand write SetOperand; + property DisplayStr : string + read FDisplayStr write SetDisplayStr; + property DisplayValue : Extended + read FDisplay write SetDisplay; + property Tape : TStrings + read GetTape write SetTape; + end; + + TOvcCalculator = class(TOvcCustomCalculator) + published + {properties} + {$IFDEF VERSION4} + property Anchors; + property Constraints; + property DragKind; + {$ENDIF} + property About; + property Align; + property BorderStyle default bsNone; + property Ctl3D; + property Font; {must be prior to "Colors"} + property TapeFont; {must be prior to "Colors"} + property Colors; + property Cursor; + property Decimals; + property DragCursor; + property DragMode; + property Enabled; + property LabelInfo; + property MaxPaperCount default 9999; + property TapeHeight ; {Must be Prior to Options} + property Options default [coShowMemoryButtons, coShowItemCount]; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ShowHint; + property TabOrder; + property TabStop default True; + property TapeSeparatorChar default '_'; + property Visible default True; + + {events} + property OnButtonPressed; + property OnDragDrop; + property OnDragOver; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnMouseWheel; + property OnStartDrag; + end; + + +implementation + +const + calcDefMinSize = 30; + + +{*** TOvcCalcColors ***} + +procedure TOvcCalcColors.Assign(Source : TPersistent); +begin + if Source is TOvcCalcColors then begin + FCalcColors := TOvcCalcColors(Source).FCalcColors; + FColorScheme := TOvcCalcColors(Source).FColorScheme; + FOnChange := TOvcCalcColors(Source).FOnChange; + end else + inherited Assign(Source); +end; + +procedure TOvcCalcColors.BeginUpdate; +begin + FUpdating := True; +end; + +procedure TOvcCalcColors.EndUpdate; +begin + FUpdating := False; + DoOnChange; +end; + +procedure TOvcCalcColors.DoOnChange; +begin + if not FUpdating and Assigned(FOnChange) then + FOnChange(Self); + + if not SettingScheme then + FColorScheme := cscalcCustom; +end; + +function TOvcCalcColors.GetColor(const Index : Integer) : TColor; +begin + Result := FCalcColors[Index]; +end; + +procedure TOvcCalcColors.SetColor(const Index : Integer; const Value : TColor); +begin + if Value <> FCalcColors[Index] then begin + FCalcColors[Index] := Value; + DoOnChange; + end; +end; + +procedure TOvcCalcColors.SetColorScheme(const Value : TOvcCalcColorScheme); +begin + if Value <> FColorScheme then begin + SettingScheme := True; + try + FColorScheme := Value; + if Value <> cscalcCustom then begin + FCalcColors := CalcScheme[Value]; + DoOnChange; + end; + finally + SettingScheme := False; + end; + end; +end; + +procedure TOvcCalcColors.SetDisplayTextColor(const Value : TColor); +begin + if Value <> FCalcColors[2] then begin + FCalcColors[2] := Value; + DoOnChange; + end; +end; + + +{*** TOvcCalcTape ***} + +constructor TOvcCalcTape.Create(const AOwner : TComponent; const AOperandSize : Integer); +begin + inherited Create; + taOwner := AOwner; + FVisible := False; + taOperandSize := AOperandSize; + taFont := TFont.Create; + taFont.Name := 'Courier New'; + taFont.Size := 10; + taFont.Style := []; +end; + +destructor TOvcCalcTape.Destroy; +begin + taFont.Free; + taFont := nil; + + inherited Destroy; +end; + +procedure TOvcCalcTape.ValidateListBox; +begin + if not Assigned(taListBox) then begin + taListBox := TListBox.Create(taOwner); + with taListBox do begin + OnClick := taOnClick; + OnDblClick := taOnDblClick; + OnDrawItem := taOnDrawItem; + Style := lbOwnerDrawFixed; + Parent := taOwner as TWinControl; + ParentFont := False; + ParentCtl3D := True; + BorderStyle := bsSingle; + Color := taTapeColor; + Visible := FVisible; + Width := taWidth; + Height := taHeight; + Font.Assign(taFont); + Font.OnChange := taFont.OnChange; + taFont.OnChange := taTapeFontChange; + TabStop := False; + end; + taTapeInitialized := False; + end; + InitializeTape; +end; + +procedure TOvcCalcTape.Add(const Value : string); +begin + ValidateListBox; + taListBox.Items.Add(Value); +end; + +procedure TOvcCalcTape.DeleteFirst; +begin + ValidateListBox; + with taListBox, Items do + if Strings[0] = '' then + taListBox.Items.Delete(0) + else + Inc(taMaxTapeCount); +end; + +procedure TOvcCalcTape.SetFont(const Value : TFont); +begin + taFont.Assign(Value); + taFont.OnChange(Self); +end; + +function TOvcCalcTape.GetFont : TFont; +begin + Result := taFont; +end; + +procedure TOvcCalcTape.SetHeight(const Value : Integer); +begin + taHeight := Value; + if Visible then begin + ValidateListBox; + taListBox.Height := Value; + end; +end; + +function TOvcCalcTape.GetHeight : Integer; +begin + if Visible then begin + ValidateListBox; + Result := taListBox.Height; + end else + Result := taHeight; +end; + +function TOvcCalcTape.GetTape : TStrings; +begin + ValidateListBox; + Result := taListBox.Items; +end; + +procedure TOvcCalcTape.SetTape(const Value : TStrings); +begin + ValidateListBox; + taListBox.Items.Assign(Value); +end; + +function TOvcCalcTape.GetTapeColor : TColor; +begin + if Visible then begin + ValidateListBox; + Result := taListBox.Color; + end else + Result := taTapeColor; +end; + +procedure TOvcCalcTape.SetTapeColor(const Value : TColor); +begin + taTapeColor := Value; + if Visible then begin + ValidateListBox; + taListBox.Color := Value; + end; +end; + +procedure TOvcCalcTape.SetTop(const Value : Integer); +begin + ValidateListBox; + taListBox.Top := Value; +end; + +function TOvcCalcTape.GetTop : Integer; +begin + ValidateListBox; + Result := taListBox.Top; +end; + +function TOvcCalcTape.GetVisible : Boolean; +begin + Result := FVisible; +end; + +procedure TOvcCalcTape.SetVisible(const Value : Boolean); +begin + FVisible := Value; + if Assigned(taListBox) then begin + if not Value and taListBox.Visible then begin + if csDesigning in taListBox.Owner.ComponentState then begin + {$IFDEF VERSION4} + taListBox.Visible := Value; + taListBox.Height := 0; + {$ELSE} + taListBox.Free; + taListBox := nil; + {$ENDIF} + end else + taListBox.Visible := Value; + end else if Value and not taListBox.Visible then begin + taListBox.Visible := Value; + {$IFDEF VERSION4} + taListBox.Height := taHeight; + {$ENDIF} + end; + end else if Value then begin + ValidateListBox; + taListBox.Visible := Value; + end; +end; + +procedure TOvcCalcTape.SetWidth(const Value : Integer); +begin + taWidth := Value; + if Visible then begin + ValidateListBox; + taListBox.Width := Value; + end; +end; + +function TOvcCalcTape.GetWidth : Integer; +begin + if Visible then begin + ValidateListBox; + Result := taListBox.Width; + end else + Result := taWidth; +end; + +procedure TOvcCalcTape.SetTopIndex(const Value : Integer); +begin + ValidateListBox; + taListBox.TopIndex := Value; +end; + +function TOvcCalcTape.GetTopIndex : Integer; +begin + ValidateListBox; + Result := taListBox.TopIndex; +end; + +procedure TOvcCalcTape.SetBounds(const ALeft, ATop, AWidth, AHeight : Integer); +begin + ValidateListBox; + taListBox.SetBounds(ALeft, ATop, AWidth, AHeight); +end; + +procedure TOvcCalcTape.InitializeTape; +begin + if not Assigned(taListBox) then + Exit; + if csDesigning in taListBox.Owner.ComponentState then + if not taListBox.HandleAllocated then + Exit; + if taTapeInitialized then + Exit; + ClearTape; + taTapeInitialized := True; +end; + +procedure TOvcCalcTape.taOnClick(Sender : TObject); +begin + ValidateListBox; + (taListBox.Owner as TOvcCustomCalculator).SetFocus; +end; + +procedure TOvcCalcTape.taOnDblClick(Sender : TObject); +var + Str : string; +begin + ValidateListBox; + if (taListBox.Items.Count < 1) then + Exit; + Str := taListBox.Items.Strings[taListBox.ItemIndex]; + try + if (Str[1] = '0') and + (Str[2] <> '.') then + Exit; + if taListBox.Items.Strings[taListBox.ItemIndex] <> '' then begin + (taListBox.Owner as TOvcCustomCalculator).DisplayValue := + StrToFloat(Copy(Str,1, Length(Str) - taOperandSize)); + (taListBox.Owner as TOvcCustomCalculator).LastOperand := + StrToFloat(Copy(Str,1, Length(Str) - taOperandSize)); + (taListBox.Owner as TOvcCustomCalculator).Operand := + StrToFloat(Copy(Str,1, Length(Str) - taOperandSize)); + (taListBox.Owner as TOvcCustomCalculator).DisplayStr := + Copy(Str,1, Length(Str) - taOperandSize); + (taListBox.Owner as TOvcCustomCalculator).SetFocus; + end; + except + end; +end; + +procedure TOvcCalcTape.taOnDrawItem(Control: TWinControl; Index: Integer; + Rect:TRect;State: TOwnerDrawState); +var + SaveColor : TColor; + SaveBack : TColor; + Str : String; + I, FirstUsedIndex : Integer; +begin + FirstUsedIndex := 0; + if Index > FMaxPaperCount then + with (Control as TListBox) do begin + for I := 0 to Index do begin + if Items[I] <> '' then begin + FirstUsedIndex := I; + Break; + end; + end; + end; + + Str := (Control as TListBox).Items[Index]; + with (Control as TListBox).Canvas do begin { draw on control canvas, not on the form } + FillRect(Rect); { clear the rectangle } + + SaveColor := (Control as TListBox).Canvas.Font.Color; + try + SaveBack := (Control as TListBox).Canvas.Brush.Color; + try + if (Trim(Str) <> '') then begin + if (Trim(Str)[1] = '-') then + (Control as TListBox).Canvas.Font.Color := clRed; + if FTapeDisplaySpace > Length(Str) then + Str := Str + StringOfChar(' ', FTapeDisplaySpace - Length(Str)); + TextOut(Rect.Left, Rect.Top, Copy(Str, 1, Length(Str) - 1)); + if Index - FirstUsedIndex >= FMaxPaperCount then + (Control as TListBox).Canvas.Brush.Color := clRed; + TextOut(PenPos.X, PenPos.Y, Copy(Str, Length(Str), 1)); + end; + finally + (Control as TListBox).Canvas.Brush.Color := SaveBack; + end; + finally + (Control as TListBox).Canvas.Font.Color := SaveColor; + end; + end; +end; + +procedure TOvcCalcTape.taTapeFontChange(Sender : TObject); +begin + if Visible then begin + taListBox.Font.Assign(taFont); + taListBox.Font.OnChange(Sender); + end; +end; + +function TOvcCalcTape.GetDisplayedItemCount : Integer; +var + DC : hDC; + SaveFont : hFont; + Size : TSize; +begin + if not Assigned(taListBox) then begin + Result := 0; + Exit; + end; + + DC := GetDC(0); + SaveFont := SelectObject(DC, taListBox.Font.Handle); + GetTextExtentPoint(DC, ' 0123456789', 11, Size); + Result := taListBox.ClientHeight div Size.cy; + if Result < 3 then + Result := 3; + SelectObject(DC, SaveFont); + ReleaseDC(0, DC); +end; + +procedure TOvcCalcTape.AddToTape(const Value : string; const OpString : string); + {-adds an operand to the tape display} +var + TapeString : string; + DSpace : Integer; +begin + DSpace := FTapeDisplaySpace - Length(Value); + TapeString := StringOfChar(' ', DSpace - taOperandSize); + TapeString := TapeString + Value + ' ' + OpString; + Add(TapeString); + DeleteFirst; + TopIndex := taMaxTapeCount - GetDisplayedItemCount + 2; +end; + +{adds an operand to the tape display} +procedure TOvcCalcTape.AddToTapeLeft(const Value : string); +var + TapeString : string; + DSpace : Integer; +begin + DSpace := FTapeDisplaySpace - Length(Value); + TapeString := StringOfChar(' ', DSpace); + TapeString := Value + TapeString; + Add(Value); + DeleteFirst; + TopIndex := taMaxTapeCount - GetDisplayedItemCount + 2; +end; + +procedure TOvcCalcTape.ClearTape; +var + I : Integer; +begin + if not Assigned(taListBox) then + Exit; + if csDesigning in taListBox.Owner.ComponentState then + if not taListBox.HandleAllocated then + Exit; + taMaxTapeCount := 30; {set starting line count} + + taListBox.Items.Clear; + for I := 0 to taMaxTapeCount - 1 do + taListBox.Items.Add(''); + taListBox.TopIndex := taMaxTapeCount - GetDisplayedItemCount + 2; +end; + +procedure TOvcCalcTape.RefreshDisplays; +var + I, Diff : Integer; + S : string; + + function AllSame(const Str : string) : Boolean; + var + I : Integer; + begin + Result := True; + for I := 2 to Length(Str) do begin + if Str[1] <> Str[I] then + Exit; + end; + end; + +begin + if not Assigned(taListBox) then + Exit; + if not taListBox.HandleAllocated then + Exit; + + if FShowTape then begin + for I := 0 to taMaxTapeCount - 1 do begin + S := taListBox.Items.Strings[I]; + if S <> '' then begin + Diff := FTapeDisplaySpace - Length(S); + if S[1] = ' ' then begin + if Diff >= 0 then + S := StringOfChar(' ', Diff) + S + else if AllSame(copy(S, 1, -Diff)) then + S := copy(S,-Diff + 1, Length(S)); + end else begin + if AllSame(S) and (not (S[1] in ['0'..'9'])) then + if Diff >= 0 then + S := S + StringOfChar(S[1], Diff) + else + S := copy(S, 1, Length(S)-Diff + 1) + else if (Diff >= 0) and not ((S[1] <> '0') or (S[2] <> '.')) then + S := StringOfChar(' ', Diff) + S; + end; + taListBox.Items.Strings[I] := S; + end; + end; + taListBox.TopIndex := taMaxTapeCount - GetDisplayedItemCount + 2; + end; +end; + +procedure TOvcCalcTape.SpaceTape(const Value : char); +var + TapeString : string; +begin + TapeString := StringOfChar(Value, FTapeDisplaySpace); + Add(TapeString); + DeleteFirst; + TopIndex := taMaxTapeCount - GetDisplayedItemCount + 2; +end; + + +{*** TOvcCustomCalculatorEngine ***} + +procedure TOvcCustomCalculatorEngine.ClearAll; +var + I : Integer; +begin + for I := 0 to 3 do + cOperands[I] := 0; + cLastOperation := coNone; + cOperationCount := 0; + cState := [csValid, csClear]; +end; + +procedure TOvcCustomCalculatorEngine.PushOperand(const Value : Extended); +var + I : Integer; +begin + for I := 2 downto 0 do + cOperands[I+1] := cOperands[I]; + cOperands[0] := Value; +end; + +function TOvcCustomCalculatorEngine.PopOperand : Extended; +var + I : Integer; +begin + Result := cOperands[0]; + for I := 0 to 2 do + cOperands[I] := cOperands[I+1]; + cOperands[3] := 0; +end; + +function TOvcCustomCalculatorEngine.TopOperand : Extended; +begin + Result := cOperands[0]; +end; + + +{*** TOvcBasicCalculatorEngine ***} +type + TOvcBasicCalculatorEngine = class(TOvcCustomCalculatorEngine) + protected {private} + {internal methods} + procedure cEvaluate(const Operation : TOvcCalculatorOperation); + public + function AddOperand(const Value : Extended; const Button : TOvcCalculatorOperation) : Boolean; + override; + function AddOperation(const Button : TOvcCalculatorOperation) : Boolean; + override; + end; + +function TOvcBasicCalculatorEngine.AddOperand( + const Value : Extended; + const Button : TOvcCalculatorOperation) : Boolean; +var + I : Integer; +begin + Result := False; + if Button <> coNone then begin + if csValid in cState then begin + Result := True; + for I := 2 downto 0 do + cOperands[I+1] := cOperands[I]; + cOperands[0] := Value; + end; + end; +end; + +procedure TOvcBasicCalculatorEngine.cEvaluate(const Operation : TOvcCalculatorOperation); +begin + if csValid in cState then begin + {evaluate the expression} + case Operation of + coAdd : begin + cOperands[1] := cOperands[1] + cOperands[0]; + PopOperand; + end; + coSub : begin + cOperands[1] := cOperands[1] - cOperands[0]; + PopOperand; + end; + coMul : begin + cOperands[1] := cOperands[1] * cOperands[0]; + PopOperand; + end; + coDiv : begin + cOperands[1] := cOperands[1] / cOperands[0]; + PopOperand; + end; + coEqual : ; + coNone : ; + coPercent : begin + if cLastOperation in [coAdd, coSub] then + cOperands[0] := (cOperands[0] / 100) * cOperands[1] {do markup/down} + else + cOperands[0] := cOperands[0] / 100; {as a percentage} + cState := [csValid, csClear]; + end; + coMemStore : begin + cMemory := cOperands[0]; + Include(cState, csClear); + end; + coMemRecall : begin + cOperands[0] := cMemory; + cState := [csValid, csClear]; + end; + coMemClear : begin + cMemory := 0; + end; + coMemAdd, + coMemSub : begin + try + if Operation = coMemAdd then + cMemory := cMemory + cOperands[0] + else + cMemory := cMemory - cOperands[0]; + except + cMemory := 0; + end; + Include(cState, csClear); + end; + coInvert : begin + cOperands[0] := 1 / cOperands[0]; + end; + coSqrt : begin + cOperands[0] := Sqrt(cOperands[0]); + end; + end; + end; +end; + +function TOvcBasicCalculatorEngine.AddOperation(const Button : TOvcCalculatorOperation) : Boolean; +begin + Result := False; + if csValid in cState then begin + {evaluate the expression} + case Button of + coAdd : begin + cEvaluate(cLastOperation); + cState := [csValid, csClear]; + if cLastOperation in [coAdd, coSub] then + Inc(cOperationCount) + else + cOperationCount := 1; + cLastOperation := Button; + Result := True; + end; + coSub : begin + cEvaluate(cLastOperation); + cState := [csValid, csClear]; + if cLastOperation in [coAdd, coSub] then + Inc(cOperationCount) + else + cOperationCount := 1; + cLastOperation := Button; + Result := True; + end; + coMul : begin + cEvaluate(cLastOperation); + cState := [csValid, csClear]; + if cLastOperation = Button then + cOperationCount := cOperationCount + 1 + else + cOperationCount := 1; + cLastOperation := Button; + Result := True; + end; + coDiv : begin + cEvaluate(cLastOperation); + cState := [csValid, csClear]; + if cLastOperation = Button then + cOperationCount := cOperationCount + 1 + else + cOperationCount := 1; + cLastOperation := Button; + Result := True; + end; + coEqual : begin + Include(cState, csClear); + if cLastOperation <> coNone then begin + cEvaluate(cLastOperation); + cState := [csClear, csValid]; + if cLastOperation = coEqual then + cLastOperation := coNone + else + cLastOperation := Button; + end; + Result := True; + end; + coNone : Result := True; + coPercent : begin + cEvaluate(Button); + if not ShowSeparatePercent then begin + cEvaluate(cLastOperation); + cState := [csValid, csClear]; + if cLastOperation = Button then + cOperationCount := cOperationCount + 1 + else + cOperationCount := 0; + cLastOperation := coEqual; + Result := True; + end else begin + if cLastOperation = Button then + cOperationCount := cOperationCount + 1 + else + cOperationCount := 0; + Result := True; + end; + end; + coMemStore : begin + cEvaluate(Button); + end; + coMemRecall : begin + cEvaluate(Button); + Result := True; + end; + coMemClear : begin + cEvaluate(Button); + end; + coMemAdd, + coMemSub : begin + cEvaluate(Button); + end; + coInvert : begin + cEvaluate(Button); + Result := True; + end; + coSqrt : begin + cEvaluate(Button); + Result := True; + end; + end; + end; +end; + + +{*** TOvcCalcPanel ***} + +procedure TOvcCalcPanel.Click; +begin + (Owner as TOvcCustomCalculator).SetFocus; +end; + + +{*** TOvcCustomCalculator ***} + +procedure TOvcCustomCalculator.cAdjustHeight; +var + DC : hDC; + SaveFont : hFont; + I : Integer; + SysMetrics : TTextMetric; + Metrics : TTextMetric; +begin + DC := GetDC(0); + GetTextMetrics(DC, SysMetrics); + SaveFont := SelectObject(DC, Font.Handle); + GetTextMetrics(DC, Metrics); + SelectObject(DC, SaveFont); + ReleaseDC(0, DC); + if NewStyleControls then begin + if Ctl3D then + I := 8 + else + I := 6; + I := GetSystemMetrics(SM_CYBORDER) * I; + end else begin + I := SysMetrics.tmHeight; + if I > Metrics.tmHeight then + I := Metrics.tmHeight; + I := I div 4 + GetSystemMetrics(SM_CYBORDER) * 4; + end; + cPanel.Height := Metrics.tmHeight + I; +end; + +procedure TOvcCustomCalculator.cCalculateLook; +var + CW : Integer; {client width} + BW : Integer; {button width} + BH : Integer; {button height} + LBW : Integer; {large button width} + M1 : Integer; {margin between buttons} + M2 : Integer; {left and right edge margins} + M3 : Integer; {margin between panel and frst row of buttons} + M4 : Integer; {margin between memory buttons and other buttons} + TM : Integer; {area where the panel is placed} + X : Integer; + Y : Integer; + PW : Integer; {panel width} + B : TOvcCalculatorButton; +begin + if not HandleAllocated then + Exit; + + {set panel height based on font} + cAdjustHeight; + + for B := Low(cButtons) to High(cButtons) do + cButtons[B].Visible := True; + + CW := ClientWidth; + + if Width <= 200 then begin + M1 := 2; + M2 := 4; + end else begin + M1 := 4; + M2 := 6; + end; + {save left/right/top/bottom margin value} + cMargin := M2; + + M4 := M2; + if coShowMemoryButtons in FOptions then begin + BW := (CW - 3*M2 - 4*M1) div 6; + M4 := CW - 2*M2 - 6*BW - 4*M1; + end else begin + BW := (CW - 2*M2 - 4*M1) div 5; + if (CW - 2*M2 - 4*M1) div 6 >= 4 then + Inc(M2, 2) + else if (CW - 2*M2 - 4*M1) div 6 >= 2 then + Inc(M2, 1); + end; + + {button height, using an estimate for TM} + TM := M2 + M2 + cPanel.Height; + + if coShowTape in FOptions then + TM := TM + M2 + cTape.Height; + + BH := (ClientHeight - TM - M2 - 4*M1) div 5; + + {calculate actual area below panel} + M3 := ClientHeight - M2 - cPanel.Height - 5*BH - 4*M1 - M2; + + {calculate actual height of area above buttons} + TM := M2 + M3 + cPanel.Height; + + {large button width} + if coShowClearTapeButton in FOptions then + LBW := (5*BW + 3*M1 - 2*M1) div 4 + else + LBW := (4*BW + 3*M1 - 2*M1) div 3; + + {calculate the width of the edit window} + cMargin := M2; + if coShowMemoryButtons in FOptions then + PW := 6*BW + M4 + 4*M1 + else + PW := 5*BW + 4*M1; + + if coShowTape in FOptions then + PW := PW - cScrBarWidth; + + + {position tape display and edit panel} + if coShowTape in FOptions then begin + cTape.Visible := True; + cTape.SetBounds(cMargin, cMargin, PW + cScrBarWidth, cTape.Height); + cPanel.SetBounds(cMargin + 2, cTape.Height + M2 + + cMargin, PW, cPanel.Height); + end else begin + cTape.Visible := False; + cPanel.SetBounds(cMargin, cMargin, PW, cPanel.Height); + end; + + {calculate # of characters required to fill display space} + {"FontWidth div 2" makes sure there is no cut off charaters} + if coShowTape in FOptions then + cTape.TapeDisplaySpace := (cTape.Width - cScrBarWidth - (cGetFontWidth div 2)) + div cGetFontWidth + else + cTape.TapeDisplaySpace := (cPanel.Width - (cGetFontWidth div 2)) div cGetFontWidth; + + cTape.InitializeTape; + + {redraw the edit panel and Tape} + cRefreshDisplays; + + {memory column} + if coShowMemoryButtons in FOptions then begin + X := M2; + Y := TM; + cButtons[cbMemClear].Position := Rect(X, Y, X+BW, Y+BH); + cButtons[cbMemClear].Caption := GetOrphStr(SCCalcMC); + + Y := TM + BH + M1; + cButtons[cbMemRecall].Position := Rect(X, Y, X+BW, Y+BH); + cButtons[cbMemRecall].Caption := GetOrphStr(SCCalcMR); + + Y := TM + 2*BH + 2*M1; + cButtons[cbMemStore].Position := Rect(X, Y, X+BW, Y+BH); + cButtons[cbMemStore].Caption := GetOrphStr(SCCalcMS); + + Y := TM + 3*BH + 3*M1; + cButtons[cbMemAdd].Position := Rect(X, Y, X+BW, Y+BH); + cButtons[cbMemAdd].Caption := GetOrphStr(SCCalcMPlus); + + Y := TM + 4*BH + 4*M1; + cButtons[cbMemSub].Position := Rect(X, Y, X+BW, Y+BH); + cButtons[cbMemSub].Caption := GetOrphStr(SCCalcMMinus); + end else + for B := cbMemClear to cbMemSub do + cButtons[B].Visible := False; + + {row 1 - large buttons} + Y := TM; + if coShowMemoryButtons in FOptions then + if coShowClearTapeButton in FOptions then + X := BW + M2 + M4 + else + X := 2*BW + M4 + M2 + M1 + else + if coShowClearTapeButton in FOptions then + X := M2 + else + X := BW + M2 + M1; + + cButtons[cbTape].Position := Rect(X, Y, X+LBW, Y+BH); + cButtons[cbTape].Caption := GetOrphStr(SCCalcCT); + + if coShowClearTapeButton in FOptions then begin + cButtons[cbTape].Visible := True; + Inc(X, LBW+M1); + if ((BW+M1)*5 - (LBW+M1)*4) >= 3 then + Inc(X, 1); + end else begin + cButtons[cbTape].Visible := False; + end; + + cButtons[cbBack].Position := Rect(X, Y, X+LBW, Y+BH); + cButtons[cbBack].Caption := GetOrphStr(SCCalcBack); + + Inc(X, LBW+M1); + if coShowClearTapeButton in FOptions then begin + if ((BW+M1)*5 - (LBW+M1)*4) >= 2 then + Inc(X, 1); + end else begin + if ((BW+M1)*4 - (LBW+M1)*3) >= 2 then + Inc(X, 1); + end; + cButtons[cbClearEntry].Position := Rect(X, Y, X+LBW, Y+BH); + cButtons[cbClearEntry].Caption := GetOrphStr(SCCalcCE); + + Inc(X, LBW+M1); + if coShowClearTapeButton in FOptions then begin + if ((BW+M1)*5 - (LBW+M1)*4) >= 1 then + Inc(X, 1); + end else begin + if ((BW+M1)*4 - (LBW+M1)*3) >= 1 then + Inc(X, 1); + end; + cButtons[cbClear].Position := Rect(X, Y, X+LBW, Y+BH); + cButtons[cbClear].Caption := GetOrphStr(SCCalcC); + + {row 2} + Y := TM + BH + M1; + if coShowMemoryButtons in FOptions then + X := M2 + BW + M4 + else + X := M2; + cButtons[cb7].Position := Rect(X, Y, X+BW, Y+BH); + cButtons[cb7].Caption := '7'; + + Inc(X, BW+M1); + cButtons[cb8].Position := Rect(X, Y, X+BW, Y+BH); + cButtons[cb8].Caption := '8'; + + Inc(X, BW+M1); + cButtons[cb9].Position := Rect(X, Y, X+BW, Y+BH); + cButtons[cb9].Caption := '9'; + + Inc(X, BW+M1); + cButtons[cbDiv].Position := Rect(X, Y, X+BW, Y+BH); + cButtons[cbDiv].Caption := '/'; + + Inc(X, BW+M1); + cButtons[cbSqrt].Position := Rect(X, Y, X+BW, Y+BH); + cButtons[cbSqrt].Caption := GetOrphStr(SCCalcSqrt); + + {row 3} + Y := TM + 2*BH + 2*M1; + if coShowMemoryButtons in FOptions then + X := M2 + BW + M4 + else + X := M2; + cButtons[cb4].Position := Rect(X, Y, X+BW, Y+BH); + cButtons[cb4].Caption := '4'; + + Inc(X, BW+M1); + cButtons[cb5].Position := Rect(X, Y, X+BW, Y+BH); + cButtons[cb5].Caption := '5'; + + Inc(X, BW+M1); + cButtons[cb6].Position := Rect(X, Y, X+BW, Y+BH); + cButtons[cb6].Caption := '6'; + + Inc(X, BW+M1); + cButtons[cbMul].Position := Rect(X, Y, X+BW, Y+BH); + cButtons[cbMul].Caption := '*'; + + Inc(X, BW+M1); + cButtons[cbPercent].Position := Rect(X, Y, X+BW, Y+BH); + cButtons[cbPercent].Caption := '%'; + + {row 4} + Y := TM + 3*BH + 3*M1; + if coShowMemoryButtons in FOptions then + X := M2 + BW + M4 + else + X := M2; + cButtons[cb1].Position := Rect(X, Y, X+BW, Y+BH); + cButtons[cb1].Caption := '1'; + + Inc(X, BW+M1); + cButtons[cb2].Position := Rect(X, Y, X+BW, Y+BH); + cButtons[cb2].Caption := '2'; + + Inc(X, BW+M1); + cButtons[cb3].Position := Rect(X, Y, X+BW, Y+BH); + cButtons[cb3].Caption := '3'; + + Inc(X, BW+M1); + cButtons[cbSub].Position := Rect(X, Y, X+BW, Y+BH); + cButtons[cbSub].Caption := '-'; + + Inc(X, BW+M1); + cButtons[cbInvert].Position := Rect(X, Y, X+BW, Y+BH); + cButtons[cbInvert].Caption := '1/x'; + + {row 5} + Y := TM + 4*BH + 4*M1; + if coShowMemoryButtons in FOptions then + X := M2 + BW + M4 + else + X := M2; + cButtons[cb0].Position := Rect(X, Y, X+BW, Y+BH); + cButtons[cb0].Caption := '0'; + + Inc(X, BW+M1); + cButtons[cbChangeSign].Position := Rect(X, Y, X+BW, Y+BH); + cButtons[cbChangeSign].Caption := '+/-'; + + Inc(X, BW+M1); + cButtons[cbDecimal].Position := Rect(X, Y, X+BW, Y+BH); + cButtons[cbDecimal].Caption := DecimalSeparator; + + Inc(X, BW+M1); + cButtons[cbAdd].Position := Rect(X, Y, X+BW, Y+BH); + cButtons[cbAdd].Caption := '+'; + + Inc(X, BW+M1); + cButtons[cbEqual].Position := Rect(X, Y, X+BW, Y+BH); + cButtons[cbEqual].Caption := '='; +end; + +procedure TOvcCustomCalculator.cClearAll; +begin + if not HandleAllocated then + Exit; + + cEngine.ClearAll; + FLastOperand := 0; + DisplayValue := 0; + FDisplayStr := '0'; + cMinus0 := False; + cTape.InitializeTape; + cPanel.Caption := StringOfChar(' ', + (cTape.TapeDisplaySpace + - Length('0') + - Length(CalcDisplayString[cbNone])) + ) + '0' + ' '; +end; + +procedure TOvcCustomCalculator.cColorChange(Sender : TObject); +begin + {update panel background color} + if Assigned(cPanel) then begin + cPanel.Color := FColors.Display; + cPanel.Font.Color := FColors.DisplayTextColor; + {update the main font color} + if not (csLoading in ComponentState) and (Font <> nil) then + Font.Color := FColors.DisplayTextColor; + end; + + if Assigned(cTape) then begin + cTape.TapeColor := FColors.Display; + end; + + Invalidate; +end; + +procedure TOvcCustomCalculator.cDisplayError; +begin + cSetDisplayString('****** '); + cEngine.State := [csLocked]; {user will have to clear this} + MessageBeep(0); +end; + +procedure TOvcCustomCalculator.cDrawCalcButton(const Button : TOvcButtonInfo; const Pressed : Boolean); +var + TR : TRect; + Buf : array[0..255] of Char; +begin + if Button.Visible then begin + TR := DrawButtonFace(Canvas, Button.Position, 1, bsNew, False, Pressed, False); + StrPLCopy(Buf, Button.Caption, 255); + DrawText(Canvas.Handle, Buf, StrLen(Buf), TR, + DT_CENTER or DT_VCENTER or DT_SINGLELINE); + + if Focused and (Button.Caption = '=') then + cDrawFocusState; + end; +end; + +procedure TOvcCustomCalculator.cDrawFocusState; +var + R : TRect; +begin + R := cButtons[cbEqual].Position; + InflateRect(R, -3, -3); +{$IFNDEF LCL} + Canvas.DrawFocusRect(R); +{$ENDIF} +end; + +procedure TOvcCustomCalculator.cDrawSizeLine; +var + OldPen : TPen; +begin + if (cSizing) then + with Canvas do begin + OldPen := TPen.Create; + try + OldPen.Assign(Pen); + Pen.Color := clBlack; + Pen.Mode := pmXor; + Pen.Style := psDot; + Pen.Width := 1; + MoveTo(0, cSizeOffset); + LineTo(ClientWidth, cSizeOffset); + finally + Canvas.Pen := OldPen; + OldPen.Free; + end; + end; +end; + +procedure TOvcCustomCalculator.cEvaluate(const Button : TOvcCalculatorButton); +begin + if csValid in cEngine.State then begin + try + {evaluate the expression} + if cEngine.AddOperation(CalcButtontoOperation[Button]) then begin + DisplayValue := cEngine.TopOperand; + if Button in [cbAdd, cbSub, cbMul, cbDiv, cbEqual, cbPercent, cbNone] then + if (Button in [cbAdd, cbSub, cbMul, cbDiv]) and (cLastButton = Button) then + cTape.AddToTape(cFormatString(LastOperand), CalcDisplayString[Button]) + else + cTape.AddToTape(FDisplayStr, CalcDisplayString[Button]); + if (Button = cbEqual) and (cEngine.LastOperation = coEqual) then begin + if coShowItemCount in FOptions then + cTape.AddToTapeLeft(Format('%3.3d',[cEngine.OperationCount+1])); + cTape.AddToTape(cFormatString(DisplayValue), CalcDisplayString[cbSubTotal]); + cTape.SpaceTape(TapeSeparatorChar); + end; + FDisplayStr := cFormatString(DisplayValue); + end; + except + cDisplayError; + end; + end; +end; + +function TOvcCustomCalculator.cFormatString(const Value : Extended) : string; +begin + if cEngine.Decimals = 0 then + Result := Format('%g',[Value]) + else if cEngine.Decimals < 0 then + Result := Format('%.*f',[-cEngine.Decimals, Value]) + else + Result := Format('%.*f',[cEngine.Decimals, Value]); +end; + +function TOvcCustomCalculator.cGetFontWidth : Integer; +var + DC : hDC; + SaveFont : hFont; + Size : TSize; +begin + if not assigned(cPanel) then begin + Result := 8; {Return something resonable } + Exit; + end; + DC := GetDC(0); + SaveFont := SelectObject(DC, cPanel.Font.Handle); + GetTextExtentPoint(DC, ' 0123456789', 11, Size); + Result := Round(Size.cx/11); + SelectObject(DC, SaveFont); + ReleaseDC(0, DC); +end; + +procedure TOvcCustomCalculator.cInvalidateIndicator; +begin + InvalidateRect(Handle, @cButtons[cbMemRecall].Position, False); + InvalidateRect(Handle, @cButtons[cbMemClear].Position, False); +end; + +procedure TOvcCustomCalculator.cRefreshDisplays; +begin + if not cPanel.HandleAllocated then + Exit; + + cTape.RefreshDisplays; +{ DisplayValue := DisplayValue; } +end; + +procedure TOvcCustomCalculator.cSetDisplayString(const Value : string); +var + DSpace : Integer; +begin + try + if cPanel.HandleAllocated then begin + DSpace := cTape.TapeDisplaySpace + - Length(Value) + - Length(CalcDisplayString[cbNone]); + cPanel.Caption := StringOfChar(' ', DSpace) + Value + ' '; + end; + except + cDisplayError; + end; +end; + +procedure TOvcCustomCalculator.cTapeFontChange(Sender : TObject); +begin + cPanel.Font := TapeFont; +end; + +procedure TOvcCustomCalculator.SetBorderStyle(const Value : TBorderStyle); +begin + if Value <> FBorderStyle then begin + FBorderStyle := Value; +{$IFNDEF LCL} + RecreateWnd; +{$ELSE} + RecreateWnd(Self); +{$ENDIF} + end; +end; + +function TOvcCustomCalculator.GetDecimals : Integer; +begin + Result := cEngine.Decimals; +end; + +procedure TOvcCustomCalculator.SetDecimals(const Value : Integer); +begin + if Value <> cEngine.Decimals then begin + cEngine.Decimals := Value; + ccalculateLook; + Invalidate; + end; +end; + +function TOvcCustomCalculator.GetMemory : Extended; +begin + Result := cEngine.Memory; +end; + +procedure TOvcCustomCalculator.SetMemory(const Value : Extended); +begin + if Value <> cEngine.Memory then begin + cEngine.Memory := Value; + cCalculateLook; + Invalidate; + end; +end; + +procedure TOvcCustomCalculator.SetMaxPaperCount(const Value : Integer); +begin + if Value <> cTape.MaxPaperCount then begin + cTape.MaxPaperCount := Value; + Invalidate; + end; +end; + +function TOvcCustomCalculator.GetMaxPaperCount : Integer; +begin + Result := cTape.MaxPaperCount; +end; + +procedure TOvcCustomCalculator.SetOptions(const Value : TOvcCalculatorOptions); +begin + if Value <> FOptions then begin + FOptions := Value; + + + cTape.ShowTape := coShowTape in FOptions; + cTape.Visible := coShowTape in FOptions; + cEngine.ShowSeparatePercent := coShowSeparatePercent in FOptions; + + cCalculateLook; + Invalidate; + end; +end; + +function TOvcCustomCalculator.GetTape : TStrings; +begin + Result := cTape.Tape; +end; + +procedure TOvcCustomCalculator.SetTape(const Value : TStrings); +begin + cTape.Tape := Value; +end; + +function TOvcCustomCalculator.GetTapeFont : TFont; +begin + Result := cTape.Font; +end; + +procedure TOvcCustomCalculator.SetTapeFont(const Value : TFont); +begin + cTape.Font := Value; +end; + +function TOvcCustomCalculator.GetTapeHeight : Integer; +begin + Result := cTape.Height; +end; + +procedure TOvcCustomCalculator.SetTapeHeight(const Value : Integer); +begin + cTape.Height := Value; + cCalculateLook; + Invalidate; +end; + +function TOvcCustomCalculator.GetVisible : Boolean; +begin + Result := inherited Visible; +end; + +procedure TOvcCustomCalculator.SetVisible(const Value : Boolean); +begin + inherited Visible := Value; + + cTape.Visible := cTape.ShowTape; +end; + +procedure TOvcCustomCalculator.SetDisplay(const Value : Extended); +var + ValueString : string; +begin + try + FDisplay := Value; + if cPanel.HandleAllocated then begin + ValueString := cFormatString(Value); + cSetDisplayString(ValueString); + end; + except + cDisplayError; + end; +end; + +procedure TOvcCustomCalculator.SetDisplayStr(const Value : string); +begin + FDisplayStr := Value; + while (Length(FDisplayStr) > 0) and (FDisplayStr[1] = ' ') do + FDisplayStr := Copy(FDisplayStr, 2, Length(FDisplayStr) - 1); +end; + +function TOvcCustomCalculator.GetOperand : Extended; +begin + Result := cEngine.TopOperand; +end; + +procedure TOvcCustomCalculator.SetOperand(const Value : Extended); +begin + if Value = cEngine.TopOperand then + Exit; + cEngine.PushOperand(Value); +end; + +procedure TOvcCustomCalculator.CMCtl3DChanged(var Msg : TMessage); +begin + inherited; + + if (csLoading in ComponentState) or not HandleAllocated then + Exit; + + if NewStyleControls and (FBorderStyle = bsSingle) then +{$IFNDEF LCL} + RecreateWnd; +{$ENDIF} + + Invalidate; +end; + +procedure TOvcCustomCalculator.CMDesignHitTest(var Msg : TCMDesignHitTest); +begin + Msg.Result := LongInt(cOverBar); +end; + +procedure TOvcCustomCalculator.CMEnter(var Msg : TMessage); +var + R : TRect; +begin + inherited; + + {invalidate the "=" button to ensure that the focus rect is painted} + R := cButtons[cbEqual].Position; + InvalidateRect(Handle, @R, False); +end; + +procedure TOvcCustomCalculator.CMExit(var Msg : TMessage); +var + R : TRect; +begin + inherited; + + {invalidate the "=" button to ensure that the focus rect is painted} + R := cButtons[cbEqual].Position; + InvalidateRect(Handle, @R, False); +end; + +procedure TOvcCustomCalculator.CMFontChanged(var Msg : TMessage); +begin + inherited; + + if not (csLoading in ComponentState) and Assigned(cPanel) then begin + cPanel.Color := FColors.Display; + cPanel.Font.Color := FColors.DisplayTextColor; + FColors.FCalcColors[2] := Font.Color; + end; + + cCalculateLook; + Invalidate; +end; + +procedure TOvcCustomCalculator.WMEraseBkgnd(var Msg : TWMEraseBkgnd); +begin + Msg.Result := 1; {don't erase background, just say we did} +end; + +procedure TOvcCustomCalculator.WMGetText(var Msg : TWMGetText); +begin + if not cPanel.HandleAllocated then + Exit; + + Msg.Result := SendMessage(cPanel.Handle, WM_GETTEXT, + TMessage(Msg).wParam, TMessage(Msg).lParam); +end; + +procedure TOvcCustomCalculator.WMGetTextLength(var Msg : TWMGetTextLength); +begin + if not cPanel.HandleAllocated then + Exit; + + Msg.Result := SendMessage(cPanel.Handle, WM_GETTEXTLENGTH, + TMessage(Msg).wParam, TMessage(Msg).lParam); +end; + +procedure TOvcCustomCalculator.WMKeyDown(var Msg : TWMKeyDown); +begin + if Msg.CharCode = Ord('M') then begin + if ({$IFNDEF LCL} GetAsyncKeyState(VK_CONTROL) {$ELSE} GetKeyState(VK_CONTROL) {$ENDIF} and $8000) <> 0 then begin + PressButton(cbMemStore); + end; + end else if Msg.CharCode = VK_RETURN then + PressButton(cbEqual); + + inherited; +end; + +procedure TOvcCustomCalculator.WMSetText(var Msg : TWMSetText); +var + I : Integer; + C : AnsiChar; +begin + cClearAll; + for I := 0 to Pred(StrLen(Msg.Text)) do begin + C := Msg.Text[I]; + KeyPress(C); + end; + Msg.Result := 1{true}; +end; + +procedure TOvcCustomCalculator.WMNCHitTest(var Msg : TWMNCHitTest); +begin + inherited; + + cHitTest.X := Msg.Pos.X; + cHitTest.Y := Msg.Pos.Y; +end; + +procedure TOvcCustomCalculator.WMSetCursor(var Msg : TWMSetCursor); +var + vHitTest : TPoint; + + procedure SetNewCursor(C : HCursor); + begin + SetCursor(C); + Msg.Result := Ord(True); + end; + +begin + if not (coShowTape in FOptions) then + Exit; + + if csDesigning in ComponentState then begin + if (Msg.HitTest = HTCLIENT) then begin + cOverBar := False; + vHitTest := ScreenToClient(cHitTest); + if vHitTest.Y > cTape.Top + cTape.Height then + if vHitTest.Y < cTape.Top + cTape.Height+4 then + cOverBar := True; + end; + + {set appropriate cursor} + if cOverBar then + SetNewCursor(cTabCursor) + else + inherited; + end else + inherited; +end; + +procedure TOvcCustomCalculator.WMCancelMode(var Msg : TMessage); +begin + inherited; + + cSizing := False; +end; + +procedure TOvcCustomCalculator.WMKillFocus(var Msg : TWMKillFocus); +begin + inherited; + + Invalidate; +end; + +procedure TOvcCustomCalculator.WMLButtonDown(var Msg : TWMMouse); +begin + inherited; + + {are we currently showing a sizing cursor? if so the user wants to + resize a column/row} + if (cOverBar) then begin + cSizeOffset := Msg.YPos; + cSizing := True; + cDrawSizeLine; + end; +end; + +procedure TOvcCustomCalculator.WMLButtonUp(var Msg : TWMMouse); +var + Form : TForm; +begin + inherited; + + if (cSizing) then begin + cDrawSizeLine; + cSizing := False; + cTape.Height := cSizeOffset - 8; + cCalculateLook; + + Refresh; + if (csDesigning in ComponentState) then begin + Form := TForm(GetParentForm(Self)); + if (Form <> nil) and (Form.Designer <> nil) then + Form.Designer.Modified; + end; + end; +end; + +procedure TOvcCustomCalculator.WMMouseMove(var Msg : TWMMouse); +begin + inherited; + + if (cSizing) then begin + cDrawSizeLine; + if Msg.YPos >= calcDefMinSize + cTape.Top then + if Msg.YPos <= Height - calcDefMinSize then + cSizeOffset := Msg.YPos + 2 + else + cSizeOffset := Height - calcDefMinSize + else + cSizeOffset := calcDefMinSize + cTape.Top; + cDrawSizeLine; + end; +end; + +procedure TOvcCustomCalculator.CopyToClipboard; +begin + Clipboard.AsText := Text; +end; + +constructor TOvcCustomCalculator.Create(AOwner : TComponent); +begin + inherited Create(AOwner); + + if cPopup then + ControlStyle := ControlStyle + [csClickEvents, csFramed] - [csCaptureMouse] + else + ControlStyle := ControlStyle + [csClickEvents, csFramed, csCaptureMouse]; + + Color := clBtnFace; + TabStop := True; + Width := 200; + Font.Name := 'MS Sans Serif'; + Font.Size := 8; + Font.Style := []; + cDecimalEntered := False; + cSizing := False; + cScrBarWidth := 18; + + {create edit control} + cPanel := TOvcCalcPanel.Create(Self); + cPanel.Parent := Self; + cPanel.ParentFont := False; + cPanel.Font.Name := 'Courier New'; + cPanel.Font.Size := 10; + cPanel.Font.Style := []; + cPanel.ParentCtl3D := True; + cPanel.Alignment := taLeftJustify; + cPanel.BevelOuter := bvLowered; + cPanel.BorderStyle := bsNone; + cPanel.Color := clWindow; + cPanel.BevelWidth := 2; + cPanel.Caption := '0 '; + + {set property defaults} + FBorderStyle := bsNone; + Height := 140; + FTapeSeparatorChar := '_'; + FOptions := [coShowMemoryButtons, coShowItemCount]; + FColors := TOvcCalcColors.Create; + FColors.OnChange := cColorChange; + + {assign default color scheme} + FColors.FCalcColors := CalcScheme[cscalcWindows]; + + {create tape} + cTape := TOvcCalcTape.Create(Self, Length(CalcDisplayString[cbNone])); + cTape.ShowTape := False; + cTape.TapeColor := clWindow; + cTape.MaxPaperCount := 9999; + TapeHeight := Height div 3; + TapeFont.OnChange := cTapeFontChange; + TapeFont.Name := 'Courier New'; + TapeFont.Size := 10; + TapeFont.Style := []; + cTape.Visible := cTape.ShowTape; + + cEngine := TOvcBasicCalculatorEngine.Create; + cEngine.Decimals := 2; + cEngine.ShowSeparatePercent := False; + + if csDesigning in ComponentState then + cTabCursor := Screen.Cursors[crVSplit]; +end; + +constructor TOvcCustomCalculator.CreateEx(AOwner : TComponent; AsPopup : Boolean); +begin + cPopup := AsPopup; + Create(AOwner); +end; + +procedure TOvcCustomCalculator.CreateParams(var Params : TCreateParams); +const + BorderStyles : array[TBorderStyle] of LongInt = (0, WS_BORDER); +begin + inherited CreateParams(Params); + + with Params do begin + Style := LongInt(Style) or BorderStyles[FBorderStyle]; + if cPopup then begin + Style := WS_POPUP or WS_BORDER; + WindowClass.Style := WindowClass.Style or CS_SAVEBITS; + end; + end; + + if NewStyleControls and (Ctl3D or cPopup) and (FBorderStyle = bsSingle) then begin + if not cPopup then + Params.Style := Params.Style and not WS_BORDER; + Params.ExStyle := Params.ExStyle or WS_EX_CLIENTEDGE; + end; +end; + +procedure TOvcCustomCalculator.CreateWnd; +begin + inherited CreateWnd; + + cCalculateLook; + cClearAll; + + cPanel.Color := FColors.Display; +end; + +destructor TOvcCustomCalculator.Destroy; +begin + cTape.Free; + cTape := nil; + + cEngine.Free; + cEngine := nil; + + FColors.Free; + FColors := nil; + + cTabCursor := 0; + + inherited Destroy; +end; + +procedure TOvcCustomCalculator.KeyDown(var Key : Word; Shift : TShiftState); +begin + inherited KeyDown(Key, Shift); + + case Key of + VK_DELETE : if Shift = [] then + PressButton(cbClearEntry); + VK_F9 : if Shift = [] then + PressButton(cbChangeSign); + end; +end; + +procedure TOvcCustomCalculator.KeyPress(var Key : Char); +begin + inherited KeyPress(Key); + + case Key of + '0' : PressButton(cb0); + '1' : PressButton(cb1); + '2' : PressButton(cb2); + '3' : PressButton(cb3); + '4' : PressButton(cb4); + '5' : PressButton(cb5); + '6' : PressButton(cb6); + '7' : PressButton(cb7); + '8' : PressButton(cb8); + '9' : PressButton(cb9); + + '+' : PressButton(cbAdd); + '-' : PressButton(cbSub); + '*' : PressButton(cbMul); + '/' : PressButton(cbDiv); + + '.' : PressButton(cbDecimal); + '=' : PressButton(cbEqual); + 'r' : PressButton(cbInvert); + '%' : PressButton(cbPercent); + '@' : PressButton(cbSqrt); + + ^L : PressButton(cbMemClear); {^L} + ^R : PressButton(cbMemRecall); {^R} + ^P : PressButton(cbMemAdd); {^P} + ^S : PressButton(cbMemSub); {^S} + ^T : PressButton(cbTape); {^T} + + ^C : CopyToClipboard; {^C}{copy} + ^V : PasteFromClipboard; {^V}{paste} + + #8 : PressButton(cbBack); {backspace} + #27 : PressButton(cbClear); {esc} + else + if Key = DecimalSeparator then + PressButton(cbDecimal); + end; +end; + +procedure TOvcCustomCalculator.MouseDown(Button : TMouseButton; Shift : TShiftState; X, Y : Integer); +var + B : TOvcCalculatorButton; +begin + SetFocus; + + if Button = mbLeft then begin + cDownButton := cbNone; + for B := Low(cButtons) to High(cButtons) do + if cButtons[B].Visible and PtInRect(cButtons[B].Position, Point(X,Y)) then begin + if (B in [cbMemClear, cbMemRecall]) and (cEngine.Memory = 0) then + Exit; + cDownButton := B; + InvalidateRect(Handle, @cButtons[cDownButton].Position, False); + Break; + end; + end; + + inherited MouseDown(Button, Shift, X, Y); +end; + +procedure TOvcCustomCalculator.MouseUp(Button : TMouseButton; Shift : TShiftState; X, Y : Integer); +begin + if cDownButton = cbNone then + Exit; + + InvalidateRect(Handle, @cButtons[cDownButton].Position, False); + + {if still over the button...} + if PtInRect(cButtons[cDownButton].Position, Point(X,Y)) then + PressButton(cDownButton); + + cDownButton := cbNone; + + inherited MouseUp(Button, Shift, X, Y); +end; + +procedure TOvcCustomCalculator.PasteFromClipboard; +var + I : Integer; + C : AnsiChar; + S : string; +begin + S := Clipboard.AsText; + if S > '' then begin + cClearAll; + for I := 1 to Length(S) do begin + C := S[I]; + if (C in ['0'..'9', DecimalSeparator, '.', '+', '-', '*', '/', '=', '%']) then + KeyPress(C); + end; + end; +end; + +procedure TOvcCustomCalculator.PressButton(Button : TOvcCalculatorButton); + + procedure Initialize; + begin + if (cLastButton <> cbClear) and (Button = cbClear) then begin + cClearAll; + cTape.SpaceTape(TapeSeparatorChar); + end; + + if (csLocked in cEngine.State) then begin + MessageBeep(0); + Exit; + end; + + {this logic is here to make cbEqual clear all the second time} + if (cLastButton in [cbEqual, cbClear, cbNone]) and (Button = cbEqual) then begin + Button := cbClear; + cClearAll; + end; + + if (cLastButton = cbPercent) and (Button in [cbAdd, cbSub, cbMul, cbDiv, cbEqual]) then + cEvaluate(Button) + else if ((((cLastButton in [cbEqual, cbMemRecall]) and + (Button in [cbAdd, cbSub, cbMul, cbDiv])))) and + cEngine.AddOperand(StrToFloat(FDisplayStr), CalcButtontoOperation[Button]) then begin + cEvaluate(Button); + end else if (Button = cbMemStore) then begin + if (cLastButton <> cbEqual) then + cEvaluate(Button); + SetMemory(DisplayValue); + end else if cEngine.AddOperand(LastOperand, CalcButtontoOperation[Button]) then begin + cEvaluate(Button); + + {remove special operations from stack} + if Button in [cbInvert, cbSqrt, cbEqual] then + LastOperand := cEngine.PopOperand; + end; + end; + + procedure NumberButton; + var + D : Extended; + DP : Integer; + begin + begin + if cEngine.LastOperation = coEqual then begin + {clear pending operations if last command was =} + cClearAll; + end; + + if csClear in cEngine.State then begin + if (Decimals < 0) then begin + FDisplayStr := '0.' + StringOfChar('0', -Decimals); + end else begin + FDisplayStr := ''; + cDecimalEntered := False; + end; + end; + + FDisplayStr := FDisplayStr + cButtons[Button].Caption[1]; + if cMinus0 then begin + FDisplayStr := '-' + FDisplayStr; + cMinus0 := False; + end; + + if (Decimals < 0) and not cDecimalEntered then begin + if Pos(DecimalSeparator, FDisplayStr) > 0 then begin + DP := Pos(DecimalSeparator, FDisplayStr); + if FDisplayStr[1] = '0' then + FDisplayStr := Copy(FDisplayStr,2,DP-2) + + Copy(FDisplayStr,DP+1,1) + + DecimalSeparator + + Copy(FDisplayStr,DP+2,Length(FDisplayStr) - DP) + else + FDisplayStr := Copy(FDisplayStr,1,DP-1) + + Copy(FDisplayStr,DP+1,1) + + DecimalSeparator + + Copy(FDisplayStr,DP+2,Length(FDisplayStr) - DP); + end; + end; + D := StrToFloat(FDisplayStr); + LastOperand := D; + if (D <> 0) or + (Pos(DecimalSeparator, FDisplayStr) > 0) then begin + DisplayValue := D; + cSetDisplayString(FDisplayStr); + cEngine.State := [csValid]; + end else begin + FDisplayStr := '0'; + DisplayValue := D; + cEngine.State := [csValid, csClear]; + end; + end; + end; + + procedure DecimalButton; + var + D : Extended; + begin + {check if the decimal was first character entered after a command} + if csClear in cEngine.State then begin + FDisplayStr := '0' + DecimalSeparator; + cSetDisplayString(FDisplayStr); + cDecimalEntered := True; + cEngine.State := [csValid]; + end; + + {check if there is already a decimal separator in the string} + if Pos(DecimalSeparator, FDisplayStr) = 0 then begin + FDisplayStr := FDisplayStr + DecimalSeparator; + if (pos(DecimalSeparator, FDisplayStr) = 1) then + FDisplayStr := '0' + FDisplayStr; + D := StrToFloat(FDisplayStr); + cSetDisplayString(FDisplayStr); + LastOperand := D; + cEngine.State := [csValid]; + cDecimalEntered := True; + end; + end; + + procedure BackButton; + var + D : Extended; + DP : Integer; + SaveSign : string; + begin + if FDisplayStr = '' then exit; + D := StrToFloat(FDisplayStr); + if D <> 0 then begin + if Length(FDisplayStr) > 1 then begin + if (Decimals < 0) and not cDecimalEntered then begin + if Pos(DecimalSeparator, FDisplayStr) > 0 then begin + if FDisplayStr[1] = '-' then begin + SaveSign :='-'; + FDisplayStr := Copy(FDisplayStr,2,Length(FDisplayStr)-1); + end else begin + SaveSign :=''; + end; + DP := Pos(DecimalSeparator, FDisplayStr); + FDisplayStr := '0' + Copy(FDisplayStr,1,DP-2) + + DecimalSeparator + + Copy(FDisplayStr,DP-1,1) + + Copy(FDisplayStr,DP+1,Length(FDisplayStr) - DP); + if (FDisplayStr[1] = '0') and (FDisplayStr[2] <> '.') then + FDisplayStr := Copy(FDisplayStr,2,Length(FDisplayStr)-1); + FDisplayStr := SaveSign + FDisplayStr; + end; + end; + FDisplayStr := Copy(FDisplayStr, 1, Length(FDisplayStr)-1); + LastOperand := StrToFloat(FDisplayStr); + cSetDisplayString(FDisplayStr); + end else begin + LastOperand := 0; + cMinus0 := False; + DisplayValue := LastOperand; + cEngine.State := [csValid, csClear]; + end; + end; + end; + + procedure ClearEntryButton; + begin + begin + FDisplayStr := ''; + LastOperand := 0; + cMinus0 := False; + DisplayValue := LastOperand; + end; + end; + + procedure ChangeSignButton; + begin + if Length(FDisplayStr) > 0 then begin + if FDisplayStr[1] <> '-' then begin + FDisplayStr := '-' + FDisplayStr; + LastOperand := StrToFloat(FDisplayStr); + cSetDisplayString(FDisplayStr); + end else begin + FDisplayStr := Copy(FDisplayStr, 2, Length(FDisplayStr)-1); + LastOperand := StrToFloat(FDisplayStr); + cSetDisplayString(FDisplayStr); + end; + DisplayValue := LastOperand; + end else begin + LastOperand := 0; + cMinus0 := not cMinus0; + DisplayValue := LastOperand; + if cMinus0 then + FDisplayStr := '-'; + cEngine.State := [csValid, csClear]; + end; + end; + + procedure ClearTapeButton; + var + I : Integer; + begin + with Tape do begin + for I := 0 to Count - 1 do begin + Strings[I] := ''; + end; + cTape.RefreshDisplays; + end; + end; + +begin + if not HandleAllocated then + Exit; + + {simulate a button down if needed} + if cDownButton = cbNone then begin + cDownButton := Button; + InvalidateRect(Handle, @cButtons[cDownButton].Position, False); + Update; + end; + + try try + Initialize; + case Button of + cb0..cb9 : NumberButton; + cbDecimal : DecimalButton; + cbBack : BackButton; + cbClearEntry : ClearEntryButton; + cbMemStore, + cbMemClear, + cbMemAdd, + cbMemSub : cInvalidateIndicator; + cbChangeSign : ChangeSignButton; + cbTape : ClearTapeButton; + cbSqrt, + cbInvert : {}; + end; + except + cDisplayError; + end; + finally + {simulate a button up, if the mouse button is up or we aren't focused} + if not Focused or ({$IFNDEF LCL} GetAsyncKeyState(GetLeftButton) {$ELSE} GetKeyState(GetLeftButton) {$ENDIF} and $8000 = 0) then begin + InvalidateRect(Handle, @cButtons[cDownButton].Position, False); + cDownButton := cbNone; + Update; + end; + end; + + cLastButton := Button; + if Assigned(FOnButtonPressed) then + FOnButtonPressed(Self, Button); +end; + +procedure TOvcCustomCalculator.PushOperand(const Value : Extended); +begin + cEngine.PushOperand(Value); + LastOperand := Value; + DisplayValue := Value; +end; + +procedure TOvcCustomCalculator.Paint; +var + B : TOvcCalculatorButton; +begin + Canvas.Font := Font; + Canvas.Brush.Color := clBtnFace; + Canvas.FillRect(ClientRect); + + if Ctl3D then begin + cPanel.BevelOuter := bvLowered; + cPanel.BorderStyle := bsNone; + end else begin + cPanel.BevelOuter := bvNone; + cPanel.BorderStyle := bsSingle; + end; + + {draw buttons} + for B := Low(cButtons) to High(cButtons) do begin + if (B in [cbMemClear, cbMemRecall, cbMemStore, cbMemAdd, cbMemSub]) then begin + if (B in [cbMemClear, cbMemRecall]) and (cEngine.Memory = 0) then + Canvas.Font.Color := FColors.DisabledMemoryButtons + else + Canvas.Font.Color := FColors.MemoryButtons; + end else if (B in [cbBack, cbClearEntry, cbClear, cbTape]) then + Canvas.Font.Color := FColors.EditButtons + else if (B in [cbAdd, cbSub, cbMul, cbDiv, cbEqual]) then + Canvas.Font.Color := FColors.OperatorButtons + else if (B in [cb0..cb9, cbDecimal]) then + Canvas.Font.Color := FColors.NumberButtons + else if (B in [cbInvert, cbChangeSign, cbPercent, cbSqrt]) then + Canvas.Font.Color := FColors.FunctionButtons; + + cDrawCalcButton(cButtons[B], (B = cDownButton)); + end; +end; + +procedure TOvcCustomCalculator.SetBounds(ALeft, ATop, AWidth, AHeight : Integer); +begin + if Height <> AHeight then + if coShowTape in FOptions then + if Top <> ATop then begin + if TapeHeight + (AHeight - Height) > calcDefMinSize then begin + TapeHeight := TapeHeight + (AHeight - Height); + end else begin + TapeHeight := calcDefMinSize; + end + end; + + inherited Setbounds(ALeft, ATop, AWidth, AHeight); + + cCalculateLook; +end; + + +end. diff --git a/components/orpheus/ovccaret.pas b/components/orpheus/ovccaret.pas new file mode 100644 index 000000000..66571f3ab --- /dev/null +++ b/components/orpheus/ovccaret.pas @@ -0,0 +1,690 @@ +{*********************************************************} +{* OVCCARET.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Short-circuit Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovccaret; + {-Caret handling class} + +interface + +uses + {$IFNDEF LCL} Windows, {$ELSE} LclIntf, MyMisc, {$ENDIF} + Graphics, Classes, Controls, Forms; + +type + TOvcCaretShape = ( {Predefined caret shapes..} + csBlock, {..block over whole cell} + csHalfBlock, {..block over bottom part of cell} + csVertLine, {..vertical line to left of cell} + csHorzLine, {..horizontal line on bottom of cell} + csCustom, {..custom width/height} + csBitmap); {..bitmap caret, custom width/height} + + TOvcCaretAlign = ( {Alignment of caret in cell..} + caLeft, {..left side, centered vertically} + caTop, {..top side, centered horizontally} + caRight, {..right side, centered vertically} + caBottom, {..bottom side, centered horizontally} + caCenter); {..centered vertically and horizontally} + +type + {Class defining a caret shape} + TOvcCaret = class(TPersistent) + {.Z+} + protected + {property fields} + FAlign : TOvcCaretAlign; {Caret alignment in cell} + FBitmap : TBitmap; {Bitmap for a bitmapped caret} + FBitmapX : Integer; {Bitmap's hotspot X} + FBitmapY : Integer; {Bitmap's hotspot Y} + FBlinkTime : word; {Blink time} + FCaretHt : Integer; {Height: autosized for some shapes} + FCaretWd : Integer; {Width: autosized for some shapes} + FIsGray : boolean; {True if a 'gray' caret} + FShape : TOvcCaretShape; {Shape} + + FOnChange : TNotifyEvent; {Owner's change notification} + + {internal fields} + RefCount : word; {Reference count} + + {property access methods} + procedure SetAlign(A : TOvcCaretAlign); + procedure SetBitmap(BM : TBitMap); + procedure SetBitmapX(X : Integer); + procedure SetBitmapY(Y : Integer); + procedure SetBlinkTime(BT : word); + procedure SetCaretHeight(CH : Integer); + procedure SetCaretWidth(CW : Integer); + procedure SetIsGray(IG : boolean); + procedure SetShape(S : TOvcCaretShape); + + {general methods} + procedure NotifyChange; + + public + {VCL methods} + constructor Create; + destructor Destroy; override; + + {other methods} + procedure Register; + procedure Deregister; + + {properties} + property OnChange : TNotifyEvent + read FOnChange + write FOnChange; + {.Z-} + + published + {properties} + property Bitmap : TBitmap + read FBitmap write SetBitmap; + property BitmapHotSpotX : Integer + read FBitmapX write SetBitmapX + default 0; + property BitmapHotSpotY : Integer + read FBitmapY write SetBitmapY + default 0; + property Shape : TOvcCaretShape + read FShape write SetShape + default csVertLine; + property Align : TOvcCaretAlign + read FAlign write SetAlign + default caLeft; + property BlinkTime : word + read FBlinkTime write SetBlinkTime + default 0; + property CaretHeight : Integer + read FCaretHt write SetCaretHeight + default 10; + property CaretWidth : Integer + read FCaretWd write SetCaretWidth + default 2; + property IsGray : boolean + read FIsGray write SetIsGray + default False; + end; + +{.Z+} +type + TOvcSingleCaret = class(TPersistent) + {Class defining a Single caret} + protected + {property fields} + FCaretType : TOvcCaret; {Current caret type} + FHeight : Integer; {Cell height} + FLinked : boolean; {True if linked to owner} + FPos : TPoint; {Position within owner} + FVisible : boolean; {True if visible} + FWidth : Integer; {Cell width} + + {other fields} + OrigBlinkTime : word; {Blink time before linking} + Owner : TWinControl; {Owning control} + XOffset : Integer; {X Offset of caret in cell} + YOffset : Integer; {Y Offset of caret in cell} + + {property access methods} + procedure SetCaretType(CT : TOvcCaret); + procedure SetCellHeight(CH : Integer); + procedure SetCellWidth(CW : Integer); + procedure SetLinked(L : boolean); + procedure SetPos(P : TPoint); + procedure SetVisible(V : boolean); + + {general methods} + procedure MakeShape; + procedure Reinit; + procedure ResetPos; + + public + {VCL methods} + constructor Create(AOwner : TWinControl); + destructor Destroy; override; + + {general methods} + procedure CaretTypeHasChanged(Sender : TObject); + + {properties} + property CaretType : TOvcCaret + read FCaretType + write SetCaretType; + + property CellHeight : Integer + read FHeight + write SetCellHeight; + + property CellWidth : Integer + read FWidth + write SetCellWidth; + + property Linked : boolean + read FLinked + write SetLinked + stored false; + + property Position : TPoint + read FPos + write SetPos; + + property Visible : boolean + read FVisible + write SetVisible; + end; + +type + TOvcCaretPair = class(TOvcSingleCaret) + {Class defining a pair of carets, one each for insert/overwrite modes} + protected + {property fields} + FInsMode : boolean; + FInsCaretType : TOvcCaret; + FOvrCaretType : TOvcCaret; + + {property access methods} + procedure SetInsMode(IM : boolean); + procedure SetInsCaretType(ICT : TOvcCaret); + procedure SetOvrCaretType(OCT : TOvcCaret); + + public + {VCL methods} + constructor Create(AOwner : TWinControl); + destructor Destroy; override; + + {properties} + property InsertMode : boolean + read FInsMode + write SetInsMode; + + property InsCaretType : TOvcCaret + read FInsCaretType + write SetInsCaretType; + + property OvrCaretType : TOvcCaret + read FOvrCaretType + write SetOvrCaretType; + end; +{.Z-} + + +implementation + + + +{---TOvcCaret----------------------------------------------------} +constructor TOvcCaret.Create; + begin + inherited Create; + + FShape := csVertLine; + FAlign := caLeft; + FBlinkTime := 0; + FIsGray := False; + FBitMap := TBitMap.Create; + FCaretHt := 10; + FCaretWd := 2; + end; +{--------} +destructor TOvcCaret.Destroy; + begin + FBitMap.Free; + inherited Destroy; + end; +{--------} +procedure TOvcCaret.Deregister; + begin + {decrement the reference count, if no one references us + any more, kill ourselves} + dec(RefCount); + if (RefCount = 0) then + Free; + end; +{--------} +procedure TOvcCaret.NotifyChange; + begin + if Assigned(FOnChange) then + FOnChange(Self); + end; +{--------} +procedure TOvcCaret.Register; + begin + inc(RefCount); + end; +{--------} +procedure TOvcCaret.SetAlign(A : TOvcCaretAlign); + begin + if (A <> FAlign) then + begin + FAlign := A; + NotifyChange; + end; + end; +{--------} +procedure TOvcCaret.SetBitmap(BM : TBitmap); + begin + if not Assigned(BM) then + Exit; + FBitMap.Assign(BM); + NotifyChange; + end; +{--------} +procedure TOvcCaret.SetBitmapX(X : Integer); + begin + if (X <> FBitMapX) then + begin + FBitMapX := X; + if (Shape = csBitMap) then + NotifyChange; + end; + end; +{--------} +procedure TOvcCaret.SetBitmapY(Y : Integer); + begin + if (Y <> FBitMapY) then + begin + FBitMapY := Y; + if (Shape = csBitMap) then + NotifyChange; + end; + end; +{--------} +procedure TOvcCaret.SetBlinkTime(BT : word); + begin + if (BT <> FBlinkTime) then + begin + FBlinkTime := BT; + NotifyChange; + end; + end; +{--------} +procedure TOvcCaret.SetCaretHeight(CH : Integer); + begin + if (CH <> FCaretHt) and (CH > 0) then + begin + FCaretHt := CH; + NotifyChange; + end; + end; +{--------} +procedure TOvcCaret.SetCaretWidth(CW : Integer); + begin + if (CW <> FCaretWd) and (CW > 0) then + begin + FCaretWd := CW; + NotifyChange; + end; + end; +{--------} +procedure TOvcCaret.SetIsGray(IG : boolean); + begin + if (IG <> FIsGray) then + begin + FIsGray := IG; + NotifyChange; + end; + end; +{--------} +procedure TOvcCaret.SetShape(S : TOvcCaretShape); + begin + if (S <> FShape) then + begin + FShape := S; + case FShape of + csBlock: + FAlign := caLeft; + csVertLine : + begin + FAlign := caLeft; + FCaretWd := 2; + end; + csHalfBlock: + FAlign := caBottom; + csHorzLine : + begin + FAlign := caBottom; + FCaretHt := 2; + end; + csBitmap : + begin + FCaretHt := FBitMap.Height; + FCaretWd := FBitMap.Width; + end; + end;{case} + NotifyChange; + end; + end; +{--------------------------------------------------------------------} + + +{---TOvcSingleCaret--------------------------------------------------} +constructor TOvcSingleCaret.Create(AOwner : TWinControl); + begin + inherited Create; + Owner := AOwner; + + FHeight := 10; + FWidth := 10; + + {make our default caret type} + FCaretType := TOvcCaret.Create; + FCaretType.Register; + Reinit; + end; +{--------} +destructor TOvcSingleCaret.Destroy; + begin + Visible := false; + Linked := false; + FCaretType.Deregister; + + inherited Destroy; + end; +{--------} +procedure TOvcSingleCaret.CaretTypeHasChanged(Sender : TObject); + var + WasLinked : boolean; + begin + {if something has changed about the caret, unlink from + our owner, recalc our values, relink} + WasLinked := Linked; + Linked := false; + Reinit; + Linked := WasLinked; + end; +{--------} +procedure TOvcSingleCaret.MakeShape; + begin + {don't bother if we aren't linked to anything or if we + don't have a caret type} + if (not Linked) or (not Assigned(FCaretType)) then + Exit; + + {create the caret, and if necessary show it} + with FCaretType do + if (Shape = csBitmap) then + CreateCaret(Owner.Handle, Bitmap.Handle, 0, 0) + else CreateCaret(Owner.Handle, ord(IsGray), CaretWidth, CaretHeight); + if Visible then + ShowCaret(Owner.Handle); + end; +{--------} +procedure TOvcSingleCaret.Reinit; + var + NewXOfs : Integer; + NewYOfs : Integer; + begin + {don't bother if we don't have a caret type} + if (not Assigned(FCaretType)) then + Exit; + + {inits} + NewXOfs := 0; + NewYOfs := 0; + + with FCaretType do + begin + {stop recursion} + OnChange := nil; + + {recalc the caret type's height and width} + if (Shape <> csBitmap) and (Shape <> csCustom) then + begin + case Shape of + csBlock : + begin + CaretHeight := FHeight; + CaretWidth := FWidth; + end; + csHalfBlock: + begin + CaretHeight := FHeight div 2; + CaretWidth := FWidth; + end; + csVertLine : CaretHeight := FHeight; + csHorzLine : CaretWidth := FWidth; + end;{case} + end; + + {allow changes to percolate through again} + OnChange := CaretTypeHasChanged; + + {recalc the X and Y offsets} + case Align of + caLeft : begin + NewXOfs := 0; + NewYOfs := (FHeight - CaretHeight) div 2; + end; + caTop : begin + NewXOfs := (FWidth - CaretWidth) div 2; + NewYOfs := 0; + end; + caRight : begin + NewXOfs := FWidth - CaretWidth; + NewYOfs := (FHeight - CaretHeight) div 2;; + end; + caBottom : begin + NewXOfs := (FWidth - CaretWidth) div 2; + NewYOfs := FHeight - CaretHeight; + end; + caCenter : begin + NewXOfs := (FWidth - CaretWidth) div 2; + NewYOfs := (FHeight - CaretHeight) div 2; + end; + end;{case} + if (Shape = csBitMap) then + begin + dec(NewXOfs, BitMapHotSpotX); + dec(NewYOfs, BitMapHotSpotY); + end; + if (NewXOfs <> XOffset) or (NewYOfs <> YOffset) then + begin + XOffset := NewXOfs; + YOffset := NewYOfs; + if Linked then + ResetPos; + end; + end; + end; +{--------} +procedure TOvcSingleCaret.ResetPos; + var + NewX, NewY : Integer; + begin + if (FPos.X = MaxInt) then + NewX := MaxInt + else NewX := FPos.X + XOffset; + if (FPos.Y = MaxInt) then + NewY := MaxInt + else NewY := FPos.Y + YOffset; + SetCaretPos(NewX, NewY); + end; +{--------} +procedure TOvcSingleCaret.SetCaretType(CT : TOvcCaret); + begin + if (CT <> FCaretType) then + begin + FCaretType.Deregister; + FCaretType := CT; + FCaretType.Register; + FCaretType.OnChange := CaretTypeHasChanged; + CaretTypeHasChanged(Self); + end; + end; +{--------} +procedure TOvcSingleCaret.SetCellHeight(CH : Integer); + begin + if (CH <> FHeight) and (CH > 0) then + begin + FHeight := CH; + CaretTypeHasChanged(Self); + end; + end; +{--------} +procedure TOvcSingleCaret.SetCellWidth(CW : Integer); + begin + if (CW <> FWidth) and (CW > 0) then + begin + FWidth := CW; + CaretTypeHasChanged(Self); + end; + end; +{--------} +procedure TOvcSingleCaret.SetLinked(L : boolean); + begin + if (L <> FLinked) then + begin + FLinked := L; + if Assigned(Owner) and Owner.HandleAllocated then + if FLinked then + begin + OrigBlinkTime := GetCaretBlinkTime; + MakeShape; + ResetPos; + if (OrigBlinkTime <> CaretType.BlinkTime) then + if (CaretType.BlinkTime <> 0) then + SetCaretBlinkTime(CaretType.BlinkTime); + end + else + begin + SetCaretBlinkTime(OrigBlinkTime); +{$IFNDEF LCL} + DestroyCaret; +{$ELSE} + DestroyCaret(Owner.Handle); +{$ENDIF} + end + else + FLinked := false; + end; + end; +{--------} +procedure TOvcSingleCaret.SetPos(P : TPoint); + begin + if (P.X < 0) then + P.X := MaxInt; + if (P.Y < 0) then + P.Y := MaxInt; + if (P.X <> FPos.X) or (P.Y <> FPos.Y) then + begin + FPos := P; + if Linked then + ResetPos; + end; + end; +{--------} +procedure TOvcSingleCaret.SetVisible(V : boolean); + begin + if (V <> FVisible) then + begin + FVisible := V; + if Linked then + if Owner.HandleAllocated then + if FVisible then + ShowCaret(Owner.Handle) + else + HideCaret(Owner.Handle); + end; + end; + + +{---TOvcCaretPair----------------------------------------------------} +constructor TOvcCaretPair.Create(AOwner : TWinControl); + begin + inherited Create(AOwner); + + FInsCaretType := TOvcCaret.Create; + FInsCaretType.Register; + + FOvrCaretType := TOvcCaret.Create; + FOvrCaretType.Register; + FOvrCaretType.Shape := csBlock; + + FInsMode := True; + + if FInsMode then + CaretType := FInsCaretType + else + CaretType := FOvrCaretType + end; + +destructor TOvcCaretPair.Destroy; +begin + FInsCaretType.Deregister; + FOvrCaretType.Deregister; + + inherited Destroy; +end; + +procedure TOvcCaretPair.SetInsMode(IM : boolean); + begin + if (IM <> FInsMode) then + begin + FInsMode := IM; + if FInsMode then + CaretType := FInsCaretType + else CaretType := FOvrCaretType; + end; + end; +{--------} +procedure TOvcCaretPair.SetInsCaretType(ICT : TOvcCaret); + begin + if (ICT <> FInsCaretType) then + begin + FInsCaretType.Deregister; + FInsCaretType := ICT; + FInsCaretType.Register; + if InsertMode then + CaretType := FInsCaretType; + end; + end; +{--------} +procedure TOvcCaretPair.SetOvrCaretType(OCT : TOvcCaret); + begin + if (OCT <> FOvrCaretType) then + begin + FOvrCaretType.Deregister; + FOvrCaretType := OCT; + FOvrCaretType.Register; + if not InsertMode then + CaretType := FOvrCaretType; + end; + end; +{--------------------------------------------------------------------} + + +end. diff --git a/components/orpheus/ovcclrcb.pas b/components/orpheus/ovcclrcb.pas new file mode 100644 index 000000000..63dd32103 --- /dev/null +++ b/components/orpheus/ovcclrcb.pas @@ -0,0 +1,330 @@ +{*********************************************************} +{* OVCCLRCB.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovcclrcb; + {-color ComboBox selector} + +interface + +uses + {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, LclType, LResources, MyMisc, {$ENDIF} + Classes, Controls, Forms, Graphics, Menus, StdCtrls, + OvcCmbx, OvcConst, OvcData; + +type + TOvcCustomColorComboBox = class(TOvcBaseComboBox) + protected {private} + {property Variables} + FShowColorNames : Boolean; + + {internal variables} + BoxWidth : Integer; + + {property methods} + function GetSelectedColor : TColor; + procedure SetSelectedColor(Value : TColor); + procedure SetShowColorNames(Value : Boolean); + function ColorFromString(Str: string): TColor; + + {internal methods} + procedure CalculateBoxWidth; + + {message methods} + procedure CMFontChanged(var Message : TMessage); + message CM_FONTCHANGED; + + procedure CreateWnd; override; + + property SelectedColor : TColor + read GetSelectedColor write SetSelectedColor; + property ShowColorNames : Boolean + read FShowColorNames write SetShowColorNames default True; + + public + constructor Create(AOwner : TComponent); override; + destructor Destroy; override; + procedure DrawItem(Index : Integer; Rect : TRect; State : TOwnerDrawState); + override; + procedure SetBounds(ALeft, ATop, AWidth, AHeight : Integer); + override; + end; + + TOvcColorComboBox = class(TOvcCustomColorComboBox) + published + {$IFDEF VERSION4} + property Anchors; + property Constraints; + property DragKind; + {$ENDIF} + property About; + property Color; + property Ctl3D; + property Cursor; + property DragCursor; + property DragMode; + property DropDownCount; + property Enabled; + property Font; + property HotTrack; +// property Items; + property ItemHeight; + property LabelInfo; + property ParentColor; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property SelectedColor default clBlack; + property ShowColorNames; + property ShowHint; + property TabOrder; + property TabStop; + property Text; + property Visible; + + {events} + property AfterEnter; + property AfterExit; + property OnChange; + property OnClick; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnDropDown; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnSelectionChange; + property OnStartDrag; + property OnMouseWheel; + end; + +implementation + +procedure TOvcCustomColorComboBox.CalculateBoxWidth; +var + I : Integer; + X : Integer; + T : Integer; +begin + if not HandleAllocated or (BoxWidth > 0) then + Exit; + + if not FShowColorNames then begin + BoxWidth := ClientWidth - 1; + Exit; + end; + + Canvas.Font := Font; + BoxWidth := 0; + T := 0; + + {calculate width of the color box} + for I := 0 to pred(Items.Count) do begin + X := Canvas.TextWidth(Items[I]+'X'); + if X > T then + T := X; + end; + + BoxWidth := ClientWidth - T; + if BoxWidth < 25 then + BoxWidth := 25; +end; + +procedure TOvcCustomColorComboBox.CMFontChanged(var Message : TMessage); +begin + inherited; + + BoxWidth := 0; + Invalidate; +end; + +constructor TOvcCustomColorComboBox.Create(AOwner : TComponent); +begin + inherited Create(AOwner); + + {disable MRU list} + FMRUList.MaxItems := 0; + + Style := ocsDropDownList; + + FShowColorNames := True; +end; + +destructor TOvcCustomColorComboBox.Destroy; +begin + inherited; +end; + +{ - modified} +procedure TOvcCustomColorComboBox.CreateWnd; +begin + inherited CreateWnd; + + Text := ''; + Items.Clear; + Items.Add(GetOrphStr(SCColorBlack)); + Items.Add(GetOrphStr(SCColorMaroon)); + Items.Add(GetOrphStr(SCColorGreen)); + Items.Add(GetOrphStr(SCColorOlive)); + Items.Add(GetOrphStr(SCColorNavy)); + Items.Add(GetOrphStr(SCColorPurple)); + Items.Add(GetOrphStr(SCColorTeal)); + Items.Add(GetOrphStr(SCColorGray)); + Items.Add(GetOrphStr(SCColorSilver)); + Items.Add(GetOrphStr(SCColorRed)); + Items.Add(GetOrphStr(SCColorLime)); + Items.Add(GetOrphStr(SCColorYellow)); + Items.Add(GetOrphStr(SCColorBlue)); + Items.Add(GetOrphStr(SCColorFuchsia)); + Items.Add(GetOrphStr(SCColorAqua)); + Items.Add(GetOrphStr(SCColorLightGray)); + Items.Add(GetOrphStr(SCColorMediumGray)); + Items.Add(GetOrphStr(SCColorDarkGray)); + Items.Add(GetOrphStr(SCColorWhite)); + Items.Add(GetOrphStr(SCColorMoneyGreen)); + Items.Add(GetOrphStr(SCColorSkyBlue)); + Items.Add(GetOrphStr(SCColorCream)); + + ItemIndex := 0; +end; + +procedure TOvcCustomColorComboBox.DrawItem(Index : Integer; Rect : TRect; + State : TOwnerDrawState); +var + BC : TColor; + S : string; +begin + {get selected color and text to display} + if Index > -1 then begin + S := Items[Index]; + BC := ColorFromString(S); + end else begin + S := GetOrphStr(SCColorBlack); + BC := clBlack; + end; + + CalculateBoxWidth; + + Canvas.Font.Color := Font.Color; + Canvas.Brush.Color := Color; + + if FShowColorNames then begin + Canvas.Pen.Color := Canvas.Brush.Color; + Canvas.Rectangle(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom); + Inc(Rect.Left); + DrawText(Canvas.Handle, @S[1], Length(S), Rect, + DT_LEFT or DT_VCENTER or DT_SINGLELINE); + end; + + Canvas.Pen.Color := Font.Color; + Canvas.Brush.Color := BC; + Canvas.Rectangle(ClientWidth - BoxWidth, Rect.Top + 1, Rect.Right -1, + Rect.Bottom - 1); +end; + +function TOvcCustomColorComboBox.GetSelectedColor : TColor; +begin + if ItemIndex > -1 then + Result := ColorFromString(Items[ItemIndex]) + else + Result := clBlack; +end; + +procedure TOvcCustomColorComboBox.SetBounds(ALeft, ATop, AWidth, AHeight : Integer); +begin + inherited SetBounds(ALeft, ATop, AWidth, AHeight); + BoxWidth := 0; + Invalidate; +end; + +procedure TOvcCustomColorComboBox.SetSelectedColor(Value : TColor); +var + I : Integer; +begin + for I := 0 to Pred(Items.Count) do + if Value = ColorFromString(Items[I]) then begin + ItemIndex := I; + Change; + Break; + end; +end; + +{ - New} +function TOvcCustomColorComboBox.ColorFromString(Str: string):TColor; +begin + if Str = GetOrphStr(SCColorBlack) then result := clBlack + else if Str = GetOrphStr(SCColorMaroon) then result := clMaroon + else if Str = GetOrphStr(SCColorGreen) then result := clGreen + else if Str = GetOrphStr(SCColorOlive) then result := clOlive + else if Str = GetOrphStr(SCColorNavy) then result := clNavy + else if Str = GetOrphStr(SCColorPurple) then result := clPurple + else if Str = GetOrphStr(SCColorTeal) then result := clTeal + else if Str = GetOrphStr(SCColorGray) then result := clGray + else if Str = GetOrphStr(SCColorSilver) then result := clSilver + else if Str = GetOrphStr(SCColorRed) then result := clRed + else if Str = GetOrphStr(SCColorLime) then result := clLime + else if Str = GetOrphStr(SCColorYellow) then result := clYellow + else if Str = GetOrphStr(SCColorBlue) then result := clBlue + else if Str = GetOrphStr(SCColorFuchsia) then result := clFuchsia + else if Str = GetOrphStr(SCColorAqua) then result := clAqua + else if Str = GetOrphStr(SCColorLightGray) then result := TColor($C0C0C0) + else if Str = GetOrphStr(SCColorMediumGray) then result := TColor($A4A0A0) + else if Str = GetOrphStr(SCColorDarkGray) then result := TColor($808080) + else if Str = GetOrphStr(SCColorWhite) then result := clWhite + else if Str = GetOrphStr(SCColorMoneyGreen) then result := TColor($C0DCC0) + else if Str = GetOrphStr(SCColorSkyBlue) then result := TColor($F0CAA6) + else if Str = GetOrphStr(SCColorCream) then result := TColor($F0FBFF) + else result := clBlack; +end; + +procedure TOvcCustomColorComboBox.SetShowColorNames(Value : Boolean); +begin + if Value <> FShowColorNames then begin + FShowColorNames := Value; + BoxWidth := 0; + Invalidate; + end; +end; + +end. diff --git a/components/orpheus/ovccmbx.pas b/components/orpheus/ovccmbx.pas new file mode 100644 index 000000000..606692185 --- /dev/null +++ b/components/orpheus/ovccmbx.pas @@ -0,0 +1,1701 @@ +{*********************************************************} +{* OVCCMBX.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovccmbx; + +interface + +uses + {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, LclType, LResources, MyMisc, {$ENDIF} + SysUtils, Classes, Graphics, Controls, Forms, StdCtrls, + Buttons, OvcBase, OvcConst, OvcData, OvcMisc, OvcBordr {$IFNDEF LCL}, OvcTimer {$ENDIF}; + +type + {this class implements a stack for keeping track of + most recently used items in the ComboBox} + TOvcMRUList = class + protected {private} + {property variables} + FMaxItems : Integer; {maximum items to keep} + FList : TStrings; {the items themselves} + + {property methods} + procedure SetMaxItems(Value: Integer); + + public + procedure Clear; + constructor Create; + destructor Destroy; + override; + + procedure NewItem(const Item : string; Obj : TObject); + procedure Shrink; + function RemoveItem(const Item : string) : Boolean; + + property Items : TStrings + read FList; + + property MaxItems : Integer + read FMaxItems + write SetMaxItems; + end; + +const + cbxSeparatorHeight = 3; + +type + TOvcComboStyle = (ocsDropDown, ocsDropDownList); + + TOvcHTColors = class(TPersistent) + protected {private} + FHighlight : TColor; + FShadow : TColor; + + public + constructor Create; + virtual; + + published + property Highlight : TColor + read FHighlight + write FHighlight + default clBtnHighlight; + + property Shadow : TColor + read FShadow + write FShadow + default clBtnShadow; + end; + + TOvcBaseComboBox = class(TCustomComboBox) + protected {private} + {property variables} + FAutoSearch : Boolean; + FBorders : TOvcBorders; + FDrawingEdit : Boolean; + FDroppedWidth : Integer; + FHotTrack : Boolean; + FHTBorder : Boolean; + FHTColors : TOvcHTColors; + FKeyDelay : Integer; + FItemHeight : Integer; {hides inherited property} + FLabelInfo : TOvcLabelInfo; + FMRUListColor : TColor; + FMRUListCount : Integer; + FStyle : TOvcComboStyle; + + {event variables} + FAfterEnter : TNotifyEvent; + FAfterExit : TNotifyEvent; + FOnMouseWheel : TMouseWheelEvent; + FOnSelChange : TNotifyEvent; {called when the selection changes} + + {internal variables} + FEventActive : Boolean; + FIsFocused : Boolean; + FIsHot : Boolean; + FLastKeyWasBackSpace : Boolean; + FMRUList : TOvcMRUList; + FList : TStringList; {Items sans MRU Items} + FListIndex : Integer; {ItemIndex sans MRU Items} + FSaveItemIndex : Integer; + FStandardHomeEnd : Boolean; + FTimer : Integer; {timer-pool handle} + + FCurItemIndex : integer; + + {internal methods} + procedure HotTimerEvent(Sender : TObject; Handle : Integer; + Interval : Cardinal; ElapsedTime : LongInt); + procedure TimerEvent(Sender : TObject; Handle : Integer; + Interval : Cardinal; ElapsedTime : LongInt); + + {property methods} + procedure SetAbout(const Value : string); + procedure SetDroppedWidth(Value : Integer); + procedure SetHotTrack(Value : Boolean); + procedure SetItemHeight(Value : Integer); + {$IFDEF VERSION6}reintroduce;{$ENDIF} + function GetListIndex: Integer; + procedure SetListIndex(Value: Integer); + function GetList : TStrings; + function GetMRUList: TStrings; + procedure SetKeyDelay(Value : Integer); + procedure SetMRUListCount(Value : Integer); + procedure SetOcbStyle(Value : TOvcComboStyle); + procedure SetStandardHomeEnd(Value : Boolean); + + {internal methods} + procedure AddItemToMRUList(Index: Integer); + +{ - HWnd changed to TOvcHWnd for BCB Compatibility } + procedure CheckHot(HotWnd : TOvcHWnd{hWnd}); + + function GetAttachedLabel : TOvcAttachedLabel; + function GetAbout : string; + procedure LabelAttach(Sender : TObject; Value : Boolean); + procedure LabelChange(Sender : TObject); + procedure PositionLabel; + procedure RecalcHeight; + procedure SetHot; + procedure UpdateMRUList; + procedure UpdateMRUListModified; + procedure MRUListUpdate(Count : Integer); + + {private message methods} + procedure OMAssignLabel(var Msg : TMessage); + message OM_ASSIGNLABEL; + procedure OMPositionLabel(var Msg : TMessage); + message OM_POSITIONLABEL; + procedure OMRecordLabelPosition(var Msg : TMessage); + message OM_RECORDLABELPOSITION; + procedure OMAfterEnter(var Msg : TMessage); + message OM_AFTERENTER; + procedure OMAfterExit(var Msg : TMessage); + message OM_AFTEREXIT; + + {windows message methods} + procedure CNCommand(var Message: TWmCommand); + message CN_COMMAND; + procedure CNDrawItem(var Msg : TWMDrawItem); + message CN_DRAWITEM; + procedure WMKillFocus(var Msg : TWMKillFocus); + message WM_KILLFOCUS; + procedure WMMeasureItem(var Message : TMessage); + message WM_MEASUREITEM; + procedure WMMouseWheel(var Msg : TMessage); + message WM_MOUSEWHEEL; + procedure WMSetFocus(var Msg : TWMSetFocus); + message WM_SETFOCUS; + + {VCL message methods} + procedure CMVisibleChanged(var Msg : TMessage); + message CM_VISIBLECHANGED; + procedure CMFontChanged(var Message: TMessage); + message CM_FONTCHANGED; + procedure CMMouseEnter (var Message : TMessage); message CM_MOUSEENTER; + procedure CMMouseLeave (var Message : TMessage); message CM_MOUSELEAVE; + + protected + {descendants can set the value of this variable after calling inherited } + {create to set the default location and point-of-reference (POR) for the} + {attached label. if dlpTopLeft, the default location and POR will be at } + {the top left of the control. if dlpBottomLeft, the default location and} + {POR will be at the bottom left} + DefaultLabelPosition : TOvcLabelPosition; + +{ - HWnd changed to TOvcHWnd for BCB Compatibility } + procedure ComboWndProc(var Message: TMessage; + ComboWnd: TOvcHWnd{HWnd}; ComboProc: Pointer); + {$IFDEF CBuilder} reintroduce; {$ELSE} {$IFNDEF LCL} override; {$ENDIF} {$ENDIF} + + procedure CreateParams(var Params : TCreateParams); + override; + procedure CreateWnd; + override; + procedure DestroyWnd; + override; + procedure DoOnMouseWheel(Shift : TShiftState; + Delta, XPos, YPos : SmallInt); + dynamic; + procedure DoExit; + override; + procedure DrawItem(Index : Integer; ItemRect : TRect; State : TOwnerDrawState); + override; + procedure KeyDown(var Key : Word; Shift: TShiftState); + override; + procedure Loaded; + override; + procedure MeasureItem(Index : Integer; var IHeight : Integer); + override; + procedure Notification(AComponent : TComponent; Operation : TOperation); + override; + procedure WndProc(var Message: TMessage); + override; + + procedure SelectionChanged; + virtual; + + procedure BorderChanged(ABorder : TObject); + procedure Paint; + procedure PaintBorders; + +{ - Hdc changed to TOvcHdc for BCB Compatibility } + procedure PaintWindow(DC : TOvcHdc{HDC}); + {$IFDEF CBuilder} reintroduce; {$ELSE} override; {$ENDIF} + + procedure WMPaint(var Msg : TWMPaint); message WM_PAINT; + + procedure SetHTBorder(Value : Boolean); + procedure SetHTColors(Value : TOvcHTColors); + + {properties} + property About : string + read GetAbout write SetAbout stored False; + property AutoSearch : Boolean + read FAutoSearch write FAutoSearch + default True; + property ItemHeight: Integer + read FItemHeight write SetItemHeight; + property KeyDelay : Integer + read FKeyDelay write SetKeyDelay + default 500; + property LabelInfo : TOvcLabelInfo + read FLabelInfo write FLabelInfo; + property MRUListColor: TColor + read FMRUListColor write FMRUListColor + default clWindow; + property MRUListCount : Integer + read FMRUListCount write SetMRUListCount + default 3; + property Style : TOvcComboStyle + read FStyle write SetOcbStyle; + + {events} + property AfterEnter : TNotifyEvent + read FAfterEnter write FAfterEnter; + property AfterExit : TNotifyEvent + read FAfterExit write FAfterExit; + + property OnMouseWheel : TMouseWheelEvent + read FOnMouseWheel write FOnMouseWheel; + + property OnSelectionChange : TNotifyEvent + read FOnSelChange write FOnSelChange; + + public + constructor Create(AOwner : TComponent); + override; + destructor Destroy; + override; + property DrawingEdit : Boolean + read FDrawingEdit; + + procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); + override; + function AddItem(const Item : string; + AObject : TObject) : Integer; + {$IFDEF VERSION4}reintroduce;{$ENDIF} + procedure AssignItems(Source: TPersistent); + procedure ClearItems; + procedure InsertItem(Index : Integer; const Item : string; + AObject: TObject); + procedure RemoveItem(const Item : string); + + procedure ClearMRUList; + procedure ForceItemsToMRUList(Value: Integer); + + property AttachedLabel : TOvcAttachedLabel + read GetAttachedLabel; + + property DroppedWidth : Integer + read FDroppedWidth + write SetDroppedWidth + default -1; + + property HotTrack : Boolean + read FHotTrack + write SetHotTrack + default False; + + property List: TStrings + read GetList; + + property ListIndex: Integer + read GetListIndex write SetListIndex; + + property MRUList: TStrings + read GetMRUList; + + property StandardHomeEnd : Boolean + read FStandardHomeEnd write SetStandardHomeEnd; + + published + property Borders : TOvcBorders + read FBorders + write FBorders; + + property HotTrackBorder : Boolean + read FHTBorder + write SetHTBorder + default True; + + property HotTrackColors : TOvcHTColors + read FHTColors + write SetHTColors; + {$IFDEF VERSION6} + property AutoComplete + default False; + {$ENDIF} + end; + + {TOvcComboBox} + + TOvcComboBox = class(TOvcBaseComboBox) + published + {properties} + {$IFDEF VERSION4} + property Anchors; + property Constraints; + property DragKind; + {$ENDIF} + property About; + property AutoSearch; + property Color; + property Ctl3D; + property Cursor; + property DragCursor; + property DragMode; + property DropDownCount; + property DroppedWidth; + property Enabled; + property Font; + property HotTrack; +{$IFNDEF LCL} + property ImeMode; + property ImeName; +{$ENDIF} + property ItemHeight; + property Items; + property KeyDelay; + property LabelInfo; + property MaxLength; + property MRUListColor; + property MRUListCount; + property ParentColor; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ShowHint; + property Sorted; + property Style default ocsDropDown; + property TabOrder; + property TabStop; + property Text; + property Visible; + + {events} + property AfterEnter; + property AfterExit; + property OnChange; + property OnClick; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnDropDown; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnSelectionChange; + property OnStartDrag; + property OnMouseWheel; + end; + +implementation + +uses + OvcVer, OvcExcpt; + +constructor TOvcHTColors.Create; +begin + inherited Create; + + {create color objects and assign defaults} + FHighlight := clBtnHighlight; + FShadow := clBtnShadow; +end; + +{*** TOvcMRUList ***} + +constructor TOvcMRUList.Create; +begin + FList := TStringList.Create; + FMaxItems := 3; +end; + +destructor TOvcMRUList.Destroy; +begin + FList.Free; + + inherited Destroy; +end; + +procedure TOvcMRUList.NewItem(const Item: string; Obj: TObject); +var + Index: Integer; +begin + Index := FList.IndexOf(Item); + if Index > -1 then begin + { If the item is already in the list, just bring it to the top } + FList.Delete(Index); + FList.InsertObject(0, Item, Obj); + end else begin + FList.InsertObject(0, Item, Obj); + {this may result in more items in the list than are allowed,} + {but a call to Shrink will remove the excess items} + Shrink; + end; +end; + +function TOvcMRUList.RemoveItem(const Item : string) : Boolean; +var + Index : Integer; +begin + Index := FList.IndexOf(Item); + if (Index > -1) and (Index < FList.Count) then begin + FList.Delete(Index); + Result := True; + end else + Result := False; +end; + +procedure TOvcMRUList.Shrink; +begin + while FList.Count > FMaxItems do + FList.Delete(FList.Count - 1); +end; + +procedure TOvcMRUList.Clear; +begin + FList.Clear; +end; + +procedure TOvcMRUList.SetMaxItems(Value: Integer); +begin + FMaxItems := Value; + Shrink; +end; + + +{*** TOvcBaseComboBox ***} + +procedure TOvcBaseComboBox.CMVisibleChanged(var Msg : TMessage); +begin + inherited; + + if csLoading in ComponentState then + Exit; + + if LabelInfo.Visible then + AttachedLabel.Visible := Visible; +end; + +procedure TOvcBaseComboBox.ClearItems; +begin + ClearMRUList; + if HandleAllocated then + Clear; +end; + +procedure TOvcBaseComboBox.ClearMRUList; +var + I : Integer; +begin + if (FMRUList.Items.Count > 0) then begin + for I := 1 to FMRUList.Items.Count do + if (I <= Items.Count) then + Items.Delete(0); + FMRUList.Clear; + end; +end; + +{ - added} +procedure TOvcBaseComboBox.ForceItemsToMRUList(Value: Integer); +var + I, J: Integer; + Str: string; +begin + if (Value > 0) or (Value <= FMRUList.MaxItems) then begin + for I := 0 to pred(Value) do begin + Str := Items.Strings[I]; + J := I + 1; + while (J < Items.Count) and (Items.Strings[J] <> Str) do + Inc(J); + if (J < Items.Count) then begin + Items.Delete(I); + AddItemToMRUList(J - 1); + end; + end; + end; + + UpdateMRUList; +end; + +procedure TOvcBaseComboBox.CNDrawItem(var Msg : TWMDrawItem); +begin + {gather flag information that Borland left out} + FDrawingEdit := (ODS_COMBOBOXEDIT and Msg.DrawItemStruct.itemState) <> 0; + inherited; +end; + +function TOvcBaseComboBox.GetList : TStrings; +var + I : Integer; +begin + FList.Clear; + FList.Assign(Items); + if FMRUList.Items.Count > 0 then + for I := 0 to Pred(FMRUList.Items.Count) do + FList.Delete(0); + Result := FList; +end; + +{ - Added} +function TOvcBaseComboBox.GetMRUList: TStrings; +begin + result := FMRUList.FList; +end; + +procedure TOvcBaseComboBox.SetListIndex(Value : Integer); + {Value is the index into the list sans MRU items} +var + I : Integer; +begin + I := FMRUList.Items.Count; + if (((Value + I) < Items.Count) and (Value >= 0)) then + ItemIndex := Value + I + else + ItemIndex := -1; +end; + +function TOvcBaseComboBox.GetListIndex; + {Translates ItemIndex into index sans MRU Items} +begin + Result := ItemIndex - FMRUList.Items.Count; +end; + +procedure TOvcBaseComboBox.AssignItems(Source: TPersistent); +begin + Clear; + Items.Assign(Source); + RecalcHeight; +end; + +function TOvcBaseComboBox.AddItem(const Item : + string; AObject : TObject) : Integer; +begin + Result := -1; + if (Items.IndexOf(Item) < 0) then begin + Result := Items.AddObject(Item, AObject) - FMRUList.Items.Count; + UpdateMRUList; + end; + RecalcHeight; +end; + +procedure TOvcBaseComboBox.InsertItem(Index : Integer; + const Item : string; AObject: TObject); +var + I : Integer; +begin + I := FMRUList.Items.Count; + if (Index> -1) and (Index < (Items.Count - I)) then begin + Items.InsertObject(Index + I, Item, AObject); + UpdateMRUList; + end; + RecalcHeight; +end; + +procedure TOvcBaseComboBox.RemoveItem(const Item : string); +var + I : Integer; + SelChange : Boolean; +begin + if FMRUList.RemoveItem(Item) then + UpdateMRUListModified; + I := Items.IndexOf(Item); + if (I > -1) then begin + SelChange := (ItemIndex = I); + Items.Delete(I); + UpdateMRUList; + if SelChange then begin + Text := ''; + SelectionChanged; + end; + RecalcHeight; + end; +end; + +procedure TOvcBaseComboBox.AddItemToMRUList(Index: Integer); +var + I : Integer; +begin + I := FMRUList.Items.Count; + if (I > -1) and (Index > -1) then begin + FMRUList.NewItem(Items[Index], Items.Objects[Index]); + if FMRUList.Items.Count > I then + Items.InsertObject(0, Items[Index], Items.Objects[Index]); + end; +end; + +procedure TOvcBaseComboBox.UpdateMRUList; +begin + MRUListUpdate(FMRUList.Items.Count); +end; + +procedure TOvcBaseComboBox.UpdateMRUListModified; + {Use this to update MRUList after removing item from MRUList} +begin + MRUListUpdate(FMRUList.Items.Count + 1); +end; + +procedure TOvcBaseComboBox.MRUListUpdate(Count : Integer); +var + I, + L : Integer; + SrchText : PChar; +begin + L := Length(Text) + 1; + GetMem(SrchText, L); + try + StrPCopy(SrchText, Text); + {the first items are part of the MRU list} + if (Count > 0) then + for I := 1 to Count do + Items.Delete(0); + {make sure the MRU list is limited to its maximum size} + FMRUList.Shrink; + {add the MRU list items to the beginning of the combo list} + if (FMRUList.Items.Count > 0) then begin + for I := Pred(FMRUList.Items.Count) downto 0 do + Items.InsertObject(0, FMRUList.Items[I], FMRUList.Items.Objects[I]); + + {this is necessary because we are always inserting item 0 and Windows + thinks that it knows the height of all other items, so it only sends + a WM_MEASUREITEM for item 0. We need the last item of the MRU list + to be taller so we can draw a separator under it} + SendMessage(Handle, CB_SETITEMHEIGHT, wParam(FMRUList.Items.Count - 1), + lParam(FItemHeight + cbxSeparatorHeight)); + end; + ItemIndex := SendMessage(Handle, + CB_FINDSTRINGEXACT, + FMRUList.Items.Count - 1, + LongInt(SrchText)); + finally + FreeMem(SrchText, L); + end; +end; + +{ - HWnd changed to TOvcHWnd for BCB Compatibility } +procedure TOvcBaseComboBox.CheckHot(HotWnd : TOvcHWnd{hWnd}); +begin + if FIsHot and ((HotWnd <> Handle) + {$IFNDEF LCL} and (HotWnd <> EditHandle) {$ENDIF}) then begin + FIsHot := False; + Invalidate; + end; +end; + +procedure TOvcBaseComboBox.CMFontChanged(var Message: TMessage); +begin + if not (csLoading in ComponentState) then + RecalcHeight +end; + +{ - HWnd changed to TOvcHWnd for BCB Compatibility } +procedure TOvcBaseComboBox.ComboWndProc(var Message: TMessage; + ComboWnd: TOvcHWnd{HWnd}; ComboProc: Pointer); +begin + if HotTrack and (Message.Msg = WM_NCHITTEST) then + SetHot; + {$IFDEF CBuilder} + inherited ComboWndProc(Message, HWnd(ComboWnd), ComboProc); + {$ELSE} +{$IFNDEF LCL} + inherited ComboWndProc(Message, ComboWnd, ComboProc); +{$ENDIF} + {$ENDIF} +end; + +procedure TOvcBaseComboBox.CNCommand(var Message: TWmCommand); +begin + if Message.NotifyCode = CBN_DROPDOWN then begin + FCurItemIndex := ItemIndex; + end else if Message.NotifyCode = CBN_CLOSEUP then begin + if ItemIndex > -1 then begin + AddItemToMRUList(ItemIndex); + Text := Items[ItemIndex]; + Click; + SelectionChanged; + end; + end; + + if HotTrack then + case Message.NotifyCode of + CBN_CLOSEUP : + Invalidate; + CBN_SETFOCUS: + begin + FIsFocused := True; + Invalidate; + end; + CBN_KILLFOCUS: + begin + FIsFocused := False; + Invalidate; + end; + end; + inherited; +end; + +constructor TOvcBaseComboBox.Create(AOwner : TComponent); +begin + inherited Create(AOwner); + + {$IFDEF VERSION6} + AutoComplete := false; + {$ENDIF} + + FLabelInfo := TOvcLabelInfo.Create; + FLabelInfo.OnChange := LabelChange; + FLabelInfo.OnAttach := LabelAttach; + DefaultLabelPosition := lpTopLeft; + + FList := TStringList.Create; + FMRUList := TOvcMRUList.Create; + + FAutoSearch := True; + FDroppedWidth := -1; + FMRUListColor := clWindow; + FMRUListCount := 3; + FKeyDelay := 500; + + FSaveItemIndex := -1; + FStandardHomeEnd := True; + + FTimer := -1; + FLastKeyWasBackSpace := False; + + {create borders class and assign notifications} + FBorders := TOvcBorders.Create; + + FBorders.LeftBorder.OnChange := BorderChanged; + FBorders.RightBorder.OnChange := BorderChanged; + FBorders.TopBorder.OnChange := BorderChanged; + FBorders.BottomBorder.OnChange := BorderChanged; + + FHTBorder := True; + FHTColors := TOvcHTColors.Create; + RecalcHeight; +end; + +procedure TOvcBaseComboBox.CreateParams(var Params : TCreateParams); +begin + inherited CreateParams(Params); + + Params.Style := Params.Style or (WS_VSCROLL or CBS_HASSTRINGS or CBS_AUTOHSCROLL); + case FStyle of + ocsDropDown : + Params.Style := Params.Style or CBS_DROPDOWN or CBS_OWNERDRAWVARIABLE; + ocsDropDownList : + Params.Style := Params.Style or CBS_DROPDOWNLIST or CBS_OWNERDRAWVARIABLE; + end; + if NewStyleControls and Ctl3D then + Params.ExStyle := Params.ExStyle or WS_EX_CLIENTEDGE; +{$IFDEF LCL} //Ancestor's Style needs to be set with LCL. + case FStyle of + ocsDropDown : inherited SetStyle(csDropDown); + ocsDropDownList : inherited SetStyle(csDropDownList); + end; +{$ENDIF} +end; + +procedure TOvcBaseComboBox.CreateWnd; +begin + inherited CreateWnd; + + if FSaveItemIndex > -1 then begin + ItemIndex := FSaveItemIndex; + FSaveItemIndex := -1; + end; + + if FDroppedWidth <> -1 then + SendMessage(Handle,CB_SETDROPPEDWIDTH,FDroppedWidth,0); +end; + +destructor TOvcBaseComboBox.Destroy; +begin + FLabelInfo.Visible := False; + FLabelInfo.Free; + FLabelInfo := nil; + + FMRUList.Free; + FMRUList := nil; + FList.Free; + FList := nil; + + if (FTimer > -1) then begin +{$IFNDEF LCL} + DefaultController.TimerPool.Remove(FTimer); +{$ENDIF} + FTimer := -1; + end; + + FBorders.Free; + FBorders := nil; + + FHTColors.Free; + FHTColors := nil; + + inherited Destroy; +end; + +procedure TOvcBaseComboBox.DestroyWnd; +begin + FSaveItemIndex := ItemIndex; + + inherited DestroyWnd; +end; + +procedure TOvcBaseComboBox.DoExit; +begin + AddItemToMRUList(ItemIndex); + + inherited DoExit; +end; + +procedure TOvcBaseComboBox.DoOnMouseWheel(Shift : TShiftState; + Delta, XPos, YPos : SmallInt); +begin + if Assigned(FOnMouseWheel) then + FOnMouseWheel(Self, Shift, Delta, XPos, YPos); +end; + +procedure TOvcBaseComboBox.DrawItem(Index : Integer; ItemRect: TRect; + State : TOwnerDrawState); +var + SepRect : TRect; + BkColor : TColor; + TxtRect : TRect; + TxtItem : PChar; + L : integer; + BkMode : Integer; +begin + with Canvas do begin + if (FMRUList.Items.Count > 0) and (Index < FMRUList.Items.Count) then + BkColor := FMRUListColor + else + BkColor := Color; + + if odSelected in State then + Brush.Color := clHighlight + else + Brush.Color := BkColor; + FillRect(ItemRect); + + with ItemRect do + TxtRect := Rect(Left + 2, Top, Right, Bottom); + L := Length(Items[Index])+1; + GetMem(TxtItem, L); + try + StrPCopy(TxtItem, Items[Index]); + BkMode := GetBkMode(Canvas.Handle); + SetBkMode(Canvas.Handle, TRANSPARENT); + DrawText(Canvas.Handle, TxtItem, StrLen(TxtItem), + TxtRect, DT_VCENTER or DT_LEFT); + SetBkMode(Canvas.Handle, BkMode); + if (FMRUList.Items.Count > 0) and + (Index = FMRUList.Items.Count - 1) and DroppedDown then begin + SepRect := ItemRect; + SepRect.Top := SepRect.Bottom - cbxSeparatorHeight; + SepRect.Bottom := SepRect.Bottom; + Pen.Color := clGrayText; + + if not DrawingEdit then + with SepRect do + Rectangle(Left-1, Top, Right+1, Bottom); + end; + finally + FreeMem(TxtItem, L); + end; + end; +end; + +function TOvcBaseComboBox.GetAttachedLabel : TOvcAttachedLabel; +begin + if not FLabelInfo.Visible then + raise Exception.Create(GetOrphStr(SCLabelNotAttached)); + + Result := FLabelInfo.ALabel; +end; + +function TOvcBaseComboBox.GetAbout : string; +begin + Result := OrVersionStr; +end; + +procedure TOvcBaseComboBox.HotTimerEvent(Sender : TObject; + Handle : Integer; Interval : Cardinal; ElapsedTime : LongInt); +var + P : TPoint; + WindowHandle : THandle; +begin + if FEventActive then + exit; + FEventActive := True; + if FIsHot and Visible and HandleAllocated then begin + GetCursorPos(P); + WindowHandle := WindowFromPoint(P); + CheckHot(WindowHandle); + end; + FEventActive := False; +end; + +procedure TOvcBaseComboBox.KeyDown(var Key: Word; Shift: TShiftState); +var + Index : Integer; + SrchText: PChar; +begin + FLastKeyWasBackSpace := False; + case Key of + VK_RETURN, 9999{timer event}: + begin + GetMem(SrchText, length(Text) + 1); + try + StrPCopy(SrchText, Text); + {this will search for the first matching item} + Index := SendMessage(Handle, CB_FINDSTRING, + FMRUList.Items.Count - 1, + LongInt(SrchText)); + finally + FreeMem(SrchText, length(Text) + 1); + end; + if Index > -1 then begin + Text := Items[Index]; + if Key = VK_RETURN then + Click; + SelLength := Length(Text); + SelectionChanged; + end else if Key = VK_RETURN then + MessageBeep(0); + end; + VK_HOME: + begin + if (not StandardHomeEnd) then begin + if Shift = [] then begin + ItemIndex := 0; + Change; + end; + end; + end; + VK_END: + begin + if (not StandardHomeEnd) then begin + if Shift = [] then begin + ItemIndex := Items.Count - 1; + Change; + end; + end; + end; + VK_BACK: + FLastKeyWasBackSpace := True; + VK_ESCAPE: + begin + ItemIndex := 0; + Change; + end; + else + case Key of + VK_LBUTTON, VK_RBUTTON, VK_CANCEL, VK_MBUTTON, VK_BACK, + VK_TAB, VK_CLEAR, VK_RETURN, VK_SHIFT, VK_CONTROL, VK_MENU, + VK_PAUSE, VK_CAPITAL, VK_ESCAPE, VK_PRIOR, VK_NEXT, VK_END, + VK_HOME, VK_LEFT, VK_UP, VK_RIGHT, VK_DOWN, VK_SELECT, VK_PRINT, + VK_EXECUTE, VK_SNAPSHOT, VK_INSERT, VK_DELETE, VK_HELP, + VK_F1..VK_F24, VK_NUMLOCK, VK_SCROLL : + else + {start/reset timer} + if AutoSearch then begin + {see if we need to reset the timer} +{$IFNDEF LCL} + if (FTimer <> -1) then + DefaultController.TimerPool.Remove(FTimer); + FTimer := DefaultController.TimerPool.AddOneTime(TimerEvent, FKeyDelay); +{$ENDIF} + end; + end; + end; + + inherited KeyDown(Key, Shift); +end; + +procedure TOvcBaseComboBox.LabelAttach(Sender : TObject; Value : Boolean); +var + PF : TForm; + S : string; +begin + if csLoading in ComponentState then + Exit; + + PF := TForm(GetParentForm(Self)); + if Value then begin + if Assigned(PF) then begin + FLabelInfo.ALabel.Free; + FLabelInfo.ALabel := TOvcAttachedLabel.CreateEx(PF, Self); + FLabelInfo.ALabel.Parent := Parent; + + S := GenerateComponentName(PF, Name + 'Label'); + FLabelInfo.ALabel.Name := S; + FLabelInfo.ALabel.Caption := S; + + FLabelInfo.SetOffsets(0, 0); + PositionLabel; + FLabelInfo.ALabel.BringToFront; + {turn off auto size} + FLabelInfo.ALabel.AutoSize := False; + end; + end else begin + if Assigned(PF) then begin + FLabelInfo.ALabel.Free; + FLabelInfo.ALabel := nil; + end; + end; +end; + +procedure TOvcBaseComboBox.LabelChange(Sender : TObject); +begin + if not (csLoading in ComponentState) then + PositionLabel; +end; + +procedure TOvcBaseComboBox.Loaded; +begin + inherited Loaded; + + RecalcHeight; +end; + +procedure TOvcBaseComboBox.MeasureItem(Index : Integer; var IHeight : Integer); +begin + {because Item 0 is always the one queried by WM_MEASUREITEM, we + set the item height of the last MRU item in the AddMRU + method of TOvcBaseComboBox. This method is still necessary because we + need the CB_OWNERDRAWVARIABLE style.} + IHeight := FItemHeight; +end; + +procedure TOvcBaseComboBox.Notification(AComponent : TComponent; + Operation : TOperation); +var + PF : TForm; +begin + inherited Notification(AComponent, Operation); + + if Operation = opRemove then begin + if Assigned(FLabelInfo) and (AComponent = FLabelInfo.ALabel) then begin + PF := TForm(GetParentForm(Self)); + if Assigned(PF) and + not (csDestroying in PF.ComponentState) then begin + FLabelInfo.FVisible := False; + FLabelInfo.ALabel := nil; + end; + end; + end; +end; + +procedure TOvcBaseComboBox.WndProc(var Message: TMessage); +var + PaintStruct : TPaintStruct; + ArLeft : Integer; + ds : TOwnerDrawState; +begin + if not HotTrack or (csDesigning in ComponentState) then begin + inherited WndProc(Message); + exit; + end; + if Message.Msg = WM_NCHitTest then begin + inherited WndProc(Message); + SetHot; + end else + if Message.Msg = WM_PAINT then begin + BeginPaint(Handle,PaintStruct); + ArLeft := Width - 15; + with Canvas do begin + Handle := PaintStruct.hdc; + Font := Self.Font; + Pen.Color := Color; {clBtnFace;} + Brush.Color := Color; {clBtnFace;} + Rectangle(0,0,Width,Height); + if DroppedDown or FIsHot or FIsFocused then begin + Pen.Width := 1; + if (FHTBorder) then begin + Pen.Color := FHTColors.FShadow; + MoveTo(1,Height-2); + LineTo(1,1); + LineTo(Width-1,1); + Pen.Color := FHTColors.FHighlight; + MoveTo(Width-2,1); + LineTo(Width-2,Height-2); + LineTo(1,Height-2); + Pen.Color := Color; + MoveTo(2,2); + LineTo(2,Height-3); + LineTo(Width-3,Height-3); + LineTo(Width-3,2); + LineTo(2,2); + end; + + if DroppedDown then begin + Pen.Width := 1; + Pen.Color := clBtnFace; + Brush.Color := clBtnFace; +{ Rectangle(ArLeft, 4, Width - 4, Height - 4);} + DrawButtonFace(Canvas, Rect(ArLeft, 3, Width-3, Height-3), + 1, bsAutoDetect, False, False, False); + Brush.Color := clBlack; + Pen.Color := clBlack; + Polygon( + [ + Point(ArLeft + 4, Height div 2), + Point(ArLeft + 6, Height div 2 + 2), + Point(ArLeft + 8, Height div 2)]); + Pen.Color := clBtnHighlight; + MoveTo(ArLeft,Height - 4); + LineTo(Width - 4,Height - 4); + LineTo(Width - 4,3); + Pen.Color := clBtnShadow; + MoveTo(ArLeft, Height - 4); + LineTo(ArLeft, 3); + LineTo(Width - 4, 3); + + if FStyle = ocsDropDownList then begin + if FCurItemIndex <> -1 then + DrawItem(FCurItemIndex,Rect(4,4,ArLeft-1,Height-3),[]); + end; + end else begin + Pen.Color := clBtnFace; + Pen.Width := 1; + Brush.Color := clBtnFace; +{ Rectangle(ArLeft, 4, Width - 4, Height - 4);} + DrawButtonFace(Canvas, Rect(ArLeft, 3, Width-3, Height-3), + 1, bsAutoDetect, False, False, False); + Brush.Color := clBlack; + Pen.Color := clBlack; + Polygon( + [ + Point(ArLeft + 3, Height div 2 - 1), + Point(ArLeft + 5, Height div 2 + 1), + Point(ArLeft + 7, Height div 2 - 1)]); + Pen.Color := Color; {clWhite} + MoveTo(ArLeft, Height - 4); + LineTo(ArLeft, 3); + LineTo(Width - 4, 3); + if FIsFocused then begin + ds := [odFocused]; + Font.Color := clHighLightText; + end else begin + ds := []; + Font.Color := clWindowText; + end; + if FIsFocused and (ItemIndex <> -1) then begin + ds := ds + [odSelected]; + Font.Color := clHighLightText; + end; + if FStyle = ocsDropDownList then + if ItemIndex <> -1 then + DrawItem(ItemIndex,Rect(4,4,ArLeft-1,Height-3),ds); + end; + Pen.Color := Color; {clBtnFace;} + dec(ArLeft,2); + MoveTo(ArLeft,3); + LineTo(ArLeft,Height - 3); + end else begin + Brush.Color := Color; {clBtnHighlight;} + Rectangle(2,2,Width-2,Height-2); + Brush.Color := Color; {clBtnFace;} + Rectangle(ArLeft, 4, Width - 4, Height - 4); + Pen.Color := clBlack; + Pen.Width := 1; + Brush.Color := clBlack; + Polygon( + [ + Point(ArLeft + 3, Height div 2 - 1), + Point(ArLeft + 5, Height div 2 + 1), + Point(ArLeft + 7, Height div 2 - 1)]); + Brush.Color := Color; + + Pen.Color := Color; {clBtnFace;} + MoveTo(2,Height-3); + LineTo(Width-3,Height-3); + if FStyle = ocsDropDownList then + if ItemIndex <> -1 then + DrawItem(ItemIndex,Rect(4,4,ArLeft-1,Height-3),[]); + end; + PaintBorders; + Handle := 0; + end; + EndPaint(Handle,PaintStruct); + Message.Result := 1; + end else + inherited WndProc(Message); +end; + +procedure TOvcBaseComboBox.OMAfterEnter(var Msg : TMessage); +begin + if Assigned(FAfterEnter) then + FAfterEnter(Self); +end; + +procedure TOvcBaseComboBox.OMAfterExit(var Msg : TMessage); +begin + if Assigned(FAfterExit) then + FAfterExit(Self); +end; + +procedure TOvcBaseComboBox.OMAssignLabel(var Msg : TMessage); +begin + FLabelInfo.ALabel := TOvcAttachedLabel(Msg.lParam); +end; + +procedure TOvcBaseComboBox.OMPositionLabel(var Msg : TMessage); +const + DX : Integer = 0; + DY : Integer = 0; +begin + if FLabelInfo.Visible and + Assigned(FLabelInfo.ALabel) and + (FLabelInfo.ALabel.Parent <> nil) and + not (csLoading in ComponentState) then begin + if DefaultLabelPosition = lpTopLeft then begin + DX := FLabelInfo.ALabel.Left - Left; + DY := FLabelInfo.ALabel.Top + FLabelInfo.ALabel.Height - Top; + end else begin + DX := FLabelInfo.ALabel.Left - Left; + DY := FLabelInfo.ALabel.Top - Top - Height; + end; + if (DX <> FLabelInfo.OffsetX) or (DY <> FLabelInfo.OffsetY) then + PositionLabel; + end; +end; + +procedure TOvcBaseComboBox.OMRecordLabelPosition(var Msg : TMessage); +begin + if Assigned(FLabelInfo.ALabel) and + (FLabelInfo.ALabel.Parent <> nil) then begin + {if the label was cut and then pasted, this will complete the re-attachment} + FLabelInfo.FVisible := True; + + if DefaultLabelPosition = lpTopLeft then + FLabelInfo.SetOffsets(FLabelInfo.ALabel.Left - Left, + FLabelInfo.ALabel.Top + FLabelInfo.ALabel.Height - Top) + else + FLabelInfo.SetOffsets(FLabelInfo.ALabel.Left - Left, + FLabelInfo.ALabel.Top - Top - Height); + end; +end; + +procedure TOvcBaseComboBox.PositionLabel; +begin + if FLabelInfo.Visible and Assigned(FLabelInfo.ALabel) and + (FLabelInfo.ALabel.Parent <> nil) and + not (csLoading in ComponentState) then begin + if DefaultLabelPosition = lpTopLeft then begin + FLabelInfo.ALabel.SetBounds(Left + FLabelInfo.OffsetX, + FLabelInfo.OffsetY - FLabelInfo.ALabel.Height + Top, + FLabelInfo.ALabel.Width, FLabelInfo.ALabel.Height); + end else begin + FLabelInfo.ALabel.SetBounds(Left + FLabelInfo.OffsetX, + FLabelInfo.OffsetY + Top + Height, + FLabelInfo.ALabel.Width, FLabelInfo.ALabel.Height); + end; + end; +end; + +procedure TOvcBaseComboBox.RecalcHeight; +var + DC : HDC; + F : HFont; + M : TTextMetric; +begin + DC := GetDC(0); + F := SelectObject(DC, Font.Handle); + GetTextMetrics(DC, M); + SelectObject(DC, F); + ReleaseDC(0, DC); + SetItemHeight(M.tmHeight - 1); +end; + +procedure TOvcBaseComboBox.SelectionChanged; +var + L : Integer; + SrchText : PChar; +begin + if FMRUListCount > 0 then + UpdateMRUList + else if (FList.Count > 0) and (FAutoSearch) then begin + L := Length(Text) + 1; + GetMem(SrchText, L); + try + StrPCopy(SrchText, Text); + ItemIndex := SendMessage(Handle, + CB_FINDSTRINGEXACT, + 0, + LongInt(SrchText)); + finally + FreeMem(SrchText, L); + end; + end; + + if Assigned(FOnSelChange) then + FOnSelChange(Self); +end; + +procedure TOvcBaseComboBox.SetBounds(ALeft, ATop, AWidth, AHeight : Integer); +begin + inherited SetBounds(ALeft, ATop, AWidth, AHeight); + + if HandleAllocated then + PostMessage(Handle, OM_POSITIONLABEL, 0, 0); +end; + +procedure TOvcBaseComboBox.SetDroppedWidth(Value : Integer); +begin + if Value <> FDroppedWidth then begin + if HandleAllocated then + if Value <> -1 then + SendMessage(Handle,CB_SETDROPPEDWIDTH,Value,0) + else + SendMessage(Handle,CB_SETDROPPEDWIDTH,0,0); + FDroppedWidth := Value; + end; +end; + +procedure TOvcBaseComboBox.SetHot; +begin + if not FIsHot {$IFNDEF LCL} and Application.Active {$ENDIF} then begin + FIsHot := True; + Invalidate; + end; +end; + +procedure TOvcBaseComboBox.SetHotTrack(Value : Boolean); +begin + if FHotTrack <> Value then begin + FHotTrack := Value; + Invalidate; + end; +end; + +{Changed !!.04} +procedure TOvcBaseComboBox.SetItemHeight(Value : Integer); +begin + if Value <> FItemHeight then begin + FItemHeight := Value; + (* !!.05 + {$IFDEF VERSION6} + inherited SetItemHeight(Value); + {$ELSE} + SetItemHeight(Value); + {$ENDIF} + *) +{$IFNDEF LCL} + RecreateWnd; +{$ELSE} + if HandleAllocated then //For some reason, handle may not be allocated. + MyMisc.RecreateWnd(Self); +{$ENDIF} + end; +end; + +procedure TOvcBaseComboBox.SetMRUListCount(Value: Integer); +begin + if ([csDesigning, csLoading] * ComponentState) = [] then + ClearMRUList; + FMRUList.MaxItems := Value; + FMRUListCount := Value; +end; + +procedure TOvcBaseComboBox.SetKeyDelay(Value : Integer); +begin + if (Value <> FKeyDelay) and (Value >= 0) then begin + FKeyDelay := Value; + end; +end; + +procedure TOvcBaseComboBox.SetOcbStyle(Value : TOvcComboStyle); +begin + if Value <> FStyle then begin + FStyle := Value; +{$IFNDEF LCL} + RecreateWnd; +{$ELSE} + if HandleAllocated then + MyMisc.RecreateWnd(Self); +{$ENDIF} + end; +end; + + +procedure TOvcBaseComboBox.SetStandardHomeEnd(Value : Boolean); +begin + if (Value <> FStandardHomeEnd) then + FStandardHomeEnd := Value; +end; + + + +procedure TOvcBaseComboBox.SetAbout(const Value : string); +begin +end; + +procedure TOvcBaseComboBox.TimerEvent(Sender : TObject; + Handle : Integer; Interval : Cardinal; ElapsedTime : LongInt); +var + Key : Word; + S : Word; + SP : Word; + EP : Integer; +begin + FTimer := -1; + if FLastKeyWasBackSpace then + Exit; + +(* + S := Length(Text); {remember current length} +*) +{$IFNDEF LCL} + SendMessage(Self.EditHandle, EM_GETSEL, WPARAM(@SP), LPARAM(@EP)); +{$ENDIF} + S := SP; + Key := 9999{timer event}; + {fake a key return to force the field to update} + KeyDown(Key, []); + SelStart := S; + SelLength := Length(Text) - S; +end; + +procedure TOvcBaseComboBox.WMKillFocus(var Msg : TWMKillFocus); +begin + inherited; + + PostMessage(Handle, OM_AFTEREXIT, 0, 0); +end; + +procedure TOvcBaseComboBox.WMMeasureItem(var Message : TMessage); +var + PMStruct : PMeasureItemStruct; + IHeight : Integer; +begin + PMStruct := PMeasureItemStruct(Message.lParam); + with PMStruct^ do begin + ItemWidth := ClientWidth; + IHeight := ItemHeight; + MeasureItem(ItemID, IHeight); + ItemHeight := IHeight; + end; +end; + +procedure TOvcBaseComboBox.WMMouseWheel(var Msg : TMessage); +begin + inherited; + + with Msg do + DoOnMouseWheel(KeysToShiftState(LOWORD(wParam)) {fwKeys}, + HIWORD(wParam) {zDelta}, + LOWORD(lParam) {xPos}, HIWORD(lParam) {yPos}); +end; + +procedure TOvcBaseComboBox.WMSetFocus(var Msg : TWMSetFocus); +begin + inherited; + + PostMessage(Handle, OM_AFTERENTER, 0, 0); +end; + +procedure TOvcBaseComboBox.SetHTBorder(Value : Boolean); +begin + if (Value <> FHTBorder) then begin + FHTBorder := Value; + if (FHTBorder) then begin + FBorders.BottomBorder.Enabled := False; + FBorders.LeftBorder.Enabled := False; + FBorders.RightBorder.Enabled := False; + FBorders.TopBorder.Enabled := False; + end; + end; +end; + +procedure TOvcBaseComboBox.SetHTColors(Value : TOvcHTColors); +begin + FHTColors.FHighlight := Value.FHighlight; + FHTColors.FShadow := Value.FShadow; +end; + +{ - Hdc changed to TOvcHdc for BCB Compatibility } +procedure TOvcBaseComboBox.PaintWindow(DC : TOvcHDC{Hdc}); +begin + inherited PaintWindow(DC); + Canvas.Handle := DC; + try + PaintBorders; + finally + Canvas.Handle := 0; + end; +end; + + +procedure TOvcBaseComboBox.Paint; +begin + PaintBorders; +end; + + +procedure TOvcBaseComboBox.WMPaint(var Msg : TWMPaint); +begin + PaintHandler(Msg); +end; + +procedure TOvcBaseComboBox.PaintBorders; +var + R : TRect; + C : TCanvas; + L : Integer; + DC: HDC; + DoRelease : Boolean; +begin + if (not Assigned(FBorders)) then Exit; + + R.Left := 0; + R.Top := 0; + R.Right := Width; + R.Bottom := Height; + + DoRelease := True; + DC := GetDC(self.handle); + Canvas.Handle := DC; + + if (HotTrack) then + L := 17 + else + L := 19; + + try + C := Canvas; + if (FBorders.LeftBorder <> nil) then begin + if (FBorders.LeftBorder.Enabled) then begin + C.Pen.Color := FBorders.LeftBorder.PenColor; + C.Pen.Width := FBorders.LeftBorder.PenWidth; + C.Pen.Style := FBorders.LeftBorder.PenStyle; + + C.MoveTo(R.Left + (FBorders.LeftBorder.PenWidth div 2), R.Top); + C.LineTo(R.Left + (FBorders.LeftBorder.PenWidth div 2), R.Bottom); + end; + end; + + if (FBorders.RightBorder <> nil) then begin + if (FBorders.RightBorder.Enabled) then begin + C.Pen.Color := FBorders.RightBorder.PenColor; + C.Pen.Width := FBorders.RightBorder.PenWidth; + C.Pen.Style := FBorders.RightBorder.PenStyle; + + C.MoveTo(R.Right - L - (FBorders.RightBorder.PenWidth div 2), R.Top); + C.LineTo(R.Right - L - (FBorders.RightBorder.PenWidth div 2), R.Bottom); + end; + end; + + if (FBorders.TopBorder <> nil) then begin + if (FBorders.TopBorder.Enabled) then begin + C.Pen.Color := FBorders.TopBorder.PenColor; + C.Pen.Width := FBorders.TopBorder.PenWidth; + C.Pen.Style := FBorders.TopBorder.PenStyle; + + C.MoveTo(R.Left, R.Top + (FBorders.TopBorder.PenWidth div 2)); + C.LineTo(R.Right - L, R.Top + (FBorders.TopBorder.PenWidth div 2)); + end; + end; + + if (FBorders.BottomBorder <> nil) then begin + if (FBorders.BottomBorder.Enabled) then begin + C.Pen.Color := FBorders.BottomBorder.PenColor; + C.Pen.Width := FBorders.BottomBorder.PenWidth; + C.Pen.Style := FBorders.BottomBorder.PenStyle; + + C.MoveTo(R.Left, R.Bottom - (FBorders.BottomBorder.PenWidth div 2)); + C.LineTo(R.Right - L-1, R.Bottom - (FBorders.BottomBorder.PenWidth div 2)); + end; + end; + finally + if DoRelease then begin + ReleaseDC(Self.Handle, DC); + Canvas.Handle := 0; + end; + end; +end; + +procedure TOvcBaseComboBox.BorderChanged(ABorder : TObject); +begin + if (FBorders.BottomBorder.Enabled) or + (FBorders.LeftBorder.Enabled) or + (FBorders.RightBorder.Enabled) or + (FBorders.TopBorder.Enabled) then begin + FHTBorder := False; + FHotTrack := True; + Ctl3D := False; + end else begin + Ctl3D := True; + FHTBorder := False; + FHotTrack := False; + end; + +{$IFNDEF LCL} + RecreateWnd; +{$ELSE} + if HandleAllocated then + MyMisc.RecreateWnd(Self); +{$ENDIF} +end; + + +procedure TOvcBaseComboBox.CMMouseEnter(var Message: TMessage); +begin + if not FIsHot and HotTrack then begin + FIsHot := True; + Invalidate; + end; +end; + +procedure TOvcBaseComboBox.CMMouseLeave(var Message: TMessage); +begin + if FIsHot and HotTrack then begin + FIsHot := False; + Invalidate; + end; +end; + +end. diff --git a/components/orpheus/ovccmd.pas b/components/orpheus/ovccmd.pas new file mode 100644 index 000000000..10ff5a6c1 --- /dev/null +++ b/components/orpheus/ovccmd.pas @@ -0,0 +1,1494 @@ +{*********************************************************} +{* OVCCMD.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovccmd; + {-Translates messages into commands} + +interface + +uses + {$IFNDEF LCL} Windows, {$ELSE} LclIntf, LclType, {$ENDIF} + Classes, Forms, Menus, Messages, SysUtils, OvcConst, OvcData, + OvcExcpt, OvcMisc; + +const + {default primary command/key table} + DefCommandTable : array[0..63] of TOvcCmdRec = ( + {Key #1 Shift state #1 + Key #2 Shift state #2 Command} + (Key1:VK_LEFT; SS1:ss_None; + Key2:VK_NONE; SS2:ss_None; Cmd:ccLeft), + (Key1:VK_RIGHT; SS1:ss_None; + Key2:VK_NONE; SS2:ss_None; Cmd:ccRight), + (Key1:VK_LEFT; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccWordLeft), + (Key1:VK_RIGHT; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccWordRight), + (Key1:VK_HOME; SS1:ss_None; + Key2:VK_NONE; SS2:ss_None; Cmd:ccHome), + (Key1:VK_END; SS1:ss_None; + Key2:VK_NONE; SS2:ss_None; Cmd:ccEnd), + (Key1:VK_DELETE; SS1:ss_None; + Key2:VK_NONE; SS2:ss_None; Cmd:ccDel), + (Key1:VK_BACK; SS1:ss_None; + Key2:VK_NONE; SS2:ss_None; Cmd:ccBack), + (Key1:VK_BACK; SS1:ss_Shift; + Key2:VK_NONE; SS2:ss_None; Cmd:ccBack), + (Key1:VK_PRIOR; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccTopOfPage), + (Key1:VK_NEXT; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccBotOfPage), + (Key1:VK_INSERT; SS1:ss_None; + Key2:VK_NONE; SS2:ss_None; Cmd:ccIns), + (Key1:VK_Z; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccUndo), + (Key1:VK_BACK; SS1:ss_Alt; + Key2:VK_NONE; SS2:ss_None; Cmd:ccRestore), + (Key1:VK_UP; SS1:ss_None; + Key2:VK_NONE; SS2:ss_None; Cmd:ccUp), + (Key1:VK_DOWN; SS1:ss_None; + Key2:VK_NONE; SS2:ss_None; Cmd:ccDown), + (Key1:VK_RETURN; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccNewLine), + (Key1:VK_LEFT; SS1:ss_Shift; + Key2:VK_NONE; SS2:ss_None; Cmd:ccExtendLeft), + (Key1:VK_RIGHT; SS1:ss_Shift; + Key2:VK_NONE; SS2:ss_None; Cmd:ccExtendRight), + (Key1:VK_HOME; SS1:ss_Shift; + Key2:VK_NONE; SS2:ss_None; Cmd:ccExtendHome), + (Key1:VK_END; SS1:ss_Shift; + Key2:VK_NONE; SS2:ss_None; Cmd:ccExtendEnd), + (Key1:VK_LEFT; SS1:ss_Shift+ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccExtWordLeft), + (Key1:VK_RIGHT; SS1:ss_Shift+ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccExtWordRight), + (Key1:VK_PRIOR; SS1:ss_Shift; + Key2:VK_NONE; SS2:ss_None; Cmd:ccExtendPgUp), + (Key1:VK_NEXT; SS1:ss_Shift; + Key2:VK_NONE; SS2:ss_None; Cmd:ccExtendPgDn), + (Key1:VK_UP; SS1:ss_Shift; + Key2:VK_NONE; SS2:ss_None; Cmd:ccExtendUp), + (Key1:VK_DOWN; SS1:ss_Shift; + Key2:VK_NONE; SS2:ss_None; Cmd:ccExtendDown), + (Key1:VK_HOME; SS1:ss_Shift+ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccExtFirstPage), + (Key1:VK_END; SS1:ss_Shift+ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccExtLastPage), + (Key1:VK_PRIOR; SS1:ss_Shift+ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccExtTopOfPage), + (Key1:VK_NEXT; SS1:ss_Shift+ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccExtBotOfPage), + (Key1:VK_DELETE; SS1:ss_Shift; + Key2:VK_NONE; SS2:ss_None; Cmd:ccCut), + (Key1:VK_X; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccCut), + (Key1:VK_INSERT; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccCopy), + (Key1:VK_C; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccCopy), + (Key1:VK_INSERT; SS1:ss_Shift; + Key2:VK_NONE; SS2:ss_None; Cmd:ccPaste), + (Key1:VK_V; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccPaste), + (Key1:VK_PRIOR; SS1:ss_None; + Key2:VK_NONE; SS2:ss_None; Cmd:ccPrevPage), + (Key1:VK_NEXT; SS1:ss_None; + Key2:VK_NONE; SS2:ss_None; Cmd:ccNextPage), + (Key1:VK_HOME; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccFirstPage), + (Key1:VK_END; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccLastPage), + (Key1:VK_TAB; SS1:ss_None; + Key2:VK_NONE; SS2:ss_None; Cmd:ccTab), + (Key1:VK_TAB; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccTab), + (Key1:VK_Z; SS1:ss_Ctrl+ss_Shift; + Key2:VK_NONE; SS2:ss_None; Cmd:ccRedo), + (Key1:VK_0; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccGotoMarker0), + (Key1:VK_1; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccGotoMarker1), + (Key1:VK_2; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccGotoMarker2), + (Key1:VK_3; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccGotoMarker3), + (Key1:VK_4; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccGotoMarker4), + (Key1:VK_5; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccGotoMarker5), + (Key1:VK_6; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccGotoMarker6), + (Key1:VK_7; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccGotoMarker7), + (Key1:VK_8; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccGotoMarker8), + (Key1:VK_9; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccGotoMarker9), + (Key1:VK_0; SS1:ss_Ctrl+ss_Shift; + Key2:VK_NONE; SS2:ss_None; Cmd:ccSetMarker0), + (Key1:VK_1; SS1:ss_Ctrl+ss_Shift; + Key2:VK_NONE; SS2:ss_None; Cmd:ccSetMarker1), + (Key1:VK_2; SS1:ss_Ctrl+ss_Shift; + Key2:VK_NONE; SS2:ss_None; Cmd:ccSetMarker2), + (Key1:VK_3; SS1:ss_Ctrl+ss_Shift; + Key2:VK_NONE; SS2:ss_None; Cmd:ccSetMarker3), + (Key1:VK_4; SS1:ss_Ctrl+ss_Shift; + Key2:VK_NONE; SS2:ss_None; Cmd:ccSetMarker4), + (Key1:VK_5; SS1:ss_Ctrl+ss_Shift; + Key2:VK_NONE; SS2:ss_None; Cmd:ccSetMarker5), + (Key1:VK_6; SS1:ss_Ctrl+ss_Shift; + Key2:VK_NONE; SS2:ss_None; Cmd:ccSetMarker6), + (Key1:VK_7; SS1:ss_Ctrl+ss_Shift; + Key2:VK_NONE; SS2:ss_None; Cmd:ccSetMarker7), + (Key1:VK_8; SS1:ss_Ctrl+ss_Shift; + Key2:VK_NONE; SS2:ss_None; Cmd:ccSetMarker8), + (Key1:VK_9; SS1:ss_Ctrl+ss_Shift; + Key2:VK_NONE; SS2:ss_None; Cmd:ccSetMarker9)); + + {default WordStar command-key table} + DefWsMaxCommands = 40; + DefWsCommandTable : array[0..DefWsMaxCommands-1] of TOvcCmdRec = ( + {Key #1 Shift state #1 + Key #2 Shift state #2 Command} + (Key1:VK_S; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccLeft), + (Key1:VK_D; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccRight), + (Key1:VK_E; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccUp), + (Key1:VK_X; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccDown), + (Key1:VK_R; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccPrevPage), + (Key1:VK_C; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccNextPage), + (Key1:VK_W; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccScrollUp), + (Key1:VK_Z; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccScrollDown), + (Key1:VK_A; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccWordLeft), + (Key1:VK_F; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccWordRight), + (Key1:VK_Q; SS1:ss_Ctrl; + Key2:VK_S; SS2:ss_Wordstar; Cmd:ccHome), + (Key1:VK_Q; SS1:ss_Ctrl; + Key2:VK_D; SS2:ss_Wordstar; Cmd:ccEnd), + (Key1:VK_G; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccDel), + (Key1:VK_H; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccBack), + (Key1:VK_Y; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccDelLine), + (Key1:VK_Q; SS1:ss_Ctrl; + Key2:VK_Y; SS2:ss_Wordstar; Cmd:ccDelEol), + (Key1:VK_V; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccIns), + (Key1:VK_T; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccDelWord), + (Key1:VK_P; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccCtrlChar), + (Key1:VK_Q; SS1:ss_Ctrl; + Key2:VK_L; SS2:ss_Wordstar; Cmd:ccRestore), + (Key1:VK_Q; SS1:ss_Ctrl; + Key2:VK_0; SS2:ss_Wordstar; Cmd:ccGotoMarker0), + (Key1:VK_Q; SS1:ss_Ctrl; + Key2:VK_1; SS2:ss_Wordstar; Cmd:ccGotoMarker1), + (Key1:VK_Q; SS1:ss_Ctrl; + Key2:VK_2; SS2:ss_Wordstar; Cmd:ccGotoMarker2), + (Key1:VK_Q; SS1:ss_Ctrl; + Key2:VK_3; SS2:ss_Wordstar; Cmd:ccGotoMarker3), + (Key1:VK_Q; SS1:ss_Ctrl; + Key2:VK_4; SS2:ss_Wordstar; Cmd:ccGotoMarker4), + (Key1:VK_Q; SS1:ss_Ctrl; + Key2:VK_5; SS2:ss_Wordstar; Cmd:ccGotoMarker5), + (Key1:VK_Q; SS1:ss_Ctrl; + Key2:VK_6; SS2:ss_Wordstar; Cmd:ccGotoMarker6), + (Key1:VK_Q; SS1:ss_Ctrl; + Key2:VK_7; SS2:ss_Wordstar; Cmd:ccGotoMarker7), + (Key1:VK_Q; SS1:ss_Ctrl; + Key2:VK_8; SS2:ss_Wordstar; Cmd:ccGotoMarker8), + (Key1:VK_Q; SS1:ss_Ctrl; + Key2:VK_9; SS2:ss_Wordstar; Cmd:ccGotoMarker9), + (Key1:VK_K; SS1:ss_Ctrl; + Key2:VK_0; SS2:ss_Wordstar; Cmd:ccSetMarker0), + (Key1:VK_K; SS1:ss_Ctrl; + Key2:VK_1; SS2:ss_Wordstar; Cmd:ccSetMarker1), + (Key1:VK_K; SS1:ss_Ctrl; + Key2:VK_2; SS2:ss_Wordstar; Cmd:ccSetMarker2), + (Key1:VK_K; SS1:ss_Ctrl; + Key2:VK_3; SS2:ss_Wordstar; Cmd:ccSetMarker3), + (Key1:VK_K; SS1:ss_Ctrl; + Key2:VK_4; SS2:ss_Wordstar; Cmd:ccSetMarker4), + (Key1:VK_K; SS1:ss_Ctrl; + Key2:VK_5; SS2:ss_Wordstar; Cmd:ccSetMarker5), + (Key1:VK_K; SS1:ss_Ctrl; + Key2:VK_6; SS2:ss_Wordstar; Cmd:ccSetMarker6), + (Key1:VK_K; SS1:ss_Ctrl; + Key2:VK_7; SS2:ss_Wordstar; Cmd:ccSetMarker7), + (Key1:VK_K; SS1:ss_Ctrl; + Key2:VK_8; SS2:ss_Wordstar; Cmd:ccSetMarker8), + (Key1:VK_K; SS1:ss_Ctrl; + Key2:VK_9; SS2:ss_Wordstar; Cmd:ccSetMarker9)); + + {default Orpheus Table command/key table} + DefGridMaxCommands = 38; + DefGridCommandTable : array[0..DefGridMaxCommands-1] of TOvcCmdRec = ( + {Key #1 Shift state #1 + Key #2 Shift state #2 Command} + (Key1:VK_LEFT; SS1:ss_None; + Key2:VK_NONE; SS2:ss_None; Cmd:ccLeft), + (Key1:VK_RIGHT; SS1:ss_None; + Key2:VK_NONE; SS2:ss_None; Cmd:ccRight), + (Key1:VK_LEFT; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccPageLeft), + (Key1:VK_RIGHT; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccPageRight), + (Key1:VK_HOME; SS1:ss_None; + Key2:VK_NONE; SS2:ss_None; Cmd:ccHome), + (Key1:VK_END; SS1:ss_None; + Key2:VK_NONE; SS2:ss_None; Cmd:ccEnd), + (Key1:VK_DELETE; SS1:ss_None; + Key2:VK_NONE; SS2:ss_None; Cmd:ccDel), + (Key1:VK_BACK; SS1:ss_None; + Key2:VK_NONE; SS2:ss_None; Cmd:ccBack), + (Key1:VK_NEXT; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccBotOfPage), + (Key1:VK_PRIOR; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccTopOfPage), + (Key1:VK_INSERT; SS1:ss_None; + Key2:VK_NONE; SS2:ss_None; Cmd:ccIns), + (Key1:VK_Z; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccRestore), + (Key1:VK_UP; SS1:ss_None; + Key2:VK_NONE; SS2:ss_None; Cmd:ccUp), + (Key1:VK_DOWN; SS1:ss_None; + Key2:VK_NONE; SS2:ss_None; Cmd:ccDown), + (Key1:VK_LEFT; SS1:ss_Shift; + Key2:VK_NONE; SS2:ss_None; Cmd:ccExtendLeft), + (Key1:VK_RIGHT; SS1:ss_Shift; + Key2:VK_NONE; SS2:ss_None; Cmd:ccExtendRight), + (Key1:VK_HOME; SS1:ss_Shift; + Key2:VK_NONE; SS2:ss_None; Cmd:ccExtendHome), + (Key1:VK_END; SS1:ss_Shift; + Key2:VK_NONE; SS2:ss_None; Cmd:ccExtendEnd), + (Key1:VK_LEFT; SS1:ss_Shift+ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccExtWordLeft), + (Key1:VK_RIGHT; SS1:ss_Shift+ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccExtWordRight), + (Key1:VK_PRIOR; SS1:ss_Shift; + Key2:VK_NONE; SS2:ss_None; Cmd:ccExtendPgUp), + (Key1:VK_NEXT; SS1:ss_Shift; + Key2:VK_NONE; SS2:ss_None; Cmd:ccExtendPgDn), + (Key1:VK_UP; SS1:ss_Shift; + Key2:VK_NONE; SS2:ss_None; Cmd:ccExtendUp), + (Key1:VK_DOWN; SS1:ss_Shift; + Key2:VK_NONE; SS2:ss_None; Cmd:ccExtendDown), + (Key1:VK_HOME; SS1:ss_Shift+ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccExtFirstPage), + (Key1:VK_END; SS1:ss_Shift+ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccExtLastPage), + (Key1:VK_PRIOR; SS1:ss_Shift+ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccExtTopOfPage), + (Key1:VK_NEXT; SS1:ss_Shift+ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccExtBotOfPage), + (Key1:VK_X; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccCut), + (Key1:VK_C; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccCopy), + (Key1:VK_V; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccPaste), + (Key1:VK_PRIOR; SS1:ss_None; + Key2:VK_NONE; SS2:ss_None; Cmd:ccPrevPage), + (Key1:VK_HOME; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccFirstPage), + (Key1:VK_NEXT; SS1:ss_None; + Key2:VK_NONE; SS2:ss_None; Cmd:ccNextPage), + (Key1:VK_END; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccLastPage), + (Key1:VK_UP; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccTopLeftCell), + (Key1:VK_DOWN; SS1:ss_Ctrl; + Key2:VK_NONE; SS2:ss_None; Cmd:ccBotRightCell), + (Key1:VK_F2; SS1:ss_None; + Key2:VK_NONE; SS2:ss_None; Cmd:ccTableEdit)); + +type + {command processor states} + TOvcProcessorState = (stNone, stPartial, stLiteral); + + {user command notify event} + TUserCommandEvent = + procedure(Sender : TObject; Command : Word) + of object; + + {forward class declarations} + TOvcCommandProcessor = class; + + TOvcCommandTable = class(TPersistent) + {.Z+} + protected {private} + FActive : Boolean; {true to use this command table} + FCommandList : TList; {list of command/key mappings} + FTableName : string; {the name of this command table} + + {property methods} + function GetCmdRec(Index : Integer) : TOvcCmdRec; + {-return the list item corresponding to "Index"} + function GetCount : Integer; + {-return the number of records in the list} + procedure PutCmdRec(Index : Integer; const CmdRec : TOvcCmdRec); + {-store a new command entry to the list at "Index" position} + + {internal methods} + procedure ctDisposeCommandEntry(P : POvcCmdRec); + {-dispose of a command entry record} + function ctNewCommandEntry(const CmdRec : TOvcCmdRec): POvcCmdRec; + {-allocate a new command entry record} + procedure ctReadData(Reader : TReader); + {-called to read the table from the stream} + procedure ctWriteData(Writer : TWriter); + {-called to store the table on the stream} + + protected + procedure DefineProperties(Filer : TFiler); + override; + + public + constructor Create; + destructor Destroy; + override; + {.Z-} + + function AddRec(const CmdRec : TOvcCmdRec) : Integer; + {-add a record to the list} + procedure Clear; + {-delete all records from the list} + procedure Delete(Index : Integer); + {-delete a record from the list} + procedure Exchange(Index1, Index2 : Integer); + {-exchange list locations of the two specified records} + function IndexOf(const CmdRec : TOvcCmdRec) : Integer; + {-return the index of the specified record} + procedure InsertRec(Index : Integer; const CmdRec : TOvcCmdRec); + {-insert a record at the specified index} + procedure LoadFromFile(const FileName : string); + {-read command entries from a text file} + procedure Move(CurIndex, NewIndex : Integer); + {-move one record to anothers index location} + procedure SaveToFile(const FileName: string); + {-write command entries to a text file} + + property Commands[Index : Integer] : TOvcCmdRec + read GetCmdRec write PutCmdRec; default; + property Count : Integer + read GetCount stored False; + property IsActive : Boolean + read FActive write FActive; + property TableName : string + read FTableName write FTableName; + end; + + TOvcCommandProcessor = class(TPersistent) + {.Z+} + protected {private} + {property variables} + FTableList : TList; {list of command tables} + + {internal variables} + cpState : TOvcProcessorState; {current state} + cpSaveKey : Byte; {saved last key processed} + cpSaveSS : Byte; {saved shift key state} + + {property methods} + function GetCount: Integer; + {-return the number of tables in the list} + function GetTable(Index : Integer) : TOvcCommandTable; + {-return the table referenced by "Index"} + procedure SetTable(Index : Integer; CT : TOvcCommandTable); + {-store a command table at position "Index"} + + {internal methods} + function cpFillCommandRec(Key1, ShiftState1, + Key2, ShiftState2 : Byte; + Command : Word) : TOvcCmdRec; + {-fill a command record} + procedure cpReadData(Reader: TReader); + {-called to read the command processor from the stream} + function cpScanTable(CT : TOvcCommandTable; Key, SFlags : Byte) : Word; + {-Scan the command table for a match} + procedure cpWriteData(Writer: TWriter); + {-called to store the command processor to the stream} + + protected + procedure DefineProperties(Filer: TFiler); + override; + + public + constructor Create; + destructor Destroy; + override; + {.Z-} + + procedure Add(CT : TOvcCommandTable); + {-add a command table to the list of tables} + procedure AddCommand(const TableName: string; + Key1, ShiftState1, + Key2, ShiftState2 : Byte; + Command : Word); + {-add a command and key sequence to the command table} + procedure AddCommandRec(const TableName: string; const CmdRec : TOvcCmdRec); + {-add a command record to the command table} + procedure ChangeTableName(const OldName, NewName: string); + {-change the name of a table} + procedure Clear; + {-delete all tables from the list} + function CreateCommandTable(const TableName : string; Active : Boolean) : Integer; + {-create a command table and add it to the table list} + procedure Delete(Index : Integer); + {-delete the "Index" table from the list of tables} + procedure DeleteCommand(const TableName: string; + Key1, ShiftState1, + Key2, ShiftState2 : Byte); + {-delete a command and key sequence from a command table} + procedure DeleteCommandTable(const TableName : string); + {-delete a command table and remove it from the table list} + procedure Exchange(Index1, Index2 : Integer); + {-exchange list locations of the two specified command tables} + function GetCommandCount(const TableName : string) : Integer; + {-return the number of commands in the command table} + function GetCommandTable(const TableName : string) : TOvcCommandTable; + {-return a pointer to the specified command table or nil} + {.Z+} + procedure GetState(var State : TOvcProcessorState; var Key, Shift : Byte); + {-return the current status of the command processor} + {.Z-} + function GetCommandTableIndex(const TableName : string) : Integer; + {-return index to the specified command table or -1 for failure} + function LoadCommandTable(const FileName : string) : Integer; virtual; + {-creates and then fills a command table from a text file} + procedure ResetCommandProcessor; + {-reset the command processor} + procedure SaveCommandTable(const TableName, FileName : string); virtual; + {-save a command table to a text file} + procedure SetScanPriority(const Names : array of string); + {-reorder the list of tables based on this array} + {.Z+} + procedure SetState(State : TOvcProcessorState; Key, Shift : Byte); + {-set the state to the command processor} + {.Z-} + function Translate(var Msg : TMessage) : Word; + {-translate a message into a command} + function TranslateUsing(const Tables : array of string; var Msg : TMessage) : Word; + {-translate a message into a command using the given tables} + function TranslateKey(Key : Word; ShiftState : TShiftState) : Word; + {-translate a key and shift-state into a command} + function TranslateKeyUsing(const Tables : array of string; Key : Word; ShiftState : TShiftState) : Word; + {-translate a key and shift-state into a command using the given tables} + + property Count: Integer + read GetCount + stored False; + + property Table[Index : Integer]: TOvcCommandTable + read GetTable + write SetTable; + default; + end; + + +implementation + + +{*** TOvcCommandTable ***} + +function TOvcCommandTable.AddRec(const CmdRec : TOvcCmdRec) : Integer; +begin + Result := GetCount; + InsertRec(Result, CmdRec); +end; + +procedure TOvcCommandTable.Clear; +var + I: Integer; +begin + {dispose of all command records in the list} + for I := 0 to FCommandList.Count - 1 do + ctDisposeCommandEntry(FCommandList[I]); + {clear the list entries} + FCommandList.Clear; +end; + +constructor TOvcCommandTable.Create; +begin + inherited Create; + FTableName := GetOrphStr(SCUnknownTable); + FActive := True; + FCommandList := TList.Create; +end; + +procedure TOvcCommandTable.ctDisposeCommandEntry(P : POvcCmdRec); +begin + if Assigned(P) then + FreeMem(P, SizeOf(TOvcCmdRec)); +end; + +function TOvcCommandTable.ctNewCommandEntry(const CmdRec : TOvcCmdRec): POvcCmdRec; +begin + GetMem(Result, SizeOf(TOvcCmdRec)); + Result^ := CmdRec; +end; + +procedure TOvcCommandTable.ctReadData(Reader : TReader); +var + CmdRec : TOvcCmdRec; + + procedure ReadAndCompareTable(const CT : array of TOvcCmdRec); + var + I : Integer; + Idx : Integer; + begin + {add all records initially} + for I := 0 to High(CT) do + AddRec(CT[I]); + + while not Reader.EndOfList do begin + with CmdRec, Reader do begin + Keys := ReadInteger; + Cmd := ReadInteger; + end; + {if keys on stream are dups replace default with redefinition} + Idx := IndexOf(CmdRec); + if Idx > -1 then begin + {if assigned to ccNone, remove instead of replace} + if CmdRec.Cmd = ccNone then + Delete(Idx) + else + Commands[Idx] := CmdRec + end else + AddRec(CmdRec); + end; + end; + +begin + FTableName := Reader.ReadString; + FActive := Reader.ReadBoolean; + Reader.ReadListBegin; + Clear; + + if CompareText(GetOrphStr(SCDefaultTableName), FTableName) = 0 then + {if this is the "default" table, fill it with default commands} + ReadAndCompareTable(DefCommandTable) + else if CompareText(GetOrphStr(SCWordStarTableName), FTableName) = 0 then + {if this is the "wordstar" table, fill it with default commands} + ReadAndCompareTable(DefWsCommandTable) + else if CompareText(GetOrphStr(SCGridTableName), FTableName) = 0 then + {if this is the "grid" table, fill it with default commands} + ReadAndCompareTable(DefGridCommandTable) + else begin + {otherwise, load complete command table from stream} + while not Reader.EndOfList do begin + with CmdRec, Reader do begin + Keys := ReadInteger; + Cmd := ReadInteger; + end; + AddRec(CmdRec); + end; + end; + + Reader.ReadListEnd; +end; + +procedure TOvcCommandTable.ctWriteData(Writer : TWriter); +var + I : Integer; + Cmdrec : TOvcCmdRec; + + procedure CompareAndWriteTable(const CT : array of TOvcCmdRec); + var + I, J : Integer; + Idx : Integer; + begin + {find commands in the CT table but missing from this table} + for I := 0 to High(CT) do begin + Idx := IndexOf(CT[I]); + if Idx = -1 then begin + {not found, store and assign to ccNone} + with CT[I], Writer do begin + WriteInteger(Keys); + WriteInteger(ccNone); + end; + end; + end; + + {store all commands in new table if they are additions to the CT table} + for I := 0 to Count - 1 do begin + CmdRec := GetCmdRec(I); + {search CT for a match} + Idx := -1; + for J := 0 to High(CT) do begin + if (CmdRec.Keys = CT[J].Keys) and (CmdRec.Cmd = CT[J].Cmd) then begin + Idx := J; + Break; + end; + end; + if Idx = -1 then begin + {not found, store it} + with CmdRec, Writer do begin + WriteInteger(Keys); + WriteInteger(Cmd); + end; + end; + end; + end; + +begin + Writer.WriteString(FTableName); + Writer.WriteBoolean(FActive); + Writer.WriteListBegin; + + {if this is the default command table, don't store command if not changed} + if CompareText(GetOrphStr(SCDefaultTableName), FTableName) = 0 then + {if this is the "default" command table, don't store commands if not changed} + CompareAndWriteTable(DefCommandTable) + else if CompareText(GetOrphStr(SCWordStarTableName), FTableName) = 0 then + {if this is the "wordstar" command table, don't store commands if not changed} + CompareAndWriteTable(DefWsCommandTable) + else if CompareText(GetOrphStr(SCGridTableName), FTableName) = 0 then + {if this is the "grid" command table, don't store commands if not changed} + CompareAndWriteTable(DefGridCommandTable) + else begin + {otherwise, save the complete table} + for I := 0 to Count - 1 do begin + CmdRec := GetCmdRec(I); + with CmdRec, Writer do begin + WriteInteger(Keys); + WriteInteger(Cmd); + end; + end; + end; + + Writer.WriteListEnd; +end; + +procedure TOvcCommandTable.DefineProperties(Filer : TFiler); +begin + inherited DefineProperties(Filer); + Filer.DefineProperty('CommandList', ctReadData, ctWriteData, Count > 0); +end; + +procedure TOvcCommandTable.Delete(Index : Integer); +begin + ctDisposeCommandEntry(FCommandList[Index]); + FCommandList.Delete(Index); +end; + +destructor TOvcCommandTable.Destroy; +begin + Clear; + FCommandList.Free; + FCommandList := nil; + + inherited Destroy; +end; + +procedure TOvcCommandTable.Exchange(Index1, Index2 : Integer); +begin + FCommandList.Exchange(Index1, Index2); +end; + +function TOvcCommandTable.GetCmdRec(Index : Integer) : TOvcCmdRec; +begin + Result := POvcCmdRec(FCommandList[Index])^; +end; + +function TOvcCommandTable.GetCount : Integer; +begin + Result := FCommandList.Count; +end; + +function TOvcCommandTable.IndexOf(const CmdRec : TOvcCmdRec) : Integer; +begin + for Result := 0 to GetCount - 1 do + if CmdRec.Keys = GetCmdRec(Result).Keys then + Exit; + Result := -1; +end; + +procedure TOvcCommandTable.InsertRec(Index : Integer; const Cmdrec : TOvcCmdRec); +begin + FCommandList.Expand.Insert(Index, ctNewCommandEntry(CmdRec)); +end; + +procedure TOvcCommandTable.LoadFromFile(const FileName: string); +var + T : System.Text; + CmdRec : TOvcCmdRec; +begin + Clear; {erase current contents of list} + System.Assign(T, FileName); + System.Reset(T); + try {finally} + ReadLn(T, FTableName); {get table name} + while not Eof(T) do begin + with CmdRec do ReadLn(T, Key1, SS1, Key2, SS2, Cmd); + AddRec(CmdRec); + end; + finally + System.Close(T); + end; +end; + +procedure TOvcCommandTable.Move(CurIndex, NewIndex : Integer); +var + CmdRec : TOvcCmdRec; +begin + if CurIndex <> NewIndex then begin + CmdRec := GetCmdRec(CurIndex); + Delete(CurIndex); + InsertRec(NewIndex, CmdRec); + end; +end; + +procedure TOvcCommandTable.PutCmdRec(Index : Integer; const CmdRec : TOvcCmdRec); +var + P : POvcCmdRec; +begin + P := FCommandList[Index]; + try + FCommandList[Index] := ctNewCommandEntry(CmdRec); + finally + ctDisposeCommandEntry(P); + end; +end; + +procedure TOvcCommandTable.SaveToFile(const FileName: string); +var + T : System.Text; + I : Integer; + CmdRec : TOvcCmdRec; +begin + System.Assign(T, FileName); + System.Rewrite(T); + try {finally} + System.WriteLn(T, FTableName); {save the table name} + for I := 0 to Count-1 do begin + CmdRec := GetCmdRec(I); + with CmdRec do + System.WriteLn(T, Key1:4, SS1:4, Key2:4, SS2:4, Cmd:6); + end; + finally + System.Close(T); + end; +end; + + +{*** TCommandProcessor ***} + +procedure TOvcCommandProcessor.Add(CT : TOvcCommandTable); + {-add a command table to the list of tables} +var + I : Integer; + Base : string; + Name : string; +begin + {make sure the table name is unique} + I := 0; + + Base := CT.TableName; + + {remove trailing numbers from the name, forming the base name} + while (Length(Base) > 1) and (Base[Length(Base)] in ['0'..'9']) do + {$IFOPT H+} + SetLength(Base, Length(Base)-1); + {$ELSE} + Dec(Byte(Base[0])); + {$ENDIF} + + Name := Base; + + {keep appending numbers until we find a unique name} + while GetCommandTable(Name) <> nil do begin + Inc(I); + Name := Base + Format('%d', [I]); + end; + if I > 0 then + CT.TableName := Name; + + {add table to the list} + FTableList.Add(CT); +end; + +procedure TOvcCommandProcessor.AddCommand(const TableName: string; + Key1, ShiftState1, + Key2, ShiftState2 : Byte; + Command : Word); + {-add a command and key sequence to the command table} +var + CmdRec : TOvcCmdRec; +begin + {fill temp command record} + CmdRec := cpFillCommandRec(Key1, ShiftState1, Key2, ShiftState2, Command); + {add the command} + AddCommandRec(TableName, CmdRec); +end; + +procedure TOvcCommandProcessor.AddCommandRec(const TableName: string; const CmdRec : TOvcCmdRec); + {-add a command record to the command table} +var + TmpTbl : TOvcCommandTable; +begin + {get the command table pointer} + TmpTbl := GetCommandTable(TableName); + if Assigned(TmpTbl) then begin + {does this key sequence conflict with any others} + if TmpTbl.IndexOf(CmdRec) = -1 then + {add the new command-key sequence} + TmpTbl.AddRec(CmdRec) + else + raise EDuplicateCommand.Create; + end else + raise ETableNotFound.Create; +end; + +procedure TOvcCommandProcessor.ChangeTableName(const OldName, NewName: string); + {-change the name of a table} +var + TmpTbl : TOvcCommandTable; +begin + TmpTbl := GetCommandTable(OldName); + if Assigned(TmpTbl) then + TmpTbl.TableName := NewName + else + raise ETableNotFound.Create; +end; + +procedure TOvcCommandProcessor.Clear; + {-delete all tables from the list} +var + I : Integer; +begin + {dispose of all command tables in the list} + for I := 0 to Count - 1 do + TOvcCommandTable(FTableList[I]).Free; + {clear the list entries} + FTableList.Clear; +end; + +function TOvcCommandProcessor.cpFillCommandRec(Key1, ShiftState1, + Key2, ShiftState2 : Byte; + Command : Word) : TOvcCmdRec; + {-fill a command record} +begin + Result.Key1 := Key1; + Result.SS1 := ShiftState1; + Result.Key2 := Key2; + Result.SS2 := ShiftState2; + Result.Cmd := Command; +end; + +procedure TOvcCommandProcessor.cpReadData(Reader : TReader); +var + TmpTbl : TOvcCommandTable; +begin + {empty current table list} + Clear; + {read the start of list marker} + Reader.ReadListBegin; + while not Reader.EndOfList do begin + {create a command table} + TmpTbl := TOvcCommandTable.Create; + {load commands into the table} + TmpTbl.ctReadData(Reader); + {add the new table to the table list} + Add(TmpTbl); + end; + {read the end of list marker} + Reader.ReadListEnd; +end; + +function TOvcCommandProcessor.cpScanTable(CT : TOvcCommandTable; Key, SFlags : Byte) : Word; + {-Scan the command table for a match} +var + J : Integer; +begin + {assume failed match} + Result := ccNone; + + {scan the list of commands looking for a match} + for J := 0 to CT.Count-1 do with CT[J] do begin + + {do we already have a partial command} + if cpState = stPartial then begin + {does first key/shift state match the saved key/shift state?} + if (Key1 = cpSaveKey) and (SS1 = cpSaveSS) then + {does the key match?} + if (Key2 = Key) then + {does the shift state match?} + {or, is this the second key of a wordstar command} + if (SS2 = SFlags) or ((SS2 = ss_Wordstar) and + ((SFlags = ss_None) or (SFlags = ss_Ctrl))) then begin + Result := Cmd; {return the command} + {if the command is ccCtrlChar, next key is literal} + if Cmd = ccCtrlChar then + cpState := stLiteral + else + cpState := stNone; + Exit; + end; + end else if (Key1 = Key) and (SS1 = SFlags) then begin + {we have an initial key match} + if Key2 = 0 then begin + {no second key} + Result := Cmd; {return the command} + {if the command is ccCtrlChar, next key is literal} + if Cmd = ccCtrlChar then + cpState := stLiteral; + Exit; + end else begin + {it's a partial command} + Result := ccPartial; + cpState := stPartial; + + {save the key and shift state} + cpSaveKey := Key; + cpSaveSS := SFlags; + Exit; + end; + end; + + end; +end; + +procedure TOvcCommandProcessor.cpWriteData(Writer: TWriter); +var + I : Integer; +begin + {write the start of list marker} + Writer.WriteListBegin; + {have each table write itself} + for I := 0 to Count - 1 do + TOvcCommandTable(FTableList[I]).ctWriteData(Writer); + {write the end of list marker} + Writer.WriteListEnd; +end; + +constructor TOvcCommandProcessor.Create; +var + I : Integer; + S : string; +begin + inherited Create; + + {create an empty command table list} + FTableList := TList.Create; + + {create and fill the default command table} + S := GetOrphStr(SCDefaultTableName); + CreateCommandTable(S, True {active}); + for I := 0 to High(DefCommandTable) do + AddCommandRec(S, DefCommandTable[I]); + + {create and fill the WordStar command table} + S := GetOrphStr(SCWordStarTableName); + CreateCommandTable(S, False {not active}); + for I := 0 to DefWsMaxCommands-1 do + AddCommandRec(S, DefWsCommandTable[I]); + + {create and fill the table(grid) command table} + S := GetOrphStr(SCGridTableName); + CreateCommandTable(S, False {not active}); + for I := 0 to DefGridMaxCommands-1 do + AddCommandRec(S, DefGridCommandTable[I]); + + ResetCommandProcessor; +end; + +function TOvcCommandProcessor.CreateCommandTable(const TableName : string; Active : Boolean) : Integer; + {-create a command table and add it to the table list} +var + TmpTbl : TOvcCommandTable; +begin + TmpTbl := TOvcCommandTable.Create; + TmpTbl.TableName := TableName; + TmpTbl.IsActive := Active; + Add(TmpTbl); + Result := FTableList.IndexOf(TmpTbl); +end; + +procedure TOvcCommandProcessor.DefineProperties(Filer: TFiler); +begin + inherited DefineProperties(Filer); + Filer.DefineProperty('TableList', cpReadData, cpWriteData, Count > 0); +end; + +procedure TOvcCommandProcessor.Delete(Index : Integer); + {-delete the "Index" table from the list of tables} +begin + if (Index >= 0) and (Index < Count) then begin + {delete the command table} + TOvcCommandTable(FTableList[Index]).Free; + {remove it from the list} + FTableList.Delete(Index); + end else + raise ETableNotFound.Create; +end; + +procedure TOvcCommandProcessor.DeleteCommand(const TableName: string; + Key1, ShiftState1, + Key2, ShiftState2 : Byte); +var + I : Integer; + CmdRec : TOvcCmdRec; + TmpTbl : TOvcCommandTable; +begin + {get the command table pointer} + TmpTbl := GetCommandTable(TableName); + if Assigned(TmpTbl) then begin + {fill temp command record} + CmdRec := cpFillCommandRec(Key1, ShiftState1, Key2, ShiftState2, 0); + {find index of entry} + I := TmpTbl.IndexOf(CmdRec); + {if found, delete it -- no error if not found} + if I > -1 then + TmpTbl.Delete(I); + end else + raise ETableNotFound.Create; +end; + +procedure TOvcCommandProcessor.DeleteCommandTable(const TableName : string); + {-delete a command table and remove from the table list} +var + I : Integer; + TmpTbl : TOvcCommandTable; +begin + TmpTbl := GetCommandTable(TableName);; + if Assigned(TmpTbl) then begin + I := FTableList.IndexOf(TmpTbl); + Delete(I); + end else + raise ETableNotFound.Create; +end; + +destructor TOvcCommandProcessor.Destroy; +begin + if Assigned(FTableList) then begin + Clear; + FTableList.Free; + end; + inherited Destroy; +end; + +procedure TOvcCommandProcessor.Exchange(Index1, Index2 : Integer); + {-exchange list locations of the two specified command tables} +begin + FTableList.Exchange(Index1, Index2); +end; + +function TOvcCommandProcessor.GetTable(Index : Integer) : TOvcCommandTable; + {-return the table referenced by "Index"} +begin + Result := TOvcCommandTable(FTableList[Index]); +end; + +function TOvcCommandProcessor.GetCommandCount(const TableName : string) : Integer; + {-return the number of commands in the command table} +var + TmpTbl : TOvcCommandTable; +begin + {get the command table pointer} + TmpTbl := GetCommandTable(TableName); + if Assigned(TmpTbl) then + Result := TmpTbl.Count + else + raise ETableNotFound.Create; +end; + +function TOvcCommandProcessor.GetCommandTable(const TableName : string) : TOvcCommandTable; + {-return a pointer to the specified command table or nil} +var + I : Integer; +begin + Result := nil; + for I := 0 To Count-1 do + if AnsiUpperCase(TOvcCommandTable(FTableList[I]).TableName) + = AnsiUpperCase(TableName) then + begin + Result := FTableList[I]; + Break; + end; +end; + +function TOvcCommandProcessor.GetCommandTableIndex(const TableName : string) : Integer; + {-return index to the specified command table or -1 for failure} +var + I : Integer; +begin + Result := -1; + for I := 0 To Count-1 do + if AnsiUpperCase(TOvcCommandTable(FTableList[I]).TableName) + = AnsiUpperCase(TableName) then + begin + Result := I; + Break; + end; +end; + +function TOvcCommandProcessor.GetCount : Integer; + {-return the number of tables in the list} +begin + Result := FTableList.Count; +end; + +procedure TOvcCommandProcessor.GetState(var State : TOvcProcessorState; var Key, Shift : Byte); +begin + State := cpState; + Key := cpSaveKey; + Shift := cpSaveSS; +end; + +function TOvcCommandProcessor.LoadCommandTable(const FileName : string) : Integer; + {-creates and then fills a command table from a text file} +var + TmpTbl : TOvcCommandTable; +begin + TmpTbl := TOvcCommandTable.Create; + try + TmpTbl.LoadFromFile(FileName); + Add(TmpTbl); + Result := FTableList.IndexOf(TmpTbl); + except + TmpTbl.Free; + raise; + end; +end; + +procedure TOvcCommandProcessor.ResetCommandProcessor; + {-reset the command processor} +begin + cpState := stNone; + cpSaveKey := VK_NONE; + cpSaveSS := 0; +end; + +procedure TOvcCommandProcessor.SaveCommandTable(const TableName, FileName : string); + {-save a command table to a text file} +var + TmpTbl : TOvcCommandTable; +begin + TmpTbl := GetCommandTable(TableName); + if Assigned(TmpTbl) then + TmpTbl.SaveToFile(FileName); +end; + +procedure TOvcCommandProcessor.SetScanPriority(const Names : array of string); + {-reorder the list of tables based on this array} +var + I : Integer; + Idx : Integer; + TmpTbl : TOvcCommandTable; +begin + for I := 0 to Pred(High(Names)) do begin + TmpTbl := GetCommandTable(Names[I]); + if Assigned(TmpTbl) then begin + Idx := FTableList.IndexOf(TmpTbl); + if (Idx > -1) and (Idx <> I) then + Exchange(I, Idx); + end; + end; +end; + +procedure TOvcCommandProcessor.SetTable(Index : Integer; CT : TOvcCommandTable); + {-store a command table at position "Index"} +var + P : TOvcCommandTable; +begin + if (Index >= 0) and (Index < Count) then begin + P := FTableList[Index]; + FTableList[Index] := CT; + P.Free; + end else + raise ETableNotFound.Create; +end; + +procedure TOvcCommandProcessor.SetState(State : TOvcProcessorState; Key, Shift : Byte); +begin + cpState := State; + cpSaveKey := Key; + cpSaveSS := Shift; +end; + +function TOvcCommandProcessor.Translate(var Msg : TMessage) : Word; + {-translate a message into a command} +var + Command : Word; + I : Integer; + K : Byte; {message key code} + SS : Byte; {shift flags} +begin + {accept the key if no match found} + Result := ccAccept; + + {check for shift state keys, note partial status and exit} + K := Lo(Msg.wParam); + case K of + VK_SHIFT, {shift} + VK_CONTROL, {ctrl} + VK_ALT, {alt} + VK_CAPITAL, {caps lock} + VK_NUMLOCK, {num lock} + VK_SCROLL : {scroll lock} + begin + {if we had a partial command before, we still do} + if cpState = stPartial then + Result := ccPartial; + Exit; + end; + end; + + {exit if this key is to be interpreted literally} + if cpState = stLiteral then begin + cpState := stNone; + Exit; + end; + + {get the current shift flags} + SS := GetShiftFlags; + + Command := ccNone; + for I := 0 to Count-1 do + if TOvcCommandTable(FTableList[I]).IsActive then begin + Command := cpScanTable(FTableList[I], K, SS); + if Command <> ccNone then + Break; + end; + + {if we found a match, return command and exit} + if Command <> ccNone then begin + Result := Command; + Exit; + end; + + {if we had a partial command, suppress this key} + if cpState = stPartial then + Result:= ccSuppress; + + cpState := stNone; +end; + +function TOvcCommandProcessor.TranslateKey(Key : Word; ShiftState : TShiftState) : Word; + {-translate a key and shift-state into a command} +var + Command : Word; + I : Integer; + SS : Byte; {shift flags} +begin + {accept the key if no match found} + Result := ccAccept; + + {check for shift state keys, note partial status and exit} + case Key of + VK_SHIFT, {shift} + VK_CONTROL, {ctrl} + VK_ALT, {alt} + VK_CAPITAL, {caps lock} + VK_NUMLOCK, {num lock} + VK_SCROLL : {scroll lock} + begin + {if we had a partial command before, we still do} + if cpState = stPartial then + Result := ccPartial; + Exit; + end; + end; + + {exit if this key is to be interpreted literally} + if cpState = stLiteral then begin + cpState := stNone; + Exit; + end; + + {get the current shift flags} + SS := (Ord(ssCtrl in ShiftState) * ss_Ctrl) + + (Ord(ssShift in ShiftState) * ss_Shift) + + (Ord(ssAlt in ShiftState) * ss_Alt); + + Command := ccNone; + for I := 0 to Count-1 do + if TOvcCommandTable(FTableList[I]).IsActive then begin + Command := cpScanTable(FTableList[I], Key, SS); + if Command <> ccNone then + Break; + end; + + {if we found a match, return command and exit} + if Command <> ccNone then begin + Result := Command; + Exit; + end; + + {if we had a partial command, suppress this key} + if cpState = stPartial then + Result:= ccSuppress; + + cpState := stNone; +end; + +function TOvcCommandProcessor.TranslateUsing(const Tables : array of string; var Msg : TMessage) : Word; + {-translate a message into a command using the given tables} +var + TmpTbl : TOvcCommandTable; + Command : Word; + I : Integer; + K : Byte; {message key code} + SS : Byte; {shift flags} +begin + {accept the key if no match found} + Result := ccAccept; + + {check for shift state keys, note partial status and exit} + K := Lo(Msg.wParam); + case K of + VK_SHIFT, {shift} + VK_CONTROL, {ctrl} + VK_ALT, {alt} + VK_CAPITAL, {caps lock} + VK_NUMLOCK, {num lock} + VK_SCROLL : {scroll lock} + begin + {if we had a partial command before, we still do} + if cpState = stPartial then + Result := ccPartial; + Exit; + end; + end; + + {get out if this key is to be interpreted literally} + if cpState = stLiteral then begin + cpState := stNone; + Exit; + end; + + {get the current shift flags} + SS := GetShiftFlags; + + Command := ccNone; + for I := 0 to High(Tables) do begin + TmpTbl := GetCommandTable(Tables[I]); + if Assigned(TmpTbl) then begin + Command := cpScanTable(TmpTbl, K, SS); + if Command <> ccNone then + Break; + end; + end; + + {if we found a match, return command and exit} + if Command <> ccNone then begin + Result := Command; + Exit; + end; + + {if we had a partial command, suppress this key} + if cpState = stPartial then + Result:= ccSuppress; + + cpState := stNone; +end; + +function TOvcCommandProcessor.TranslateKeyUsing(const Tables : array of string; Key : Word; ShiftState : TShiftState) : Word; + {-translate a Key and shift-state into a command using the given tables} +var + TmpTbl : TOvcCommandTable; + Command : Word; + I : Integer; + SS : Byte; {shift flags} +begin + {accept the key if no match found} + Result := ccAccept; + + {check for shift state keys, note partial status and exit} + case Key of + VK_SHIFT, {shift} + VK_CONTROL, {ctrl} + VK_ALT, {alt} + VK_CAPITAL, {caps lock} + VK_NUMLOCK, {num lock} + VK_SCROLL : {scroll lock} + begin + {if we had a partial command before, we still do} + if cpState = stPartial then + Result := ccPartial; + Exit; + end; + end; + + {get out if this key is to be interpreted literally} + if cpState = stLiteral then begin + cpState := stNone; + Exit; + end; + + {get the shift flags} + SS := (Ord(ssCtrl in ShiftState) * ss_Ctrl) + + (Ord(ssShift in ShiftState) * ss_Shift) + + (Ord(ssAlt in ShiftState) * ss_Alt); + + Command := ccNone; + for I := 0 to High(Tables) do begin + TmpTbl := GetCommandTable(Tables[I]); + if Assigned(TmpTbl) then begin + Command := cpScanTable(TmpTbl, Key, SS); + if Command <> ccNone then + Break; + end; + end; + + {if we found a match, return command and exit} + if Command <> ccNone then begin + Result := Command; + Exit; + end; + + {if we had a partial command, suppress this key} + if cpState = stPartial then + Result:= ccSuppress; + + cpState := stNone; +end; + + +end. diff --git a/components/orpheus/ovccolor.pas b/components/orpheus/ovccolor.pas new file mode 100644 index 000000000..5ef1ff776 --- /dev/null +++ b/components/orpheus/ovccolor.pas @@ -0,0 +1,200 @@ +{*********************************************************} +{* OVCCOLOR.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovccolor; + {-Color selection class} + +interface + +uses + {$IFNDEF LCL} Windows, {$ELSE} LclIntf, {$ENDIF} Classes, Graphics; + +type + TOvcColors = class(TPersistent) + {.Z+} + protected {private} + {property variables} + FBackColor : TColor; {background color} + FTextColor : TColor; {text or font color} + FUseDefault : Boolean; {true to use defaults} + + {event variables} + FOnColorChange : TNotifyEvent; + + {internal variables} + cDefBackColor : TColor; {default background} + cDefTextColor : TColor; {default text color} + + {property methods} + procedure SetBackColor(Value: TColor); + {-set the color used for the background} + procedure SetTextColor(Value: TColor); + {-set the color used for the foreground} + procedure SetUseDefault(Value: Boolean); + {-set the flag to reset colors to parent default values} + + procedure ReadUseDefault(Reader : TReader); + {-read the UseDefault property. for backward compatibility only} + + protected + procedure DefineProperties(Filer : TFiler); + override; + + procedure DoOnColorChange; + {-notify onwing object that a color has changed} + dynamic; + + procedure ResetToDefaultColors; + {-assign default color values} + dynamic; + + public + procedure Assign(Source : TPersistent); + override; + constructor Create(FG, BG : TColor); + virtual; + {.Z-} + + property OnColorChange : TNotifyEvent + read FOnColorChange + write FOnColorChange; + + published + property BackColor : TColor + read FBackColor + write SetBackColor; + + property TextColor : TColor + read FTextColor + write SetTextColor; + + property UseDefault : Boolean + read FUseDefault + write SetUseDefault + stored False; + end; + + +implementation + + +{*** TOvcColors ***} + +procedure TOvcColors.Assign(Source : TPersistent); +var + C : TOvcColors absolute Source; +begin + if (Source <> nil) and (Source is TOvcColors) then begin + BackColor := C.BackColor; + TextColor := C.TextColor; + end else + inherited Assign(Source); +end; + +constructor TOvcColors.Create(FG, BG : TColor); +begin + inherited Create; + + cDefBackColor := BG; + cDefTextColor := FG; + FUseDefault := True; + + {initialize to these colors} + ResetToDefaultColors; +end; + +procedure TOvcColors.DefineProperties(Filer : TFiler); +begin + inherited DefineProperties(Filer); + {define a UseDefault property for compatibility with eariler versions} + Filer.DefineProperty('UseDefault', ReadUseDefault, nil, False); +end; + +procedure TOvcColors.DoOnColorChange; + {-notify onwing object that a color has changed} +begin + if Assigned(FOnColorChange) then + FOnColorChange(Self); +end; + +procedure TOvcColors.ReadUseDefault(Reader : TReader); +begin + {read property and discard it} + Reader.ReadBoolean; +end; + +procedure TOvcColors.ResetToDefaultColors; + {-obtain default color values} +begin + FBackColor := cDefBackColor; + FTextColor := cDefTextColor; +end; + +procedure TOvcColors.SetBackColor(Value: TColor); + {-set the color used for the background} +begin + if Value <> FBackColor then begin + if Value <> cDefBackColor then + FUseDefault := False; + FBackColor := Value; + DoOnColorChange; + end; +end; + +procedure TOvcColors.SetTextColor(Value: TColor); + {-set the color used for the foreground} +begin + if Value <> FTextColor then begin + if Value <> cDefTextColor then + FUseDefault := False; + FTextColor := Value; + DoOnColorChange; + end; +end; + +procedure TOvcColors.SetUseDefault(Value: Boolean); + {-set the flag to reset colors to parent default values} +begin + FUseDefault := Value; + if FUseDefault then begin + ResetToDefaultColors; {assign default values} + DoOnColorChange; + end; +end; + + +end. diff --git a/components/orpheus/ovcconst.pas b/components/orpheus/ovcconst.pas new file mode 100644 index 000000000..bd33a7011 --- /dev/null +++ b/components/orpheus/ovcconst.pas @@ -0,0 +1,604 @@ +{*********************************************************} +{* OVCCONST.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovcconst; + {-Command and resource constants} + +interface + +const + {value used to offset string resource id's} + BaseOffset = 32768; {***} + +const + {constants for exception messages} + SCUnknownError = 30168; + SCDuplicateCommand = 30169; + SCTableNotFound = 30170; + SCNotDoneYet = 30171; + SCNoControllerAssigned = 30172; + SCCantCreateCommandTable = 30173; + SCCantDelete = 30174; + SCInvalidKeySequence = 30175; + SCNotWordStarCommands = 30176; + SCNoCommandSelected = 30177; + SCDuplicateKeySequence = 30178; + SCRangeError = 30179; + SCInvalidNumber = 30180; + SCRequiredField = 30181; + SCInvalidDate = 30182; + SCInvalidTime = 30183; + SCBlanksInField = 30184; + SCPartialEntry = 30185; + SCRegionTooLarge = 30186; + SCOutOfMemoryForCopy = 30187; + SCInvalidParamValue = 30188; + SCNoTimersAvail = 30189; + SCTooManyEvents = 30190; + SCBadTriggerHandle = 30191; + SCOnSelectNotAssigned = 30192; + SCInvalidPageIndex = 30193; + SCInvalidDataType = 30194; + SCInvalidTabFont = 30195; + SCInvalidLabelFont = 30196; + SCOutOfMemory = 30197; + SCTooManyParas = 30198; + SCCannotJoin = 30199; + SCTooManyBytes = 30200; + SCParaTooLong = 30201; + SCInvalidPictureMask = 30202; + SCInvalidRange = 30203; + SCInvalidRealRange = 30204; + SCInvalidExtendedRange = 30205; + SCInvalidDoubleRange = 30206; + SCInvalidSingleRange = 30207; + SCInvalidCompRange = 30208; + SCInvalidDateRange = 30209; + SCInvalidTimeRange = 30210; + SCInvalidRangeValue = 30211; + SCRangeNotSupported = 30212; + SCInvalidLineOrParaIndex = 30213; + SCNonFixedFont = 30214; + SCInvalidFontParam = 30215; + SCInvalidLineOrColumn = 30216; + SCSAEGeneral = 30217; + SCSAEAtMaxSize = 30218; + SCSAEOutOfBounds = 30219; + SCInvalidXMLFile = 30220; + SCUnterminatedElement = 30221; + SCBadColorConst = 30222; + SCBadColorValue = 30223; + SCInvalidFieldType = 30224; + SCBadAlarmHandle = 30225; + SCOnIsSelectedNotAssigned= 30226; + SCInvalidDateForMask = 30227; + SCNoTableAttached = 30228; + SCViewerIOError = 30232; + SCViewerFileNotFound = 30233; + SCViewerPathNotFound = 30234; + SCViewerTooManyOpenFiles = 30235; + SCViewerFileAccessDenied = 30236; + SCControlAttached = 30237; + SCCantEdit = 30238; + SCChildTableError = 30239; + SCNoCollection = 30241; + SCNotOvcDescendant = 30242; + SCItemIncompatible = 30243; + SCLabelNotAttached = 30244; + SCClassNotSet = 30245; + SCCollectionNotFound = 30246; + SCDayConvertError = 30247; + SCMonthConvertError = 30248; + SCMonthNameConvertError = 30249; + SCYearConvertError = 30250; + SCDayRequired = 30251; + SCMonthRequired = 30252; + SCYearRequired = 30253; + SCInvalidDay = 30254; + SCInvalidMonth = 30255; + SCInvalidMonthName = 30256; + SCInvalidYear = 30257; + SCTableRowOutOfBounds = 30258; + SCTableMaxRows = 30259; + SCTableMaxColumns = 30260; + SCTableGeneral = 30261; + SCTableToManyColumns = 30262; + SCTableInvalidFieldIndex = 30263; + SCTableHeaderNotAssigned = 30264; + SCTableInvalidHeaderCell = 30265; + SCGridTableName = 30266; + {general constants for string table resource entries} + SCNoneStr = 30268; + SCccUser = 30269; + SCccUserNum = 30270; + SCDeleteTable = 30271; + SCRenameTable = 30272; + SCEnterTableName = 30273; + SCNewTable = 30274; + SCDefaultTableName = 30275; + SCWordStarTableName = 30276; + SCUnknownTable = 30277; + SCDefaultEntryErrorText = 30278; + SCGotItemWarning = 30279; + SCSampleListItem = 30280; + SCAlphaString = 30281; + SCTallLowChars = 30282; + SCDefault = 30283; + SCDescending = 30285; + SCDefaultIndex = 30286; + SCRestoreMI = 30287; + SCCutMI = 30288; + SCCopyMI = 30289; + SCPasteMI = 30290; + SCDeleteMI = 30291; + SCSelectAllMI = 30292; + SCCalcBack = 30293; + SCCalcMC = 30294; + SCCalcMR = 30295; + SCCalcMS = 30296; + SCCalcMPlus = 30297; + SCCalcMMinus = 30298; + SCCalcCT = 30299; + SCCalcCE = 30300; + SCCalcC = 30301; + SCCalcSqrt = 30302; + SCCalNext = 30303; + SCCalLast = 30304; + SCCalFirst = 30305; + SCCal1st = 30306; + SCCalSecond = 30307; + SCCal2nd = 30308; + SCCalThird = 30309; + SCCal3rd = 30310; + SCCalFourth = 30311; + SCCal4th = 30312; + SCCalFinal = 30313; + SCCalBOM = 30314; + SCCalEnd = 30315; + SCCalEOM = 30316; + SCCalYesterday = 30317; + SCCalToday = 30318; + SCCalTomorrow = 30319; + SCEditingSections = 30320; + SCEditingItems = 30321; + SCEditingFolders = 30322; + SCEditingPages = 30323; + SCEditingImages = 30324; + SCSectionBaseName = 30325; + SCItemBaseName = 30326; + SCFolderBaseName = 30327; + SCPageBaseName = 30328; + SCImageBaseName = 30329; + SCOwnerMustBeForm = 30330; + SCTimeConvertError = 30331; + SCCancelQuery = 30332; + SCNoPagesAssigned = 30333; + SCCalPrev = 30334; + SCCalBegin = 30335; + SCInvalidMinMaxValue = 30336; + SCFormUseOnly = 30337; + + {misc constant values} + SCYes = 30368; + SCNo = 30369; + SCTrue = 30370; + SCFalse = 30371; + SCHoursName = 30372; + SCMinutesName = 30373; + SCSecondsName = 30374; + SCCloseCaption = 30375; + + {report view exceptions} + SCViewFieldNotFound = 30376; + SCCantResolveField = 30377; + SCItemAlreadyExists = 30378; + SCAlreadyInTempMode = 30379; + SCItemNotFound = 30380; + SCUpdatePending = 30381; + SCOnCompareNotAssigned = 30382; + SCOnFilterNotAssigned = 30383; + SCGetAsFloatNotAssigned = 30384; + SCNotInTempMode = 30385; + SCItemNotInIndex = 30387; + SCNoActiveView = 30388; + SCItemIsNotGroup = 30389; + SCNotMultiSelect = 30390; + SCLineNoOutOfRange = 30391; + SCUnknownView = 30392; + SCOnKeySearchNotAssigned = 30393; + SCOnEnumNotAssigned = 30394; + SCOnEnumSelectedNA = 30395; + + {MRU list exceptions } + SCNoMenuAssigned = 30400; + SCNoAnchorAssigned = 30401; + SCInvalidParameter = 30402; + SCInvalidOperation = 30403; + + SCColorBlack = 30500; + SCColorMaroon = 30501; + SCColorGreen = 30502; + SCColorOlive = 30503; + SCColorNavy = 30504; + SCColorPurple = 30505; + SCColorTeal = 30506; + SCColorGray = 30507; + SCColorSilver = 30508; + SCColorRed = 30509; + SCColorLime = 30510; + SCColorYellow = 30511; + SCColorBlue = 30512; + SCColorFuchsia = 30513; + SCColorAqua = 30514; + SCColorWhite = 30515; + SCColorLightGray = 30516; + SCColorMediumGray = 30517; + SCColorDarkGray = 30518; + SCColorMoneyGreen = 30519; + SCColorSkyBlue = 30520; + SCColorCream = 30521; + +const + cHotKeyChar = '&'; {hotkey prefix character} + +const + {offset for resource id's} + CommandResOfs = BaseOffset + 1000; {***} + + {command codes - corresponding text offset by CommandOfs, stored in rc file} + {*** must be contiguous ***} + ccFirstCmd = 0; {first defined command} + ccNone = 0; {no command or not a known command} + ccBack = 1; {backspace one character} + ccBotOfPage = 2; {move caret to end of last page} + ccBotRightCell = 3; {move to the bottom right hand cell in a table} + ccCompleteDate = 4; {use default date for current date sub field} + ccCompleteTime = 5; {use default time for current time sub field} + ccCopy = 6; {copy highlighted text to clipboard} + ccCtrlChar = 7; {accept control character} + ccCut = 8; {copy highlighted text to clipboard and delete it} + ccDec = 9; {decrement the current entry field value} + ccDel = 10; {delete current character} + ccDelBol = 11; {delete from caret to beginning of line} + ccDelEol = 12; {delete from caret to end of line} + ccDelLine = 13; {delete entire line} + ccDelWord = 14; {delete word to right of caret} + ccDown = 15; {cursor down} + ccEnd = 16; {caret to end of line} + ccExtendDown = 17; {extend selection down one line} + ccExtendEnd = 18; {extend highlight to end of field} + ccExtendHome = 19; {extend highlight to start of field} + ccExtendLeft = 20; {extend highlight left one character} + ccExtendPgDn = 21; {extend selection down one page} + ccExtendPgUp = 22; {extend selection up one page} + ccExtendRight = 23; {extend highlight right one character} + ccExtendUp = 24; {extend selection up one line} + ccExtBotOfPage = 25; {extend selection to bottom of page} + ccExtFirstPage = 26; {extend selection to first page} + ccExtLastPage = 27; {extend selection to last page} + ccExtTopOfPage = 28; {extend selection to top of page} + ccExtWordLeft = 29; {extend highlight left one word} + ccExtWordRight = 30; {extend highlight right one word} + ccFirstPage = 31; {first page in table} + ccGotoMarker0 = 32; {editor & viewer, go to a position marker} + ccGotoMarker1 = 33; {editor & viewer, go to a position marker} + ccGotoMarker2 = 34; {editor & viewer, go to a position marker} + ccGotoMarker3 = 35; {editor & viewer, go to a position marker} + ccGotoMarker4 = 36; {editor & viewer, go to a position marker} + ccGotoMarker5 = 37; {editor & viewer, go to a position marker} + ccGotoMarker6 = 38; {editor & viewer, go to a position marker} + ccGotoMarker7 = 39; {editor & viewer, go to a position marker} + ccGotoMarker8 = 40; {editor & viewer, go to a position marker} + ccGotoMarker9 = 41; {editor & viewer, go to a position marker} + ccHome = 42; {caret to beginning of line} + ccInc = 43; {increment the current entry field value} + ccIns = 44; {toggle insert mode} + ccLastPage = 45; {last page in table} + ccLeft = 46; {caret left by one character} + ccNewLine = 47; {editor, create a new line} + ccNextPage = 48; {next page in table} + ccPageLeft = 49; {move left a page in the table} + ccPageRight = 50; {move right a page in the table} + ccPaste = 51; {paste text from clipboard} + ccPrevPage = 52; {previous page in table} + ccRedo = 53; {re-do the last undone operation} + ccRestore = 54; {restore default and continue} + ccRight = 55; {caret right by one character} + ccScrollDown = 56; {editor, scroll page up one line} + ccScrollUp = 57; {editor, scroll page down one line} + ccSetMarker0 = 58; {editor & viewer, set a position marker} + ccSetMarker1 = 59; {editor & viewer, set a position marker} + ccSetMarker2 = 60; {editor & viewer, set a position marker} + ccSetMarker3 = 61; {editor & viewer, set a position marker} + ccSetMarker4 = 62; {editor & viewer, set a position marker} + ccSetMarker5 = 63; {editor & viewer, set a position marker} + ccSetMarker6 = 64; {editor & viewer, set a position marker} + ccSetMarker7 = 65; {editor & viewer, set a position marker} + ccSetMarker8 = 66; {editor & viewer, set a position marker} + ccSetMarker9 = 67; {editor & viewer, set a position marker} + ccTab = 68; {editor, for tab entry} + ccTableEdit = 69; {enter/exit table edit mode} + ccTopLeftCell = 70; {move to the top left cell in a table} + ccTopOfPage = 71; {move caret to beginning of first page} + ccUndo = 72; {undo last operation} + ccUp = 73; {cursor up} + ccWordLeft = 74; {caret left one word} + ccWordRight = 75; {caret right one word} + + ccLastCmd = 75; {***} {last interfaced command} + + {internal} + ccChar = 249; {regular character; generated internally} + ccMouse = 250; {mouse selection; generated internally} + ccMouseMove = 251; {mouse move; generated internally} + ccAccept = 252; {accept next key; internal} + ccDblClk = 253; {mouse double click; generated internally} + ccSuppress = 254; {suppress next key; internal} + ccPartial = 255; {partial command; internal} + + {user defined commands start here} + ccUserFirst = 256; + ccUser0 = ccUserFirst + 0; + ccUser1 = ccUserFirst + 1; + ccUser2 = ccUserFirst + 2; + ccUser3 = ccUserFirst + 3; + ccUser4 = ccUserFirst + 4; + ccUser5 = ccUserFirst + 5; + ccUser6 = ccUserFirst + 6; + ccUser7 = ccUserFirst + 7; + ccUser8 = ccUserFirst + 8; + ccUser9 = ccUserFirst + 9; + {... = ccUserFirst + 65535 - ccUserFirst} + + +{data type base offset} +const + DataTypeOfs = BaseOffset + 1300; {***} + +{entry field data type sub codes} +const + fsubString = 0; {field subclass codes} + fsubChar = 1; + fsubBoolean = 2; + fsubYesNo = 3; + fsubLongInt = 4; + fsubWord = 5; + fsubInteger = 6; + fsubByte = 7; + fsubShortInt = 8; + fsubReal = 9; + fsubExtended = 10; + fsubDouble = 11; + fsubSingle = 12; + fsubComp = 13; + fsubDate = 14; + fsubTime = 15; + + +{constants for simple, picture, and numeric picture} +{mask samples used in the property editors} +const + PictureMaskOfs = BaseOffset + 1700; {***} + + {simple field mask characters} + stsmFirst = 34468; + stsmLast = 34468 + 23; + + {numeric field picture masks} + stnmFirst = 34493; + stnmLast = 34493 + 17; + + {picture field picture masks} + stpmFirst = 34518; + stpmLast = 34518 + 23; + +const +{String Resource Constants...} + +{Note: These should stay in numerical order. It's not as important here as it + is in the O32SR.pas file's Lookup Array, but you should still keep it in + mind when editing these values...} + + {String Resource Index Constants} + IccNone = 33768; + IccBack = 33769; + IccBotOfPage = 33770; + IccBotRightCell = 33771; + IccCompleteDate = 33772; + IccCompleteTime = 33773; + IccCopy = 33774; + IccCtrlChar = 33775; + IccCut = 33776; + IccDec = 33777; + IccDel = 33778; + IccDelBol = 33779; + IccDelEol = 33780; + IccDelLine = 33781; + IccDelWord = 33782; + IccDown = 33783; + IccEnd = 33784; + IccExtendDown = 33785; + IccExtendEnd = 33786; + IccExtendHome = 33787; + IccExtendLeft = 33788; + IccExtendPgDn = 33789; + IccExtendPgUp = 33790; + IccExtendRight = 33791; + IccExtendUp = 33792; + IccExtBotOfPage = 33793; + IccExtFirstPage = 33794; + IccExtLastPage = 33795; + IccExtTopOfPage = 33796; + IccExtWordLeft = 33797; + IccExtWordRight = 33798; + IccFirstPage = 33799; + IccGotoMarker0 = 33800; + IccGotoMarker1 = 33801; + IccGotoMarker2 = 33802; + IccGotoMarker3 = 33803; + IccGotoMarker4 = 33804; + IccGotoMarker5 = 33805; + IccGotoMarker6 = 33806; + IccGotoMarker7 = 33807; + IccGotoMarker8 = 33808; + IccGotoMarker9 = 33809; + IccHome = 33810; + IccInc = 33811; + IccIns = 33812; + IccLastPage = 33813; + IccLeft = 33814; + IccNewLine = 33815; + IccNextPage = 33816; + IccPageLeft = 33817; + IccPageRight = 33818; + IccPaste = 33819; + IccPrevPage = 33820; + IccRedo = 33821; + IccRestore = 33822; + IccRight = 33823; + IccScrollDown = 33824; + IccScrollUp = 33825; + IccSetMarker0 = 33826; + IccSetMarker1 = 33827; + IccSetMarker2 = 33828; + IccSetMarker3 = 33829; + IccSetMarker4 = 33830; + IccSetMarker5 = 33831; + IccSetMarker6 = 33832; + IccSetMarker7 = 33833; + IccSetMarker8 = 33834; + IccSetMarker9 = 33835; + IccTab = 33836; + IccTableEdit = 33837; + IccTopLeftCell = 33838; + IccTopOfPage = 33839; + IccUndo = 33840; + IccUp = 33841; + IccWordLeft = 33842; + IccWordRight = 33843; + + IString = 34068; + IChar = 34069; + IBoolean = 34070; + IYesNo = 34071; + ILongInt = 34072; + IWord = 34073; + ISmallInt = 34074; + IByte = 34075; + IShortInt = 34076; + IReal = 34077; + IExtended = 34078; + IDouble = 34079; + ISingle = 34080; + IComp = 34081; + IDate = 34082; + ITime = 34083; + + {Character Masks} + ICharMask1 = 34468; + ICharMask2 = 34469; + ICharMask3 = 34470; + ICharMask4 = 34471; + ICharMask5 = 34472; + ICharMask6 = 34473; + ICharMask7 = 34474; + ICharMask8 = 34475; + ICharMask9 = 34476; + ICharMask10 = 34477; + ICharMask11 = 34478; + ICharMask12 = 34479; + ICharMask13 = 34480; + ICharMask14 = 34481; + ICharMask15 = 34482; + ICharMask16 = 34483; + ICharMask17 = 34484; + ICharMask18 = 34485; + ICharMask19 = 34486; + ICharMask20 = 34487; + ICharMask21 = 34488; + ICharMask22 = 34489; + ICharMask23 = 34490; + ICharMask24 = 34491; + + {Sample Field Masks } + IFieldMask1 = 34493; + IFieldMask2 = 34494; + IFieldMask3 = 34495; + IFieldMask4 = 34496; + IFieldMask5 = 34497; + IFieldMask6 = 34498; + IFieldMask7 = 34499; + IFieldMask8 = 34500; + IFieldMask9 = 34501; + IFieldMask10 = 34502; + IFieldMask11 = 34503; + IFieldMask12 = 34504; + IFieldMask13 = 34505; + IFieldMask14 = 34506; + IFieldMask15 = 34507; + IFieldMask16 = 34508; + IFieldMask17 = 34509; + IFieldMask18 = 34510; + + IFieldMask19 = 34518; + IFieldMask20 = 34519; + IFieldMask21 = 34520; + IFieldMask22 = 34521; + IFieldMask23 = 34522; + IFieldMask24 = 34523; + IFieldMask25 = 34524; + IFieldMask26 = 34525; + IFieldMask27 = 34526; + IFieldMask28 = 34527; + IFieldMask29 = 34528; + IFieldMask30 = 34529; + IFieldMask31 = 34530; + IFieldMask32 = 34531; + IFieldMask33 = 34532; + IFieldMask34 = 34533; + IFieldMask35 = 34534; + IFieldMask36 = 34535; + IFieldMask37 = 34536; + IFieldMask38 = 34537; + IFieldMask39 = 34538; + IFieldMask40 = 34539; + IFieldMask41 = 34540; + IFieldMask42 = 34541; + +implementation + +end. diff --git a/components/orpheus/ovcdata.pas b/components/orpheus/ovcdata.pas new file mode 100644 index 000000000..6c365f16e --- /dev/null +++ b/components/orpheus/ovcdata.pas @@ -0,0 +1,624 @@ +{*********************************************************} +{* OVCDATA.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovcdata; + {-Miscellaneous type and constant declarations} + +interface + +uses + {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, LclType, MyMisc, {$ENDIF} + Controls, Forms, Graphics, StdCtrls, SysUtils, OvcConst, OvcDate, O32SR; + +const + BorderStyles : array[TBorderStyle] of LongInt = + (0, WS_BORDER); + ScrollBarStyles : array [TScrollStyle] of LongInt = + (0, WS_HSCROLL, WS_VSCROLL, WS_HSCROLL or WS_VSCROLL +{$IFDEF LCL} + ,WS_HSCROLL, WS_VSCROLL, WS_HSCROLL or WS_VSCROLL +{$ENDIF} + ); + +{$IFNDEF VERSION4} +type + PDateTime = ^TDateTime; +{$ENDIF} + +{some colors that are not defined by Delphi} +const + clCream = TColor($A6CAF0); + clMoneyGreen = TColor($C0DCC0); + clSkyBlue = TColor($FFFBF0); + +type + TCharSet = set of AnsiChar; {a Pascal set of characters} + +type + PPointer = ^Pointer; + +type + {secondary field options--internal} + TsefOption = ( + sefValPending, {field needs validation} + sefInvalid, {field is invalid} + sefNoHighlight, {Don't highlight field initially} + sefIgnoreFocus, {We're ignoring the focus} + sefValidating, {We're validating a field} + sefModified, {Field recently modified} + sefEverModified, {Field has been modified after last data transfer} + sefFixSemiLits, {Semi-literals were stripped} + sefHexadecimal, {Field's value is shown in hex} + sefOctal, {Field's value is shown in octal} + sefBinary, {Field's value is shown in binary} + sefNumeric, {Edit from right to left--for numbers only} + sefRealVar, {Field is of a real/8087 type} + sefNoLiterals, {Picture mask has no literals} + sefHaveFocus, {Control has the focus} + sefRetainPos, {Retain caret position} + sefErrorPending, {Error pending?} + sefInsert, {Insert mode on} + sefLiteral, {Next char is literal} + sefAcceptChar, {Accept next character} + sefCharOK, {OK to add a character} + sefUpdating, {field is being updated} + sefGettingValue, {field contents are being retrieved} + sefUserValidating, {user validation in progress} + sefNoUserValidate); {don't perform user validation} + + {Set of current secondary options for entry fields} + TsefOptionSet = set of TsefOption; + +const + {default secondary field options} + sefDefOptions : TsefOptionSet = [sefCharOK, sefInsert]; + +const + DefPadChar = ' '; {Default character used to pad the end of a display string} + MaxEditLen = 255; {Maximum length of edit string} + MaxPicture = 255; {Maximum length of a picture mask} + +{*** Picture masks ***} +const + {the following characters are meaningful in Picture masks} + pmAnyChar = 'X'; {allows any character} + pmForceUpper = '!'; {allows any character, forces upper case} + pmForceLower = 'L'; {allows any character, forces lower case} + pmForceMixed = 'x'; {allows any character, forces mixed case} + pmAlpha = 'a'; {allows alphas only} + pmUpperAlpha = 'A'; {allows alphas only, forces upper case} + pmLowerAlpha = 'l'; {allows alphas only, forces lower case} + pmPositive = '9'; {allows numbers and spaces only} + pmWhole = 'i'; {allows numbers, spaces, minus} + pmDecimal = '#'; {allows numbers, spaces, minus, period} + pmScientific = 'E'; {allows numbers, spaces, minus, period, 'e'} + pmHexadecimal = 'K'; {allows 0-9, A-F, and space forces upper case} + pmOctal = 'O'; {allows 0-7, space} + pmBinary = 'b'; {allows 0-1, space} + pmTrueFalse = 'B'; {allows T, t, F, f} + pmYesNo = 'Y'; {allows Y, y, N, n} + + pmUser1 = '1'; {User-defined picture mask characters} + pmUser2 = '2'; + pmUser3 = '3'; + pmUser4 = '4'; + pmUser5 = '5'; + pmUser6 = '6'; + pmUser7 = '7'; + pmUser8 = '8'; + + Subst1 = #241; {User-defined substitution characters} + Subst2 = #242; + Subst3 = #243; + Subst4 = #244; + Subst5 = #245; + Subst6 = #246; + Subst7 = #247; + Subst8 = #248; + +const + {Other special characters allowed in Picture strings} + pmDecimalPt = '.'; {insert decimal point} + pmComma = ','; {character used to separate numbers} + pmFloatDollar = '$'; {floating dollar sign} + pmCurrencyLt = 'c'; {currency to left of the amount} + pmCurrencyRt = 'C'; {currency to right of the amount} + pmNegParens = 'p'; {indicates () should be used for negative #'s} + pmNegHere = 'g'; {placeholder for minus sign} + {NOTE: Comma and FloatDollar are allowed only in fields containing fixed + decimal points and/or numeric fields. NegParens and NegHere should be used + only in numeric fields.} + +const + {the following characters are meaningful in date Picture masks} + pmMonth = 'm'; {formatting character for a date string picture mask} + pmMonthU = 'M'; {formatting character for a date string picture mask. + Uppercase means pad with ' ' rather than '0'} + pmDay = 'd'; {formatting character for a date string picture mask} + pmDayU = 'D'; {formatting character for a date string picture mask. + Uppercase means pad with ' ' rather then '0'} + pmYear = 'y'; {formatting character for a date string picture mask} + pmDateSlash = '/'; {formatting character for a date string picture mask} + + {'n'/'N' may be used in place of 'm'/'M' when the name of the month is + desired instead of its number. E.g., 'dd/nnn/yyyy' -\> '01-Jan-1980'. + 'dd/NNN/yyyy' -\> '01-JAN-1980' (if SlashChar = '-'). The abbreviation used + is based on the width of the subfield (3 in the example) and the current + contents of the MonthString array.} + pmMonthName = 'n'; {formatting character for a date string picture mask} + pmMonthNameU = 'N'; {formatting character for a date string picture mask. + Uppercase causes the output to be in uppercase} + + {'w'/'W' may be used to include the day of the week in a date string. E.g., + 'www dd nnn yyyy' -\> 'Mon 01 Jan 1989'. The abbreviation used is based on + the width of the subfield (3 in the example) and the current contents of the + DayString array. Note that entry field will not allow the user to enter + text into a subfield containing 'w' or 'W'. The day of the week will be + supplied automatically when a valid date is entered.} + pmWeekDay = 'w'; {formatting character for a date string picture mask} + pmWeekDayU = 'W'; {formatting character for a date string picture mask. + Uppercase causes the output to be in uppercase} + + pmLongDateSub1 = 'f'; {mask character used with Window's long date format} + pmLongDateSub2 = 'g'; {mask character used with Window's long date format} + pmLongDateSub3 = 'h'; {mask character used with Window's long date format} + +const + {if uppercase letters are used, numbers are padded with ' ' rather than '0'} + pmHour = 'h'; {formatting character for a time string picture mask} + pmHourU = 'H'; {formatting character for a time string picture mask} + pmMinute = 'm'; {formatting character for a time string picture mask} + pmMinuteU = 'M'; {formatting character for a time string picture mask} + pmSecond = 's'; {formatting character for a time string picture mask} + pmSecondU = 'S'; {formatting character for a time string picture mask} + {'hh:mm:ss tt' -\> '12:00:00 pm', 'hh:mmt' -\> '12:00p'} + pmAmPm = 't'; {formatting character for a time string picture mask. + This generates 'AM' or 'PM'} + pmTimeColon = ':'; {formatting character for a time string picture mask} + +const + PictureChars : TCharSet = [ + pmAnyChar, pmForceUpper, pmForceLower, pmForceMixed, + pmAlpha, pmUpperAlpha, pmLowerAlpha, + pmPositive, pmWhole, pmDecimal, pmScientific, + pmHexadecimal, pmOctal, pmBinary, + pmTrueFalse, pmYesNo, + pmMonthName, pmMonthNameU, pmMonth, + pmMonthU, pmDay, pmDayU, pmYear, pmHour, pmHourU, {$IFNDEF FPC} pmMinute, + pmMinuteU, {$ENDIF} pmSecond, pmSecondU, pmAmPm, pmUser1..pmUser8]; + +const + {set of allowable picture characters for simple fields} + SimplePictureChars : TCharSet = [ + pmAnyChar, pmForceUpper, pmForceLower, pmForceMixed, + pmAlpha, pmUpperAlpha, pmLowerAlpha, + pmPositive, pmWhole, pmDecimal, pmScientific, + pmHexadecimal, pmOctal, pmBinary, + pmTrueFalse, pmYesNo, + pmUser1..pmUser8]; + +type + {types of case change operations associated with a picture mask character} + TCaseChange = (mcNoChange, mcUpperCase, mcLowerCase, mcMixedCase); + +type + TUserSetRange = pmUser1..pmUser8; + TForceCaseRange = pmUser1..pmUser8; + TSubstCharRange = Subst1..Subst8; + + TUserCharSets = array[TUserSetRange] of TCharSet; + TForceCase = array[TForceCaseRange] of TCaseChange; + TSubstChars = array[TSubstCharRange] of AnsiChar; + +const + MaxDateLen = 40; {maximum length of date picture strings} + MaxMonthName = 15; {maximum length for month names} + MaxDayName = 15; {maximum length for day names} + +const + otf_SizeData = 0; {These three constants are used in data transfers to} + otf_GetData = 1; {specify the type of transfer operation being requested} + otf_SetData = 2; + +type + TEditString = array[0..MaxEditLen] of AnsiChar; + TPictureMask = array[0..MaxPicture] of AnsiChar; + + {An array of flags that indicate the type of mask character at a given + location in a picture mask} + TPictureFlags = array[0..MaxEditLen+1] of Byte; + + {Each entry field maintains two data structures of this type, one to store + the lower limit of a field's value, and another to store the upper limit} + PRangeType = ^TRangeType; + TRangeType = packed record + case Byte of {size} + 00 : (rtChar : AnsiChar); {01} + 01 : (rtByte : Byte); {01} + 02 : (rtSht : ShortInt); {01} + 03 : (rtInt : SmallInt); {02} + 04 : (rtWord : Word); {02} + 05 : (rtLong : LongInt); {04} + 06 : (rtSgl : Single); {04} + 07 : (rtPtr : Pointer); {04} + {$IFDEF CBuilder} + 08 : (rtReal : Double); {06} + {$ELSE} + 08 : (rtReal : Real); {06} + {$ENDIF CBuilder} + 09 : (rtDbl : Double); {08} + {$IFDEF CBuilder} + 10 : (rtComp : Double); {08} + {$ELSE} + {$IFNDEF FPC} {Delphi} + 10 : (rtComp : Comp); {08} + {$ELSE} {FPC} + {$IFDEF CPU86} + 10 : (rtComp : Comp); {08} + {$ELSE} {Comp is true integer with non-Intel} + 10 : (rtComp : Double); {08} + {$ENDIF} + {$ENDIF} + {$ENDIF CBuilder} + 11 : (rtExt : Extended); {10} + 12 : (rtDate : LongInt); {04} + 13 : (rtTime : LongInt); {04} + 14 : (rt10 : array[1..10] of Byte); {10} {forces structure to size of 10 bytes} + end; + +const + BlankRange : TRangeType = (rt10 : (0, 0, 0, 0, 0, 0, 0, 0, 0, 0)); + +{*** Date/Time declarations ***} +type + TOvcDate = TStDate; + TOvcTime = TStTime; + TDayType = TStDayType; + +type + {states for data aware entry fields} + TDbEntryFieldStates = (esFocused, esSelected, esReset); + TDbEntryFieldState = set of TDbEntryFieldStates; + +type + {Search option flags for editor and viewer} + TSearchOptions = ( + soFind, {find (this option is assumed) } + soBackward, {search backwards } + soMatchCase, {don't ignore case when searching } + soGlobal, {search globally } + soReplace, {find and replace (editor only)} + soReplaceAll, {find and replace all (editor only)} + soWholeWord, {match on whole word only (editor only)} + soSelText); {search in selected text (editor only)} + TSearchOptionSet = set of TSearchOptions; + +const + {maximum length of a search/replacement string} + MaxSearchString = 255; + +type + {types of tabs supported in the editor} + TTabType = (ttReal, ttFixed, ttSmart); + + {entry field flag for display of number field with zero value} + TZeroDisplay = (zdShow, zdHide, zdHideUntilModified); + +type + {structrue of the commands stored in the command table} + POvcCmdRec = ^TOvcCmdRec; + TOvcCmdRec = packed record + case Byte of + 0 : (Key1 : Byte; {first keys' virtual key code} + SS1 : Byte; {shift state of first key} + Key2 : Byte; {second keys' virtual key code, if any} + SS2 : Byte; {shift state of second key} + Cmd : Word); {command to return for this entry} + 1 : (Keys : LongInt); {used for sorting, searching, and storing} + end; + +const + {shift state flags for command processors} + ss_None = $00; {no shift key is pressed} + ss_Shift = $02; {the shift key is pressed} + ss_Ctrl = $04; {the control key is pressed} + ss_Alt = $08; {the alt key is pressed} + ss_Wordstar = $80; {2nd key of a twokey wordstar command: ss_Ctrl or ss_None} + {the second key of a two-key wordstar command is accepted if} + {pressed by itself of with the ctrl key. case is ignored} + +const + {virtual key constants not already defined} + VK_NONE = 0; + VK_ALT = VK_MENU; + VK_A = Ord('A'); VK_B = Ord('B'); VK_C = Ord('C'); VK_D = Ord('D'); + VK_E = Ord('E'); VK_F = Ord('F'); VK_G = Ord('G'); VK_H = Ord('H'); + VK_I = Ord('I'); VK_J = Ord('J'); VK_K = Ord('K'); VK_L = Ord('L'); + VK_M = Ord('M'); VK_N = Ord('N'); VK_O = Ord('O'); VK_P = Ord('P'); + VK_Q = Ord('Q'); VK_R = Ord('R'); VK_S = Ord('S'); VK_T = Ord('T'); + VK_U = Ord('U'); VK_V = Ord('V'); VK_W = Ord('W'); VK_X = Ord('X'); + VK_Y = Ord('Y'); VK_Z = Ord('Z'); VK_0 = Ord('0'); VK_1 = Ord('1'); + VK_2 = Ord('2'); VK_3 = Ord('3'); VK_4 = Ord('4'); VK_5 = Ord('5'); + VK_6 = Ord('6'); VK_7 = Ord('7'); VK_8 = Ord('8'); VK_9 = Ord('9'); + +var + AlphaCharSet : TCharSet; + +const + IntegerCharSet: TCharSet = ['0'..'9', ' ']; + RealCharSet : TCharSet = ['0'..'9', ' ', '-', '.']; + +const + {Picture flag values for elements in a TPictureFlags array} + pflagLiteral = 0; {Corresponding char in the mask is a literal} + pflagFormat = 1; {Corresponding char in the mask is a formatting character} + pflagSemiLit = 2; {Corresponding char in the mask is a semi-literal character} + +const + {------------------- Windows messages -----------------------} + {Not a message code. Value of the first of the message codes used} + OM_FIRST = $7F00; {***} + + {entry field error} + OM_REPORTERROR = OM_FIRST + 0; + {messages for/from viewer/editor controls} + OM_SETFOCUS = OM_FIRST + 1; + {sent by an entry field to the controller to request return of the + focus. lParam is pointer of the object to return the focus to} + OM_SHOWSTATUS = OM_FIRST + 2; + {sent by a viewer or editor control to itself when the caret moves, or + when text is inserted or deleted. wParam is the current column (an + effective column number), and lParam is the current line} + OM_GETDATASIZE = OM_FIRST + 3; + {sent to an entry field to obtain its data size} + OM_RECREATEWND = OM_FIRST + 5; + {sent to force a call to RecreateWnd} + OM_PREEDIT = OM_FIRST + 6; + {sent to preform pre-edit notification for entry fields} + OM_POSTEDIT = OM_FIRST + 7; + {sent to preform post-edit notification for entry fields} + OM_AFTERENTER = OM_FIRST + 8; + {sent to preform after-enter notification} + OM_AFTEREXIT = OM_FIRST + 9; + {sent to preform after-exit notification} + OM_DELAYNOTIFY = OM_FIRST + 10; + {sent to preform delayed notification} + OM_POSITIONLABEL = OM_FIRST + 11; + {sent to cause the label to be repositioned} + OM_RECORDLABELPOSITION = OM_FIRST + 12; + {sent to cause the current position of the label to be recorded} + OM_ASSIGNLABEL = OM_FIRST + 13; + {sent to assign a albel to a control} + OM_FONTUPDATEPREVIEW = OM_FIRST + 14; + {sent to postpone the font change of the preview control} + OM_DESTROYHOOK = OM_FIRST + 15; + {send to cause the window hook to be destroyed} + OM_PROPCHANGE = OM_FIRST + 16; + {sent by a collection to its property editor when a property is changed} + OM_ISATTACHED = OM_FIRST + 17; + {sent to other controls to see if they are attached. Used by attached + button components and components that use an internal validator. + Result is LongInt(Self) if true} + OM_VALIDATE = OM_FIRST + 18; + {Sent to the FlexEdit as a call for it to Validate Itself} + +{message crackers for the above Orpheus messages} + +type + TOMReportError = packed record + Msg : Cardinal; + Error : Word; + Unused : Word; + lParam : LongInt; + Result : LongInt; + end; + + TOMSetFocus = packed record + Msg : Cardinal; + wParam : Integer; + Control: TWinControl; + Result : LongInt; + end; + + TOMShowStatus = packed record + Msg : Cardinal; + Column : Integer; + Line : LongInt; + Result : LongInt; + end; + + +type + TShowStatusEvent = + procedure(Sender : TObject; LineNum : LongInt; ColNum : Integer) + of object; + {-event to notify of a viewer or editor caret position change} + + TTopLineChangedEvent = + procedure(Sender : TObject; Line : LongInt) + of object; + {-event to notify when the top line changes for the editor or viewer} + +const + {*** Error message codes ***} + oeFirst = 256; + + oeRangeError = oeFirst + 0; + {This error occurs when a user enters a value that is not within the + accepted range of values for the field} + oeInvalidNumber = oeFirst + 1; + {This error is reported if the user enters a string that does not represent + a number in a field that should contain a numeric value} + oeRequiredField = oeFirst + 2; + {This error occurs when the user leaves blank a field that is marked as + required} + oeInvalidDate = oeFirst + 3; + {This error occurs when the user enters a value in a date field that does + not represent a valid date} + oeInvalidTime = oeFirst + 4; + {This error occurs when the user enters a value in a time field that does + not represent a valid time of day} + oeBlanksInField = oeFirst + 5; + {This error is reported only by the validation helper routines + ValidateNoBlanks and ValidateSubfields. It indicates that a blank was left + in a field or subfield in which no blanks are allowed} + oePartialEntry = oeFirst + 6; + {This error is reported only by the validation helper routines + ValidateNotPartial and ValidateSubfields in OODEWCC. It indicates that a + partial entry was given in a field or subfield in which the field/subfield + must be either entirely empty or entirely full} + oeOutOfMemory = oeFirst + 7; + {This error is reported by a viewer or editor control when there is + insufficient memory to perform the requested operation. A viewer control + reports this error only when copying selected text to the clipboard} + oeRegionSize = oeFirst + 8; + {This error is reported by an editor control when the user asks to + copy selected text to the clipboard, and the selected region exceeds + 64K in size} + oeTooManyParas = oeFirst + 9; + {This error is reported by an editor control when the limit on the number + of paragraphs is reached, and the requested operation would cause it to be + exceeded} + oeCannotJoin = oeFirst + 10; + {This error is reported by an editor control when the user attempts to join + two paragraphs that cannot be joined. Typically this occurs when joining + the two paragraphs would cause the new paragraph to exceed its size limit} + oeTooManyBytes = oeFirst + 11; + {This error is reported by an editor control when the limit on the total + number of bytes is reached, and the requested operation would cause it to + be exceeded} + oeParaTooLong = oeFirst + 12; + {This error is reported by an editor control when the limit on the length + of an individual paragraph is reached, and the requested operation would + cause it to be exceeded} + oeCustomError = 32768; + {the first error code reserved for user applications. All } + {error values less than this value are reserved for use by} + {Orpheus} + +{*** Field class and type constant id's ***} + +const + {Field class codes} + fcSimple = 0; + fcPicture = 1; + fcNumeric = 2; + + {Field class divisor} + fcpDivisor = $40; + + {Field class prefixes} + fcpSimple = fcpDivisor*fcSimple; + fcpPicture = fcpDivisor*fcPicture; + fcpNumeric = fcpDivisor*fcNumeric; + + {Field type IDs for simple fields} + fidSimpleString = fcpSimple+fsubString; + fidSimpleChar = fcpSimple+fsubChar; + fidSimpleBoolean = fcpSimple+fsubBoolean; + fidSimpleYesNo = fcpSimple+fsubYesNo; + fidSimpleLongInt = fcpSimple+fsubLongInt; + fidSimpleWord = fcpSimple+fsubWord; + fidSimpleInteger = fcpSimple+fsubInteger; + fidSimpleByte = fcpSimple+fsubByte; + fidSimpleShortInt = fcpSimple+fsubShortInt; + fidSimpleReal = fcpSimple+fsubReal; + fidSimpleExtended = fcpSimple+fsubExtended; + fidSimpleDouble = fcpSimple+fsubDouble; + fidSimpleSingle = fcpSimple+fsubSingle; + fidSimpleComp = fcpSimple+fsubComp; + + {Field type IDs for picture fields} + fidPictureString = fcpPicture+fsubString; + fidPictureChar = fcpPicture+fsubChar; + fidPictureBoolean = fcpPicture+fsubBoolean; + fidPictureYesNo = fcpPicture+fsubYesNo; + fidPictureLongInt = fcpPicture+fsubLongInt; + fidPictureWord = fcpPicture+fsubWord; + fidPictureInteger = fcpPicture+fsubInteger; + fidPictureByte = fcpPicture+fsubByte; + fidPictureShortInt = fcpPicture+fsubShortInt; + fidPictureReal = fcpPicture+fsubReal; + fidPictureExtended = fcpPicture+fsubExtended; + fidPictureDouble = fcpPicture+fsubDouble; + fidPictureSingle = fcpPicture+fsubSingle; + fidPictureComp = fcpPicture+fsubComp; + fidPictureDate = fcpPicture+fsubDate; + fidPictureTime = fcpPicture+fsubTime; + + {Field type IDs for numeric fields} + fidNumericLongInt = fcpNumeric+fsubLongInt; + fidNumericWord = fcpNumeric+fsubWord; + fidNumericInteger = fcpNumeric+fsubInteger; + fidNumericByte = fcpNumeric+fsubByte; + fidNumericShortInt = fcpNumeric+fsubShortInt; + fidNumericReal = fcpNumeric+fsubReal; + fidNumericExtended = fcpNumeric+fsubExtended; + fidNumericDouble = fcpNumeric+fsubDouble; + fidNumericSingle = fcpNumeric+fsubSingle; + fidNumericComp = fcpNumeric+fsubComp; + + +function GetOrphStr(Index : Word) : string; + {-return a string from our RCDATA string resource} + +implementation + +function GetOrphStr(Index : Word) : string; +begin + Result := ResourceStrByNumber(Index); + if Result = '' then + Result := 'Unknown'; +end; + + +procedure InitAlphaCharSet; + {-Initialize AlphaOnlySet} +var + C : AnsiChar; +begin + AlphaCharSet := ['A'..'Z', 'a'..'z', ' ', '-', '.', ',']; + for C := #128 to #255 do + {ask windows what other characters are considered alphas} + if IsCharAlpha(C) then + AlphaCharSet := AlphaCharSet + [C]; +end; + +initialization + InitAlphaCharSet; + +end. diff --git a/components/orpheus/ovcdate.pas b/components/orpheus/ovcdate.pas new file mode 100644 index 000000000..6084d41ef --- /dev/null +++ b/components/orpheus/ovcdate.pas @@ -0,0 +1,996 @@ +{*********************************************************} +{* OVCDATE.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$IFDEF VERSION7} + {$IFNDEF FPC} + {$WARN UNSAFE_CODE OFF} + {$WARN UNSAFE_TYPE OFF} + {$WARN UNSAFE_CAST OFF} + {$ENDIF} +{$ENDIF} + +{For BCB 3.0 package support.} +{$IFDEF VER110} + {$ObjExportAll On} +{$ENDIF} + + +{---Global compiler defines for Delphi 2.0---} +{$A+} {Word Align Data} +{$H+} {Huge string support} +{$Q-} {Overflow check} +{$R-} {Range check} +{$S-} {Stack check} +{$T-} {Typed @ check} +{$V-} {Var strings} + +unit ovcdate; {formerly StDate} + {-Date and time manipulation} + +interface + +uses + {$IFNDEF LCL} Windows, {$ELSE} LclIntf, {$ENDIF} SysUtils; + +type + TStDate = LongInt; + {In STDATE, dates are stored in long integer format as the number of days + since January 1, 1600} + + TDateArray = array[0..(MaxLongInt div SizeOf(TStDate))-1] of TStDate; + {Type for StDate open array} + + TStDayType = (Sunday, Monday, Tuesday, Wednesday, Thursday, Friday, Saturday); + {An enumerated type used when representing a day of the week} + + TStBondDateType = (bdtActual, bdt30E360, bdt30360, bdt30360psa); + {An enumerated type used for calculating bond date differences} + + TStTime = LongInt; + {STDATE handles time in a manner similar to dates, representing a given + time of day as the number of seconds since midnight} + + TStDateTimeRec = + record + {This record type simply combines the two basic date types defined by + STDATE, Date and Time} + D : TStDate; + T : TStTime; + end; + +const + MinYear = 1600; {Minimum valid year for a date variable} + MaxYear = 3999; {Maximum valid year for a date variable} + Mindate = $00000000; {Minimum valid date for a date variable - 01/01/1600} + Maxdate = $000D6025; {Maximum valid date for a date variable - 12/31/3999} + Date1900 = $0001AC05; {This constant contains the Julian date for 01/01/1900} + Date1980 = $00021E28; {This constant contains the Julian date for 01/01/1980} + Date2000 = $00023AB1; {This constant contains the Julian date for 01/01/2000} + {This value is used to represent an invalid date, such as 12/32/1992} + BadDate = LongInt($FFFFFFFF); + + DeltaJD = $00232DA8; {Days between 1/1/-4173 and 1/1/1600} + + MinTime = 0; {Minimum valid time for a time variable - 00:00:00 am} + MaxTime = 86399; {Maximum valid time for a time variable - 23:59:59 pm} + {This value is used to represent an invalid time of day, such as 12:61:00} + BadTime = LongInt($FFFFFFFF); + + SecondsInDay = 86400; {Number of seconds in a day} + SecondsInHour = 3600; {Number of seconds in an hour} + SecondsInMinute = 60; {Number of seconds in a minute} + HoursInDay = 24; {Number of hours in a day} + MinutesInHour = 60; {Number of minutes in an hour} + MinutesInDay = 1440; {Number of minutes in a day} + +var + DefaultYear : Integer; {default year--used by DateStringToDMY} + DefaultMonth : ShortInt; {default month} + + {-------julian date routines---------------} + +function CurrentDate : TStDate; + {-returns today's date as a Julian date} + +function ValidDate(Day, Month, Year, Epoch : Integer) : Boolean; + {-Verify that day, month, year is a valid date} + +function DMYtoStDate(Day, Month, Year, Epoch : Integer) : TStDate; + {-Convert from day, month, year to a Julian date} + +procedure StDateToDMY(Julian : TStDate; var Day, Month, Year : Integer); + {-Convert from a Julian date to day, month, year} + +function IncDate(Julian : TStDate; Days, Months, Years : Integer) : TStDate; + {-Add (or subtract) the number of days, months, and years to a date} + +function IncDateTrunc(Julian : TStDate; Months, Years : Integer) : TStDate; + {-Add (or subtract) the specified number of months and years to a date} + +procedure DateDiff(Date1, Date2 : TStDate; + var Days, Months, Years : Integer); +{-Return the difference in days, months, and years between two valid Julian + dates} + +function BondDateDiff(Date1, Date2 : TStDate; DayBasis : TStBondDateType) : TStDate; + {-Return the difference in days between two valid Julian + dates using a specific financial basis} + +function WeekOfYear(Julian : TStDate) : Byte; + {-Returns the week number of the year given the Julian Date} + +function AstJulianDate(Julian : TStDate) : Double; + {-Returns the Astronomical Julian Date from a TStDate} + +function AstJulianDatetoStDate(AstJulian : Double; Truncate : Boolean) : TStDate; + {-Returns a TStDate from an Astronomical Julian Date. + Truncate TRUE Converts to appropriate 0 hours then truncates + FALSE Converts to appropriate 0 hours, then rounds to + nearest;} + +function AstJulianDatePrim(Year, Month, Date : Integer; UT : TStTime) : Double; + {-Returns an Astronomical Julian Date for any year, even those outside + MinYear..MaxYear} + +function DayOfWeek(Julian : TStDate) : TStDayType; + {-Return the day of the week for a Julian date} + +function DayOfWeekDMY(Day, Month, Year, Epoch : Integer) : TStDayType; + {-Return the day of the week for the day, month, year} + +function IsLeapYear(Year : Integer) : Boolean; + {-Return True if Year is a leap year} + +function DaysInMonth(Month : Integer; Year, Epoch : Integer) : Integer; + {-Return the number of days in the specified month of a given year} + +function ResolveEpoch(Year, Epoch : Integer) : Integer; + {-Convert 2 digit year to 4 digit year according to Epoch} + + + {-------time routines---------------} + +function ValidTime(Hours, Minutes, Seconds : Integer) : Boolean; + {-Return True if Hours:Minutes:Seconds is a valid time} + +procedure StTimeToHMS(T : TStTime; + var Hours, Minutes, Seconds : Byte); + {-Convert a time variable to hours, minutes, seconds} + +function HMStoStTime(Hours, Minutes, Seconds : Byte) : TStTime; + {-Convert hours, minutes, seconds to a time variable} + +function CurrentTime : TStTime; + {-Return the current time in seconds since midnight} + +procedure TimeDiff(Time1, Time2 : TStTime; + var Hours, Minutes, Seconds : Byte); + {-Return the difference in hours, minutes, and seconds between two times} + +function IncTime(T : TStTime; Hours, Minutes, Seconds : Byte) : TStTime; + {-Add the specified hours, minutes, and seconds to a given time of day} + +function DecTime(T : TStTime; Hours, Minutes, Seconds : Byte) : TStTime; + {-Subtract the specified hours, minutes, and seconds from a given time of day} + +function RoundToNearestHour(T : TStTime; Truncate : Boolean) : TStTime; + {-Given a time, round it to the nearest hour, or truncate minutes and + seconds} + +function RoundToNearestMinute(const T : TStTime; Truncate : Boolean) : TStTime; + {-Given a time, round it to the nearest minute, or truncate seconds} + + {-------- routines for DateTimeRec records ---------} + +procedure DateTimeDiff(DT1 : TStDateTimeRec; var DT2 : TStDateTimeRec; + var Days : LongInt; var Secs : LongInt); + {-Return the difference in days and seconds between two points in time} + +procedure IncDateTime(DT1 : TStDateTimeRec; var DT2 : TStDateTimeRec; + Days : Integer; Secs : LongInt); + {-Increment (or decrement) a date and time by the specified number of days + and seconds} + +function DateTimeToStDate(DT : TDateTime) : TStDate; + {-Convert Delphi TDateTime to TStDate} + +function DateTimeToStTime(DT : TDateTime) : TStTime; + {-Convert Delphi TDateTime to TStTime} + +function StDateToDateTime(D : TStDate) : TDateTime; + {-Convert TStDate to TDateTime} + +function StTimeToDateTime(T : TStTime) : TDateTime; + {-Convert TStTime to TDateTime} + +function Convert2ByteDate(TwoByteDate : Word) : TStDate; + {-Convert an Object Professional two byte date into a SysTools date} + +function Convert4ByteDate(FourByteDate : TStDate) : Word; + {-Convert a SysTools date into an Object Professional two byte date} + + +implementation + +const + First2Months = 59; {1600 was a leap year} + FirstDayOfWeek = Saturday; {01/01/1600 was a Saturday} + DateLen = 40; {maximum length of Picture strings} + MaxMonthName = 15; + MaxDayName = 15; + + +type +{ DateString = string[DateLen];} + SString = string[255]; + +function IsLeapYear(Year : Integer) : Boolean; + {-Return True if Year is a leap year} +begin + Result := (Year mod 4 = 0) and (Year mod 4000 <> 0) and + ((Year mod 100 <> 0) or (Year mod 400 = 0)); +end; + +function IsLastDayofMonth(Day, Month, Year : Integer) : Boolean; + {-Return True if date is the last day in month} +var + Epoch : Integer; +begin + Epoch := (Year div 100) * 100; + if ValidDate(Day + 1, Month, Year, Epoch) then + Result := false + else + Result := true; +end; + +function IsLastDayofFeb(Date : TStDate) : Boolean; + {-Return True if date is the last day in February} +var + Day, Month, Year : Integer; +begin + StDateToDMY(Date, Day, Month, Year); + if (Month = 2) and IsLastDayOfMonth(Day, Month, Year) then + Result := true + else + Result := false; +end; + + +{$IFDEF NoAsm} +procedure ExchangeLongInts(var I, J : LongInt); +var + Temp : LongInt; +begin + Temp := I; + I := J; + J := Temp; +end; + +// ExchangeStructs not needed - see the one place where called below. + +{$ELSE} +procedure ExchangeLongInts(var I, J : LongInt); +register; +asm + mov ecx, [eax] + push ecx + mov ecx, [edx] + mov [eax], ecx + pop ecx + mov [edx], ecx +end; + +procedure ExchangeStructs(var I, J; Size : Cardinal); +register; +asm + push edi + push ebx + push ecx + shr ecx, 2 + jz @@LessThanFour + +@@AgainDWords: + mov ebx, [eax] + mov edi, [edx] + mov [edx], ebx + mov [eax], edi + add eax, 4 + add edx, 4 + dec ecx + jnz @@AgainDWords + +@@LessThanFour: + pop ecx + and ecx, $3 + jz @@Done + mov bl, [eax] + mov bh, [edx] + mov [edx], bl + mov [eax], bh + inc eax + inc edx + dec ecx + jz @@Done + + mov bl, [eax] + mov bh, [edx] + mov [edx], bl + mov [eax], bh + inc eax + inc edx + dec ecx + jz @@Done + + mov bl, [eax] + mov bh, [edx] + mov [edx], bl + mov [eax], bh + +@@Done: + pop ebx + pop edi +end; +{$ENDIF} + +function ResolveEpoch(Year, Epoch : Integer) : Integer; + {-Convert 2-digit year to 4-digit year according to Epoch} +var + EpochYear, + EpochCent : Integer; +begin + if Word(Year) < 100 then begin + EpochYear := Epoch mod 100; + EpochCent := (Epoch div 100) * 100; + if (Year < EpochYear) then + Inc(Year,EpochCent+100) + else + Inc(Year,EpochCent); + end; + Result := Year; +end; + +function CurrentDate : TStDate; + {-Returns today's date as a julian} +var + Year, Month, Date : Word; +begin + DecodeDate(Now,Year,Month,Date); + Result := DMYToStDate(Date,Month,Year,0); +end; + +function DaysInMonth(Month : integer; Year, Epoch : Integer) : Integer; + {-Return the number of days in the specified month of a given year} +begin + Year := ResolveEpoch(Year, Epoch); + + if (Year < MinYear) OR (Year > MaxYear) then + begin + Result := 0; + Exit; + end; + + case Month of + 1, 3, 5, 7, 8, 10, 12 : + Result := 31; + 4, 6, 9, 11 : + Result := 30; + 2 : + Result := 28+Ord(IsLeapYear(Year)); + else + Result := 0; + end; +end; + +function ValidDate(Day, Month, Year, Epoch : Integer) : Boolean; + {-Verify that day, month, year is a valid date} +begin + Year := ResolveEpoch(Year, Epoch); + + if (Day < 1) or (Year < MinYear) or (Year > MaxYear) then + Result := False + else case Month of + 1..12 : + Result := Day <= DaysInMonth(Month, Year, Epoch); + else + Result := False; + end +end; + +function DMYtoStDate(Day, Month, Year, Epoch : Integer) : TStDate; + {-Convert from day, month, year to a julian date} +begin + Year := ResolveEpoch(Year, Epoch); + + if not ValidDate(Day, Month, Year, Epoch) then + Result := BadDate + else if (Year = MinYear) and (Month < 3) then + if Month = 1 then + Result := Pred(Day) + else + Result := Day+30 + else begin + if Month > 2 then + Dec(Month, 3) + else begin + Inc(Month, 9); + Dec(Year); + end; + Dec(Year, MinYear); + Result := + ((LongInt(Year div 100)*146097) div 4)+ + ((LongInt(Year mod 100)*1461) div 4)+ + (((153*Month)+2) div 5)+Day+First2Months; + end; +end; + +function WeekOfYear(Julian : TStDate) : Byte; + {-Returns the week number of the year given the Julian Date} +var + Day, Month, Year : Integer; + FirstJulian : TStDate; +begin + if (Julian < MinDate) or (Julian > MaxDate) then + begin + Result := 0; + Exit; + end; + + Julian := Julian + 3 - ((6 + Ord(DayOfWeek(Julian))) mod 7); + StDateToDMY(Julian,Day,Month,Year); + FirstJulian := DMYToStDate(1,1,Year,0); + Result := 1 + (Julian - FirstJulian) div 7; +end; + +function AstJulianDate(Julian : TStDate) : Double; + {-Returns the Astronomical Julian Date from a TStDate} +begin + {Subtract 0.5d since Astronomical JD starts at noon + while TStDate (with implied .0) starts at midnight} + Result := Julian - 0.5 + DeltaJD; +end; + + +function AstJulianDatePrim(Year, Month, Date : Integer; UT : TStTime) : Double; +var + A, B : integer; + LY, + GC : Boolean; + +begin + Result := -MaxLongInt; + if (not (Month in [1..12])) or (Date < 1) then + Exit + else if (Month in [1, 3, 5, 7, 8, 10, 12]) and (Date > 31) then + Exit + else if (Month in [4, 6, 9, 11]) and (Date > 30) then + Exit + else if (Month = 2) then begin + LY := IsLeapYear(Year); + if ((LY) and (Date > 29)) or (not (LY) and (Date > 28)) then + Exit; + end else if ((UT < 0) or (UT >= SecondsInDay)) then + Exit; + + if (Month <= 2) then begin + Year := Year - 1; + Month := Month + 12; + end; + A := abs(Year div 100); + + if (Year > 1582) then + GC := True + else if (Year = 1582) then begin + if (Month > 10) then + GC := True + else if (Month < 10) then + GC := False + else begin + if (Date >= 15) then + GC := True + else + GC := False; + end; + end else + GC := False; + if (GC) then + B := 2 - A + abs(A div 4) + else + B := 0; + + Result := Trunc(365.25 * (Year + 4716)) + + Trunc(30.6001 * (Month + 1)) + + Date + B - 1524.5 + + UT / SecondsInDay; +end; + + +function AstJulianDatetoStDate(AstJulian : Double; Truncate : Boolean) : TStDate; + {-Returns a TStDate from an Astronomical Julian Date. + Truncate TRUE Converts to appropriate 0 hours then truncates + FALSE Converts to appropriate 0 hours, then rounds to + nearest;} +begin + {Convert to TStDate, adding 0.5d for implied .0d of TStDate} + AstJulian := AstJulian + 0.5 - DeltaJD; + if (AstJulian < MinDate) OR (AstJulian > MaxDate) then + begin + Result := BadDate; + Exit; + end; + + if Truncate then + Result := Trunc(AstJulian) + else + Result := Trunc(AstJulian + 0.5); +end; + +procedure StDateToDMY(Julian : TStDate; var Day, Month, Year : Integer); + {-Convert from a julian date to month, day, year} +var + I, J : LongInt; +begin + if Julian = BadDate then begin + Day := 0; + Month := 0; + Year := 0; + end else if Julian <= First2Months then begin + Year := MinYear; + if Julian <= 30 then begin + Month := 1; + Day := Succ(Julian); + end else begin + Month := 2; + Day := Julian-30; + end; + end else begin + I := (4*LongInt(Julian-First2Months))-1; + + J := (4*((I mod 146097) div 4))+3; + Year := (100*(I div 146097))+(J div 1461); + I := (5*(((J mod 1461)+4) div 4))-3; + Day := ((I mod 153)+5) div 5; + + Month := I div 153; + if Month < 10 then + Inc(Month, 3) + else begin + Dec(Month, 9); + Inc(Year); + end; + Inc(Year, MinYear); + end; +end; + +function IncDate(Julian : TStDate; Days, Months, Years : Integer) : TStDate; + {-Add (or subtract) the number of months, days, and years to a date. + Months and years are added before days. No overflow/underflow + checks are made} +var + Day, Month, Year, Day28Delta : Integer; +begin + StDateToDMY(Julian, Day, Month, Year); + Day28Delta := Day-28; + if Day28Delta < 0 then + Day28Delta := 0 + else + Day := 28; + + Inc(Year, Years); + Inc(Year, Months div 12); + Inc(Month, Months mod 12); + if Month < 1 then begin + Inc(Month, 12); + Dec(Year); + end + else if Month > 12 then begin + Dec(Month, 12); + Inc(Year); + end; + + Julian := DMYtoStDate(Day, Month, Year,0); + if Julian <> BadDate then begin + Inc(Julian, Days); + Inc(Julian, Day28Delta); + end; + Result := Julian; +end; + +function IncDateTrunc(Julian : TStDate; Months, Years : Integer) : TStDate; + {-Add (or subtract) the specified number of months and years to a date} +var + Day, Month, Year : Integer; + MaxDay, Day28Delta : Integer; +begin + StDateToDMY(Julian, Day, Month, Year); + Day28Delta := Day-28; + if Day28Delta < 0 then + Day28Delta := 0 + else + Day := 28; + + Inc(Year, Years); + Inc(Year, Months div 12); + Inc(Month, Months mod 12); + if Month < 1 then begin + Inc(Month, 12); + Dec(Year); + end + else if Month > 12 then begin + Dec(Month, 12); + Inc(Year); + end; + + Julian := DMYtoStDate(Day, Month, Year,0); + if Julian <> BadDate then begin + MaxDay := DaysInMonth(Month, Year,0); + if Day+Day28Delta > MaxDay then + Inc(Julian, MaxDay-Day) + else + Inc(Julian, Day28Delta); + end; + Result := Julian; +end; + +procedure DateDiff(Date1, Date2 : TStDate; var Days, Months, Years : Integer); + {-Return the difference in days,months,years between two valid julian dates} +var + Day1, Day2, Month1, Month2, Year1, Year2 : Integer; +begin + {we want Date2 > Date1} + if Date1 > Date2 then + ExchangeLongInts(Date1, Date2); + + {convert dates to day,month,year} + StDateToDMY(Date1, Day1, Month1, Year1); + StDateToDMY(Date2, Day2, Month2, Year2); + + {days first} + if (Day1 = DaysInMonth(Month1, Year1, 0)) then begin + Day1 := 0; + Inc(Month1); {OK if Month1 > 12} + end; + if (Day2 = DaysInMonth(Month2, Year2, 0)) then begin + Day2 := 0; + Inc(Month2); {OK if Month2 > 12} + end; + if (Day2 < Day1) then begin + Dec(Month2); + if Month2 = 0 then begin + Month2 := 12; + Dec(Year2); + end; + Days := Day2 + DaysInMonth(Month1, Year1, 0) - Day1; + end else + Days := Day2-Day1; + + {now months and years} + if Month2 < Month1 then begin + Inc(Month2, 12); + Dec(Year2); + end; + Months := Month2-Month1; + Years := Year2-Year1; +end; + +function BondDateDiff(Date1, Date2 : TStDate; DayBasis : TStBondDateType) : TStDate; + {-Return the difference in days between two valid Julian + dates using one a specific accrual method} +var + Day1, + Month1, + Year1, + Day2, + Month2, + Year2 : Integer; + IY : LongInt; +begin + {we want Date2 > Date1} + if Date1 > Date2 then + ExchangeLongInts(Date1, Date2); + + if (DayBasis = bdtActual) then + Result := Date2-Date1 + else + begin + StDateToDMY(Date1, Day1, Month1, Year1); + StDateToDMY(Date2, Day2, Month2, Year2); + + if ((DayBasis = bdt30360PSA) and IsLastDayofFeb(Date1)) or (Day1 = 31) then + Day1 := 30; + if (DayBasis = bdt30E360) then + begin + if (Day2 = 31) then + Day2 := 30 + end else + if (Day2 = 31) and (Day1 >= 30) then + Day2 := 30; + + IY := 360 * (Year2 - Year1); + Result := IY + 30 * (Month2 - Month1) + (Day2 - Day1); + end; +end; + +function DayOfWeek(Julian : TStDate) : TStDayType; + {-Return the day of the week for the date. Returns TStDayType(7) if Julian = + BadDate.} +var + B : Byte; +begin + if Julian = BadDate then begin + B := 7; + Result := TStDayType(B); + end else + Result := TStDayType( (Julian+Ord(FirstDayOfWeek)) mod 7 ); +end; + +function DayOfWeekDMY(Day, Month, Year, Epoch : Integer) : TStDayType; + {-Return the day of the week for the day, month, year} +begin + Result := DayOfWeek( DMYtoStDate(Day, Month, Year, Epoch) ); +end; + +procedure StTimeToHMS(T : TStTime; var Hours, Minutes, Seconds : Byte); + {-Convert a Time variable to Hours, Minutes, Seconds} +begin + if T = BadTime then begin + Hours := 0; + Minutes := 0; + Seconds := 0; + end + else begin + Hours := T div SecondsInHour; + Dec(T, LongInt(Hours)*SecondsInHour); + Minutes := T div SecondsInMinute; + Dec(T, LongInt(Minutes)*SecondsInMinute); + Seconds := T; + end; +end; + +function HMStoStTime(Hours, Minutes, Seconds : Byte) : TStTime; + {-Convert Hours, Minutes, Seconds to a Time variable} +var + T : TStTime; +begin + Hours := Hours mod HoursInDay; + T := (LongInt(Hours)*SecondsInHour)+(LongInt(Minutes)*SecondsInMinute)+Seconds; + Result := T mod SecondsInDay; +end; + +function ValidTime(Hours, Minutes, Seconds : Integer) : Boolean; + {-Return true if Hours:Minutes:Seconds is a valid time} +begin + if (Hours < 0) or (Hours > 23) or + (Minutes < 0) or (Minutes >= 60) or + (Seconds < 0) or (Seconds >= 60) then + Result := False + else + Result := True; +end; + +function CurrentTime : TStTime; + {-Returns current time in seconds since midnight} +begin + Result := Trunc(SysUtils.Time * SecondsInDay); +end; + +procedure TimeDiff(Time1, Time2 : TStTime; var Hours, Minutes, Seconds : Byte); + {-Return the difference in hours,minutes,seconds between two times} +begin + StTimeToHMS(Abs(Time1-Time2), Hours, Minutes, Seconds); +end; + +function IncTime(T : TStTime; Hours, Minutes, Seconds : Byte) : TStTime; + {-Add the specified hours,minutes,seconds to T and return the result} +begin + Inc(T, HMStoStTime(Hours, Minutes, Seconds)); + Result := T mod SecondsInDay; +end; + +function DecTime(T : TStTime; Hours, Minutes, Seconds : Byte) : TStTime; + {-Subtract the specified hours,minutes,seconds from T and return the result} +begin + Hours := Hours mod HoursInDay; + Dec(T, HMStoStTime(Hours, Minutes, Seconds)); + if T < 0 then + Result := T+SecondsInDay + else + Result := T; +end; + +function RoundToNearestHour(T : TStTime; Truncate : Boolean) : TStTime; + {-Round T to the nearest hour, or Truncate minutes and seconds from T} +var + Hours, Minutes, Seconds : Byte; +begin + StTimeToHMS(T, Hours, Minutes, Seconds); + Seconds := 0; + if not Truncate then + if Minutes >= (MinutesInHour div 2) then + Inc(Hours); + Minutes := 0; + Result := HMStoStTime(Hours, Minutes, Seconds); +end; + +function RoundToNearestMinute(const T : TStTime; Truncate : Boolean) : TStTime; + {-Round T to the nearest minute, or Truncate seconds from T} +var + Hours, Minutes, Seconds : Byte; +begin + StTimeToHMS(T, Hours, Minutes, Seconds); + if not Truncate then + if Seconds >= (SecondsInMinute div 2) then + Inc(Minutes); + Seconds := 0; + Result := HMStoStTime(Hours, Minutes, Seconds); +end; + + +procedure DateTimeDiff(DT1 : TStDateTimeRec; var DT2 : TStDateTimeRec; + var Days : LongInt; var Secs : LongInt); + {-Return the difference in days and seconds between two points in time} +var + tDT1, tDT2 : TStDateTimeRec; +{$IFDEF NoAsm} + Temp : TStDateTimeRec; +{$ENDIF} +begin + tDT1 := DT1; + tDT2 := DT2; + {swap if tDT1 later than tDT2} + if (tDT1.D > tDT2.D) or ((tDT1.D = tDT2.D) and (tDT1.T > tDT2.T)) then +{$IFDEF NoAsm} + begin + Temp := tDT1; + tDT1 := tDT2; + tDT2 := Temp; + end; +{$ELSE} + ExchangeStructs(tDT1, tDT2,sizeof(TStDateTimeRec)); +{$ENDIF} + + {the difference in days is easy} + Days := tDT2.D-tDT1.D; + + {difference in seconds} + if tDT2.T < tDT1.T then begin + {subtract one day, add 24 hours} + Dec(Days); + Inc(tDT2.T, SecondsInDay); + end; + Secs := tDT2.T-tDT1.T; +end; + +function DateTimeToStDate(DT : TDateTime) : TStDate; + {-Convert Delphi TDateTime to TStDate} +var + Day, Month, Year : Word; +begin + DecodeDate(DT, Year, Month, Day); + Result := DMYToStDate(Day, Month, Year, 0); +end; + +function DateTimeToStTime(DT : TDateTime) : TStTime; + {-Convert Delphi TDateTime to TStTime} +var + Hour, Min, Sec, MSec : Word; +begin + DecodeTime(DT, Hour, Min, Sec, MSec); + Result := HMSToStTime(Hour, Min, Sec); +end; + +function StDateToDateTime(D : TStDate) : TDateTime; + {-Convert TStDate to TDateTime} +var + Day, Month, Year : Integer; +begin + Result := 0; + if D <> BadDate then begin + StDateToDMY(D, Day, Month, Year); + Result := EncodeDate(Year, Month, Day); + end; +end; + +function StTimeToDateTime(T : TStTime) : TDateTime; + {-Convert TStTime to TDateTime} +var + Hour, Min, Sec : Byte; +begin + Result := 0; + if T <> BadTime then begin + StTimeToHMS(T, Hour, Min, Sec); + Result := EncodeTime(Hour, Min, Sec, 0); + end; +end; + +procedure IncDateTime(DT1 : TStDateTimeRec; var DT2 : TStDateTimeRec; Days : Integer; Secs : LongInt); + {-Increment (or decrement) DT1 by the specified number of days and seconds + and put the result in DT2} +begin + DT2 := DT1; + + {date first} + Inc(DT2.D, LongInt(Days)); + + if Secs < 0 then begin + {change the sign} + Secs := -Secs; + + {adjust the date} + Dec(DT2.D, Secs div SecondsInDay); + Secs := Secs mod SecondsInDay; + + if Secs > DT2.T then begin + {subtract a day from DT2.D and add a day's worth of seconds to DT2.T} + Dec(DT2.D); + Inc(DT2.T, SecondsInDay); + end; + + {now subtract the seconds} + Dec(DT2.T, Secs); + end + else begin + {increment the seconds} + Inc(DT2.T, Secs); + + {adjust date if necessary} + Inc(DT2.D, DT2.T div SecondsInDay); + + {force time to 0..SecondsInDay-1 range} + DT2.T := DT2.T mod SecondsInDay; + end; +end; + +function Convert2ByteDate(TwoByteDate : Word) : TStDate; +begin + Result := LongInt(TwoByteDate) + Date1900; +end; + +function Convert4ByteDate(FourByteDate : TStDate) : Word; +begin + Result := Word(FourByteDate - Date1900); +end; + +procedure SetDefaultYear; + {-Initialize DefaultYear and DefaultMonth} +var + Month, Day, Year : Word; + T : TDateTime; +begin + T := Now; + DecodeDate(T, Year, Month, Day); + DefaultYear := Year; + DefaultMonth := Month; +end; + + +initialization + {initialize DefaultYear and DefaultMonth} + SetDefaultYear; +end. diff --git a/components/orpheus/ovcdrag.pas b/components/orpheus/ovcdrag.pas new file mode 100644 index 000000000..e61514eee --- /dev/null +++ b/components/orpheus/ovcdrag.pas @@ -0,0 +1,272 @@ +{*********************************************************} +{* OVCDRAG.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovcdrag; + +interface + +uses + {$IFNDEF LCL} Windows, {$ELSE} LclIntf, LclType, MyMisc, {$ENDIF} + Classes, Graphics; + +type + TOvcDragShow = class(TObject) + {.Z+} + protected + dStretchBltMode : Integer; + dMemDC,dSMemDC, + dDstDC,dSaveDC : hDC; + dSaveBmp, dMemBmp, + dSMemBmp : hBITMAP; + dcrText, dcrBack : TColorRef; + dRect : TRect; + dSize : TPoint; + dSystemPalette16 : hPalette; + dOldPal : hPalette; + Bitmap,dMask : TBitmap; + DeltaX, DeltaY : Integer; + dDragging, + dHaveOriginal : Boolean; + + procedure ilDragDraw; + procedure ilRestoreOriginal; + procedure ilSaveOriginal; + + public + constructor Create(X, Y : Integer; SourceRect : TRect; TransColor : TColor); + destructor Destroy; + override; + procedure DragMove(X, Y : Integer); + procedure HideDragImage; + procedure ShowDragImage; + {.Z+} + end; + + +implementation + + +{*** TOvcDragShow ***} + +constructor TOvcDragShow.Create(X, Y : Integer; SourceRect : TRect; TransColor : TColor); +var + dMaskDC : HDC; + SrcDC : HDC; +begin + dHaveOriginal := False; + dDstDC := GetDC(0); + DeltaX := X - SourceRect.Left; + DeltaY := Y - SourceRect.Top; + dec(X, DeltaX); + dec(Y, DeltaY); + dRect.Left := X; + dRect.Top := Y; + Bitmap := nil; + dMask := nil; + try + Bitmap := TBitmap.Create; + Bitmap.Width := SourceRect.Right - SourceRect.Left + 1; + Bitmap.Height := SourceRect.Bottom - SourceRect.Top + 1; + + dMask := TBitmap.Create; + dMask.Width := SourceRect.Right - SourceRect.Left + 1; + dMask.Height := SourceRect.Bottom - SourceRect.Top + 1; + + BitBlt(Bitmap.Canvas.Handle, 0, 0, Bitmap.Width, Bitmap.Height, dDstDC, SourceRect.Left, + SourceRect.Top, SRCCOPY); +{$IFNDEF LCL} + dMask.Canvas.BrushCopy(Rect(0, 0, dMask.Width - 1, dMask.Height - 1), Bitmap, + Rect(0, 0, dMask.Width - 1, dMask.Height - 1), TransColor); +{$ELSE} + BrushCopy(dMask.Canvas, Rect(0, 0, dMask.Width - 1, dMask.Height - 1), Bitmap, + Rect(0, 0, dMask.Width - 1, dMask.Height - 1), TransColor); +{$ENDIF} + + dMemDC := CreateCompatibleDC(0); + dSaveDC := CreateCompatibleDC(0); + dDragging := True; + dStretchBltMode := SetStretchBltMode(dDstDC, BLACKONWHITE); + dSize.X := Bitmap.Width; + dSize.Y := Bitmap.Height; + dRect.Right := dRect.Left + dSize.X - 1; + dRect.Bottom := dRect.Top + dSize.Y - 1; + SrcDC := Bitmap.Canvas.Handle; + dMaskDC := dMask.Canvas.Handle; + dSMemDC := CreateCompatibleDC(dMaskDC); + dMemBmp := CreateCompatibleBitmap(SrcDC, dSize.X, dSize.Y); + SelectObject(dMemDC, dMemBmp); + dSMemBmp := CreateCompatibleBitmap(dMaskDC, dSize.X, dSize.Y); + SelectObject(dSMemDC, dSMemBmp); + dSaveBmp := CreateCompatibleBitmap(SrcDC, dSize.X, dSize.Y); + SelectObject(dSaveDC, dSaveBmp); + dSystemPalette16 := GetStockObject(DEFAULT_PALETTE); + dOldPal := SelectPalette(SrcDC, dSystemPalette16, False); + SelectPalette(SrcDC, dOldPal, False); + if dOldPal <> 0 then begin + SelectPalette(dMemDC, dOldPal, True); + SelectPalette(dSaveDC, dOldPal, True); + end else begin + SelectPalette(dMemDC, dSystemPalette16, True); + SelectPalette(dSaveDC, dSystemPalette16, True); + end; + RealizePalette(dMemDC); + RealizePalette(dSaveDC); + + BitBlt(dSMemDC, 0, 0, dSize.X, dSize.Y, dMaskDC, 0, 0, SrcCopy); + BitBlt(dMemDC, 0, 0, dSize.X, dSize.Y, dMaskDC, 0, 0, SrcCopy); + BitBlt(dMemDC, 0, 0, dSize.X, dSize.Y, SrcDC, 0, 0, SrcErase); + dcrText := SetTextColor(dDstDC, $0); + dcrBack := SetBkColor(dDstDC, $FFFFFF); + ilSaveOriginal; + ilDragDraw; + except + Bitmap.Free; + dMask.Free; + raise; + end; +end; + +destructor TOvcDragShow.Destroy; +begin + ilRestoreOriginal; + SetTextColor(dDstDC, dcrText); + SetBkColor(dDstDC, dcrBack); + DeleteObject(dMemBmp); + DeleteObject(dSaveBmp); + DeleteObject(dSMemBmp); + DeleteDC(dMemDC); + DeleteDC(dSMemDC); + DeleteDC(dSaveDC); + SetStretchBltMode(dDstDC, dStretchBltMode); + ReleaseDC(0,dDstDC); + dDragging := False; + Bitmap.Free; + dMask.Free; + inherited Destroy; +end; + +procedure TOvcDragShow.DragMove(X, Y: Integer); +var + NewRect, Union : TRect; + UnionSize : TPoint; + WorkDC : hDC; + WorkBM : hBitmap; +begin + if not dDragging then exit; + dec(X, DeltaX); + dec(Y, DeltaY); + {if we didn't move, get out} + if (X = dRect.Left) and (Y = dRect.Top) then exit; + {let's see where we're going} + NewRect := Rect(X, Y, X + dSize.X - 1, Y + dSize.Y - 1); + {if drag image not currently shown, just update next draw position and exit} + if not dHaveOriginal then begin + dRect := NewRect; + exit; + end; + {do the old and new positions overlap?} + if ord(IntersectRect(Union, dRect, NewRect)) <> 0 then begin + {rect old and new combined:} + UnionRect(Union, NewRect, dRect); + {size of union:} + UnionSize.X := Union.Right - Union.Left + 1; + UnionSize.Y := Union.Bottom - Union.Top + 1; + {create combination buffer} + WorkDC := CreateCompatibleDC(0); + WorkBM := CreateCompatibleBitmap(dDstDC, UnionSize.X, UnionSize.Y); + SelectObject(WorkDC, WorkBM); + if dOldPal <> 0 then + SelectPalette(WorkDC, dOldPal, True) + else + SelectPalette(WorkDC, dSystemPalette16, True); + RealizePalette(WorkDC); + {copy screen section (including old image) to local buffer} + BitBlt(WorkDC, 0, 0, UnionSize.X, UnionSize.Y, dDstDC, Union.Left, Union.Top, SRCCOPY); + {"repair" by restoring background for old image} + BitBlt(WorkDC, dRect.Left - Union.Left, dRect.Top - Union.Top, + dSize.X, dSize.Y, dSaveDC, 0, 0, SRCCOPY); + {save background so we can do the same next time} + BitBlt(dSaveDC, 0, 0, dSize.X, dSize.Y, WorkDC, NewRect.Left - Union.Left, NewRect.Top - Union.Top, SrcCopy); + {write image at new position into local buffer} + BitBlt(WorkDC, NewRect.Left - Union.Left, NewRect.Top - Union.Top, dSize.X, dSize.Y, dSMemDC, 0, 0, SrcAnd); + BitBlt(WorkDC, NewRect.Left - Union.Left, NewRect.Top - Union.Top, dSize.X, dSize.Y, dMemDC, 0, 0, SrcInvert); + {copy combined image to screen} + BitBlt(dDstDC, Union.Left, Union.Top, UnionSize.X, UnionSize.Y, WorkDC, 0, 0, SRCCOPY); + dRect := NewRect; + DeleteDC(WorkDC); + DeleteObject(WorkBM); + end else begin + {images dont overlap, so we might as well do the draw in two steps} + ilRestoreOriginal; + dRect := NewRect; + ilSaveOriginal; + ilDragDraw; + end; +end; + +procedure TOvcDragShow.HideDragImage; +begin + ilRestoreOriginal; +end; + +procedure TOvcDragShow.ilDragDraw; +begin + BitBlt(dDstDC, dRect.Left, dRect.Top, dSize.X, dSize.Y, dSMemDC, 0, 0, SrcAnd); + BitBlt(dDstDC, dRect.Left, dRect.Top, dSize.X, dSize.Y, dMemDC, 0, 0, SrcInvert); +end; + +procedure TOvcDragShow.ilRestoreOriginal; +begin + if not dHaveOriginal then exit; + BitBlt(dDstDC, dRect.Left, dRect.Top, dSize.X, dSize.Y, dSaveDC, 0, 0, SrcCopy); + dHaveOriginal := False; +end; + +procedure TOvcDragShow.ilSaveOriginal; +begin + BitBlt(dSaveDC, 0, 0, dSize.X, dSize.Y, dDstDC, dRect.Left, dRect.Top, SrcCopy); + dHaveOriginal := True; +end; + +procedure TOvcDragShow.ShowDragImage; +begin + ilSaveOriginal; + ilDragDraw; +end; + + +end. diff --git a/components/orpheus/ovcedcal.pas b/components/orpheus/ovcedcal.pas new file mode 100644 index 000000000..98b37bcc0 --- /dev/null +++ b/components/orpheus/ovcedcal.pas @@ -0,0 +1,1124 @@ +{*********************************************************} +{* OVCEDCAL.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovcedcal; + {-date edit field with popup calendar} + +interface + +uses + {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, LclType, MyMisc, {$ENDIF} + Buttons, Classes, Controls, Forms, Graphics, Menus, + StdCtrls, SysUtils, {$IFNDEF LCL} {$IFDEF VERSION4} MultiMon, {$ENDIF} {$ENDIF} OvcBase, OvcCal, + OvcConst, OvcData, OvcEdPop, OvcExcpt, OvcIntl, OvcMisc, OvcEditF, OvcDate; + +type + TOvcDateOrder = (doMDY, doDMY, doYMD); + TOvcRequiredDateField = (rfYear, rfMonth, rfDay); + TOvcRequiredDateFields = set of TOvcRequiredDateField; + + {Events} + TOvcGetDateEvent = procedure(Sender : TObject; var Value : string) of object; + TOvcPreParseDateEvent = procedure(Sender : TObject; var Value : string) + of object; + TOvcGetDateMaskEvent = procedure(Sender : TObject; var Mask : string) + of object; + + TOvcCustomDateEdit = class(TOvcEdPopup) + protected {private} + {property variables} + FAllowIncDec : Boolean; + FCalendar : TOvcCalendar; + FDate : TDateTime; + FEpoch : Integer; + FForceCentury : Boolean; + FRequiredFields : TOvcRequiredDateFields; + FTodayString : string; + + {event variables} + FOnGetDate : TOvcGetDateEvent; + FOnGetDateMask : TOvcGetDateMaskEvent; + FOnPreParseDate : TOvcPreParseDateEvent; + FOnSetDate : TNotifyEvent; + + {internal variables} + DateOrder : TOvcDateOrder; + HoldCursor : TCursor; + PopupClosing : Boolean; + WasAutoScroll : Boolean; + + {property methods} + function GetDate : TDateTime; + function GetEpoch : Integer; + function GetPopupColors : TOvcCalColors; + function GetPopupFont : TFont; + function GetPopupHeight : Integer; + function GetPopupDateFormat : TOvcDateFormat; + function GetPopupDayNameWidth : TOvcDayNameWidth; + function GetPopupOptions : TOvcCalDisplayOptions; + function GetPopupWeekStarts : TOvcDayType; + function GetPopupWidth : Integer; + function GetReadOnly : Boolean; + procedure SetEpoch(Value : Integer); + procedure SetForceCentury(Value : Boolean); + procedure SetPopupColors(Value : TOvcCalColors); + procedure SetPopupFont(Value : TFont); + procedure SetPopupHeight(Value : Integer); + procedure SetPopupWidth(Value : Integer); + procedure SetPopupDateFormat(Value : TOvcDateFormat); + procedure SetPopupDayNameWidth(Value : TOvcDayNameWidth); + procedure SetPopupOptions(Value : TOvcCalDisplayOptions); + procedure SetPopupWeekStarts(Value : TOvcDayType); + procedure SetReadOnly(Value : Boolean); + + {internal methods} + function ParseDate(const Value : string) : string; + procedure PopupDateChange(Sender : TObject; Date : TDateTime); + procedure PopupKeyDown(Sender : TObject; var Key : Word; + Shift : TShiftState); + procedure PopupKeyPress(Sender : TObject; var Key : Char); + procedure PopupMouseDown(Sender : TObject; Button : TMouseButton; + Shift : TShiftState; X, Y : Integer); + protected + procedure DoExit; override; + procedure GlyphChanged; override; + procedure KeyDown(var Key : Word; Shift : TShiftState); override; + procedure KeyPress(var Key : Char); override; + procedure SetDate(Value : TDateTime); + + {protected properties} + property AllowIncDec : Boolean read FAllowIncDec write FAllowIncDec; + property Epoch : Integer read GetEpoch write SetEpoch; + property ForceCentury : Boolean read FForceCentury write SetForceCentury; + property PopupColors : TOvcCalColors read GetPopupColors + write SetPopupColors; + property PopupFont : TFont read GetPopupFont write SetPopupFont; + property PopupHeight : Integer read GetPopupHeight write SetPopupHeight; + property PopupWidth : Integer read GetPopupWidth write SetPopupWidth; + property PopupDateFormat : TOvcDateFormat read GetPopupDateFormat + write SetPopupDateFormat; + property PopupDayNameWidth : TOvcDayNameWidth read GetPopupDayNameWidth + write SetPopupDayNameWidth; + property PopupOptions : TOvcCalDisplayOptions read GetPopupOptions + write SetPopupOptions; + property PopupWeekStarts : TOvcDayType read GetPopupWeekStarts + write SetPopupWeekStarts; + property ReadOnly : Boolean read GetReadOnly write SetReadOnly; + property RequiredFields : TOvcRequiredDateFields read FRequiredFields + write FRequiredFields; + property TodayString : string read FTodayString write FTodayString; + + {protected events} + property OnGetDate : TOvcGetDateEvent read FOnGetDate write FOnGetDate; + property OnGetDateMask : TOvcGetDateMaskEvent read FOnGetDateMask + write FOnGetDateMask; + property OnPreParseDate : TOvcPreParseDateEvent read FOnPreParseDate + write FOnPreParseDate; + property OnSetDate : TNotifyEvent read FOnSetDate write FOnSetDate; + + public + constructor Create(AOwner : TComponent); override; + function DateString(const Mask : string) : string; + function FormatDate(Value : TDateTime) : string; dynamic; + procedure PopupClose(Sender : TObject); override; + procedure PopupOpen; override; + procedure SetDateText(Value : string); dynamic; + {public properties} + property Calendar : TOvcCalendar read FCalendar; + property Date: TDateTime read GetDate write SetDate; + end; + + + TOvcDateEdit = class(TOvcCustomDateEdit) + published + {properties} + {$IFDEF VERSION4} + property Anchors; + property Constraints; + property DragKind; + {$ENDIF} + property About; + property AllowIncDec; +{$IFNDEF LCL} + property AutoSelect; +{$ENDIF} + property AutoSize; + property BorderStyle; + property ButtonGlyph; + property CharCase; + property Color; + property Controller; + property Ctl3D; + property Cursor; + property DragCursor; + property DragMode; + property Enabled; + property Epoch; + property Font; + property ForceCentury; +{$IFNDEF LCL} + property HideSelection; +{$ENDIF} + property LabelInfo; + property ParentColor; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PopupAnchor; + property PopupColors; + property PopupDateFormat; + property PopupDayNameWidth; + property PopupFont; + property PopupHeight; + property PopupMenu; + property PopupOptions; + property PopupWidth; + property PopupWeekStarts; + property ReadOnly; + property RequiredFields; + property ShowButton; + property ShowHint; + property TabOrder; + property TabStop; + property TodayString; + property Visible; + + {inherited events} + property OnChange; + property OnClick; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnGetDate; + property OnGetDateMask; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnPopupClose; + property OnPopupOpen; + property OnPreParseDate; + property OnSetDate; + property OnStartDrag; + end; + +implementation + +{*** TOvcCustomDateEdit ***} + +constructor TOvcCustomDateEdit.Create(AOwner : TComponent); +var + C : array[0..1] of Char; +begin + inherited Create(AOwner); + + ControlStyle := ControlStyle - [csSetCaption]; + + FAllowIncDec := True; + FForceCentury := False; + FRequiredFields := [rfMonth, rfDay]; + FTodayString := DateSeparator; + + {get the date order from windows} + C[0] := '0'; {default} + + GetProfileString('intl', 'iDate', '0', C, 2); + DateOrder := TOvcDateOrder(Ord(C[0])-Ord('0')); + + {load button glyph} +{$IFNDEF LCL} + FButtonGlyph.Handle := LoadBaseBitmap('ORBTNCAL'); +{$ELSE} + FButtonGlyph.LoadFromLazarusResource('ORBTNCAL'); +{$ENDIF} + FButton.Glyph.Assign(FButtonGlyph); + + FCalendar := TOvcCalendar.CreateEx(Self, True); + FCalendar.OnChange := PopupDateChange; + FCalendar.OnExit := PopupClose; + FCalendar.OnKeyDown := PopupKeyDown; + FCalendar.OnKeyPress := PopupKeyPress; + FCalendar.OnMouseDown := PopupMouseDown; + FCalendar.Visible := False; {to avoid flash at 0,0} + FCalendar.BorderStyle := bsSingle; + FCalendar.ParentFont := False; + FCalendar.Parent := GetImmediateParentForm(Self); +end; + +procedure TOvcCustomDateEdit.DoExit; +begin + try + SetDateText(Text); + except + SetFocus; + raise; + end; + + if not PopupActive then + inherited DoExit; +end; + +function TOvcCustomDateEdit.DateString(const Mask : string) : string; +begin + Result := OvcIntlSup.DateToDateString(Mask, DateTimeToSTDate(Date), False); +end; + +function TOvcCustomDateEdit.FormatDate(Value : TDateTime) : string; +var + DateMask : string; + Mask : string; +begin + DateMask := OvcIntlSup.InternationalDate(FForceCentury); + if Assigned(FOnGetDateMask) then begin + FOnGetDateMask(Self, DateMask); + {see if the date order needs to be changed} + Mask := AnsiUpperCase(DateMask); + if (Pos('M', Mask) > Pos('Y', Mask)) or + (Pos('N', Mask) > Pos('Y', Mask)) then + DateOrder := doYMD + else if (Pos('M', Mask) > Pos('D', Mask)) or + (Pos('N', Mask) > Pos('D', Mask)) then + DateOrder := doDMY + else + DateOrder := doMDY; + end; + Result := OvcIntlSup.DateToDateString(DateMask, DateTimeToSTDate(Value), False); +end; + +function TOvcCustomDateEdit.GetDate : TDateTime; +begin + SetDateText(Text); + Result := FDate; +end; + +function TOvcCustomDateEdit.GetEpoch : Integer; +begin + Result := FEpoch; + + if (csWriting in ComponentState) then + Exit; + + if (Result = 0) and ControllerAssigned then + Result := Controller.Epoch; +end; + +function TOvcCustomDateEdit.GetPopupColors : TOvcCalColors; +begin + Result := FCalendar.Colors; +end; + +function TOvcCustomDateEdit.GetPopupDateFormat : TOvcDateFormat; +begin + Result := FCalendar.DateFormat; +end; + +function TOvcCustomDateEdit.GetPopupDayNameWidth : TOvcDayNameWidth; +begin + Result := FCalendar.DayNameWidth; +end; + +function TOvcCustomDateEdit.GetPopupFont : TFont; +begin + Result := FCalendar.Font; +end; + +function TOvcCustomDateEdit.GetPopupHeight : Integer; +begin + Result := FCalendar.Height; +end; + +function TOvcCustomDateEdit.GetPopupOptions: TOvcCalDisplayOptions; +begin + Result := FCalendar.Options; +end; + +function TOvcCustomDateEdit.GetPopupWeekStarts: TOvcDayType; +begin + Result := FCalendar.WeekStarts; +end; + +function TOvcCustomDateEdit.GetPopupWidth : Integer; +begin + Result := FCalendar.Width; +end; + +function TOvcCustomDateEdit.GetReadOnly : Boolean; +begin + Result := inherited ReadOnly; +end; + +procedure TOvcCustomDateEdit.GlyphChanged; +begin + inherited GlyphChanged; + + if FButtonGlyph.Empty then +{$IFNDEF LCL} + FButtonGlyph.Handle := LoadBaseBitmap('ORBTNCAL'); +{$ELSE} + FButtonGlyph.LoadFromLazarusResource('ORBTNCAL'); +{$ENDIF} +end; + +procedure TOvcCustomDateEdit.KeyDown(var Key : Word; Shift : TShiftState); +begin + inherited KeyDown(Key, Shift); + + if ShowButton and (Key = VK_DOWN) and (ssAlt in Shift) then + PopupOpen; +end; + +procedure TOvcCustomDateEdit.KeyPress(var Key : Char); +var + D : Word; + M : Word; + Y : Word; +begin + inherited KeyPress(Key); + + if (ReadOnly) then Exit; + + if FAllowIncDec and (Key in ['+', '-']) then begin + {accept current date} + DoExit; + if FDate = 0 then + DecodeDate(SysUtils.Date, Y, M, D) + else + DecodeDate(FDate, Y, M, D); + if Key = '+' then begin + Inc(D); + if D > DaysInMonth(M, Y, Epoch) then begin + D := 1; + Inc(M); + if M > 12 then begin + Inc(Y); + M := 1; + end; + end; + end else begin + {Key = '-'} + Dec(D); + if D < 1 then begin + Dec(M); + if M < 1 then begin + M := 12; + Dec(Y); + end; + D := DaysInMonth(M, Y, Epoch); + end; + end; + SetDate(STDateToDateTime(DMYToSTDate(D, M, Y, Epoch))); + + {clear} + Key := #0; + end; +end; + +function TOvcCustomDateEdit.ParseDate(const Value : string) : string; +var + S : string; + ThisYear : Word; + ThisMonth : Word; + ThisDay : Word; + DefaultDate : TStDate; + Increment : Integer; + Occurrence : Integer; + StartDate : TStDate; + + procedure DoSetDate; + var + I : integer; + D : TStDate; + DOW : TStDayType; + begin + D := StartDate; + DOW := DayofWeek(DateTimeToStDate(SysUtils.Date)); + if Pos(AnsiUppercase(Copy(LongDayNames[1],1,3)), S) > 0 then begin + DOW := Sunday; + end else if Pos(AnsiUppercase(Copy(LongDayNames[2],1,3)), S) > 0 then begin + DOW := Monday; + end else if Pos(AnsiUppercase(Copy(LongDayNames[3],1,3)), S) > 0 then begin + DOW := Tuesday; + end else if Pos(AnsiUppercase(Copy(LongDayNames[4],1,3)), S) > 0 then begin + DOW := Wednesday; + end else if Pos(AnsiUppercase(Copy(LongDayNames[5],1,3)), S) > 0 then begin + DOW := Thursday; + end else if Pos(AnsiUppercase(Copy(LongDayNames[6],1,3)), S) > 0 then begin + DOW := Friday; + end else if Pos(AnsiUppercase(Copy(LongDayNames[7],1,3)), S) > 0 then begin + DOW := Saturday; + end else begin + if DefaultDate > 0 then begin + D := DefaultDate; + Occurrence := 0; + end else if DefaultDate < 0 then begin + Result := S; + exit; + end; + end; + I := 0; + while I < Occurrence do begin + D := D + Increment; + if DayOfWeek(D) = DOW then begin + inc(I); + end; + end; + Result := FormatDate(StDateToDateTime(D)); + end; + +begin + {The following code provides the user the ability to enter dates + using text descriptions. All descriptions assume the current + date as a reference date. The following descriptions are currently + supported: + Next is assumed; may be abbreviated -- 1st 3 chars + Next + Last current day of week is assumed + Last + First | 1st current day of week is assumed + First | 1st + Second | 2nd current day of week is assumed + Second | 2nd + Third | 3rd current day of week is assumed + Third | 3rd + Fourth | 4th current day of week is assumed + Fourth | 4th + Final | lst current day of week is assumed + Final | lst + BOM | Begin returns first day of current month + EOM | End returns last day of current month + Yesterday returns yesterday's date + Today returns today's date + Tomorrow returns tomorrow's date} + + S := AnsiUppercase(Value); + if Pos(GetOrphStr(SCCalYesterday), S) > 0 then begin + Result := FormatDate(StDateToDateTime(DateTimeToStDate(SysUtils.Date) - 1)); + end else if Pos(GetOrphStr(SCCalToday), S) > 0 then begin + Result := FormatDate(StDateToDateTime(DateTimeToStDate(SysUtils.Date))); + end else if Pos(GetOrphStr(SCCalTomorrow), S) > 0 then begin + Result := FormatDate(StDateToDateTime(DateTimeToStDate(SysUtils.Date) + 1)); + end else if Pos(GetOrphStr(SCCalNext), S) > 0 then begin + Increment := 1; + Occurrence := 1; + StartDate := DateTimeToStDate(SysUtils.Date); + DefaultDate := StartDate + 7; + DoSetDate; + end else if Pos(GetOrphStr(SCCalLast), S) > 0 then begin + Increment := -1; + Occurrence := 1; + StartDate := DateTimeToStDate(SysUtils.Date); + DefaultDate := StartDate - 7; + DoSetDate; + end else if Pos(GetOrphStr(SCCalPrev), S) > 0 then begin + Increment := -1; + Occurrence := 1; + StartDate := DateTimeToStDate(SysUtils.Date); + DefaultDate := StartDate - 7; + DoSetDate; + end else if (Pos(GetOrphStr(SCCalFirst), S) > 0) + or (Pos(GetOrphStr(SCCal1st), S) > 0) then begin + Increment := 1; + Occurrence := 1; + DecodeDate(SysUtils.Date, ThisYear, ThisMonth, ThisDay); + StartDate := DMYToStDate(1, ThisMonth, ThisYear, Epoch) - 1; + DefaultDate := 0; + DoSetDate; + end else if (Pos(GetOrphStr(SCCalSecond), S) > 0) + or (Pos(GetOrphStr(SCCal2nd), S) > 0) then begin + Increment := 1; + Occurrence := 2; + DecodeDate(SysUtils.Date, ThisYear, ThisMonth, ThisDay); + StartDate := DMYToStDate(1, ThisMonth, ThisYear, Epoch) - 1; + DefaultDate := 0; + DoSetDate; + end else if (Pos(GetOrphStr(SCCalThird), S) > 0) + or (Pos(GetOrphStr(SCCal3rd), S) > 0) then begin + Increment := 1; + Occurrence := 3; + DecodeDate(SysUtils.Date, ThisYear, ThisMonth, ThisDay); + StartDate := DMYToStDate(1, ThisMonth, ThisYear, Epoch) - 1; + DefaultDate := 0; + DoSetDate; + end else if (Pos(GetOrphStr(SCCalFourth), S) > 0) + or (Pos(GetOrphStr(SCCal4th), S) > 0) then begin + Increment := 1; + Occurrence := 4; + DecodeDate(SysUtils.Date, ThisYear, ThisMonth, ThisDay); + StartDate := DMYToStDate(1, ThisMonth, ThisYear, Epoch) - 1; + DefaultDate := 0; + DoSetDate; + end else if Pos(GetOrphStr(SCCalFinal), S) > 0 then begin + Increment := -1; + Occurrence := 1; + DecodeDate(SysUtils.Date, ThisYear, ThisMonth, ThisDay); + StartDate := DMYToStDate(DaysInMonth(ThisMonth, + ThisYear, Epoch), + ThisMonth, ThisYear, Epoch) + 1; + DefaultDate := 0; + DoSetDate; + end else if (Pos(GetOrphStr(SCCalBOM), S) > 0) + or (Pos(GetOrphStr(SCCalBegin), S) > 0) then begin + Increment := 0; + Occurrence := 0; + DecodeDate(SysUtils.Date, ThisYear, ThisMonth, ThisDay); + StartDate := DMYToStDate(1, ThisMonth, ThisYear, Epoch); + DefaultDate := StartDate; + DoSetDate; + end else if (Pos(GetOrphStr(SCCalEOM), S) > 0) + or (Pos(GetOrphStr(SCCalEnd), S) > 0) then begin + Increment := 0; + Occurrence := 0; + DecodeDate(SysUtils.Date, ThisYear, ThisMonth, ThisDay); + StartDate := DMYToStDate(DaysInMonth(ThisMonth, + ThisYear, Epoch), + ThisMonth, ThisYear, Epoch); + DefaultDate := StartDate; + DoSetDate; + end else begin + Increment := 1; + Occurrence := 1; + StartDate := DateTimeToStDate(SysUtils.Date); + DefaultDate := -1; + DoSetDate; + end; +end; + +procedure TOvcCustomDateEdit.PopupClose(Sender : TObject); +begin + if not FCalendar.Visible then + {already closed, exit} + Exit; + + if PopupClosing then + Exit; + + {avoid recursion} + PopupClosing := True; + + try + inherited PopupClose(Sender); + + if GetCapture = FCalendar.Handle then + ReleaseCapture; + + SetFocus; + {hide the Calendar} + FCalendar.Hide; + if FCalendar.Parent is TForm then + TForm(FCalendar.Parent).AutoScroll := WasAutoScroll; + + Cursor := HoldCursor; + + {change parentage so that we control the window handle destruction} + FCalendar.Parent := Self; + finally + PopupClosing := False; + end; +end; + +procedure TOvcCustomDateEdit.PopupKeyDown(Sender : TObject; var Key : Word; Shift : TShiftState); +var + X : Integer; +begin + case Key of + VK_TAB : + begin + if Shift = [ssShift] then begin + PopupClose(Sender); + PostMessage(Handle, WM_KeyDown, VK_TAB, Integer(ssShift)); + end else if Shift = [] then begin + PopupClose(Sender); + PostMessage(Handle, WM_KeyDown, VK_TAB, 0); + end; + end; + VK_UP : + begin + if Shift = [ssAlt] then begin + PopupClose(Sender); + X := SelStart; + SetFocus; + SelStart := X; + SelLength := 0; + end; + end; + end; +end; + +procedure TOvcCustomDateEdit.PopupKeyPress(Sender : TObject; var Key : Char); +var + X : Integer; +begin + case Key of + #13, + #32, + #27 : + begin + PopupClose(Sender); + X := SelStart; + SetFocus; + SelStart := X; + SelLength := 0; + end; + end; +end; + +procedure TOvcCustomDateEdit.PopupMouseDown(Sender : TObject; Button : TMouseButton; Shift : TShiftState; X, Y : Integer); +var + P : TPoint; + I : Integer; +begin + P := Point(X,Y); + if not PtInRect(FCalendar.ClientRect, P) then + PopUpClose(Sender); + + {convert to our coordinate system} + P := ScreenToClient(FCalendar.ClientToScreen(P)); + + if PtInRect(ClientRect, P) then begin + I := SelStart; + SetFocus; + SelStart := I; + SelLength := 0; + end; +end; + +procedure TOvcCustomDateEdit.PopupOpen; +var + P : TPoint; + R : TRect; + {$IFDEF VERSION4} + {$IFNDEF LCL} + F : TCustomForm; + MonInfo : TMonitorInfo; + {$ENDIF} + {$ENDIF} +begin + if FCalendar.Visible then + {already popped up, exit} + Exit; + + inherited PopupOpen; + + {force update of date} + DoExit; + + FCalendar.Parent := GetParentForm(Self); + if FCalendar.Parent is TForm then begin + WasAutoScroll := TForm(FCalendar.Parent).AutoScroll; + TForm(FCalendar.Parent).AutoScroll := False; + end; + + {set 3d to be the same as our own} + FCalendar.ParentCtl3D := False; + FCalendar.Ctl3D := False; + + {determine the proper position} + SystemParametersInfo(SPI_GETWORKAREA, 0, @R, 0); + {$IFDEF VERSION4} + {$IFNDEF LCL} + F := GetParentForm(Self); + if Assigned(F) then begin + FillChar(MonInfo, SizeOf(MonInfo), #0); + MonInfo.cbSize := SizeOf(MonInfo); + GetMonitorInfo(F.Monitor.Handle, @MonInfo); + R := MonInfo.rcWork; + end; + {$ENDIF} + {$ENDIF} + if FPopupAnchor = paLeft then + P := ClientToScreen(Point(-3, Height-4)) + else {paRight} + P := ClientToScreen(Point(Width-FCalendar.Width-1, Height-2)); + if not Ctl3D then begin + Inc(P.X, 3); + Inc(P.Y, 3); + end; + if P.Y + FCalendar.Height >= R.Bottom then + P.Y := P.Y - FCalendar.Height - Height; + if P.X + FCalendar.Width >= R.Right then + P.X := R.Right - FCalendar.Width - 1; + if P.X <= R.Left then + P.X := R.Left + 1; + + MoveWindow(FCalendar.Handle, P.X, P.Y, FCalendar.Width, FCalendar.Height, False); + + if Text = '' then + FCalendar.Date := SysUtils.Date + else + FCalendar.Date := FDate; + + HoldCursor := Cursor; + Cursor := crArrow; + FCalendar.Show; + FCalendar.SetFocus; + + SetCapture(FCalendar.Handle); +end; + +procedure TOvcCustomDateEdit.PopupDateChange(Sender : TObject; Date : TDateTime); +begin + {get the current value} + SetDate(FCalendar.Date); + Modified := True; + + if FCalendar.Browsing then + Exit; + + {hide the Calendar} + PopupClose(Sender); + SetFocus; + SelStart := Length(Text); + SelLength := 0; +end; + +procedure TOvcCustomDateEdit.SetDate(Value : TDateTime); +begin + FDate := Value; + Modified := True; + + if FDate = 0 then + Text := '' + else + Text := FormatDate(FDate); + + if Assigned(FOnSetDate) then + FOnSetDate(Self); +end; + +procedure TOvcCustomDateEdit.SetDateText(Value : string); +var + Field : Integer; + I1 : Integer; + I2 : Integer; + Error : Integer; + ThisYear : Word; + ThisMonth : Word; + ThisDay : Word; + Year : Word; + Month : Word; + Day : Word; + EpochYear : Integer; + EpochCent : Integer; + StringList : TStringList; + FieldOrder : string[3]; + S : string; +begin + if Assigned(FOnPreParseDate) then + FOnPreParseDate(Self, Value); + Value := ParseDate(Value); + + if Assigned(FOnGetDate) then + FOnGetDate(Self, Value); + + if (Value = '') and (FRequiredFields <> []) then begin + FDate := 0; + Text := ''; + Exit; + end; + + if AnsiCompareText(Value, TodayString) = 0 then begin + SetDate(SysUtils.Date); + Text := FormatDate(FDate); + end else begin + DecodeDate(SysUtils.Date, ThisYear, ThisMonth, ThisDay); + Value := AnsiUpperCase(Value); + StringList := TStringList.Create; + try + {parse the string into subfields using a string list to hold the parts} + I1 := 1; + while (I1 <= Length(Value)) and not (Value[I1] in ['0'..'9', 'A'..'Z']) do + Inc(I1); + while I1 <= Length(Value) do begin + I2 := I1; + while (I2 <= Length(Value)) and (Value[I2] in ['0'..'9', 'A'..'Z']) do + Inc(I2); + StringList.Add(Copy(Value, I1, I2-I1)); + while (I2 <= Length(Value)) and not (Value[I2] in ['0'..'9', 'A'..'Z']) do + Inc(I2); + I1 := I2; + end; + + case DateOrder of + doMDY : FieldOrder := 'MDY'; + doDMY : FieldOrder := 'DMY'; + doYMD : FieldOrder := 'YMD'; + end; + + Year := 0; + Month := 0; + Day := 0; + Error := 0; + for Field := 1 to Length(FieldOrder) do begin + if StringList.Count > 0 then + S := StringList[0] + else + S := ''; + + case FieldOrder[Field] of + 'M' : + begin + if (S = '') or (S[1] in ['0'..'9']) then begin + {numeric month} + try + if S = '' then + Month := 0 + else + Month := StrToInt(S); + except + Month := 0; + {error converting month number} + Error := SCMonthConvertError; + end; + if not (Month in [1..12]) then + Month := 0; + end else begin + {one or more letters in month} + Month := 0; + I1 := 1; + S := Copy(S, 1, 3); + {error converting month name} + Error := SCMonthNameConvertError; + repeat + if S = AnsiUpperCase(Copy(ShortMonthNames[I1], 1, Length(S))) then begin + Month := I1; + I1 := 13; + Error := 0; + end else + Inc(I1); + until I1 = 13; + end; + + if Month = 0 then begin + if rfMonth in FRequiredFields then + {month required} + Error := SCMonthRequired + else + Month := ThisMonth; + end else if StringList.Count > 0 then + StringList.Delete(0); + + if Error > 0 then + Break; + end; + 'Y' : + begin + try + if S = '' then + Year := 0 + else + Year := StrToInt(S); + except + Year := 0; + {error converting year} + Error := SCYearConvertError; + end; + if (Epoch = 0) and (Year < 100) and (S <> '') then + {default to current century if Epoch is zero} + Year := Year + (ThisYear div 100 * 100) + else if (Epoch > 0) and (Year < 100) and (S <> '') then begin + {use epoch} + EpochYear := Epoch mod 100; + EpochCent := (Epoch div 100) * 100; + if (Year < EpochYear) then + Inc(Year,EpochCent+100) + else + Inc(Year,EpochCent); + end; + if Year = 0 then begin + if rfYear in FRequiredFields then + {year is required} + Error := SCYearRequired + else + Year := ThisYear; + end else if StringList.Count > 0 then + StringList.Delete(0); + if Error > 0 then + Break; + end; + 'D' : + begin + try + if S = '' then + Day := 0 + else + Day := StrToInt(S); + except + Day := 0; + {error converting day} + Error := SCDayConvertError; + end; + if not (Day in [1..31]) then + Day := 0; + if Day = 0 then begin + if rfDay in FRequiredFields then + {day is required} + Error := SCDayRequired + else + Day := ThisDay; + end + else if StringList.Count > 0 then + StringList.Delete(0); + + if Error > 0 then + Break; + end; + end; + end; + + case Error of + SCDayConvertError : + if S = '' then + raise EOvcException.Create( + GetOrphStr(SCInvalidDay) + ' "' + Value + '"') + else + raise EOvcException.Create( + GetOrphStr(SCInvalidDay) + ' "' + S + '"'); + SCMonthConvertError : + if S = '' then + raise EOvcException.Create( + GetOrphStr(SCInvalidMonth) + ' "' + Value + '"') + else + raise EOvcException.Create( + GetOrphStr(SCInvalidMonth) + ' "' + S + '"'); + SCMonthNameConvertError : + if S = '' then + raise EOvcException.Create( + GetOrphStr(SCInvalidMonthName) + ' "' + Value + '"') + else + raise EOvcException.Create( + GetOrphStr(SCInvalidMonthName) + ' "' + S + '"'); + SCYearConvertError : + if S = '' then + raise EOvcException.Create( + GetOrphStr(SCInvalidYear) + ' "' + Value + '"') + else + raise EOvcException.Create( + GetOrphStr(SCInvalidYear) + ' "' + S + '"'); + SCDayRequired : + raise EOvcException.Create( + GetOrphStr(SCDayRequired)); + SCMonthRequired : + raise EOvcException.Create( + GetOrphStr(SCMonthRequired)); + SCYearRequired : + raise EOvcException.Create( + GetOrphStr(SCYearRequired)); + end; + + try + SetDate(STDatetoDateTime(DMYToStDate(Day, Month, Year, Epoch))); + Text := FormatDate(FDate); + except + raise EOvcException.Create( + GetOrphStr(SCInvalidDate) + ' "' + Value + '"'); + end; + + finally + StringList.Free; + end; + end; +end; + +procedure TOvcCustomDateEdit.SetEpoch(Value : Integer); +begin + if Value <> FEpoch then + if (Value = 0) or ((Value >= MinYear) and (Value <= MaxYear)) then + FEpoch := Value; +end; + +procedure TOvcCustomDateEdit.SetForceCentury(Value : Boolean); +begin + if Value <> FForceCentury then begin + FForceCentury := Value; + SetDate(FCalendar.Date); + end; +end; + +procedure TOvcCustomDateEdit.SetPopupColors(Value : TOvcCalColors); +begin + FCalendar.Colors := Value; +end; + +procedure TOvcCustomDateEdit.SetPopupDateFormat(Value : TOvcDateFormat); +begin + FCalendar.DateFormat := Value; +end; + +procedure TOvcCustomDateEdit.SetPopupFont(Value : TFont); +begin + if Assigned(Value) then + FCalendar.Font.Assign(Value); +end; + +procedure TOvcCustomDateEdit.SetPopupHeight(Value : Integer); +begin + FCalendar.Height := Value; +end; + +procedure TOvcCustomDateEdit.SetPopupDayNameWidth(Value : TOvcDayNameWidth); +begin + FCalendar.DayNameWidth := Value; +end; + +procedure TOvcCustomDateEdit.SetPopupOptions(Value : TOvcCalDisplayOptions); +begin + FCalendar.Options := Value; +end; + +procedure TOvcCustomDateEdit.SetPopupWidth(Value : Integer); +begin + FCalendar.Width := Value; +end; + +procedure TOvcCustomDateEdit.SetPopupWeekStarts(Value : TOvcDayType); +begin + FCalendar.WeekStarts := Value; +end; + +procedure TOvcCustomDateEdit.SetReadOnly(Value : Boolean); +begin + inherited ReadOnly := Value; + + FButton.Enabled := not ReadOnly; +end; + +end. diff --git a/components/orpheus/ovcedclc.pas b/components/orpheus/ovcedclc.pas new file mode 100644 index 000000000..d7a78c9b8 --- /dev/null +++ b/components/orpheus/ovcedclc.pas @@ -0,0 +1,599 @@ +{*********************************************************} +{* OVCEDCLC.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovcedclc; + {-numeric edit field with popup calculator} + +interface + +uses + {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, LclType, MyMisc, {$ENDIF} + Buttons, Classes, Controls, Forms, Graphics, Menus, + StdCtrls, SysUtils, {$IFDEF VERSION4}{$IFNDEF LCL} MultiMon, {$ENDIF}{$ENDIF} + OvcBase, OvcCalc, OvcEdPop, OvcMisc; + +type + TOvcCustomNumberEdit = class(TOvcEdPopup) + {.Z+} + protected {private} + FAllowIncDec : Boolean; + FCalculator : TOvcCalculator; + + {internal variables} + PopupClosing : Boolean; + HoldCursor : TCursor; + WasAutoScroll : Boolean; + + {property methods} + function GetAsFloat : Double; + function GetAsInteger : LongInt; + function GetAsString : string; + function GetPopupColors : TOvcCalcColors; + function GetPopupDecimals : Integer; + function GetPopupFont : TFont; + function GetPopupHeight : Integer; + function GetPopupWidth : Integer; + function GetReadOnly : Boolean; + procedure SetAsFloat(Value : Double); + procedure SetAsInteger(Value : LongInt); + procedure SetAsString(const Value : string); + procedure SetPopupColors(Value : TOvcCalcColors); + procedure SetPopupDecimals(Value : Integer); + procedure SetPopupFont(Value : TFont); + procedure SetPopupHeight(Value : Integer); + procedure SetPopupWidth(Value : Integer); + procedure SetReadOnly(Value : Boolean); + + {internal methods} + procedure PopupButtonPressed(Sender : TObject; Button : TOvcCalculatorButton); + procedure PopupKeyDown(Sender : TObject; var Key : Word; Shift : TShiftState); + procedure PopupKeyPress(Sender : TObject; var Key : Char); + procedure PopupMouseDown(Sender : TObject; Button : TMouseButton; Shift : TShiftState; X, Y : Integer); + + protected + procedure DoExit; + override; + procedure GlyphChanged; + override; + procedure KeyDown(var Key : Word; Shift : TShiftState); + override; + procedure KeyPress(var Key : Char); + override; + {.Z-} + + property AllowIncDec : Boolean + read FAllowIncDec write FAllowIncDec; + property PopupColors : TOvcCalcColors + read GetPopupColors write SetPopupColors; + property PopupDecimals : Integer + read GetPopupDecimals write SetPopupDecimals; + property PopupFont : TFont + read GetPopupFont write SetPopupFont; + property PopupHeight : Integer + read GetPopupHeight write SetPopupHeight; + property PopupWidth : Integer + read GetPopupWidth write SetPopupWidth; + property ReadOnly : Boolean + read GetReadOnly write SetReadOnly; + + public + {.Z+} + constructor Create(AOwner : TComponent); + override; + {.Z-} + + procedure PopupClose(Sender : TObject); + override; + procedure PopupOpen; + override; + + property AsInteger : LongInt + read GetAsInteger + write SetAsInteger; + + {public properties} + property Calculator : TOvcCalculator + read FCalculator; + property AsFloat : Double + read GetAsFloat write SetAsFloat; + property AsString : string + read GetAsString write SetAsString; + end; + + TOvcNumberEdit = class(TOvcCustomNumberEdit) + published + {properties} + {$IFDEF VERSION4} + property Anchors; + property Constraints; + property DragKind; + {$ENDIF} + property About; + property AllowIncDec; +{$IFNDEF LCL} + property AutoSelect; +{$ENDIF} + property AutoSize; + property BorderStyle; + property ButtonGlyph; + property Color; + property Ctl3D; + property Cursor; + property DragCursor; + property DragMode; + property Enabled; + property Font; +{$IFNDEF LCL} + property HideSelection; +{$ENDIF} + property LabelInfo; + property ParentColor; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PopupAnchor; + property PopupColors; + property PopupDecimals; + property PopupFont; + property PopupHeight; + property PopupWidth; + property PopupMenu; + property ReadOnly; + property ShowHint; + property ShowButton; + property TabOrder; + property TabStop; + property Visible; + + {events} + property OnChange; + property OnClick; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnPopupClose; + property OnPopupOpen; + property OnStartDrag; + end; + + +implementation + + +{*** TOvcCustomNumberEdit ***} + +constructor TOvcCustomNumberEdit.Create(AOwner : TComponent); +begin + inherited Create(AOwner); + + ControlStyle := ControlStyle - [csSetCaption]; + + FAllowIncDec := False; + + {load button glyph} +{$IFNDEF LCL} + FButtonGlyph.Handle := LoadBaseBitmap('ORBTNCLC'); +{$ELSE} + FButtonGlyph.LoadFromLazarusResource('ORBTNCLC'); +{$ENDIF} + FButton.Glyph.Assign(FButtonGlyph); + + FCalculator := TOvcCalculator.CreateEx(Self, True); + FCalculator.OnButtonPressed := PopupButtonPressed; + FCalculator.OnExit := PopupClose; + FCalculator.OnKeyDown := PopupKeyDown; + FCalculator.OnKeyPress := PopupKeyPress; + FCalculator.OnMouseDown := PopupMouseDown; + FCalculator.Visible := False; {to avoid flash at 0,0} + FCalculator.Options := [coShowItemCount]; + FCalculator.BorderStyle := bsSingle; + FCalculator.ParentFont := False; +end; + +procedure TOvcCustomNumberEdit.DoExit; +begin + if not PopupActive then + inherited DoExit; +end; + +function TOvcCustomNumberEdit.GetAsFloat : Double; +var + I : Integer; + S : string; +begin + S := Text; + for I := Length(S) downto 1 do + if not (S[I] in ['0'..'9', '+', '-', DecimalSeparator]) then + Delete(S, I, 1); + Result := StrToFloat(S); +end; + +function TOvcCustomNumberEdit.GetAsInteger : LongInt; +begin + Result := Round(GetAsFloat); +end; + +function TOvcCustomNumberEdit.GetAsString : string; +begin + Result := Text; +end; + +function TOvcCustomNumberEdit.GetPopupColors : TOvcCalcColors; +begin + Result := FCalculator.Colors; +end; + +function TOvcCustomNumberEdit.GetPopupDecimals : Integer; +begin + Result := FCalculator.Decimals; +end; + +function TOvcCustomNumberEdit.GetPopupFont : TFont; +begin + Result := FCalculator.Font; +end; + +function TOvcCustomNumberEdit.GetPopupHeight : Integer; +begin + Result := FCalculator.Height; +end; + +function TOvcCustomNumberEdit.GetPopupWidth : Integer; +begin + Result := FCalculator.Width; +end; + +function TOvcCustomNumberEdit.GetReadOnly : Boolean; +begin + Result := inherited ReadOnly; +end; + +procedure TOvcCustomNumberEdit.GlyphChanged; +begin + inherited GlyphChanged; + + if FButtonGlyph.Empty then +{$IFNDEF LCL} + FButtonGlyph.Handle := LoadBaseBitmap('ORBTNCLC'); +{$ELSE} + FButtonGlyph.LoadFromLazarusResource('ORBTNCLC'); +{$ENDIF} +end; + +procedure TOvcCustomNumberEdit.KeyDown(var Key : Word; Shift : TShiftState); +begin + inherited KeyDown(Key, Shift); + + if (Key = VK_DOWN) and (ssAlt in Shift) then + PopupOpen; +end; + +procedure TOvcCustomNumberEdit.KeyPress(var Key : Char); +var + D : Double; + X : Integer; + L : Integer; +begin + inherited KeyPress(Key); + + if not ((Key = #22) or (Key = #3) or (Key = #24)) then begin + if not (Key in [#27, '0'..'9', '.', DecimalSeparator, + #8, '+', '-', '*', '/']) then begin + Key := #0; +{$IFNDEF LCL} + MessageBeep(0); +{$ENDIF} + Exit; + end; + + {Disallow more than one DecimalSeparator in the number} + if (SelLength <> Length(Text)) + and (Key = DecimalSeparator) and (Pos(DecimalSeparator, Text) > 0) + then begin + Key := #0; +{$IFNDEF LCL} + MessageBeep(0); +{$ENDIF} + Exit; + end; + + if FAllowIncDec and (Key in ['+', '-']) then begin + if Text = '' then + Text := '0'; + D := StrToFloat(Text); + X := SelStart; + L := SelLength; + + if Key = '+' then + Text := FloatToStr(D+1) + else {'-'} + Text := FloatToStr(D-1); + + SelStart := X; + SelLength := L; + + Key := #0; {clear key} + end; + + if (Key in ['+', '*', '/']) then begin + PopUpOpen; + FCalculator.KeyPress(Key); + Key := #0; {clear key} + end; + end; +end; + +procedure TOvcCustomNumberEdit.PopupButtonPressed(Sender : TObject; + Button : TOvcCalculatorButton); +begin + case Button of + cbEqual : + begin + {get the current value} + Text := FloatToStr(FCalculator.DisplayValue); + Modified := True; + + {hide the calculator} + PopupClose(Sender); + SetFocus; + SelStart := Length(Text); + SelLength := 0; + end; + end; +end; + +procedure TOvcCustomNumberEdit.PopupClose(Sender : TObject); +begin + if not FCalculator.Visible then + Exit; {already closed, exit} + + if PopupClosing then + Exit; + + PopupClosing := True; {avoid recursion} + try + inherited PopupClose(Sender); + + if GetCapture = FCalculator.Handle then + ReleaseCapture; + + SetFocus; + FCalculator.Hide; {hide the calculator} + TForm(FCalculator.Parent).AutoScroll := WasAutoScroll; + Cursor := HoldCursor; + + {change parentage so that we control the window handle destruction} + FCalculator.Parent := Self; + finally + PopupClosing := False; + end; +end; + +procedure TOvcCustomNumberEdit.PopupKeyDown(Sender : TObject; var Key : Word; Shift : TShiftState); +var + X : Integer; +begin + case Key of + + VK_TAB : + begin + if Shift = [ssShift] then begin + PopupClose(Sender); + PostMessage(Handle, WM_KeyDown, VK_TAB, Integer(ssShift)); + end else if Shift = [] then begin + PopupClose(Sender); + PostMessage(Handle, WM_KeyDown, VK_TAB, 0); + end; + end; + + + VK_UP : if Shift = [ssAlt] then begin + PopupClose(Sender); + X := SelStart; + SetFocus; + SelStart := X; + SelLength := 0; + end; + end; +end; + +procedure TOvcCustomNumberEdit.PopupKeyPress(Sender : TObject; var Key : Char); +var + X : Integer; +begin + case Key of + #27 : + begin + PopupClose(Sender); + X := SelStart; + SetFocus; + SelStart := X; + SelLength := 0; + end; + end; +end; + +procedure TOvcCustomNumberEdit.PopupMouseDown(Sender : TObject; Button : TMouseButton; Shift : TShiftState; X, Y : Integer); +var + P : TPoint; + I : Integer; +begin + P := Point(X,Y); + if not PtInRect(FCalculator.ClientRect, P) then + PopUpClose(Sender); + + {convert to our coordinate system} + P := ScreenToClient(FCalculator.ClientToScreen(P)); + + if PtInRect(ClientRect, P) then begin + I := SelStart; + SetFocus; + SelStart := I; + SelLength := 0; + end; +end; + +procedure TOvcCustomNumberEdit.PopupOpen; +var + P : TPoint; + R : TRect; + {$IFDEF VERSION4} + {$IFNDEF LCL} + F : TCustomForm; + MonInfo : TMonitorInfo; + {$ENDIF} + {$ENDIF} +begin + if FCalculator.Visible then + Exit; {already popped up, exit} + + inherited PopupOpen; + + FCalculator.Parent := GetImmediateParentForm(Self); + if FCalculator.Parent is TForm then begin + WasAutoScroll := TForm(FCalculator.Parent).AutoScroll; + TForm(FCalculator.Parent).AutoScroll := False; + end; + + {set 3d to be the same as our own} + FCalculator.ParentCtl3D := False; + FCalculator.Ctl3D := False; + + {determine the proper position} + SystemParametersInfo(SPI_GETWORKAREA, 0, @R, 0); + {$IFDEF VERSION4} + {$IFNDEF LCL} + F := GetParentForm(Self); + if Assigned(F) then begin + FillChar(MonInfo, SizeOf(MonInfo), #0); + MonInfo.cbSize := SizeOf(MonInfo); + GetMonitorInfo(F.Monitor.Handle, @MonInfo); + R := MonInfo.rcWork; + end; + {$ENDIF} + {$ENDIF} + if FPopupAnchor = paLeft then + P := ClientToScreen(Point(-3, Height-4)) + else {paRight} + P := ClientToScreen(Point(Width-FCalculator.Width-1, Height-2)); + if not Ctl3D then begin + Inc(P.X, 3); + Inc(P.Y, 3); + end; + if P.Y + FCalculator.Height >= R.Bottom then + P.Y := P.Y - FCalculator.Height - Height; + if P.X + FCalculator.Width >= R.Right then + P.X := R.Right - FCalculator.Width - 1; + if P.X <= R.Left then + P.X := R.Left + 1; + +{$IFNDEF LCL} + MoveWindow(FCalculator.Handle, P.X, P.Y, FCalculator.Width, FCalculator.Height, False); + {$ENDIF} + + HoldCursor := Cursor; + Cursor := crArrow; + FCalculator.PressButton(cbClear); + FCalculator.Show; + FCalculator.Visible := True; + if Text <> '' then + FCalculator.PushOperand(AsFloat) + else + FCalculator.PushOperand(0); + FCalculator.SetFocus; + + SetCapture(FCalculator.Handle); +end; + +procedure TOvcCustomNumberEdit.SetAsFloat(Value : Double); +begin + Text := FloatToStr(Value); +end; + +procedure TOvcCustomNumberEdit.SetAsInteger(Value : LongInt); +begin + Text := IntToStr(Value); +end; + +procedure TOvcCustomNumberEdit.SetAsString(const Value : string); +begin + Text := Value; +end; + +procedure TOvcCustomNumberEdit.SetPopupColors(Value : TOvcCalcColors); +begin + FCalculator.Colors := Value; +end; + +procedure TOvcCustomNumberEdit.SetPopupDecimals(Value : Integer); +begin + FCalculator.Decimals := Value; +end; + +procedure TOvcCustomNumberEdit.SetPopupFont(Value : TFont); +begin + if Assigned(Value) then + FCalculator.Font.Assign(Value); +end; + +procedure TOvcCustomNumberEdit.SetPopupHeight(Value : Integer); +begin + FCalculator.Height := Value; +end; + +procedure TOvcCustomNumberEdit.SetPopupWidth(Value : Integer); +begin + FCalculator.Width := Value; +end; + +procedure TOvcCustomNumberEdit.SetReadOnly(Value : Boolean); +begin + inherited ReadOnly := Value; + + FButton.Enabled := not ReadOnly; +end; + +end. diff --git a/components/orpheus/ovceditf.pas b/components/orpheus/ovceditf.pas new file mode 100644 index 000000000..49986277d --- /dev/null +++ b/components/orpheus/ovceditf.pas @@ -0,0 +1,418 @@ +{*********************************************************} +{* OVCEDITF.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} +{$J+} {Writable constants} + +unit ovceditf; + {-old style base edit field class w/ attached label} + {to be deprecated in a future release} + +interface + +uses + {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, MyMisc, {$ENDIF} + Buttons, Classes, Controls, ExtCtrls, Forms, Graphics, Menus, + StdCtrls, SysUtils, OvcBase, OvcConst, OvcData, OvcExcpt, OvcVer, OvcMisc; + +type + TOvcCustomEdit = class(TCustomEdit) + protected {private} + {property variables} + FController : TOvcController; + FLabelInfo : TOvcLabelInfo; + {property methods} + function GetAbout : string; + function GetAttachedLabel : TOvcAttachedLabel; + procedure SetAbout(const Value : string); + procedure SetController(Value : TOvcController); + {internal methods} + procedure LabelChange(Sender : TObject); + procedure LabelAttach(Sender : TObject; Value : Boolean); + procedure PositionLabel; + {VCL message methods} + procedure CMVisibleChanged(var Msg : TMessage); message CM_VISIBLECHANGED; + procedure OrAssignLabel(var Msg : TMessage); message OM_ASSIGNLABEL; + procedure OrPositionLabel(var Msg : TMessage); message OM_POSITIONLABEL; + procedure OrRecordLabelPosition(var Msg : TMessage); + message OM_RECORDLABELPOSITION; + protected + {descendants can set the value of this variable after calling inherited } + {create to set the default location and point-of-reference (POR) for the} + {attached label. if dlpTopLeft, the default location and POR will be at } + {the top left of the control. if dlpBottomLeft, the default location and} + {POR will be at the bottom left} + DefaultLabelPosition : TOvcLabelPosition; + procedure CreateWnd; override; + procedure Notification(AComponent : TComponent; Operation: TOperation); + override; + function ControllerAssigned : Boolean; + property About : string read GetAbout write SetAbout stored False; + property LabelInfo : TOvcLabelInfo read FLabelInfo write FLabelInfo; + public + constructor Create(AOwner : TComponent); override; + destructor Destroy; override; + procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override; + property AttachedLabel : TOvcAttachedLabel read GetAttachedLabel; + property Controller : TOvcController read FController write SetController; + end; + + TOvcEdit = class(TOvcCustomEdit) + published + {properties} + {$IFDEF VERSION4} + property Anchors; +{$IFNDEF LCL} + property BiDiMode; + property ParentBiDiMode; +{$ENDIF} + property Constraints; + property DragKind; + {$ENDIF} + property About; +{$IFNDEF LCL} + property AutoSelect; +{$ENDIF} + property AutoSize; + property BorderStyle; + property CharCase; + property Color; + property Controller; + property Ctl3D; + property Cursor; + property DragCursor; + property DragMode; + property Enabled; + property Font; +{$IFNDEF LCL} + property HideSelection; + property ImeMode; + property ImeName; +{$ENDIF} + property LabelInfo; + property MaxLength; +{$IFNDEF LCL} + property OEMConvert; +{$ENDIF} + property ParentColor; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PasswordChar; + property PopupMenu; + property ReadOnly; + property ShowHint; + property TabOrder; + property TabStop; + property Text; + property Visible; + {events} + property OnChange; + property OnClick; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + {$IFDEF VERSION4} + property OnEndDock; + property OnStartDock; + {$ENDIF} + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnStartDrag; + end; + +implementation + +{===== TOvcCustomEdit ================================================} + +procedure TOvcCustomEdit.CMVisibleChanged(var Msg : TMessage); +begin + inherited; + + if csLoading in ComponentState then + Exit; + + if LabelInfo.Visible then + AttachedLabel.Visible := Visible; +end; +{=====} + +function TOvcCustomEdit.ControllerAssigned : Boolean; +begin + Result := Assigned(FController); +end; +{=====} + +constructor TOvcCustomEdit.Create(AOwner : TComponent); +begin + inherited Create(AOwner); + + ControlStyle := ControlStyle - [csSetCaption]; + + {set default position and reference point} + DefaultLabelPosition := lpTopLeft; + + FLabelInfo := TOvcLabelInfo.Create; + FLabelInfo.OnChange := LabelChange; + FLabelInfo.OnAttach := LabelAttach; +end; +{=====} + +procedure TOvcCustomEdit.CreateWnd; +var + OurForm : TWinControl; +begin + OurForm := GetImmediateParentForm(Self); + + {do this only when the component is first dropped on the form, not during loading} + if (csDesigning in ComponentState) and not (csLoading in ComponentState) then + ResolveController(OurForm, FController); + + if not Assigned(FController) and not (csLoading in ComponentState) then begin + {try to find a controller on this form that we can use} + FController := FindController(OurForm); + + {if not found and we are not designing, use default controller} + if not Assigned(FController) and not (csDesigning in ComponentState) then + FController := DefaultController; + end; + + inherited CreateWnd; +end; +{=====} + +destructor TOvcCustomEdit.Destroy; +begin + {detatch and destroy label, if any} + FLabelInfo.Visible := False; + + {destroy label info} + FLabelInfo.Free; + FLabelInfo := nil; + + inherited Destroy; +end; +{=====} + +function TOvcCustomEdit.GetAttachedLabel : TOvcAttachedLabel; +begin + if not FLabelInfo.Visible then + raise Exception.Create(GetOrphStr(SCLabelNotAttached)); + + Result := FLabelInfo.ALabel; +end; +{=====} + +function TOvcCustomEdit.GetAbout : string; +begin + Result := OrVersionStr; +end; +{=====} + +procedure TOvcCustomEdit.LabelAttach(Sender : TObject; Value : Boolean); +var +{$IFDEF VERSION5} + PF : TWinControl; +{$ELSE} + PF : TForm; +{$ENDIF} + S :string; +begin + if csLoading in ComponentState then + Exit; + +{$IFDEF VERSION5} + PF := GetImmediateParentForm(Self); +{$ELSE} + PF := TForm(GetParentForm(Self)); +{$ENDIF} + if Value then begin + if Assigned(PF) then begin + FLabelInfo.ALabel.Free; + FLabelInfo.ALabel := TOvcAttachedLabel.CreateEx(PF, Self); + FLabelInfo.ALabel.Parent := Parent; + + S := GenerateComponentName(PF, Name + 'Label'); + FLabelInfo.ALabel.Name := S; + FLabelInfo.ALabel.Caption := S; + + FLabelInfo.SetOffsets(0, 0); + PositionLabel; + FLabelInfo.ALabel.BringToFront; + {turn off auto size} + TLabel(FLabelInfo.ALabel).AutoSize := False; + end; + end else begin + if Assigned(PF) then begin + FLabelInfo.ALabel.Free; + FLabelInfo.ALabel := nil; + end; + end; +end; +{=====} + +procedure TOvcCustomEdit.LabelChange(Sender : TObject); +begin + if not (csLoading in ComponentState) then + PositionLabel; +end; +{=====} + +procedure TOvcCustomEdit.Notification(AComponent : TComponent; Operation: TOperation); +var +{$IFDEF VERSION5} + PF : TWinControl; +{$ELSE} + PF : TForm; +{$ENDIF} +begin + inherited Notification(AComponent, Operation); + + if Operation = opRemove then + if Assigned(FLabelInfo) and (AComponent = FLabelInfo.ALabel) then begin + {$IFDEF VERSION5} + PF := GetImmediateParentForm(Self); + {$ELSE} + PF := TForm(GetParentForm(Self)); + {$ENDIF} + if Assigned(PF) and not (csDestroying in PF.ComponentState) then begin + FLabelInfo.FVisible := False; + FLabelInfo.ALabel := nil; + end + end; + + if (AComponent = FController) and (Operation = opRemove) then + FController := nil + else if (Operation = opInsert) and (FController = nil) then begin + if (AComponent is TOvcController) then + FController := TOvcController(AComponent); + end; +end; +{=====} + +procedure TOvcCustomEdit.OrAssignLabel(var Msg : TMessage); +begin + FLabelInfo.ALabel := TOvcAttachedLabel(Msg.lParam); +end; +{=====} + +procedure TOvcCustomEdit.OrPositionLabel(var Msg : TMessage); +const + DX : Integer = 0; + DY : Integer = 0; +begin + if FLabelInfo.Visible and Assigned(FLabelInfo.ALabel) and + (FLabelInfo.ALabel.Parent <> nil) and + not (csLoading in ComponentState) then begin + if DefaultLabelPosition = lpTopLeft then begin + DX := FLabelInfo.ALabel.Left - Left; + DY := FLabelInfo.ALabel.Top + FLabelInfo.ALabel.Height - Top; + end else begin + DX := FLabelInfo.ALabel.Left - Left; + DY := FLabelInfo.ALabel.Top - Top - Height; + end; + if (DX <> FLabelInfo.OffsetX) or (DY <> FLabelInfo.OffsetY) then + PositionLabel; + end; +end; +{=====} + +procedure TOvcCustomEdit.OrRecordLabelPosition(var Msg : TMessage); +begin + if Assigned(FLabelInfo.ALabel) and (FLabelInfo.ALabel.Parent <> nil) then begin + {if the label was cut and then pasted, this will complete the reattachment} + FLabelInfo.FVisible := True; + + if DefaultLabelPosition = lpTopLeft then + FLabelInfo.SetOffsets(FLabelInfo.ALabel.Left - Left, + FLabelInfo.ALabel.Top + FLabelInfo.ALabel.Height - Top) + else + FLabelInfo.SetOffsets(FLabelInfo.ALabel.Left - Left, + FLabelInfo.ALabel.Top - Top - Height); + end; +end; +{=====} + +procedure TOvcCustomEdit.PositionLabel; +begin + if FLabelInfo.Visible and Assigned(FLabelInfo.ALabel) and + (FLabelInfo.ALabel.Parent <> nil) and + not (csLoading in ComponentState) then begin + + if DefaultLabelPosition = lpTopLeft then begin + FLabelInfo.ALabel.SetBounds(Left + FLabelInfo.OffsetX, + FLabelInfo.OffsetY - FLabelInfo.ALabel.Height + Top, + FLabelInfo.ALabel.Width, FLabelInfo.ALabel.Height); + end else begin + FLabelInfo.ALabel.SetBounds(Left + FLabelInfo.OffsetX, + FLabelInfo.OffsetY + Top + Height, + FLabelInfo.ALabel.Width, FLabelInfo.ALabel.Height); + end; + end; +end; +{=====} + +procedure TOvcCustomEdit.SetBounds(ALeft, ATop, AWidth, AHeight : Integer); +begin + inherited SetBounds(ALeft, ATop, AWidth, AHeight); + + if not HandleAllocated then + Exit; + + if HandleAllocated then + PostMessage(Handle, OM_POSITIONLABEL, 0, 0); +end; +{=====} + +procedure TOvcCustomEdit.SetController(Value : TOvcController); +begin + FController := Value; + if Value <> nil then + Value.FreeNotification(Self); +end; +{=====} + +procedure TOvcCustomEdit.SetAbout(const Value : string); +begin +end; + +end. diff --git a/components/orpheus/ovcedpop.pas b/components/orpheus/ovcedpop.pas new file mode 100644 index 000000000..4331db2a2 --- /dev/null +++ b/components/orpheus/ovcedpop.pas @@ -0,0 +1,341 @@ +{*********************************************************} +{* OVCEDPOP.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} +{$J+} {Writable constants} + +unit ovcedpop; + {-base popup edit field class} + +interface + +uses + {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, LclType, MyMisc, {$ENDIF} + Buttons, Classes, Controls, ExtCtrls, Forms, Graphics, Menus, + StdCtrls, SysUtils, OvcEditF; + +const + MsgClose = WM_USER+100; + MsgOpen = WM_USER+101; + +type + TOvcEdButton = class(TBitBtn) + public + procedure Click; + override; + end; + + TOvcPopupEvent = + procedure(Sender : TObject) of object; + + TOvcPopupAnchor = (paLeft, paRight); + + TOvcEdPopup = class(TOvcCustomEdit) + protected {private} + {property variables} + FButton : TOvcEdButton; + FButtonGlyph : TBitmap; + FPopupActive : Boolean; + FPopupAnchor : TOvcPopupAnchor; + FOnPopupClose : TOvcPopupEvent; + FOnPopupOpen : TOvcPopupEvent; + FShowButton : Boolean; + + {property methods} + function GetButtonGlyph : TBitmap; + procedure SetButtonGlyph(Value : TBitmap); + procedure SetShowButton(Value : Boolean); + + {internal methods} + function GetButtonWidth : Integer; + +{$IFDEF VERSION4} + procedure CMDialogKey(var Msg : TCMDialogKey); + message CM_DIALOGKEY; +{$ENDIF} + + protected + procedure CreateParams(var Params : TCreateParams); + override; + procedure CreateWnd; + override; + function GetButtonEnabled : Boolean; + dynamic; + procedure GlyphChanged; + dynamic; + procedure Loaded; + override; + + procedure OnMsgClose(var M : TMessage); + message MsgClose; + procedure OnMsgOpen(var M : TMessage); + message MsgOpen; + + property PopupAnchor : TOvcPopupAnchor + read FPopupAnchor write FPopupAnchor; + property ShowButton : Boolean + read FShowButton write SetShowButton; + + public + constructor Create(AOwner : TComponent); + override; + destructor Destroy; + override; + procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); + override; + + property ButtonGlyph : TBitmap + read GetButtonGlyph + write SetButtonGlyph; + + procedure PopupClose(Sender : TObject); + dynamic; + procedure PopupOpen; + dynamic; + + property OnPopupClose : TOvcPopupEvent + read FOnPopupClose + write FOnPopupClose; + + property OnPopupOpen : TOvcPopupEvent + read FOnPopupOpen + write FOnPopupOpen; + + property PopupActive : Boolean + read FPopupActive; + + property Controller; + end; + +implementation + +{*** TOvcEdButton ***} + +procedure TOvcEdButton.Click; +begin + TOvcEdPopup(Parent).PopupOpen; +end; + + +{*** TOvcEdPopup ***} + +constructor TOvcEdPopup.Create(AOwner : TComponent); +begin + inherited Create(AOwner); + + ControlStyle := ControlStyle - [csSetCaption]; + + FShowButton := True; + FButton := TOvcEdButton.Create(Self); + FButton.Visible := True; + FButton.Parent := Self; + FButton.Caption := ''; + FButton.TabStop := False; +{$IFNDEF LCL} + FButton.Style := bsNew; +{$ENDIF} + + FButtonGlyph := TBitmap.Create; +end; + +procedure TOvcEdPopup.CreateParams(var Params : TCreateParams); +begin + inherited CreateParams(Params); + + Params.Style := Params.Style or WS_CLIPCHILDREN; +end; + +procedure TOvcEdPopup.CreateWnd; +begin + inherited CreateWnd; + + {force button placement} + SetBounds(Left, Top, Width, Height); + + FButton.Enabled := GetButtonEnabled; +end; + + +destructor TOvcEdPopup.Destroy; +begin + {destroy button} + FButton.Free; + FButton := nil; + + {destroy button glyph} + FButtonGlyph.Free; + FButtonGlyph := nil; + + inherited Destroy; +end; + +function TOvcEdPopup.GetButtonEnabled : Boolean; +begin + Result := not ReadOnly; +end; + +function TOvcEdPopup.GetButtonWidth : Integer; +begin + if FShowButton then begin + Result := GetSystemMetrics(SM_CXHSCROLL); + if Assigned(FButtonGlyph) and not FButtonGlyph.Empty then + if FButtonGlyph.Width + 4 > Result then + Result := FButtonGlyph.Width + 4; + end else + Result := 0; +end; + +function TOvcEdPopup.GetButtonGlyph : TBitmap; +begin + if not Assigned(FButtonGlyph) then + FButtonGlyph := TBitmap.Create; + + Result := FButtonGlyph +end; + +procedure TOvcEdPopup.GlyphChanged; +begin +end; + +procedure TOvcEdPopup.Loaded; +begin + inherited Loaded; + + if Assigned(FButtonGlyph) then + FButton.Glyph.Assign(FButtonGlyph); +end; + +procedure TOvcEdPopup.OnMsgClose(var M : TMessage); +begin + if (Assigned(FOnPopupClose)) then + FOnPopupClose(Self); +end; + +procedure TOvcEdPopup.OnMsgOpen(var M : TMessage); +begin + if (Assigned(FOnPopupOpen)) then + FOnPopupOpen(Self); +end; + + +procedure TOvcEdPopup.PopupClose; +begin + FPopupActive := False; + PostMessage(Handle, MsgClose, 0, 0); +end; + +procedure TOvcEdPopup.PopupOpen; +begin + FPopupActive := True; + PostMessage(Handle, MsgOpen, 0, 0); +end; + +procedure TOvcEdPopup.SetBounds(ALeft, ATop, AWidth, AHeight : Integer); +var + H : Integer; +begin + inherited SetBounds(ALeft, ATop, AWidth, AHeight); + + if not HandleAllocated then + Exit; + + if not FShowButton then begin + FButton.Height := 0; + FButton.Width := 0; + Exit; + end; + + H := ClientHeight; + if BorderStyle = bsNone then begin + FButton.Height := H; + FButton.Width := GetButtonWidth; + FButton.Left := Width - FButton.Width; + FButton.Top := 0; + end else if Ctl3D then begin + FButton.Height := H; + FButton.Width := GetButtonWidth; + FButton.Left := Width - FButton.Width - 4; + FButton.Top := 0; + end else begin + FButton.Height := H - 2; + FButton.Width := GetButtonWidth; + FButton.Left := Width - FButton.Width - 1; + FButton.Top := 1; + end; +end; + +procedure TOvcEdPopup.SetButtonGlyph(Value : TBitmap); +begin + if not Assigned(FButtonGlyph) then + FButtonGlyph := TBitmap.Create; + + if not Assigned(Value) then begin + FButtonGlyph.Free; + FButtonGlyph := TBitmap.Create; + end else + FButtonGlyph.Assign(Value); + + GlyphChanged; + + FButton.Glyph.Assign(FButtonGlyph); + SetBounds(Left, Top, Width, Height); +end; + +procedure TOvcEdPopup.SetShowButton(Value : Boolean); +begin + if Value <> FShowButton then begin + FShowButton := Value; + {force resize and redisplay of button} + SetBounds(Left, Top, Width, Height); + end; +end; + +{$IFDEF VERSION4} +procedure TOvcEdPopup.CMDialogKey(var Msg : TCMDialogKey); +begin + if PopupActive then begin + with Msg do begin + if ((CharCode = VK_RETURN) or (CHarCode = VK_ESCAPE)) then begin + PopupClose(Self); + Result := 1; + end; + end; + end else + inherited; +end; +{$ENDIF} + + +end. diff --git a/components/orpheus/ovcedtim.pas b/components/orpheus/ovcedtim.pas new file mode 100644 index 000000000..b77a456b5 --- /dev/null +++ b/components/orpheus/ovcedtim.pas @@ -0,0 +1,706 @@ +{*********************************************************} +{* OVCEDTIM.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovcedtim; + {-time edit field} + +interface + +uses + {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, LclType, MyMisc, {$ENDIF} + Buttons, Classes, Controls, Forms, Graphics, Menus, + StdCtrls, SysUtils, OvcConst, OvcData, OvcExcpt, OvcIntl, OvcMisc, + OvcEditF, OvcDate; + +type + TOvcTimeField = (tfHours, tfMinutes, tfSeconds); + TOvcTimeMode = (tmClock, tmDuration); + TOvcDurationDisplay = (ddHMS, ddHM, ddMS, ddHHH, ddMMM, ddSSS); + + TOvcGetTimeEvent = procedure(Sender : TObject; var Value : string) + of object; + TOvcPreParseTimeEvent = procedure(Sender : TObject; var Value : string) + of object; + + TOvcCustomTimeEdit = class(TOvcCustomEdit) + {.Z+} + protected {private} + {property variables} + FDurationDisplay : TOvcDurationDisplay; + FNowString : string; + FDefaultToPM : Boolean; + FPrimaryField : TOvcTimeField; + FShowSeconds : Boolean; + FShowUnits : Boolean; + FTime : TDateTime; + FTimeMode : TOvcTimeMode; + FUnitsLength : Integer; + + {event variables} + FOnGetTime : TOvcGetTimeEvent; + FOnPreParseTime : TOvcPreParseTimeEvent; + FOnSetTime : TNotifyEvent; + + {property methods} + function GetAsHours : LongInt; + function GetAsMinutes : LongInt; + function GetAsSeconds : LongInt; + function GetTime : TDateTime; + procedure SetAsHours(Value : LongInt); + procedure SetAsMinutes(Value : LongInt); + procedure SetAsSeconds(Value : LongInt); + procedure SetDurationDisplay(Value : TOvcDurationDisplay); + procedure SetShowSeconds(Value : Boolean); + procedure SetShowUnits(Value : Boolean); + procedure SetTimeMode(Value : TOvcTimeMode); + procedure SetUnitsLength(Value : Integer); + + {internal methods} + procedure ParseFields(const Value : string; S : TStringList); + + protected + procedure DoExit; + override; + procedure SetTime(Value : TDateTime); + procedure SetTimeText(Value : string); + dynamic; + {.Z-} + + {protected properties} + property DefaultToPM : Boolean + read FDefaultToPM write FDefaultToPM; + property DurationDisplay : TOvcDurationDisplay + read FDurationDisplay write SetDurationDisplay; + property NowString : string + read FNowString write FNowString; + property PrimaryField : TOvcTimeField + read FPrimaryField write FPrimaryField; + property ShowSeconds : Boolean + read FShowSeconds write SetShowSeconds; + property ShowUnits : Boolean + read FShowUnits write SetShowUnits; + property TimeMode : TOvcTimeMode + read FTimeMode write SetTimeMode; + property UnitsLength : Integer + read FUnitsLength write SetUnitsLength; + + {protected events} + property OnGetTime : TOvcGetTimeEvent + read FOnGetTime write FOnGetTime; + property OnPreParseTime : TOvcPreParseTimeEvent + read FOnPreParseTime write FOnPreParseTime; + property OnSetTime : TNotifyEvent + read FOnSetTime write FOnSetTime; + + public + {.Z+} + constructor Create(AOwner : TComponent); + override; + {.Z-} + + function FormatTime(Value : TDateTime) : string; + dynamic; + + {public properties} + property AsDateTime : TDateTime + read GetTime write SetTime; + property AsHours : LongInt + read GetAsHours write SetAsHours; + property AsMinutes : LongInt + read GetAsMinutes write SetAsMinutes; + property AsSeconds : LongInt + read GetAsSeconds write SetAsSeconds; + end; + + TOvcTimeEdit = class(TOvcCustomTimeEdit) + published + {properties} + {$IFDEF VERSION4} + property Anchors; + property Constraints; + property DragKind; + {$ENDIF} + property About; +{$IFNDEF LCL} + property AutoSelect; +{$ENDIF} + property AutoSize; + property BorderStyle; + property CharCase; + property Color; + property Controller; + property Ctl3D; + property Cursor; + property DefaultToPM; + property DragCursor; + property DragMode; + property DurationDisplay; + property Enabled; + property Font; +{$IFNDEF LCL} + property HideSelection; + property ImeMode; + property ImeName; +{$ENDIF} + property LabelInfo; + property MaxLength; + property NowString; +{$IFNDEF LCL} + property OEMConvert; + {$IFDEF VERSION4} + property ParentBiDiMode; + {$ENDIF} +{$ENDIF} + property ParentColor; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property PrimaryField; + property ReadOnly; + property ShowHint; + property ShowSeconds; + property ShowUnits; + property TabOrder; + property TabStop; + property TimeMode; + property UnitsLength; + property Visible; + + {inherited events} + property OnChange; + property OnClick; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + {$IFDEF VERSION4} + property OnEndDock; + {$ENDIF} + property OnEndDrag; + property OnEnter; + property OnExit; + property OnGetTime; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnPreParseTime; + property OnSetTime; + property OnStartDrag; + end; + + +implementation + + +procedure DateTimeToHMS(D : TDateTime; var H, M, S : LongInt); +var + HS, Days : Double; +begin + HS := 1 / 86400 / 2; {half second portion of a day} + Days := Trunc(D); + D := (D-Days) * 24; + H := Trunc(D + HS); + D := (D - H) * 60; + M := Trunc(D + HS); + S := Trunc((D - M + HS) * 60); + H := Trunc(H + Days * 24); +end; + +function HMSToDateTime(H, M, S : LongInt) : TDateTime; +var + HID, MID, SID : Double; +begin + HID := 24; + MID := 24*60; + SID := 24*60*60; + Result := H / HID + M / MID + S / SID; +end; + +{*** TOvcCustomTimeEdit ***} + +constructor TOvcCustomTimeEdit.Create(AOwner : TComponent); +begin + inherited Create(AOwner); + + ControlStyle := ControlStyle - [csSetCaption]; + + FDurationDisplay := ddHMS; + FPrimaryField := tfHours; + FNowString := TimeSeparator; + FShowSeconds := False; + FTime := SysUtils.Time; + FTimeMode := tmClock; + FUnitsLength := 1; +end; + +procedure TOvcCustomTimeEdit.DoExit; +begin + try + SetTimeText(Text); + except + SetFocus; + raise; + end; + inherited DoExit; +end; + +function TOvcCustomTimeEdit.FormatTime(Value : TDateTime) : string; +var + H, M, S : LongInt; + TimeMask : string; +begin + TimeMask := OvcIntlSup.InternationalTime(FShowSeconds); + + if FTimeMode = tmClock then + Result := OvcIntlSup.TimeToTimeString(TimeMask, DateTimeToSTTime(Value), False) + else begin + DateTimeToHMS(Value, H, M, S); + if FShowUnits then begin + case FDurationDisplay of + ddHMS : Result := + IntToStr(H) + ' ' + Copy(GetOrphStr(SCHoursName), 1, FUnitsLength) + ' ' + + InttoStr(M) + ' ' + Copy(GetOrphStr(SCMinutesName), 1, FUnitsLength) + ' ' + + InttoStr(S) + ' ' + Copy(GetOrphStr(SCSecondsName), 1, FUnitsLength); + ddHM : Result := + IntToStr(H) + ' ' + Copy(GetOrphStr(SCHoursName), 1, FUnitsLength) + ' ' + + InttoStr(M) + ' ' + Copy(GetOrphStr(SCMinutesName), 1, FUnitsLength); + ddMS : Result := + InttoStr(H*60+M) + ' ' + Copy(GetOrphStr(SCMinutesName), 1, FUnitsLength) + ' ' + + InttoStr(S) + ' ' + Copy(GetOrphStr(SCSecondsName), 1, FUnitsLength); + ddHHH : Result := + IntToStr(H) + ' ' + Copy(GetOrphStr(SCHoursName), 1, FUnitsLength); + ddMMM : Result := + InttoStr(H*60+M) + ' ' + Copy(GetOrphStr(SCMinutesName), 1, FUnitsLength); + ddSSS : Result := + InttoStr((H*60+M)*60+S) + ' ' + Copy(GetOrphStr(SCSecondsName), 1, FUnitsLength); + end; + end else begin + case FDurationDisplay of + ddHMS : Result := IntToStr(H) + TimeSeparator + InttoStr(M) + TimeSeparator + InttoStr(S); + ddHM : Result := IntToStr(H) + TimeSeparator + InttoStr(M); + ddMS : Result := IntToStr(H*60+M) + TimeSeparator + InttoStr(S); + ddHHH : Result := IntToStr(H); + ddMMM : Result := IntToStr(H*60+M); + ddSSS : Result := IntToStr((H*60+M)*60+S); + end; + end; + end; +end; + +function TOvcCustomTimeEdit.GetAsHours : LongInt; +var + H, M, S : LongInt; +begin + DateTimeToHMS(FTime, H, M, S); + Result := H; +end; + +function TOvcCustomTimeEdit.GetAsMinutes : LongInt; +var + H, M, S : LongInt; +begin + DateTimeToHMS(FTime, H, M, S); + Result := H*60+M; +end; + +function TOvcCustomTimeEdit.GetAsSeconds : LongInt; +var + H, M, S : LongInt; +begin + DateTimeToHMS(FTime, H, M, S); + Result := (H*60+M)*60+S; +end; + +function TOvcCustomTimeEdit.GetTime : TDateTime; +begin + SetTimeText(Text); + Result := FTime; +end; + +procedure TOvcCustomTimeEdit.SetAsHours(Value : LongInt); +var + D, H : Integer; +begin + H := Value; + D := H div 24; + H := H - D * 24; + SetTime(D + EncodeTime(H, 0, 0, 0)); +end; + +procedure TOvcCustomTimeEdit.SetAsMinutes(Value : LongInt); +var + D, H, M : Integer; +begin + M := Value; + D := M div (24 * 60); + M := M - D * (24 * 60); + H := M div 60; + M := M - H * 60; + SetTime(D + EncodeTime(H, M, 0, 0)); +end; + +procedure TOvcCustomTimeEdit.SetAsSeconds(Value : LongInt); +var + D, H, M, S : Integer; +begin + S := Value; + D := S div (24 * 60 * 60); + S := S - D * (24 * 60 * 60); + H := S div (60 * 60); + S := S - H * (60 * 60); + M := S div 60; + S := S - M * 60; + SetTime(D + EncodeTime(H, M, S, 0)); +end; + +procedure TOvcCustomTimeEdit.SetDurationDisplay(Value : TOvcDurationDisplay); +begin + if Value <> FDurationDisplay then begin + FDurationDisplay := Value; + if not (csLoading in ComponentState) then + SetTime(FTime); {force redisplay with current options} + end; +end; + +procedure TOvcCustomTimeEdit.SetShowSeconds(Value : Boolean); +begin + if Value <> FShowSeconds then begin + FShowSeconds := Value; + if not (csLoading in ComponentState) then + SetTime(FTime); {force redisplay with current options} + end; +end; + +procedure TOvcCustomTimeEdit.SetShowUnits(Value : Boolean); +begin + if Value <> FShowUnits then begin + FShowUnits := Value; + if not (csLoading in ComponentState) then + SetTime(FTime); {force redisplay with current options} + end; +end; + +procedure TOvcCustomTimeEdit.SetTime(Value : TDateTime); +begin + FTime := Value; + Modified := True; + + if FTime < 0 then + Text := '' + else + Text := FormatTime(FTime); + + if Assigned(FOnSetTime) then + FOnSetTime(Self); +end; + +procedure TOvcCustomTimeEdit.SetTimeMode(Value : TOvcTimeMode); +begin + if Value <> FTimeMode then begin + FTimeMode := Value; + if not (csLoading in ComponentState) then + SetTime(FTime); {force redisplay with current options} + end; +end; + +procedure TOvcCustomTimeEdit.ParseFields(const Value : string; S : TStringList); +var + I : Integer; + I1 : Integer; + I2 : Integer; + T : string; +begin + {parse the string into subfields using a string list to hold the parts} + I1 := 1; + while (I1 <= Length(Value)) and not (Value[I1] in ['0'..'9', 'A'..'Z']) do + Inc(I1); + while I1 <= Length(Value) do begin + I2 := I1; + while (I2 <= Length(Value)) and (Value[I2] in ['0'..'9', 'A'..'Z']) do + Inc(I2); + + T := Copy(Value, I1, I2-I1); + {if this is a combination of numbers and letters without sperators} + {representing multiple fields, split them up} + while Length(T) > 0 do begin + I := 1; + case T[1] of + 'A'..'Z' : while T[I] in ['A'..'Z'] do Inc(I); + '0'..'9' : while T[I] in ['0'..'9'] do Inc(I); + end; + S.Add(Copy(T, 1, I-1)); + Delete(T, 1, I-1); + end; + + while (I2 <= Length(Value)) and not (Value[I2] in ['0'..'9', 'A'..'Z']) do + Inc(I2); + I1 := I2; + end; +end; + +procedure TOvcCustomTimeEdit.SetTimeText(Value : string); +var + Field : Integer; + Error : Integer; + Hours : Integer; + Minutes : Integer; + Seconds : Integer; + FieldList : TStringList; + S : string; + FieldCount : Integer; + Am, Pm, AmPm : string[1]; + FoundUnits : Boolean; + V : Integer; +begin + if Assigned(FOnPreParseTime) then + FOnPreParseTime(Self, Value); + + if Assigned(FOnGetTime) then + FOnGetTime(Self, Value); + + if (Value = '') then begin + FTime := 0; + Text := ''; + Exit; + end; + + if AnsiCompareText(Value, NowString) = 0 then begin + SetTime(SysUtils.Time); + Text := FormatTime(FTime); + end else begin + Value := AnsiUpperCase(Value); + FieldList := TStringList.Create; + try + {break entry into fields} + ParseFields(Value, FieldList); + + Hours := -1; + Minutes := -1; + Seconds := -1; + if FTimeMode = tmDuration then begin + {if a single field entered, assume primary field} + if FieldList.Count = 1 then begin + case FPrimaryField of + tfHours : Hours := StrToIntDef(FieldList[0], -1); + tfMinutes : Minutes := StrToIntDef(FieldList[0], -1); + tfSeconds : Seconds := StrToIntDef(FieldList[0], -1); + end; + end else begin + FieldCount := FieldList.Count; + FoundUnits := False; + for Field := 1 to FieldCount do begin + if FoundUnits then begin + FoundUnits := False; + Continue; {skip this field - it is a unit field} + end; + S := FieldList[Field-1]; + V := StrToIntDef(S, -1); + {if more fields, see if next field is units for this one} + if Field < FieldCount then begin + S := FieldList[Field]; {get next field value} + if not (S[1] in ['0'..'9']) then begin + if PartialCompare(S, GetOrphStr(SCHoursName)) then begin + Hours := V; + FoundUnits := True; + end else if PartialCompare(S, GetOrphStr(SCMinutesName)) then begin + Minutes := V; + FoundUnits := True; + end else if PartialCompare(S, GetOrphStr(SCSecondsName)) then begin + Seconds := V; + FoundUnits := True; + end; + end; + end; + {uses "logical" units for the time field based on prior fields} + if not FoundUnits then begin + if Hours = -1 then + Hours := V + else if Minutes = -1 then + Minutes := V + else if Seconds = -1 then + Seconds := V; + end; + end; + end; + + {if a value assigned, set time and exit} + if (Hours > -1) or (Minutes > -1) or (Seconds > -1) then begin + if Hours = -1 then + Hours := 0; + if Minutes = -1 then + Minutes := 0; + if Seconds = -1 then + Seconds := 0; + SetTime(HMSToDateTime(Hours, Minutes, Seconds)); + Exit; + end; + end; + + {handle as "normal" time -- "hh:mm:ss tt" format or variations} + Hours := 0; + Minutes := 0; + Seconds := 0; + Error := 0; + + {set default am/pm} + {in case user has deleted these window settings} + if (TimeAmString > '') and (TimePmString > '') then begin + Am := AnsiUpperCase(TimeAmString[1]); + Pm := AnsiUpperCase(TimePmString[1]); + end else begin + Am := 'A'; + Pm := 'P' + end; + if FDefaultToPM then + AmPm := Pm + else + AmPm := Am; + + {see if we're using a 24 hour time format} + if (Pos(Am, ShortTimeFormat) = 0) and + (Pos(Pm, ShortTimeFormat) = 0) then + AmPm := ''; + + FieldCount := FieldList.Count; + for Field := FieldCount-1 downto 0 do begin + S := AnsiUpperCase(FieldList[Field]); + if Pos(Am, S) > 0 then begin + AmPm := Am; + FieldList.Delete(Field); + Continue; + end; + if Pos(Pm, S) > 0 then begin + AmPm := Pm; + FieldList.Delete(Field); + Continue; + end; + end; + + FieldCount := FieldList.Count; + for Field := 1 to FieldCount do begin + S := FieldList[Field-1]; + case Field of + 1 : + begin + if (S = '') or (S[1] in ['0'..'9']) then begin + V := StrToIntDef(S, 0); + if FTimeMode = tmDuration then begin + case FPrimaryField of + tfHours : Hours := V; + tfMinutes : Minutes := V; + tfSeconds : Seconds := V; + end; + end else begin + Hours := V; + if (Hours < 12) and (AmPm = Pm) then + Inc(Hours, 12); + if not (Hours in [0..23]) then + Error := SCTimeConvertError; + end; + end; + if Error > 0 then + Break; + end; + 2 : + begin + if (S = '') or (S[1] in ['0'..'9']) then begin + V := StrToIntDef(S, 0); + if FTimeMode = tmDuration then begin + case FPrimaryField of + tfHours : Minutes := V; + tfMinutes : Seconds := V; + end; + end else begin + Minutes := V; + if not (Minutes in [0..59]) then + Error := SCTimeConvertError; + end; + end; + if Error > 0 then + Break; + end; + 3 : + begin + if (S = '') or (S[1] in ['0'..'9']) then begin + V := StrToIntDef(S, 0); + if FTimeMode = tmDuration then begin + case FPrimaryField of + tfHours : Seconds := V; + end; + end else begin + Seconds := V; + if not (Seconds in [0..59]) then + Error := SCTimeConvertError; + end; + end; + if Error > 0 then + Break; + end; + end; + end; + + {special handling for times at or just after midnight} + if (AmPm = Am) then + if (Hours = 12) or (Hours = 24) then + Hours := 0; + + if Error > 0 then + raise EOvcException.Create(GetOrphStr(Error) + ' "' + Value + '"'); + + SetTime(HMSToDateTime(Hours, Minutes, Seconds)); + + finally + FieldList.Free; + end; + + end; +end; + +procedure TOvcCustomTimeEdit.SetUnitsLength(Value : Integer); +begin + if Value <> FUnitsLength then begin + FUnitsLength := Value; + if not (csLoading in ComponentState) then + SetTime(FTime); {force redisplay with current options} + end; +end; + + +end. diff --git a/components/orpheus/ovcef.pas b/components/orpheus/ovcef.pas new file mode 100644 index 000000000..4ee28bd34 --- /dev/null +++ b/components/orpheus/ovcef.pas @@ -0,0 +1,4743 @@ +{*********************************************************} +{* OVCEF.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovcef; + {-Base entry field class} + +interface + +uses + {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, Types, LclType, MyMisc, {$ENDIF} + Classes, ClipBrd, Controls, Forms, Graphics, Menus, + SysUtils, {$IFDEF VERSION6} Variants, {$ENDIF} + OvcBase, OvcCaret, OvcColor, OvcConst, OvcCmd, OvcData, OvcExcpt, + OvcIntl, OvcMisc, OvcStr, OvcUser, OvcDate, OvcBordr; + +type + {user validation event} + TUserValidationEvent = + procedure(Sender : TObject; var ErrorCode : Word) + of object; + TValidationErrorEvent = + procedure(Sender : TObject; ErrorCode : Word; ErrorMsg : string) + of object; + + {options available to specific fields} + TOvcEntryFieldOption = (efoArrowIncDec, efoCaretToEnd, efoForceInsert, + efoForceOvertype, efoInputRequired, + efoPasswordMode, efoReadOnly, efoRightAlign, + efoRightJustify, efoSoftValidation, + efoStripLiterals, efoTrimBlanks); + + TOvcEntryFieldOptions = set of TOvcEntryFieldOption; + +const + efDefOptions = [efoCaretToEnd, efoTrimBlanks]; + +type + {combined color class} + TOvcEfColors = class(TPersistent) + protected {private} + FDisabled : TOvcColors; {colors for disabled fields} + FError : TOvcColors; {colors for invalid fields} + FHighlight : TOvcColors; {background and text highlight colors} + public + procedure Assign(Source : TPersistent); override; + constructor Create; virtual; + destructor Destroy; override; + published + property Disabled : TOvcColors read FDisabled write FDisabled; + property Error : TOvcColors read FError write FError; + property Highlight : TOvcColors read FHighlight write FHighlight; + end; + + {abstract entry field class} + TOvcBaseEntryField = class(TOvcCustomControlEx) + {.Z+} + protected {private} + {property instance variables} + FAutoSize : Boolean; {size control when font changes} + FBorders : TOvcBorders; {simple line borders} + FBorderStyle : TBorderStyle; {border around the edit field} + FCtrlColor : TColor; {control character foreground color} + FDecimalPlaces : Byte; {max decimal places, if no '.' in Picture} + FEFColors : TOvcEfColors; {entry field colors} + FEpoch : Integer; {combined epoch year and cenury} + FIntlSup : TOvcIntlSup; {international support object} + FLastError : Word; {result of last validation} + FMaxLength : Word; {maximum length of string} + FOptions : TOvcEntryFieldOptions; + FPadChar : AnsiChar; {character used to pad end of string} + FPasswordChar : AnsiChar; {character used in password mode} + FTextMargin : Integer; {indent from left (right)} + FUninitialized : Boolean; {the field isblanked out completely except when it has the focus} + FUserData : TOvcUserData; {field mask and data object} + FZeroDisplay : TZeroDisplay; {true to display an empty field} + FZeroDisplayValue : Double; {value used by ZeroDisplay logic} + + {event variables} + FOnChange : TNotifyEvent; + FOnError : TValidationErrorEvent; + FOnGetEpoch : TGetEpochEvent; + FOnUserCommand : TUserCommandEvent; + FOnUserValidation : TUserValidationEvent; + + {internal variables} + efCaret : TOvcCaretPair; {our carets} + efDataSize : Word; {size of data type being edited} + efDataType : Byte; {code indicating field type} + efEditSt : TEditString; {the edit string} + efFieldClass : Byte; {fcSimple, fcPicture, or fcNumeric} + efHOffset : Integer; {horizontal scrolling offset} + efHPos : Integer; {current position in field (column)} + efPicLen : Word; {length of picture mask} + efPicture : TPictureMask; {picture mask} + efRangeHi : TRangeType; {high range for the field} + efRangeLo : TRangeType; {low range for the field} + efRightAlignActive : Boolean; {true if right-align is in use} + efSaveData : Boolean; {save data during create window} + efSaveEdit : PAnsiChar; {saved copy of edit string} + efSelStart : Integer; {start of highlighted selection} + efSelEnd : Integer; {end of highlighted selection} + efTopMargin : Integer; {margin above text} + sefOptions : TsefOptionSet; {secondary field options} + + {property methods} + function GetAsBoolean : Boolean; + function GetAsCents : LongInt; + function GetAsExtended : Extended; + function GetAsFloat : Double; + function GetAsInteger : Longint; + function GetAsDateTime : TDateTime; + function GetAsStDate : TStDate; + function GetAsStTime : TStTime; + function GetAsString : string; + function GetAsVariant : Variant; + function GetCurrentPos : Integer; + function GetDataSize : Word; + function GetDisplayString : string; + function GetEditString : string; + function GetEpoch : Integer; + function GetEverModified : Boolean; + function GetInsCaretType : TOvcCaret; + function GetInsertMode : Boolean; + function GetModified : Boolean; + function GetOvrCaretType : TOvcCaret; + function GetRangeHiStr : string; + function GetRangeLoStr : string; + function GetSelLength : Integer; + function GetSelStart : Integer; + function GetSelText : string; + procedure SetAsBoolean(Value : Boolean); + procedure SetAsCents(Value : LongInt); + procedure SetAsDateTime(Value : TDateTime); + procedure SetAsExtended(Value : Extended); + procedure SetAsFloat(Value : Double); + procedure SetAsInteger(Value : Longint); + procedure SetAsStDate(Value : TStDate); + procedure SetAsStTime(Value : TStTime); + procedure SetAsVariant(Value : Variant); + procedure SetAutoSize(Value : Boolean); {$IFDEF VERSION6}{$IFNDEF LCL} override;{$ENDIF}{$ENDIF} + procedure SetBorderStyle(Value : TBorderStyle); + procedure SetDecimalPlaces(Value : Byte); + procedure SetEpoch(Value : Integer); + procedure SetEverModified(Value : Boolean); + procedure SetInsCaretType(const Value : TOvcCaret); + procedure SetInsertMode(Value : Boolean); + procedure SetIntlSupport(Value : TOvcIntlSup); + procedure SetMaxLength(Value : Word); + procedure SetModified(Value : Boolean); + procedure SetOptions(Value : TOvcEntryFieldOptions); + procedure SetOvrCaretType(const Value : TOvcCaret); + procedure SetPadChar(Value : AnsiChar); + procedure SetPasswordChar(Value : AnsiChar); + procedure SetRangeLoStr(const Value : string); + procedure SetRangeHiStr(const Value : string); + procedure SetSelLength(Value : Integer); + procedure SetSelStart(Value : Integer); + procedure SetSelText(const Value : string); + procedure SetTextMargin(Value : Integer); + procedure SetUninitialized(Value : Boolean); + procedure SetUserData(Value : TOvcUserData); + procedure SetZeroDisplay(Value : TZeroDisplay); + procedure SetZeroDisplayValue(Value : Double); + + {internal methods} + procedure efBorderChanged(ABorder : TObject); + procedure efCalcTopMargin; + procedure efColorChanged(AColor : TObject); + function efGetTextExtent(S : PChar; Len : Integer) : Word; + procedure efInitializeDataSize; + +{ - HWnd changed to TOvcHWnd for BCB Compatibility } + function efIsSibling(HW : TOvcHWnd{hWnd}) : Boolean; + + procedure efMoveFocus(C : TWinControl); + procedure efPaintBorders; + procedure efPerformEdit(var Msg : TMessage; Cmd : Word); + procedure efPerformPreEditNotify(C : TWinControl); + procedure efPerformPostEditNotify(C : TWinControl); + procedure efReadRangeHi(Stream : TStream); + procedure efReadRangeLo(Stream : TStream); + function efTransferPrim(DataPtr : Pointer; TransferFlag : Word) : Word; + procedure efWriteRangeHi(Stream : TStream); + procedure efWriteRangeLo(Stream : TStream); + + + + {VCL control methods} + procedure CMCtl3DChanged(var Msg : TMessage); + message CM_CTL3DCHANGED; + procedure CMDialogChar(var Msg : TCMDialogChar); + message CM_DIALOGCHAR; + procedure CMEnabledChanged(var Msg : TMessage); + message CM_ENABLEDCHANGED; + procedure CMFontChanged(var Msg : TMessage); + message CM_FONTCHANGED; + + {private message response methods} + procedure OMGetDataSize(var Msg : TMessage); + message OM_GETDATASIZE; + procedure OMReportError(var Msg : TOMReportError); + message OM_REPORTERROR; + + {windows message response methods} + procedure WMChar(var Msg : TWMChar); + message WM_CHAR; + procedure WMClear(var Msg : TWMClear); + message WM_CLEAR; + procedure WMCopy(var Msg : TWMCopy); + message WM_COPY; + procedure WMCut(var Msg : TWMCut); + message WM_CUT; + procedure WMEraseBkGnd(var Msg : TWMEraseBkGnd); + message WM_ERASEBKGND; + procedure WMGetDlgCode(var Msg : TWMGetDlgCode); + message WM_GETDLGCODE; + procedure WMKeyDown(var Msg : TWMKeyDown); + message WM_KEYDOWN; + procedure WMKillFocus(var Msg : TWMKillFocus); + message WM_KILLFOCUS; + procedure WMLButtonDblClk(var Msg : TWMLButtonDblClk); + message WM_LBUTTONDBLCLK; + procedure WMLButtonDown(var Msg : TWMLButtonDown); + message WM_LBUTTONDOWN; + procedure WMMouseActivate(var Msg : TWMMouseActivate); + message WM_MOUSEACTIVATE; + procedure WMMouseMove(var Msg : TWMMouseMove); + message WM_MOUSEMOVE; + procedure WMPaste(var Msg : TWMPaste); + message WM_PASTE; + procedure WMRButtonUp(var Msg : TWMRButtonDown); + message WM_RBUTTONUP; + procedure WMSetFocus(var Msg : TWMSetFocus); + message WM_SETFOCUS; + procedure WMSetFont(var Msg : TWMSetFont); + message WM_SETFONT; + procedure WMSetText(var Msg : TWMSetText); + message WM_SETTEXT; + procedure WMSize(var Msg : TWMSize); + message WM_SIZE; + procedure WMSysKeyDown(var Msg : TWMSysKeyDown); + message WM_SYSKEYDOWN; + + {edit control message methods} + procedure EMGetModify(var Msg : TMessage); + message EM_GETMODIFY; + procedure EMGetSel(var Msg : TMessage); + message EM_GETSEL; + procedure EMSetModify(var Msg : TMessage); + message EM_SETMODIFY; + procedure EMSetSel(var Msg : TMessage); + message EM_SETSEL; + + protected + {VCL methods} + procedure CreateParams(var Params : TCreateParams); + override; + procedure CreateWnd; + override; + procedure DefineProperties(Filer : TFiler); + override; + procedure Paint; + override; + + {dynamic event wrappers} + procedure DoOnChange; + dynamic; + {-perform notification of a change} + procedure DoOnError(ErrorCode : Word; const ErrorMsg : string); + dynamic; + {-perform notification of an error} + procedure DoOnUserCommand(Command : Word); + dynamic; + {-perform notification of a user command} + procedure DoOnUserValidation(var ErrorCode : Word); + dynamic; + {-perform call to user validation event handler} + + procedure DoRestoreClick(Sender : TObject); + dynamic; + procedure DoCutClick(Sender : TObject); + dynamic; + procedure DoCopyClick(Sender : TObject); + dynamic; + procedure DoPasteClick(Sender : TObject); + dynamic; + procedure DoDeleteClick(Sender : TObject); + dynamic; + procedure DoSelectAllClick(Sender : TObject); + dynamic; + + procedure efAdjustSize; + dynamic; + {-adjust the size of the control based on the current font} + function efCanClose(DoValidation : Boolean) : Boolean; + virtual; + {-returns true if the field contents are valid} + procedure efCaretToEnd; + virtual; + {-move the caret to the end of the field} + procedure efCaretToStart; + virtual; + {-move the caret to the beginning of the field} + procedure efChangeMask(Mask : PAnsiChar); + dynamic; + {-change the picture mask} + function efCharOK(PicChar : AnsiChar; var Ch : AnsiChar; + PrevCh : AnsiChar; Fix : Boolean) : Boolean; + {-return True if Ch is in character set corresponding to PicChar} + procedure efConditionalBeep; + {-beep if pefBeepOnError option is active} + procedure efCopyPrim; + {-Primitive clipboard copy method} + function efBinStr2Long(St : PAnsiChar; var L : LongInt) : Boolean; + {-convert a binary string to a longint} + function efCalcDataSize(St : PAnsiChar; MaxLen : Word) : Word; + {-calculate data size of a string field with literal stripping option on} + procedure efEdit(var Msg : TMessage; Cmd : Word); + virtual; abstract; + {-process the specified editing command} + function efEditBegin : Word; + virtual; + {-return offset of first editable position in field} + function efFieldIsEmpty : Boolean; + virtual; + {-return True if the field is empty} + procedure efFieldModified; + {-mark the field as modified; tell parent form it changed} + procedure efFindCtrlChars(P : PAnsiChar; var ChCnt, CtCnt : Integer); + {-find control caracters and return normal and control char counts} + procedure efFixCase(PicChar : AnsiChar; var Ch : AnsiChar; PrevCh : AnsiChar); + {-fix the case of Ch based on PicChar} + function efGetDisplayString(Dest : PAnsiChar; Size : Word) : PAnsiChar; + virtual; + {-return the display string in Dest and a pointer as the result} + function efGetMousePos(MPos : Integer) : Integer; + {-get the position of a mouse click} + procedure efGetSampleDisplayData(T : PAnsiChar); + dynamic; + {-return sample data for the current field type} + procedure efIncDecValue(Wrap : Boolean; Delta : Double); + dynamic; abstract; + {-increment field by Delta} + function efIsNumericType : Boolean; + {-return True if field is of a numeric type} + function efIsReadOnly : Boolean; + virtual; + {-return True if field is read-only} + procedure efLong2Str(P : PAnsiChar; L : LongInt); + {-convert a longint to a string} + procedure efMapControlChars(Dest, Src : PAnsiChar); + {-copy from Src to Dest, mapping control characters to alph in process} + procedure efMoveFocusToNextField; + dynamic; + {-give next field the focus} + procedure efMoveFocusToPrevField; + dynamic; + {-give previous field the focus} + function efNthMaskChar(N : Word) : AnsiChar; + {-return the N'th character in the picture mask. N is 0-based} + function efOctStr2Long(St : PAnsiChar; var L : LongInt) : Boolean; + {-convert an octal string to a longint} + +{ - Hdc changed to TOvcHdc for BCB Compatibility } + procedure efPaintPrim(DC : TOvcHDC{Hdc}; ARect : TRect; Offset : Integer); + {-primitive routine to draw the entry field control} + + procedure efPerformRepaint(Modified : Boolean); + {-flag the field as modified and redraw it} + function efPositionCaret(Adjust : Boolean) : Boolean; + {-position the editing caret} + function efRangeToStRange(const Value : TRangeType) : string; + {-returns the range as a string} + function efStRangeToRange(const Value : string; var R : TRangeType) : Boolean; + {-converts a string range to a RangeType} + procedure efRemoveBadOptions; + virtual; + {-remove inappropriate options for this field and data type} + procedure efResetCaret; + virtual; + {-move the caret to the beginning or end of the field, as appropriate} + procedure efSaveEditString; + {-save a copy of the edit string} + procedure efSetDefaultRange(FT : Byte); + {-set the default range for the given field type} + procedure efSetInitialValue; + {-set the initial value of the field} + function efStr2Long(P : PAnsiChar; var L : LongInt) : Boolean; + {-convert a string to a longint} + function efTransfer(DataPtr : Pointer; TransferFlag : Word) : Word; + virtual; + {-transfer data to/from the entry fields} + function efValidateField : Word; + virtual; abstract; + {-validate contents of field; result is error code or 0} + + {virtual property methods} + procedure efSetCaretPos(Value : Integer); + virtual; + {-set position of the caret within the field} + procedure SetAsString(const Value : string); + virtual; + {-sets the field value to a String Value} + procedure SetName(const Value : TComponentName); + override; + {-catch when component name is changed} + + public + constructor Create(AOwner : TComponent); + override; + destructor Destroy; + override; + procedure SetBounds(ALeft, ATop, AWidth, AHeight : Integer); + override; + {.Z-} + + procedure ClearContents; + {-clear the contents of the entry field} + procedure ClearSelection; + {-erase the highlighted text} + procedure CopyToClipboard; + {-copies the highlighted text to the clipboard} + procedure CutToClipboard; + dynamic; + {-performs a CopyToClipboard then deletes the highlighted text from the field} + procedure DecreaseValue(Wrap : Boolean; Delta : Double); + {-decrease the value of the field by Delta, wrapping if enabled} + procedure Deselect; + {-unhighlight any highlighted text} + function FieldIsEmpty : Boolean; + {-return True if the field is completely empty} + function GetStrippedEditString : string; + dynamic; + {-return edit string stripped of literals and semi-literals} + function GetValue(var Data) : Word; + {-returns the current field value in Data. Result is 0 or error code} + procedure IncreaseValue(Wrap : Boolean; Delta : Double); + {-increase the value of the field by Delta, wrapping if enabled} + function IsValid : Boolean; + {-returns true if the field is not marked as invalid} + procedure MergeWithPicture(const S : string); + dynamic; + {-combines S with the picture mask and updates the edit string} + procedure MoveCaret(Delta : Integer); + {-moves the caret to the right or left Value positions} + procedure MoveCaretToEnd; + {-move the caret to the end of the field} + procedure MoveCaretToStart; + {-move the caret to the beginning of the field} + procedure PasteFromClipboard; + dynamic; + {-places the text content of the clipboard into the field} + procedure ProcessCommand(Cmd, CharCode : Word); + {-process the specified command} + procedure ResetCaret; + {-move the caret to the beginning or end of the field, as appropriate} + procedure Restore; + dynamic; + {-restore the previous contents of the field} + procedure SelectAll; + {-selects the current edit text} + procedure SetInitialValue; + {-resets the field value to its initial value} + procedure SetRangeHi(const Value : TRangeType); + {-set the high range for this field} + procedure SetRangeLo(const Value : TRangeType); + {-set the low range for this field} + procedure SetSelection(Start, Stop : Word); + {-mark offsets Start..Stop as selected} + procedure SetValue(const Data); + {-changes the field's value to the value in Data} + function ValidateContents(ReportError : Boolean) : Word; + dynamic; + {-performs field validation, returns error code, and conditionally reports error} + function ValidateSelf : Boolean; + {-performs field validation, returns true if no errors, and reports error} + + {public properties} + property ParentColor default False; + property AsBoolean : Boolean + read GetAsBoolean write SetAsBoolean; + property AsCents : LongInt + read GetAsCents write SetAsCents; + property AsDateTime : TDateTime + read GetAsDateTime write SetAsDateTime; + property AsExtended : Extended + read GetAsExtended write SetAsExtended; + property AsFloat : Double + read GetAsFloat write SetAsFloat; + property AsInteger : Longint + read GetAsInteger write SetAsInteger; + property AsOvcDate : TOvcDate + read GetAsStDate write SetAsStDate; + property AsOvcTime : TOvcTime + read GetAsStTime write SetAsStTime; + property AsString : string + read GetAsString write SetAsString; + property AsVariant : Variant + read GetAsVariant write SetAsVariant; + property AsStDate : TStDate + read GetAsStDate write SetAsStDate; + property AsStTime : TStTime + read GetAsStTime write SetAsStTime; + property Font; + property Canvas; + property Color; + property CurrentPos : Integer + read GetCurrentPos write efSetCaretPos; + property DataSize : Word + read GetDataSize; + property DisplayString : string + read GetDisplayString; + property EditString : string + read GetEditString; + property Epoch : Integer + read GetEpoch write SetEpoch; + property EverModified : Boolean + read GetEverModified write SetEverModified; + + {.Z+} + property InsertMode : Boolean + read GetInsertMode write SetInsertMode; + {.Z-} + + property IntlSupport : TOvcIntlSup + read FIntlSup write SetIntlSupport; + property LastError : Word + read FLastError; + property Modified : Boolean + read GetModified write SetModified; + property SelectionLength : Integer + read GetSelLength write SetSelLength; + property SelectionStart : Integer + read GetSelStart write SetSelStart; + property SelectedText : string + read GetSelText write SetSelText; + property Text : string + read GetAsString write SetAsString; + property UserData : TOvcUserData + read FUserData write SetUserData; + + {publishable properties} + {revised} + property AttachedLabel : TOvcAttachedLabel + read GetAttachedLabel; + property AutoSize : Boolean + read FAutoSize write SetAutoSize default True; + property Borders : TOvcBorders + read FBorders write FBorders; + property BorderStyle : TBorderStyle + read FBorderStyle write SetBorderStyle default bsSingle; + property CaretIns : TOvcCaret + read GetInsCaretType write SetInsCaretType; + property CaretOvr : TOvcCaret + read GetOvrCaretType write SetOvrCaretType; + property ControlCharColor : TColor + read FCtrlColor write FCtrlColor; + property DecimalPlaces : Byte + read FDecimalPlaces write SetDecimalPlaces; + property EFColors : TOvcEfColors + read FEFColors write FEFColors; + property MaxLength : Word + read FMaxLength write SetMaxLength default 15; + property Options : TOvcEntryFieldOptions + read FOptions write SetOptions default efDefOptions; + property PadChar : AnsiChar + read FPadChar write SetPadChar default DefPadChar; + property PasswordChar : AnsiChar + read FPasswordChar write SetPasswordChar default '*'; + property RangeHi : string + read GetRangeHiStr write SetRangeHiStr stored False; + property RangeLo : string + read GetRangeLoStr write SetRangeLoStr stored False; + property TextMargin : Integer + read FTextMargin write SetTextMargin default 2; + property Uninitialized : Boolean + read FUninitialized write SetUninitialized default False; + property ZeroDisplay : TZeroDisplay + read FZeroDisplay write SetZeroDisplay default zdShow; + property ZeroDisplayValue : Double + read FZeroDisplayValue write SetZeroDisplayValue; + + {events} + property OnChange : TNotifyEvent + read FOnChange write FOnChange; + property OnError : TValidationErrorEvent + read FOnError write FOnError; + property OnGetEpoch : TGetEpochEvent + read FOnGetEpoch write FOnGetEpoch; + property OnUserCommand : TUserCommandEvent + read FOnUserCommand write FOnUserCommand; + property OnUserValidation : TUserValidationEvent + read FOnUserValidation write FOnUserValidation; + end; + + +implementation + +{*** TOvcEfColors ***} + +procedure TOvcEfColors.Assign(Source : TPersistent); +var + C : TOvcEfColors absolute Source; +begin + if (Source <> nil) and (Source is TOvcEfColors) then begin + FDisabled.Assign(C.Disabled); + FError.Assign(C.Error); + FHighlight.Assign(C.Highlight); + end else + inherited Assign(Source); +end; + +constructor TOvcEfColors.Create; +begin + inherited Create; + + {create color objects and assign defaults} + FDisabled := TOvcColors.Create(clGrayText, clWindow); + FError := TOvcColors.Create(clBlack, clRed); + FHighlight := TOvcColors.Create(clHighlightText, clHighlight); +end; + +destructor TOvcEfColors.Destroy; +begin + {dispose of the color objects} + FDisabled.Free; + FError.Free; + FHighlight.Free; + + inherited Destroy; +end; + + +{*** TOvcBaseEntryField ***} + +procedure TOvcBaseEntryField.ClearContents; + {-erases the contents of the edit field} +var + RO : Boolean; +begin + if HandleAllocated then begin + RO := efoReadOnly in Options; {store current read only state} + Exclude(FOptions, efoReadOnly); + + {set the updating flag so OnChange doesn't get fired} + Include(sefOptions, sefUpdating); + SetWindowText(Handle, ''); + Exclude(sefOptions, sefUpdating); + {restore previous state} + if RO then + Include(FOptions, efoReadOnly); + end; +end; + +procedure TOvcBaseEntryField.ClearSelection; +begin + if HandleAllocated then + Perform(WM_CLEAR, 0, 0); +end; + +procedure TOvcBaseEntryField.CMCtl3DChanged(var Msg : TMessage); +begin + if not HandleAllocated then + Exit; + + if NewStyleControls and (FBorderStyle = bsSingle) then begin +{$IFNDEF LCL} + RecreateWnd; +{$ELSE} + MyMisc.RecreateWnd(Self); +{$ENDIF} + if not (csLoading in ComponentState) then + efAdjustSize; + end; + + efCalcTopMargin; + + inherited; +end; + +procedure TOvcBaseEntryField.CMDialogChar(var Msg : TCMDialogChar); +begin + {see if this is an Alt-Backspace key sequence (Alt flag is bit 29} + if (Msg.CharCode = VK_BACK) and (HiWord(Msg.KeyData) and $2000 <> 0) then + {don't pass it on as a dialog character since we use it as} + {the restore command by default} + Msg.Result := 1; + + inherited; +end; + +procedure TOvcBaseEntryField.CMEnabledChanged(var Msg : TMessage); +begin + inherited; + + Repaint; +end; + +procedure TOvcBaseEntryField.CMFontChanged(var Msg : TMessage); +begin + inherited; + + if (csLoading in ComponentState) then + Exit; + + if not HandleAllocated then + Exit; + + {efCalcTopMargin;} + efAdjustSize; {adjust height based on font} + efCalcTopMargin; + + if GetFocus = Handle then + efPositionCaret(False); {adjust caret for new font} +end; + +procedure TOvcBaseEntryField.CopyToClipboard; + {-copies the selected text to the clipboard} +begin + if HandleAllocated then + Perform(WM_COPY, 0, 0); +end; + +constructor TOvcBaseEntryField.Create(AOwner : TComponent); +const + CStyle = [csClickEvents, csCaptureMouse, csOpaque]; +begin + inherited Create(AOwner); + + if NewStyleControls then + ControlStyle := ControlStyle + CStyle + else + ControlStyle := ControlStyle + CStyle + [csFramed]; + +// TurboPower bug: forgot to enable XP theme support. + ControlStyle := ControlStyle + [csNeedsBorderPaint]; //Added + + {create borders class and assign notifications} + FBorders := TOvcBorders.Create; + + FBorders.LeftBorder.OnChange := efBorderChanged; + FBorders.RightBorder.OnChange := efBorderChanged; + FBorders.TopBorder.OnChange := efBorderChanged; + FBorders.BottomBorder.OnChange := efBorderChanged; + + + Cursor := crIBeam; + Height := 25; + ParentColor := False; + Width := 130; + TabStop := True; + + {defaults} + FAutoSize := True; + FBorderStyle := bsSingle; + FCtrlColor := clRed; + FDecimalPlaces := 0; + FMaxLength := 15; + FOptions := efDefOptions; + FPadChar := DefPadChar; + FPasswordChar := '*'; + FTextMargin := 2; + FUninitialized := False; + FZeroDisplay := zdShow; + FZeroDisplayValue := 0; + + efRangeLo := BlankRange; + efRangeHi := BlankRange; + + {default picture and field settings} + efPicture[0] := 'X'; + efPicture[1] := #0; + efPicLen := 1; + efFieldClass := fcSimple; + efDataType := fidSimpleString; + + {assign default user data object} + FUserData := OvcUserData; + + {assign default international support object} + FIntlSup := OvcIntlSup; + + {create the caret class} + efCaret := TOvcCaretPair.Create(Self); + + {init edit and save edit strings} + FillChar(efEditSt, MaxEditLen, #0); + efSaveEdit := nil; + + {create colors class} + FEFColors := TOvcEfColors.Create; + + {assign color change notification methods} + FEFColors.FDisabled.OnColorChange := efColorChanged; + FEFColors.FError.OnColorChange := efColorChanged; + FEFColors.FHighlight.OnColorChange := efColorChanged; + + efCalcTopMargin; +end; + + +procedure TOvcBaseEntryField.CreateParams(var Params : TCreateParams); +begin + inherited CreateParams(Params); + + Params.Style := LongInt(Params.Style) or BorderStyles[FBorderStyle]; + + if NewStyleControls and Ctl3D and (FBorderStyle = bsSingle) then begin + Params.Style := Params.Style and not WS_BORDER; + Params.ExStyle := Params.ExStyle or WS_EX_CLIENTEDGE; + end; + + {set picture length and check MaxLength} + efPicLen := StrLen(efPicture); + if FMaxLength = 0 then + FMaxLength := efPicLen; + + {reset secondary options} + sefOptions := sefDefOptions; + +{$IFDEF LCL} + inherited SetBorderStyle(FBorderStyle); +{$ENDIF} +end; + +procedure TOvcBaseEntryField.CreateWnd; +begin + inherited CreateWnd; + + efHOffset := 0; + efHPos := 0; + efSelStart := 0; + efSelEnd := 0; + + {set efDataSize for this field type} + efInitializeDataSize; + + {if input is required then these fields must also be uninitialized} + if efoInputRequired in Options then + case efDataType mod fcpDivisor of + fsubChar, fsubBoolean, fsubYesNo, fsubLongInt, + fsubWord, fsubInteger, fsubByte, fsubShortInt, + fsubReal, fsubExtended, fsubDouble, fsubSingle, + fsubComp : Uninitialized := True; + end; + + {is it a hex, binary, octal, and/or numeric field?} + if StrScan(efPicture, pmHexadecimal) <> nil then + Include(sefOptions, sefHexadecimal) + else + Exclude(sefOptions, sefHexadecimal); + + if StrScan(efPicture, pmBinary) <> nil then + Include(sefOptions, sefBinary) + else + Exclude(sefOptions, sefBinary); + + if StrScan(efPicture, pmOctal) <> nil then + Include(sefOptions, sefOctal) + else + Exclude(sefOptions, sefOctal); + + if efFieldClass = fcNumeric then + Include(sefOptions, sefNumeric) + else + Exclude(sefOptions, sefNumeric); + + {assume no literals in mask} + Include(sefOptions, sefNoLiterals); + + {reject bad options} + efRemoveBadOptions; + + {set canvas font to selected font} + Canvas.Font := Font; + + efAdjustSize; {adjust height based on font} + efCalcTopMargin; + + efRightAlignActive := efoRightAlign in Options; +end; + +procedure TOvcBaseEntryField.CutToClipboard; + {-erases the selected text and places it in the clipboard} +begin + if HandleAllocated then + Perform(WM_CUT, 0, 0); +end; + +procedure TOvcBaseEntryField.DefineProperties(Filer : TFiler); +var + Save : Boolean; +begin + inherited DefineProperties(Filer); + + Save := not (efDataType mod fcpDivisor in [fsubString, fsubBoolean, fsubYesNo]); + + Filer.DefineBinaryProperty('RangeHigh', efReadRangeHi, efWriteRangeHi, Save); + Filer.DefineBinaryProperty('RangeLow', efReadRangeLo, efWriteRangeLo, Save); +end; + +procedure TOvcBaseEntryField.DecreaseValue(Wrap : Boolean; Delta : Double); + {-decrease the value of the field by Delta, wrapping if enabled} +begin + SendMessage(Handle, WM_SETREDRAW, 0, 0); + efIncDecValue(Wrap, -Delta); + SetSelection(0, 0); + SendMessage(Handle, WM_SETREDRAW, 1, 0); + Refresh; +end; + +procedure TOvcBaseEntryField.Deselect; + {-unhighlight any highlighted text} +begin + SetSelection(0, 0); +end; + +destructor TOvcBaseEntryField.Destroy; +var + PF : TCustomForm; +begin + if Focused then begin + PF := GetParentForm(Self); + PF.DefocusControl(Self, True); + end; + + {dispose of the caret object} + efCaret.Free; + + {dispose of the color object} + FEFColors.Free; + + {dispose the borders object} + FBorders.Free; + + {dispose of the saved edit string} + if efSaveEdit <> nil then + StrDispose(efSaveEdit); + + inherited Destroy; +end; + +procedure TOvcBaseEntryField.DoOnChange; + {-perform notification of a change} +begin + if Assigned(FOnChange) and not (sefUpdating in sefOptions) then + FOnChange(Self); +end; + +procedure TOvcBaseEntryField.DoOnError(ErrorCode : Word; const ErrorMsg : string); +begin + if Assigned(FOnError) then + FOnError(Self, ErrorCode, ErrorMsg) + else + Controller.DoOnError(Self, ErrorCode, ErrorMsg); +end; + +procedure TOvcBaseEntryField.DoOnUserCommand(Command : Word); + {-perform notification of a user command} +begin + if Assigned(FOnUserCommand) then + FOnUserCommand(Self, Command); +end; + +procedure TOvcBaseEntryField.DoOnUserValidation(var ErrorCode : Word); + {-perform call to user validation event handler} +begin + if Assigned(FOnUserValidation) then + if not (sefNoUserValidate in sefOptions) then + FOnUserValidation(Self, ErrorCode); +end; + +procedure TOvcBaseEntryField.DoRestoreClick(Sender : TObject); +begin + Restore; + efPositionCaret(True); +end; + +procedure TOvcBaseEntryField.DoCutClick(Sender : TObject); +begin + CutToClipboard +end; + +procedure TOvcBaseEntryField.DoCopyClick(Sender : TObject); +begin + CopyToClipboard; +end; + +procedure TOvcBaseEntryField.DoPasteClick(Sender : TObject); +begin + PasteFromClipboard; +end; + +procedure TOvcBaseEntryField.DoDeleteClick(Sender : TObject); +begin + ClearSelection; +end; + +procedure TOvcBaseEntryField.DoSelectAllClick(Sender : TObject); +begin + SelectAll; +end; + +procedure TOvcBaseEntryField.efAdjustSize; + {-adjust the height of the control based on the current font} +var + DC : hDC; + SaveFont : hFont; + I : Integer; + SysMetrics : TTextMetric; + Metrics : TTextMetric; +begin + if not FAutoSize then + Exit; + + DC := GetDC(0); + try + GetTextMetrics(DC, SysMetrics); + SaveFont := SelectObject(DC, Font.Handle); + GetTextMetrics(DC, Metrics); + SelectObject(DC, SaveFont); + finally + ReleaseDC(0, DC); + end; + + if NewStyleControls then begin + if Ctl3D then + I := 8 + else + I := 6; + I := GetSystemMetrics(SM_CYBORDER) * I; + end else begin + I := SysMetrics.tmHeight; + if I > Metrics.tmHeight then + I := Metrics.tmHeight; + I := I div 4 + GetSystemMetrics(SM_CYBORDER) * 4; + end; + + Height := Metrics.tmHeight + I; + + {SetBounds may have turn this off, turn it back on} + if not FAutoSize then + FAutoSize := True; +end; + +function TOvcBaseEntryField.efBinStr2Long(St : PAnsiChar; var L : LongInt) : Boolean; + {-convert a binary string to a longint} +var + BitNum : Word; + Len : Word; + LT : LongInt; +begin + Result := False; + Len := StrLen(St); + BitNum := 0; + LT := 0; + while Len > 0 do begin + Dec(Len); + case St[Len] of + '0' : {OK}; + '1' : if BitNum > 31 then + Exit + else + Inc(LT, LongInt(1) shl BitNum); + else Exit; + end; + Inc(BitNum); + end; + L := LT; + Result := True; +end; + +function TOvcBaseEntryField.efCalcDataSize(St : PAnsiChar; MaxLen : Word) : Word; + {-calculate data size of a string field with literal stripping option on} +var + I, L : Word; +begin + I := 0; + L := StrLen(St); + while St^ <> #0 do begin + if (St^ in PictureChars) then + Inc(I) + else case St^ of + pmFloatDollar, pmComma : Inc(I); + end; + Inc(St); + end; + Result := I+(MaxLen-L)+1; +end; + +function TOvcBaseEntryField.efCanClose(DoValidation : Boolean) : Boolean; +var + SoftV : Boolean; +begin + Result := True; + + {don't do any of this if we're hidden or not enabled} + if (not Visible) or (not Enabled) then + Exit; + + HandleNeeded; + + {clear error flag} + FLastError := 0; + + {check for empty/uninitialized required field} + if (efoInputRequired in Options) and not efIsReadOnly then + if efFieldIsEmpty or (Uninitialized and not (sefModified in sefOptions)) then + FLastError := oeRequiredField; + + {ask the validation routine if there's an error} + if FLastError = 0 then begin + Include(sefOptions, sefValidating); + FLastError := efValidateField; + Exclude(sefOptions, sefValidating); + end; + + if efHPos > LongInt(StrLen(efEditSt)) then + efHPos := LongInt(StrLen(efEditSt)); + + if FLastError = 0 then + Exclude(sefOptions, sefInvalid) + else begin + if DoValidation and (efoSoftValidation in Options) then begin + Include(sefOptions, sefInvalid); + Result := True; {say we can close, error is in FLastError} + Exit; + end else begin + if (efoSoftValidation in Options) then + Include(sefOptions, sefInvalid); + + {set flag to indicate that an error is pending} + Include(sefOptions, sefErrorPending); + + {keep the caret where it is if we have the focus} + if sefHaveFocus in sefOptions then + Include(sefOptions, sefRetainPos); + + {force soft validation on} + SoftV := efoSoftValidation in Options; + Include(FOptions, efoSoftValidation); + try + {ask the parent form to give us back the focus} + efMoveFocus(Self); + + {report the error} + if not Controller.ErrorPending then + PostMessage(Handle, om_ReportError, FLastError, 0); + + {set controller's error pending flag} + Controller.ErrorPending := True; + finally + {restore old options} + if SoftV then + Include(FOptions, efoSoftValidation) + else + Exclude(FOptions, efoSoftValidation); + end; + end; + end; + + Result := FLastError = 0; +end; + +procedure TOvcBaseEntryField.efCaretToEnd; + {-move the caret to the end of the field} +begin + efHPos := StrLen(efEditSt); +end; + +procedure TOvcBaseEntryField.efCaretToStart; + {-move the caret to the beginning of the field} +begin + efHPos := 0; + efHOffset := 0; +end; + +procedure TOvcBaseEntryField.efChangeMask(Mask : PAnsiChar); + {-change the picture mask} +var + Buf : array[0..MaxEditLen] of Byte; +begin + if (Mask <> nil) and (Mask^ <> #0) then begin + if csLoading in ComponentState then begin + {change the mask} + StrLCopy(efPicture, Mask, MaxPicture); + efPicLen := StrLen(efPicture); + end else begin + {save the current field value in tmp buffer} + efTransfer(@Buf, otf_GetData); + + {change the mask} + StrLCopy(efPicture, Mask, MaxPicture); + efPicLen := StrLen(efPicture); + + {reset the field to its former value} + efTransfer(@Buf, otf_SetData); + end; + end; +end; + +function TOvcBaseEntryField.efCharOK(PicChar : AnsiChar; var Ch : AnsiChar; + PrevCh : AnsiChar; Fix : Boolean) : Boolean; + {-return True if Ch is in character set corresponding to PicChar} +begin + if Ch = #0 then begin + Result := False; + Exit; + end; + + if Fix then + efFixCase(PicChar, Ch, PrevCh); + + {assume it's OK} + Result := True; + + case PicChar of + pmAnyChar, pmForceUpper, pmForceLower, pmForceMixed : + ; + pmMonthName, pmMonthNameU, pmAlpha, pmUpperAlpha, pmLowerAlpha : + Result := Ch in AlphaCharSet; + pmDecimal : + Result := Ch in RealCharSet; + pmWhole : + Result := (Ch = '-') or (Ch in IntegerCharSet); + pmMonth, pmMonthU, pmDay, pmDayU, pmYear, + pmHour, pmHourU, pmSecond, pmSecondU, + pmPositive : + Result := Ch in IntegerCharSet; + pmHexadecimal : + case Ch of + 'A'..'F' : ; + else + Result := Ch in IntegerCharSet; + end; + pmOctal : + case Ch of + '0'..'7', ' ' : ; + else + Result := False; + end; + pmBinary : + case Ch of + '0', '1', ' ' : ; + else + Result := False; + end; + pmAmPm : {}; + pmTrueFalse : + Result := (Ch = FIntlSup.TrueChar) or (Ch = FIntlSup.FalseChar); + pmYesNo : + Result := (Ch = FIntlSup.YesChar) or (Ch = FIntlSup.NoChar); + pmScientific : + case Ch of + '+', 'E' : ; + else + Result := Ch in RealCharSet; + end; + pmUser1..pmUser8 : + Result := Ch in UserData.UserCharSet[PicChar]; + end; +end; + +procedure TOvcBaseEntryField.efConditionalBeep; +begin + if (efoBeepOnError in Controller.EntryOptions) then + MessageBeep(0); +end; + +procedure TOvcBaseEntryField.efCopyPrim; +var + Size : Word; + H : THandle; + GP : PAnsiChar; + I : Word; + T : TEditString; + +begin + Size := efSelEnd-efSelStart; + if Size > 0 then begin + {allocate global memory block} + H := GlobalAlloc(GHND, Size+1); + if H = 0 then + Exit; + + {copy selected text to global memory block} + GP := GlobalLock(H); + efGetDisplayString(T, MaxEditLen); + StrStCopy(GP, T, efSelStart, Size); + + {remove control characters} + for I := efSelStart to efSelEnd-1 do + case efEditSt[I] of + #1..#31 : GP[I-efSelStart] := efEditSt[I]; + end; + + GlobalUnlock(H); + + {give the handle to the clipboard} +{$IFNDEF LCL} + Clipboard.SetAsHandle(CF_TEXT, H); +{$ENDIF} + end; +end; + +function TOvcBaseEntryField.efEditBegin : Word; + {-return offset of first editable position in field} +begin + Result := 0; +end; + +function TOvcBaseEntryField.efFieldIsEmpty : Boolean; + {-return True if the field is empty} +var + P : PAnsiChar; +begin + P := efEditSt; + while P^ = ' ' do + Inc(P); + Result := (P^ = #0); +end; + +procedure TOvcBaseEntryField.efFieldModified; + {-mark the field as modified; call notify event} +begin + Include(sefOptions, sefModified); + Include(sefOptions, sefEverModified); + DoOnChange; +end; + +procedure TOvcBaseEntryField.efFindCtrlChars(P : PAnsiChar; var ChCnt, CtCnt : Integer); + {-find control caracters and return normal and control char counts} +const + Space = ' '; +var + I : Integer; +begin + ChCnt := 0; + CtCnt := 0; + I := 0; + {count "normal" characters} + while (I < LongInt(StrLen(P))) and (P[I] >= Space) do begin + Inc(ChCnt); + Inc(I); + end; + {count "control" characters} + while (I < LongInt(StrLen(P))) and (P[I] < Space) do begin + Inc(CtCnt); + Inc(I); + end; +end; + +procedure TOvcBaseEntryField.efFixCase(PicChar : AnsiChar; var Ch : AnsiChar; PrevCh : AnsiChar); + {-fix the case of Ch based on PicChar} +begin + case PicChar of + pmMonthNameU, pmForceUpper, pmUpperAlpha, pmTrueFalse, + pmYesNo, pmScientific, pmHexadecimal : + Ch := UpCaseChar(Ch); + pmForceLower, pmLowerAlpha : + Ch := LoCaseChar(Ch); + pmForceMixed : + case PrevCh of + ' ', '-' : + Ch := UpCaseChar(Ch); + end; + pmAmPm : ; + pmUser1..pmUser8 : + case UserData.ForceCase[PicChar] of + mcUpperCase : + Ch := UpCaseChar(Ch); + mcLowerCase : + Ch := LoCaseChar(Ch); + mcMixedCase : + case PrevCh of + ' ', '-' : + Ch := UpCaseChar(Ch); + end; + end; + end; +end; + +function TOvcBaseEntryField.efGetDisplayString(Dest : PAnsiChar; Size : Word) : PAnsiChar; + {-return the display string in Dest and a pointer as the result} +var + Len : Word; + Value : Double; + Code : Integer; + S : string; +begin + FillChar(Dest^, Size, #0); + efMapControlChars(Dest, efEditSt); + + {see if zero values should be displayed} + if efIsNumericType and not (sefHaveFocus in sefOptions) then begin + if (ZeroDisplay = zdHide) or + ((ZeroDisplay = zdHideUntilModified) and not EverModified) then begin + S := Trim(GetStrippedEditString); + Val(S, Value, Code); + if (Value = ZeroDisplayValue) and (Code = 0) then begin + Len := StrLen(Dest); + if Len > 0 then + FillChar(Dest^, Len, ' '); + end; + end; + end; + + Result := Dest; +end; + +function TOvcBaseEntryField.efGetMousePos(MPos : Integer) : Integer; + {-get the position of a mouse click} +var + I : Integer; + Len : Integer; + Ex : Integer; + Pos : Integer; + S : PAnsiChar; + Metrics : TTextMetric; + TmpSt : TEditString; + Done : Boolean; + SLen : Integer; + X : Integer; + LMargin : Integer; +begin + LMargin := TextMargin; + if (MPos < 0) and (efHOffset > 0) then begin + GetTextMetrics(Canvas.Handle, Metrics); + I := (Abs(MPos)+Metrics.tmAveCharWidth) div Metrics.tmAveCharWidth; + Dec(efHOffset, I); + if efHOffset < 0 then + efHOffset := 0; + end; + + {get a copy of the display string} + efGetDisplayString(TmpSt, MaxEditLen); + Len := StrLen(TmpSt); + + if efHOffset > Len then + I := Len + else + I := efHOffset; + S := @TmpSt[I]; + + if efRightAlignActive then begin + if (Assigned(FBorders)) then begin + if (FBorders.RightBorder.Enabled) then + LMargin := LMargin + FBorders.RightBorder.PenWidth; + end; + MPos := ClientWidth-LMargin-1-MPos; + + Pos := Len + 1; + I := 0; + end else begin + if (Assigned(FBorders)) then begin + if (FBorders.LeftBorder.Enabled) then + LMargin := LMargin + FBorders.LeftBorder.PenWidth; + end; + MPos := MPos - LMargin+1; + Pos := 0; + end; + + repeat + if efRightAlignActive then begin + Dec(Pos); + S := @TmpSt[Pos-1]; + SLen := Len - Pos + 1; + end else begin + Inc(Pos); + SLen := Pos; + end; + Ex := efGetTextExtent(S, SLen); + X := (efGetTextExtent(@S[SLen-1], 1) div 2); + if efRightAlignActive then + Done := (Ex+X > MPos) or (I+Pos < 1) + else + Done := (Ex-X > MPos) or (I+Pos > Len); + until Done; + + Result := I+(Pos-1); + if Result < 0 then + Result := 0; + + if efRightAlignActive then begin + if MPos < 1 then + Result := I+Pos; + end; +end; + +procedure TOvcBaseEntryField.efGetSampleDisplayData(T : PAnsiChar); + {-return sample data for the current field type} +var + Buf : TEditString; + I : Integer; +begin + {return the picture mask for the sample display data} + StrLCopy(Buf, efPicture, MaxLength); + if efFieldClass = fcSimple then begin + for I := 1 to MaxLength-1 do + Buf[I] := Buf[I-1]; + Buf[MaxLength] := #0; + end; + StrLCopy(T, Buf, MaxLength); +end; + +function TOvcBaseEntryField.efGetTextExtent(S : PChar; Len : Integer) : Word; +var + Size : TSize; +begin + GetTextExtentPoint32(Canvas.Handle, S, Len, Size); + Result := Size.cX; +end; + + + +procedure TOvcBaseEntryField.efBorderChanged(ABorder : TObject); +begin + if (FBorders.BottomBorder.Enabled) or + (FBorders.LeftBorder.Enabled) or + (FBorders.RightBorder.Enabled) or + (FBorders.TopBorder.Enabled) then begin + BorderStyle := bsNone; + Ctl3D := False; + end else begin + BorderStyle := bsSingle; + Ctl3D := True; + end; +{$IFNDEF LCL} + RecreateWnd; +{$ELSE} + MyMisc.RecreateWnd(Self); +{$ENDIF} +end; + + + +procedure TOvcBaseEntryField.efCalcTopMargin; +begin + if HandleAllocated then + efTopMargin := GetTopTextMargin(Font, BorderStyle, Height, Ctl3D) + else + efTopMargin := 0; + + if (Assigned(FBorders)) then begin + if (FBorders.TopBorder.Enabled) then + efTopMargin := efTopMargin + FBorders.TopBorder.PenWidth; + end; +end; + +procedure TOvcBaseEntryField.efColorChanged(AColor : TObject); +begin + Repaint; +end; + +procedure TOvcBaseEntryField.efInitializeDataSize; +begin + case efDataType mod fcpDivisor of + fsubString : + begin + efDataSize := MaxLength+1; + {handle special data size cases} + if efDataType = fidPictureString then + if (efoStripLiterals in Options) then + efDataSize := efCalcDataSize(efPicture, MaxLength); + end; + + fsubChar : efDataSize := SizeOf(AnsiChar); + fsubBoolean : efDataSize := SizeOf(Boolean); + fsubYesNo : efDataSize := SizeOf(Boolean); + fsubLongInt : efDataSize := SizeOf(LongInt); + fsubWord : efDataSize := SizeOf(Word); + fsubInteger : efDataSize := SizeOf(SmallInt); + fsubByte : efDataSize := SizeOf(Byte); + fsubShortInt : efDataSize := SizeOf(ShortInt); + fsubReal : efDataSize := SizeOf(Real); + fsubExtended : efDataSize := SizeOf(Extended); + fsubDouble : efDataSize := SizeOf(Double); + fsubSingle : efDataSize := SizeOf(Single); + fsubComp : efDataSize := SizeOf(Comp); + fsubDate : efDataSize := SizeOf(TStDate); + fsubTime : efDataSize := SizeOf(TStTime); + else + efDataSize := 0; + end; +end; + +function TOvcBaseEntryField.efIsNumericType : Boolean; + {-return True if field is of a numeric type} +begin + case efDataType mod fcpDivisor of + fsubLongInt, fsubWord, fsubInteger, fsubByte, + fsubShortInt, fsubReal, fsubExtended, fsubDouble, + fsubSingle, fsubComp : + Result := True; + else + Result := False; + end; +end; + +function TOvcBaseEntryField.efIsReadOnly : Boolean; + {-return True if field is read-only} +begin + Result := efoReadOnly in Options; +end; + +{ - HWnd changed to TOvcHWnd for BCB Compatibility } +function TOvcBaseEntryField.efIsSibling(HW : TOvcHWnd{hWnd}) : Boolean; + {-is the window HW one of our siblings} +var + C : TWinControl; + H : hWnd; +begin + Result := False; + if HW = 0 then + Exit; + + C := FindControl(HW); + + {see if this window is a child of one of our siblings} + if not Assigned(C) then begin + H := GetParent(HW); + if H > 0 then + C := FindControl(H); + end; + + if Assigned(C) then + {$IFDEF VERSION5} + if (GetImmediateParentForm(C) = GetImmediateParentForm(Self)) then + {$ELSE} + if GetParentForm(C) = GetParentForm(Self) then + {$ENDIF} + Result := True; +end; + +procedure TOvcBaseEntryField.efLong2Str(P : PAnsiChar; L : LongInt); + {-convert a longint to a string} +var + W : Word; + S : array[0..32] of AnsiChar; + St : string[32]; +begin + W := efDataSize * 2; + if sefHexadecimal in sefOptions then begin + HexLPChar(S, L); + if W < 8 then + StrStDeletePrim(S, 0, 8-W); + end else if sefOctal in sefOptions then begin + OctalLPChar(S, L); + if W < 8 then + StrStDeletePrim(S, 0, 12-(W*2)); + end else if sefBinary in sefOptions then begin + BinaryLPChar(S, L); + if W < 8 then + StrStDeletePrim(S, 0, 32-(W*4)); + end else if L = 0 then begin + S[0] := '0'; + S[1] := #0; + end else begin + Str(L, St); + StrPCopy(S, St); + end; + StrCopy(P, S); +end; + +procedure TOvcBaseEntryField.efMapControlChars(Dest, Src : PAnsiChar); + {-copy from Src to Dest, mapping control characters to alpha in process} +var + I : Integer; +begin + StrCopy(Dest, Src); + if (StrLen(Dest) > 0) then begin + for I := 0 to StrLen(Dest)-1 do + if Dest[I] < ' ' then + Dest[I] := AnsiChar(Byte(Dest[I])+64); + end; +end; + +procedure TOvcBaseEntryField.efMoveFocus(C : TWinControl); + {-ask the controller to move the focus to the specified control} +begin +{$IFNDEF LCL} + PostMessage(Controller.Handle, om_SetFocus, 0, LongInt(C)); +{$ELSE} + Controller.PostMessage(Controller.Handle, om_SetFocus, 0, LongInt(C)); +{$ENDIF} +end; + +procedure TOvcBaseEntryField.efMoveFocusToNextField; + {-give next field the focus} +var + PF : TForm; +begin + PF := TForm(GetParentForm(Self)); + if not Assigned(PF) then + Exit; + +{$IFNDEF LCL} + PostMessage(PF.Handle, WM_NEXTDLGCTL, 0, 0); +{$ELSE} //WM_NEXTDLGCTL message apparently not handled by LCL TForm + Self.PerformTab(True); +{$ENDIF} +end; + +procedure TOvcBaseEntryField.efMoveFocusToPrevField; + {-give previous field the focus} +var + PF : TForm; +begin + PF := TForm(GetParentForm(Self)); + if not Assigned(PF) then + Exit; + +{$IFNDEF LCL} + PostMessage(PF.Handle, WM_NEXTDLGCTL, 1, 0); +{$ELSE} //WM_NEXTDLGCTL message apparently not handled by LCL TForm + Self.PerformTab(False); +{$ENDIF} +end; + +function TOvcBaseEntryField.efNthMaskChar(N : Word) : AnsiChar; + {-return the N'th character in the picture mask. N is 0-based} +begin + if N >= efPicLen then + Result := efPicture[efPicLen-1] + else + Result := efPicture[N]; +end; + +function TOvcBaseEntryField.efOctStr2Long(St : PAnsiChar; var L : LongInt) : Boolean; + {-convert an octal string to a longint} +var + I : Word; +begin + Result := True; + L := 0; + for I := 0 to StrLen(St)-1 do begin + {are we going to loose any of the top 3 bits} + if (L and $E0000000) <> 0 then + Result := False; + L := L shl 3; + L := L or (Ord(St[I]) - Ord('0')); + end; +end; + +{ - Hdc changed to TOvcHdc for BCB Compatibility } +procedure TOvcBaseEntryField.efPaintPrim(DC : TOvcHdc{Hdc}; + ARect : TRect; Offset : Integer); + {-primitive routine to draw the entry field control} +var + X, Y : Integer; + ChCnt : Integer; + CtCnt : Integer; + HStart : Integer; + HEnd : Integer; + OldBKMode : Integer; + RTC, HTC : LongInt; + RBC, HBC : LongInt; + CtlClr : LongInt; + SA, SD : PAnsiChar; + T : TEditString; + LMargin : Integer; +// I : Integer; + + procedure Display(Count : Word; TC, BC : LongInt); + begin + if (Count <> 0) and (X < ARect.Right) then begin + SetTextColor(DC, TC); + SetBkColor(DC, BC); + ExtTextOut(DC, X, Y, ETO_CLIPPED, @ARect, SD, Count, nil); + end; + + if (Count <> 0) then begin + {adjust X coordinate} + Inc(X, efGetTextExtent(SD, Count)); + + {advance string pointers} + Inc(SD, Count); + Inc(SA, Count); + + {adjust highlight indices} + Dec(HStart, Count); + if HStart < 0 then + HStart := 0; + Dec(HEnd, Count); + if HEnd <= HStart then + HEnd := 0; + end; + end; + + procedure DisplayPrim(Count : Word; TC, HC : LongInt); + var + SubCnt : Word; + Buf : TEditString; + begin + if (Count > 0) and (efFieldClass = fcNumeric) then begin + StrCopy(Buf, SD); + + {remove leading and trailing spaces} + TrimAllSpacesPChar(Buf); + SubCnt := StrLen(Buf); + if HStart < HEnd then begin + SetTextColor(DC, HTC); + SetBkColor(DC, HBC) + end else begin + SetTextColor(DC, RTC); + SetBkColor(DC, RBC); + end; + + {set right alignment} + SetTextAlign(DC, TA_RIGHT); + + + {paint the text right aligned} + ExtTextOut(DC, X, Y, ETO_CLIPPED, @ARect, Buf, SubCnt, nil); + Exit; + end; + + if (HStart = 0) and (HEnd > 0) then begin + SubCnt := HEnd-HStart; + if SubCnt > Count then + SubCnt := Count; + + {highlighted chars} + OldBKMode := SetBkMode(DC, OPAQUE); + Display(SubCnt, HC, HBC); + SetBkMode(DC, OldBkMode); + end else begin + if HStart > 0 then begin + SubCnt := HStart; + if SubCnt > Count then + SubCnt := Count; + end else + SubCnt := Count; + Display(SubCnt, TC, RBC); + end; + + {do we need to recurse?} + Dec(Count, SubCnt); + if Count > 0 then + DisplayPrim(Count, TC, HC); + end; + +begin + {select the font into our painting DC} + SelectObject(DC, Font.Handle); + SetBkColor(DC, Graphics.ColorToRGB(Color)); + SetTextColor(DC, Graphics.ColorToRGB(Font.Color)); + + {display samples of appropriate data while designing} + if csDesigning in ComponentState then begin + efGetSampleDisplayData(T); + SD := @T[0]; + end else begin + {get the display version of the string} + efGetDisplayString(T, MaxEditLen); + SD := @T[Offset]; + end; + + {point to the starting point of the string} + SA := @efEditSt[Offset]; + + {determine highlighted portion of the string} + if not (sefHaveFocus in sefOptions) then begin + HStart := 0; + HEnd := 0; + end else begin + HStart := efSelStart-Offset; + HEnd := efSelEnd-Offset; + if HStart < 0 then + HStart := 0; + if HEnd <= HStart then + HEnd := 0; + end; + + {get text colors to use} + if IsValid then begin + RTC := GetTextColor(DC); + RBC := GetBkColor(DC); + end else begin + RTC := Graphics.ColorToRGB(FEFColors.Error.TextColor); + RBC := Graphics.ColorToRGB(FEFColors.Error.BackColor); + end; + + {fill in the background} + if not Enabled then + Canvas.Brush.Color := FEFColors.Disabled.BackColor + else if IsValid then + Canvas.Brush.Color := Color + else + Canvas.Brush.Color := FEFColors.Error.BackColor; + + OldBkMode := SetBkMode(DC, TRANSPARENT); + FillRect(DC, ARect, Canvas.Brush.Handle); + SetBkMode(DC, OldBkMode); + + if csDesigning in ComponentState then begin + {no highlights if we're designing} + HStart := 0; + HEnd := 0; + end else if not Enabled then begin + {no highlights} + HStart := 0; + HEnd := 0; + RTC := Graphics.ColorToRGB(FEFColors.Disabled.TextColor); + RBC := Graphics.ColorToRGB(FEFColors.Disabled.BackColor); + end; + + if csDesigning in ComponentState then begin + ChCnt := StrLen(T); + CtCnt := 0; + end else + {count characters (use actual string, SA, not display string, SD)} + efFindCtrlChars(SA, ChCnt, CtCnt); + + LMargin := FTextMargin; + if (efFieldClass = fcNumeric) then begin + if (Assigned(FBorders)) then begin + if (FBorders.RightBorder.Enabled) then + LMargin := LMargin + FBorders.RightBorder.PenWidth; + end; + X := ClientWidth-LMargin-1; + + end else begin + efRightAlignActive := efoRightAlign in Options; + if efRightAlignActive then begin + if (Assigned(FBorders)) then begin + if (FBorders.RightBorder.Enabled) then + LMargin := LMargin + FBorders.RightBorder.PenWidth; + end; + X := efGetTextExtent(SD, StrLen(SD)); + if X >= ClientWidth-LMargin-1 then begin +(* +!!.04 - This is a classic bad idea. It royally messes stuff up. + {the display string doesn't fit in the client area, so strip all } + {padding. } + while SD[0] = PadChar do begin + for I := 0 to Length(SD) - 1 do + SD[i] := SD[i + 1]; + end; + ChCnt := Length(SD); + efRightAlignActive := False; +*) + X := LMargin-1; + end else + X := ClientWidth-X-LMargin-1; + end else begin + if (Assigned(FBorders)) then begin + if (FBorders.LeftBorder.Enabled) then + LMargin := LMargin + Borders.LeftBorder.PenWidth; + end; +(* +!!.04 - This is a classic bad idea. It royally messes stuff up. + {the display string doesn't fit in the client area, so strip any } + {padding away so that the important stuff can show } + X := efGetTextExtent(SD, StrLen(SD)); + if X >= ClientWidth-LMargin-1 then + if efoTrimBlanks in Options then + while SD[0] = PadChar do begin + for I := 0 to Length(SD) - 1 do + SD[i] := SD[i + 1]; + end; + ChCnt := Length(SD); +*) + X := LMargin-1; + end; + end; + + Y := efTopMargin; + + {convert TColor values to RGB values} + CtlClr := Graphics.ColorToRGB(FCtrlColor); + HTC := Graphics.ColorToRGB(FEFColors.Highlight.TextColor); + HBC := Graphics.ColorToRGB(FEFColors.Highlight.BackColor); + + {display loop} + while (ChCnt or CtCnt) <> 0 do begin + {display regular characters} + if ChCnt > 0 then + DisplayPrim(ChCnt, RTC, HTC); + + {display control characters} + if CtCnt > 0 then + DisplayPrim(CtCnt, CtlClr, CtlClr); + + {check for more characters} + if CtCnt = 0 then + ChCnt := 0 + else + efFindCtrlChars(SA, ChCnt, CtCnt); + end; +end; + +procedure TOvcBaseEntryField.efPerformEdit(var Msg : TMessage; Cmd : Word); + {-process the specified editing command if appropriate} +begin + HandleNeeded; + if not HandleAllocated then + Exit; + + {the null character implies that the this key should be} + {ignored. the only way for the null character to get here} + {is by changing a key after it has been entered , probably} + {in a key preview event handler} + if (Cmd = ccChar) and (AnsiChar(Lo(Msg.wParam)) = #0) then + Exit; + + {filter out commands that are inappropriate in read-only mode} + if efIsReadOnly then begin + case Cmd of + ccChar, ccCtrlChar, ccRestore, ccBack, ccDel, ccDelEol, + ccDelBol, ccDelLine, ccDelWord, ccCut, ccPaste, + ccInc, ccDec : + begin + efConditionalBeep; + Exit; + end; + end; + end; + + {do user command notification for user commands} + if Cmd >= ccUserFirst then begin + DoOnUserCommand(Cmd); + Cmd := ccSuppress; + end; + + {allow descendant classes to perform edit processing} + efEdit(Msg, Cmd); +end; + +procedure TOvcBaseEntryField.efPerformRepaint(Modified : Boolean); + {-flag the field as modified and redraw it} +begin + if Modified then + efFieldModified; + Refresh; +end; + +procedure TOvcBaseEntryField.efPerformPreEditNotify(C : TWinControl); + {-pre-edit notification to parent form} +begin + Controller.DoOnPreEdit(Self, C); +end; + +procedure TOvcBaseEntryField.efPerformPostEditNotify(C : TWinControl); + {-post-edit notification to parent form} +begin + Controller.DoOnPostEdit(Self, C); +end; + +function TOvcBaseEntryField.efPositionCaret(Adjust : Boolean) : Boolean; + {-position the editing caret} +var + Delta : Word; + S : PAnsiChar; + OK : Boolean; + Metrics : TTextMetric; + CW : Integer; + Pos : TPoint; + T : TEditString; + SLen : Integer; + LMargin : Integer; +begin + Result := False; + if not (sefHaveFocus in sefOptions) then + Exit; + + if Adjust then begin + {when a character is entered that erases the existing text, + efHPos may be 1 greater than EditBegin because of the + entered character} + if ((efHPos = efEditBegin) or (efHPos = efEditBegin+1)) and + (efHOffset <> 0) then begin + efHOffset := 0; + Result := True; + end else if (efHPos < efHOffset) then begin + efHOffset := efHPos; + Result := True; + end; + end; + + efGetDisplayString(T, MaxEditLen); + + efRightAlignActive := efoRightAlign in Options; + if efRightAlignActive then begin + Delta := efGetTextExtent(T, StrLen(T)); + if Delta >= ClientWidth-FTextMargin-1 then begin + {the display string doesn't fit in the client area, it is displayed left aligned} + efRightAlignActive := False; + end else begin + efRightAlignActive := True; + efHOffset := 0; + end; + end; + + repeat + if not efRightAlignActive then begin + S := @T[efHOffset]; + end else begin + S := @T[efHPos]; + end; + + SLen := StrLen(S); + if (efHPos = efHOffset) and not efRightAlignActive then + Delta := 0 + else begin + if not efRightAlignActive then + Delta := efGetTextExtent(S, efHPos-efHOffset) + else + Delta := efGetTextExtent(S, SLen); + end; + + OK := (Delta < ClientWidth-FTextMargin-1) or + (sefNumeric in sefOptions) or not Adjust; + if not OK then begin + if efHOffset >= efHPos then + OK := True + else begin + Inc(efHOffset); + Result := True; + end; + end; + until OK; + + {get metrics for current font} + GetTextMetrics(Canvas.Handle, Metrics); + + {get character width} + CW := efGetTextExtent(@T[efHPos], 1); + + {set caret cell height and width} + efCaret.CellHeight := Metrics.tmHeight; + efCaret.CellWidth := CW; + + {adjust caret position if using a wide cursor} + if (efCaret.CaretType.Shape in [csBlock, csHalfBlock, csHorzLine]) or + (efCaret.CaretType.CaretWidth > 4) then + if efRightAlignActive then + Dec(Delta) + else + Inc(Delta); + + {set caret position} + + LMargin := FTextMargin; + if (efFieldClass = fcNumeric) then begin + if (Assigned(FBorders)) then begin + if (FBorders.RightBorder.Enabled) then + LMargin := LMargin + FBorders.RightBorder.PenWidth; + end; + Pos.X := ClientWidth-LMargin-1; + end else begin + if efRightAlignActive then begin + if (Assigned(FBorders)) then begin + if (FBorders.RightBorder.Enabled) then + LMargin := LMargin + FBorders.RightBorder.PenWidth; + end; + Pos.X := ClientWidth - Succ(Delta) - LMargin - 1; + end else begin + if (Assigned(FBorders)) then begin + if (FBorders.LeftBorder.Enabled) then + LMargin := LMargin + FBorders.LeftBorder.PenWidth; + end; + Pos.X := Succ(Delta) + LMargin - 3; + end; + end; + + Pos.Y := efTopMargin; + if Pos.Y < 0 then + Pos.Y := 0; + + efCaret.Position := Pos; +end; + +function TOvcBaseEntryField.efRangeToStRange(const Value : TRangeType) : string; + {-returns the range as a string} +var + D : Byte; + Ex : Extended; + Buf : TEditString; + DateMask : string[MaxDateLen]; + TimeMask : string[MaxDateLen]; + + function GetDecimalPlaces : Byte; + var + I : Cardinal; + DotPos : Cardinal; + begin + if not StrChPos(efPicture, pmDecimalPt, DotPos) then + Result := DecimalPlaces + else begin + Result := 0; + for I := DotPos+1 to MaxLength-1 do + if efNthMaskChar(I) in PictureChars then + Inc(Result) + else + Break; + end; + end; + + function ExtendedToString(E : Extended; DP : Byte) : string; + label + UseScientificNotation; + var + I : Cardinal; + S : TEditString; + begin + if StrScan(efPicture, pmScientific) <> nil then + goto UseScientificNotation; + + {try to use regular notation} + Str(E:0:DP, S); + + {trim trailing 0's if appropriate} + if StrScan(S, pmDecimalPt) <> nil then + TrimTrailingZerosPChar(S); + + {does it fit?} + if StrLen(S) > MaxLength then begin + {won't fit--use scientific notation} + UseScientificNotation: + if (DP > 0) and (9+DP < MaxLength) then + Str(E:9+DP, S) + else + Str(E:MaxLength, S); + TrimAllSpacesPChar(S); + TrimEmbeddedZerosPChar(S); + end; + + {convert decimal point} + if StrChPos(S, pmDecimalPt, I) then + S[I] := IntlSupport.DecimalChar; + Result := StrPas(S); + end; + +begin + Result := ''; + D := GetDecimalPlaces; + case efDataType mod fcpDivisor of + fsubString : {}; + fsubBoolean, fsubYesNo : {}; + fsubChar : + if Value.rtChar <= ' ' then begin + Str(Ord(Value.rtChar), Result); + Result := '#' + Result; + end else + Result := Value.rtChar; + fsubLongInt, fsubInteger, fsubShortInt, fsubWord, fsubByte : + begin + efLong2Str(Buf, Value.rtLong); + Result := StrPas(Buf); + end; + fsubReal : + begin + Ex := Value.rtReal; + Result := ExtendedToString(Ex, D); + end; + fsubExtended, fsubDouble, fsubSingle, fsubComp : + Result := ExtendedToString(Value.rtExt, D); + fsubDate : + begin + DateMask := OvcIntlSup.InternationalDate(True); + if Value.rtDate = BadDate then + Result := '' + else + Result := OvcIntlSup.DateToDateString(DateMask, Value.rtDate, False); + end; + fsubTime : + begin + TimeMask := OvcIntlSup.InternationalTime(False); + if Value.rtTime = BadTime then + Result := '' + else + Result := OvcIntlSup.TimeToTimeString(TimeMask, Value.rtTime, False); + end; + end; +end; + +procedure TOvcBaseEntryField.efRemoveBadOptions; + {-remove inappropriate options for this field and data type} +begin + if csLoading in ComponentState then + Exit; + + case efFieldClass of + fcSimple : + case efDataType mod fcpDivisor of + fsubString : + begin + Exclude(FOptions, efoRightJustify); + Exclude(FOptions, efoStripLiterals); + end; + fsubChar, fsubBoolean, fsubYesNo : + begin + Exclude(FOptions, efoCaretToEnd); + Exclude(FOptions, efoForceInsert); + Exclude(FOptions, efoTrimBlanks); + Exclude(FOptions, efoRightJustify); + Exclude(FOptions, efoStripLiterals); + end; + fsubLongInt, fsubWord, fsubInteger, fsubByte, + fsubShortInt, fsubReal, fsubExtended, fsubDouble, + fsubSingle, fsubComp : + begin + Exclude(FOptions, efoTrimBlanks); + Exclude(FOptions, efoRightJustify); + Exclude(FOptions, efoStripLiterals); + end; + end; + fcPicture : + case efDataType mod fcpDivisor of + fsubString : {}; + fsubChar, fsubBoolean, fsubYesNo : + begin + Exclude(FOptions, efoCaretToEnd); + Exclude(FOptions, efoForceInsert); + Exclude(FOptions, efoTrimBlanks); + Exclude(FOptions, efoRightJustify); + Exclude(FOptions, efoStripLiterals); + end; + fsubLongInt, fsubWord, fsubInteger, fsubByte, + fsubShortInt, fsubReal, fsubExtended, fsubDouble, + fsubSingle, fsubComp : + begin + Exclude(FOptions, efoTrimBlanks); + Exclude(FOptions, efoStripLiterals); + end; + fsubDate, fsubTime : + begin + Exclude(FOptions, efoTrimBlanks); + Exclude(FOptions, efoRightJustify); + Exclude(FOptions, efoStripLiterals); + end; + end; + fcNumeric : + begin + Exclude(FOptions, efoCaretToEnd); + Exclude(FOptions, efoForceInsert); + Exclude(FOptions, efoTrimBlanks); + Exclude(FOptions, efoRightJustify); + Exclude(FOptions, efoStripLiterals); + Exclude(FOptions, efoRightAlign); + end; + end; + + {if input is required then these fields must also be uninitialized} + if (csDesigning in ComponentState) and (efoInputRequired in Options) then + case efDataType mod fcpDivisor of + fsubChar, fsubBoolean, fsubYesNo, fsubLongInt, + fsubWord, fsubInteger, fsubByte, fsubShortInt, + fsubReal, fsubExtended, fsubDouble, fsubSingle, + fsubComp : FUninitialized := True; + end; +end; + +procedure TOvcBaseEntryField.efResetCaret; + {-move the caret to the beginning or end of the field, as appropriate} +begin + if (efoCaretToEnd in FOptions) then + efCaretToEnd + else + efCaretToStart; +end; + +procedure TOvcBaseEntryField.efSaveEditString; + {-save a copy of the edit string} +begin + if (efSaveEdit = nil) or (StrLen(efEditSt) <> StrLen(efSaveEdit)) then begin + if efSaveEdit <> nil then + StrDispose(efSaveEdit); + efSaveEdit := StrNew(efEditSt); + end else + StrCopy(efSaveEdit, efEditSt); +end; + +procedure TOvcBaseEntryField.efSetCaretPos(Value : Integer); + {-set position of caret within the field} +begin + if not (sefHaveFocus in sefOptions) then + Exit; + + if Value < 0 then + efHPos := 0 + else if Value > LongInt(StrLen(efEditSt)) then + efHPos := StrLen(efEditSt)+1 + else + efHPos := Value; + efPositionCaret(True); +end; + +procedure TOvcBaseEntryField.efSetDefaultRange(FT : Byte); + {-set the default range for the given field type FT} +begin + efRangeLo := BlankRange; + efRangeHi := BlankRange; + case FT mod fcpDivisor of + fsubString : {}; + fsubBoolean, fsubYesNo : {}; + fsubChar : + begin + efRangeLo.rtChar := #32; + efRangeHi.rtChar := #32; + end; + fsubLongInt : + begin + efRangeLo.rtLong := Low(LongInt); {80000000} + efRangeHi.rtLong := High(LongInt); {7FFFFFFF} + end; + fsubWord : + begin + efRangeLo.rtLong := Low(Word); {0} + efRangeHi.rtLong := High(Word); {65535} + end; + fsubInteger : + begin + efRangeLo.rtLong := Low(SmallInt); {-32768} + efRangeHi.rtLong := High(SmallInt); {+32767} + end; + fsubByte : + begin + efRangeLo.rtLong := Low(Byte); {0} + efRangeHi.rtLong := High(Byte); {255} + end; + fsubShortInt : + begin + efRangeLo.rtLong := Low(ShortInt); {-128} + efRangeHi.rtLong := High(ShortInt); {127} + end; + fsubReal : + begin + efRangeLo.rtReal := -1.7e+38; + efRangeHi.rtReal := +1.7e+38; + end; + fsubExtended : + begin +{$IFNDEF FPC} + efRangeLo.rtExt := -1.1e+4932; + efRangeHi.rtExt := +1.1e+4932; +{$ELSE} + {$IFDEF FPC_HAS_TYPE_EXTENDED} + efRangeLo.rtExt := -1.1e+4932; + efRangeHi.rtExt := +1.1e+4932; + {$ELSE} {Extended same as Double on PPC} + efRangeLo.rtExt := -1.7e+308; + efRangeHi.rtExt := +1.7e+308; + {$ENDIF} +{$ENDIF} + end; + fsubDouble : + begin + efRangeLo.rtExt := -1.7e+308; + efRangeHi.rtExt := +1.7e+308; + end; + fsubSingle : + begin + efRangeLo.rtExt := -3.4e+38; + efRangeHi.rtExt := +3.4e+38; + end; + fsubComp : + begin + efRangeLo.rtExt := -9.2e+18; + efRangeHi.rtExt := +9.2e+18; + end; + fsubDate : + begin + efRangeLo.rtDate := MinDate; + efRangeHi.rtDate := MaxDate; + end; + fsubTime : + begin + efRangeLo.rtTime := MinTime; + efRangeHi.rtTime := MaxTime; + end; + end; +end; + +procedure TOvcBaseEntryField.efSetInitialValue; + {-set the initial value of the field} +var + R : TRangeType; + FST : Byte; +begin + if csDesigning in ComponentState then + Exit; + + R := BlankRange; + FST := efDataType mod fcpDivisor; + case FST of + fsubChar : + if (' ' >= efRangeLo.rtChar) and (' ' <= efRangeHi.rtChar) then + R.rtChar := ' ' + else + R.rtChar := efRangeLo.rtChar; + fsubLongInt, fsubWord, fsubInteger, fsubByte, fsubShortInt : + if (0 < efRangeLo.rtLong) or (0 > efRangeHi.rtLong) then + R.rtLong := efRangeLo.rtLong; + fsubReal : + if (0 < efRangeLo.rtReal) or (0 > efRangeHi.rtReal) then + R.rtReal := efRangeLo.rtReal; + fsubExtended, fsubDouble, fsubSingle, fsubComp : + if (0 < efRangeLo.rtExt) or (0 > efRangeHi.rtExt) then + case FST of + fsubExtended : R.rtExt := efRangeLo.rtExt; + fsubDouble : R.rtDbl := efRangeLo.rtExt; + fsubSingle : R.rtSgl := efRangeLo.rtExt; + fsubComp : R.rtComp := efRangeLo.rtExt; + end; + fsubDate : R.rtDate := BadDate; + fsubTime : R.rtTime := BadTime; + end; + efTransfer(@R, otf_SetData); +end; + +procedure TOvcBaseEntryField.SetName(const Value : TComponentName); +begin + inherited SetName(Value); + + Repaint; +end; + +procedure TOvcBaseEntryField.SetSelection(Start, Stop : Word); + {-mark offsets Start..Stop as selected} +var + Len : Word; +begin + if Start <= Stop then begin + Len := StrLen(efEditSt); + + if Start > Len then + Start := Len; + if Stop > Len then + Stop := Len; + + {all or nothing for numeric fields} + if (efFieldClass = fcNumeric) then + if (Start <> Stop) then begin + Start := 0; + Stop := MaxEditLen; + end; + + efSelStart := Start; + efSelEnd := Stop; + end; +end; + +function TOvcBaseEntryField.efStr2Long(P : PAnsiChar; var L : LongInt) : Boolean; + {-convert a string to a long integer} +var + S : TEditString; +begin + Result := True; + StrCopy(S, P); + TrimAllSpacesPChar(S); + + {treat an empty string as 0} + if StrLen(S) = 0 then begin + L := 0; + Exit; + end; + + if sefBinary in sefOptions then + Result := efBinStr2Long(S, L) + else if sefOctal in sefOptions then + Result := efOctStr2Long(S, L) + else begin + if (sefHexadecimal in sefOptions) and (S[0] <> #0) then + if StrPos(S, '$') = nil then + StrChInsertPrim(S, '$', 0); + + {check for special value the Val() doesn't handle correctly} + if StrComp(S, '-2147483648') = 0 then + L := LongInt($80000000) + else + Result := StrToLongPChar(S, L); + end; +end; + +function TOvcBaseEntryField.efStRangeToRange(const Value : string; var R : TRangeType) : Boolean; + {-converts a string range to a RangeType} +var + I : Integer; + Code : Integer; + fSub : Byte; + Buf : TEditString; + DateMask : string[MaxDateLen]; + TimeMask : string[MaxDateLen]; +begin + Code := 0; {assume success} + R := BlankRange; + fSub := efDataType mod fcpDivisor; + case fSub of + fsubString : {}; + fsubBoolean, fsubYesNo : {}; + fsubChar : + if Value = '' then + R.rtChar := #32 + else if Value[1] = '#' then begin + Val(Copy(Value, 2, 3), I, Code); + if Code = 0 then + R.rtChar := Chr(I) + else begin + Code := 0; + R.rtChar := #32; + end; + end else + R.rtChar := Value[1]; + fsubLongInt, fsubWord, fsubInteger, fsubByte, fsubShortInt : + begin + StrPCopy(Buf, Value); + if not efStr2Long(Buf, R.rtLong) then + Code := 1 + else if (fSub = fsubWord) and + ((R.rtLong < Low(Word)) or (R.rtLong > High(Word))) then + Code := 1 + else if (fSub = fsubInteger) and + ((R.rtLong < Low(SmallInt)) or (R.rtLong > High(SmallInt))) then + Code := 1 + else if (fSub = fsubByte) and + ((R.rtLong < Low(Byte)) or (R.rtLong > High(Byte))) then + Code := 1 + else if (fSub = fsubShortInt) and + ((R.rtLong < Low(ShortInt)) or (R.rtLong > High(ShortInt))) then + Code := 1; + end; + fsubReal : + if Value = '' then + R.rtReal := 0 + else + Val(Value, R.rtReal, Code); + fsubExtended, fsubDouble, fsubSingle, fsubComp : + begin + if Value = '' then + R.rtExt := 0 + else + Val(Value, R.rtExt, Code); + if (Code = 0) then begin + if (fSub = fsubDouble) and ((R.rtExt < -1.7e+308) or (R.rtExt > +1.7e+308)) then + Code := 1 + else if (fSub = fsubSingle) and ((R.rtExt < -3.4e+38) or (R.rtExt > +3.4e+38)) then + Code := 1 + else if (fSub = fsubComp) and ((R.rtExt < -9.2e+18) or (R.rtExt > +9.2e+18)) then + Code := 1; + end; + end; + fsubDate : + begin + DateMask := OvcIntlSup.InternationalDate(True); + if Length(Value) <> Length(DateMask) then + R.rtDate := BadDate + else + R.rtDate := OvcIntlSup.DateStringToDate(DateMask, Value, GetEpoch); + if R.rtDate = BadDate then + Code := 1; + end; + fsubTime : + begin + TimeMask := OvcIntlSup.InternationalTime(False); + if Length(Value) <> Length(TimeMask) then + R.rtTime := BadTime + else + R.rtTime := OvcIntlSup.TimeStringToTime(TimeMask, Value); + if R.rtTime = BadTime then + Code := 1; + end; + end; + Result := Code = 0; +end; + +procedure TOvcBaseEntryField.efReadRangeHi(Stream : TStream); + {-called to read the high range from the stream} +begin + Stream.Read(efRangeHi, SizeOf(TRangeType)); +end; + +procedure TOvcBaseEntryField.efReadRangeLo(Stream : TStream); + {-called to read the low range from the stream} +begin + Stream.Read(efRangeLo, SizeOf(TRangeType)); +end; + +function TOvcBaseEntryField.efTransfer(DataPtr : Pointer; TransferFlag : Word) : Word; + {-transfer data to or from the field} +begin + if (TransferFlag <> otf_SizeData) and not (csDesigning in ComponentState) then + Result := efTransferPrim(DataPtr, TransferFlag) + else + Result := efDataSize; + {descendant classes will do the actual transfering of data} +end; + +function TOvcBaseEntryField.efTransferPrim(DataPtr : Pointer; TransferFlag : Word) : Word; + {-reset for new data in field} +begin + Result := efDataSize; + if TransferFlag = otf_SetData then begin + if not (sefValidating in sefOptions) then begin + Exclude(sefOptions, sefRetainPos); + if sefHaveFocus in sefOptions then begin + efResetCaret; + efPositionCaret(True); + + {if we are doing a transfer due to a GetValue} + {validation, don't reset selection} + if not (sefGettingValue in sefOptions) then + SetSelection(0, MaxEditLen); + end else + Exclude(sefOptions, sefInvalid); + + {clear modified flags} + Exclude(sefOptions, sefModified); + Exclude(sefOptions, sefEverModified); + + Invalidate; + end; + end; +end; + +procedure TOvcBaseEntryField.efWriteRangeHi(Stream : TStream); + {-called to store the high range on the stream} +begin + Stream.Write(efRangeHi, SizeOf(TRangeType)); +end; + +procedure TOvcBaseEntryField.efWriteRangeLo(Stream : TStream); + {-called to store the low range on the stream} +begin + Stream.Write(efRangeLo, SizeOf(TRangeType)); +end; + +procedure TOvcBaseEntryField.EMGetModify(var Msg : TMessage); +begin + Msg.Result := 0; + if sefModified in sefOptions then + Msg.Result := 1; +end; + +procedure TOvcBaseEntryField.EMGetSel(var Msg : TMessage); +begin + {Return this info in Msg as well as in Result} + with Msg do begin + if LPDWORD(wParam) <> nil then + LPDWORD(wParam)^ := efSelStart; + if LPDWORD(lParam) <> nil then + LPDWORD(lParam)^ := efSelEnd; + end; + Msg.Result := MakeLong(efSelStart, efSelEnd); +end; + +procedure TOvcBaseEntryField.EMSetModify(var Msg : TMessage); +begin + if Msg.wParam > 0 then begin + Include(sefOptions, sefModified); + Include(sefOptions, sefEverModified); + end else + Exclude(sefOptions, sefModified); +end; + +procedure TOvcBaseEntryField.EMSetSel(var Msg : TMessage); +begin + with Msg do begin + if lParamLo = $FFFF then + SetSelection(0, 0) + else if (lParamLo = 0) and (lParamHi = $FFFF) then + SetSelection(0, MaxEditLen) + else if lParamHi >= lParamLo then + SetSelection(lParamLo, lParamHi); + end; + Invalidate; +end; + +function TOvcBaseEntryField.GetAsBoolean : Boolean; + {-returns the field value as a Boolean Value} +begin + Result := False; + if (efDataType mod fcpDivisor) in [fsubBoolean, fsubYesNo] then + FLastError := GetValue(Result) + else + raise EInvalidDataType.Create; +end; + +function TOvcBaseEntryField.GetAsCents : LongInt; + {-returns the field value as a LongInt Value representing pennies} +const + C = 100.0; +var + Re : Real; + Db : Double; + Si : Single; + Ex : Extended; +begin + Result := 0; + case (efDataType mod fcpDivisor) of + fsubReal : + begin + FLastError := GetValue(Re); + if FLastError = 0 then + Result := Round(Re * C); + end; + fsubDouble : + begin + FLastError := GetValue(Db); + if FLastError = 0 then + Result := Round(Db * C); + end; + fsubSingle : + begin + FLastError := GetValue(Si); + if FLastError = 0 then + Result := Round(Si * C); + end; + fsubExtended : + begin + FLastError := GetValue(Ex); + if FLastError = 0 then + Result := Round(Ex * C); + end; + else + raise EInvalidDataType.Create; + end; +end; + +function TOvcBaseEntryField.GetAsDateTime : TDateTime; + {-returns the field value as a Delphi DateTime Value} +var + D : TStDate; + T : TStTime; +begin + case (efDataType mod fcpDivisor) of + fsubDate : + begin + FLastError := GetValue(D); + if FLastError <> 0 then + Result := 0 + else + Result := StDateToDateTime(D); + end; + fsubTime : + begin + FLastError := GetValue(T); + if FLastError <> 0 then + Result := 0 + else + Result := StTimeToDateTime(T); + end; + else + raise EInvalidDataType.Create; + end; +end; + +function TOvcBaseEntryField.GetAsExtended : Extended; + {-returns the field value as an Extended Value} +var + Ex : Extended; + Co : Comp absolute Ex; + Db : Double; + Sg : Single absolute Db; + Re : Real absolute Db; + Li : Longint; + Wo : Word absolute Li; + It : SmallInt absolute Li; + By : Byte absolute Li; + Si : ShortInt absolute Li; +begin + Result := 0; + case efDataType mod fcpDivisor of + fsubExtended : + begin + FLastError := GetValue(Ex); + if FLastError = 0 then + Result := Ex; + end; + fsubComp : + begin + FLastError := GetValue(Co); + if FLastError = 0 then + Result := Co; + end; + fsubReal : + begin + FLastError := GetValue(Re); + if FLastError = 0 then + Result := Re; + end; + fsubDouble : + begin + FLastError := GetValue(Db); + if FLastError = 0 then + Result := Db; + end; + fsubSingle : + begin + FLastError := GetValue(Sg); + if FLastError = 0 then + Result := Sg; + end; + fsubLongInt : + begin + FLastError := GetValue(Li); + if FLastError = 0 then + Result := Li; + end; + fsubWord : + begin + FLastError := GetValue(Wo); + if FLastError = 0 then + Result := Wo; + end; + fsubInteger : + begin + FLastError := GetValue(It); + if FLastError = 0 then + Result := It; + end; + fsubByte : + begin + FLastError := GetValue(By); + if FLastError = 0 then + Result := By; + end; + fsubShortInt : + begin + FLastError := GetValue(Si); + if FLastError = 0 then + Result := Si; + end; + else + raise EInvalidDataType.Create; + end; +end; + +function TOvcBaseEntryField.GetAsFloat : Double; + {-returns the field value as a Double Value} +var + Db : Double; + Sg : Single absolute Db; + Re : Real absolute Db; + Ex : Extended; + Co : Comp absolute Ex; + Li : LongInt; + Wo : Word absolute Li; + It : SmallInt absolute Li; + By : Byte absolute Li; + Si : ShortInt absolute Li; +begin + Result := 0; + case efDataType mod fcpDivisor of + fsubReal : + begin + FLastError := GetValue(Re); + if FLastError = 0 then + Result := Re; + end; + fsubDouble : + begin + FLastError := GetValue(Db); + if FLastError = 0 then + Result := Db; + end; + fsubSingle : + begin + FLastError := GetValue(Sg); + if FLastError = 0 then + Result := Sg; + end; + fsubExtended : + begin + FLastError := GetValue(Ex); + if FLastError = 0 then + Result := Ex; + end; + fsubComp : + begin + FLastError := GetValue(Co); + if FLastError = 0 then + Result := Co; + end; + fsubLongInt : + begin + FLastError := GetValue(Li); + if FLastError = 0 then + Result := Li; + end; + fsubWord : + begin + FLastError := GetValue(Wo); + if FLastError = 0 then + Result := Wo; + end; + fsubInteger : + begin + FLastError := GetValue(It); + if FLastError = 0 then + Result := It; + end; + fsubByte : + begin + FLastError := GetValue(By); + if FLastError = 0 then + Result := By; + end; + fsubShortInt : + begin + FLastError := GetValue(Si); + if FLastError = 0 then + Result := Si; + end; + else + raise EInvalidDataType.Create; + end; +end; + +function TOvcBaseEntryField.GetAsInteger : Longint; + {-returns the field value as a LongInt Value} +var + Li : Longint; + Wo : Word absolute Li; + It : SmallInt absolute Li; + By : Byte absolute Li; + Si : ShortInt absolute Li; +begin + Result := 0; + case efDataType mod fcpDivisor of + fsubLongInt : + begin + FLastError := GetValue(Li); + if FLastError = 0 then + Result := Li; + end; + fsubWord : + begin + FLastError := GetValue(Wo); + if FLastError = 0 then + Result := Wo; + end; + fsubInteger : + begin + FLastError := GetValue(It); + if FLastError = 0 then + Result := It; + end; + fsubByte : + begin + FLastError := GetValue(By); + if FLastError = 0 then + Result := By; + end; + fsubShortInt : + begin + FLastError := GetValue(Si); + if FLastError = 0 then + Result := Si; + end; + else + raise EInvalidDataType.Create; + end; +end; + +function TOvcBaseEntryField.GetAsString : string; + {-return the field value as a string value} +var + Buf : TEditString; + S : string[MaxEditLen]; +begin + Result := ''; + if (efDataType mod fcpDivisor) = fsubString then begin + FLastError := GetValue(S); + if FLastError = 0 then + Result := S; + end else begin + StrCopy(Buf, efEditSt); + if efoTrimBlanks in Options then + TrimAllSpacesPChar(Buf); + Result := StrPas(Buf); + FLastError := 0; + end; +end; + +function TOvcBaseEntryField.GetAsVariant : Variant; + {return the field value as a Variant value} +begin + case efDataType mod fcpDivisor of + fsubBoolean : Result := GetAsBoolean; + fsubYesNo : Result := GetAsBoolean; + fsubLongInt : Result := GetAsInteger; + fsubWord : Result := GetAsInteger; + fsubInteger : Result := GetAsInteger; + fsubByte : Result := GetAsInteger; + fsubShortInt : Result := GetAsInteger; + fsubReal : Result := GetAsFloat; + fsubDouble : Result := GetAsFloat; + fsubSingle : Result := GetAsFloat; + fsubExtended : Result := GetAsExtended; + fsubComp : Result := GetAsExtended; + else + Result := GetAsString; + end; +end; + +function TOvcBaseEntryField.GetAsStDate : TStDate; + {-returns the field value as a Date Value} +begin + if (efDataType mod fcpDivisor) = fsubDate then begin + FLastError := GetValue(Result); + if FLastError <> 0 then + Result := BadDate; + end else + raise EInvalidDataType.Create; +end; + +function TOvcBaseEntryField.GetAsStTime : TStTime; + {-returns the field value as a Time Value} +begin + if (efDataType mod fcpDivisor) = fsubTime then begin + FLastError := GetValue(Result); + if FLastError <> 0 then + Result := BadTime; + end else + raise EInvalidDataType.Create; +end; + +function TOvcBaseEntryField.GetCurrentPos : Integer; + {-get position of the caret within the field} +begin + if sefHaveFocus in sefOptions then + Result := efHPos + else + Result := -1; +end; + +function TOvcBaseEntryField.GetDataSize : Word; + {-return the size of the data for this field} +begin + if efDataSize = 0 then + efInitializeDataSize; + Result := efDataSize; +end; + +function TOvcBaseEntryField.GetDisplayString : string; + {-return the display string} +var + Buf : TEditString; +begin + efGetDisplayString(Buf, MaxEditLen); + Result := StrPas(Buf); +end; + +function TOvcBaseEntryField.GetEditString : string; + {-return a string containing the edit text} +var + Buf : TEditString; +begin + StrLCopy(Buf, efEditSt, MaxEditLen); + Result := StrPas(Buf); +end; + +function TOvcBaseEntryField.GetEpoch : Integer; +begin + Result := FEpoch; + + {avoid writing controller's epoch value} + if csWriting in ComponentState then + Exit; + + if Assigned(FOnGetEpoch) then + FOnGetEpoch(Self, Result); + if (Result = 0) and ControllerAssigned then + Result := Controller.Epoch; +end; + +function TOvcBaseEntryField.GetEverModified : Boolean; + {-return true if this field has ever been modified} +begin + Result := (sefEverModified in sefOptions) or (sefModified in sefOptions); +end; + +function TOvcBaseEntryField.GetInsCaretType : TOvcCaret; + {-return the current caret type} +begin + Result := efCaret.InsCaretType; +end; + +function TOvcBaseEntryField.GetInsertMode : Boolean; + {-return the controller's insert mode state} +begin + if ControllerAssigned then + Result := Controller.InsertMode + else + Result := sefInsert in sefOptions; +end; + +function TOvcBaseEntryField.GetModified : Boolean; + {-return true if this field is modified} +begin + Result := sefModified in sefOptions; +end; + +function TOvcBaseEntryField.GetOvrCaretType : TOvcCaret; + {-return the current caret type} +begin + Result := efCaret.OvrCaretType; +end; + +function TOvcBaseEntryField.GetRangeHiStr : string; + {-get the high field range as string value} +begin + Result := efRangeToStRange(efRangeHi); +end; + +function TOvcBaseEntryField.GetRangeLoStr : string; + {-get the low field range as string value} +begin + Result := efRangeToStRange(efRangeLo); +end; + +function TOvcBaseEntryField.GetSelLength : Integer; + {-return the length of the currently selected text} +begin + Result := efSelEnd - efSelStart; +end; + +function TOvcBaseEntryField.GetSelStart : Integer; + {-return the starting position of the selection, if any} +begin + Result := efSelStart; +end; + +function TOvcBaseEntryField.GetSelText : string; + {-return the currently selected text} +var + Len : Integer; +begin + Result := ''; + Len := efSelEnd - efSelStart; + if Len > 0 then begin + {limit length to max edit length} + if Len > MaxEditLen then + Len := MaxEditLen; + SetLength(Result, Len); + StrLCopy(@Result[1], @efEditSt[efSelStart], Len); + end; +end; + +function TOvcBaseEntryField.FieldIsEmpty : Boolean; + {-return True if the field is completely empty} +begin + HandleNeeded; + Result := efFieldIsEmpty; +end; + +function TOvcBaseEntryField.GetStrippedEditString : string; + {-return edit string stripped of literals and semi-literals} +begin + Result := GetEditString; +end; + +function TOvcBaseEntryField.GetValue(var Data) : Word; + {-returns the current field value in Data. Result is 0 or error code} +begin + {flag to inform validate and transfer} + {methods that we are retrieving a value} + Include(sefOptions, sefGettingValue); + try + Result := efValidateField; + if Result <> 0 then + Exit; + + case efDataType mod fcpDivisor of + fsubString : efTransfer(@ShortString(Data), otf_GetData); + fsubChar : efTransfer(@AnsiChar(Data), otf_GetData); + fsubBoolean : efTransfer(@Boolean(Data), otf_GetData); + fsubYesNo : efTransfer(@Boolean(Data), otf_GetData); + fsubLongInt : efTransfer(@LongInt(Data), otf_GetData); + fsubWord : efTransfer(@Word(Data), otf_GetData); + fsubInteger : efTransfer(@SmallInt(Data), otf_GetData); + fsubByte : efTransfer(@Byte(Data), otf_GetData); + fsubShortInt : efTransfer(@ShortInt(Data), otf_GetData); + fsubReal : efTransfer(@Real(Data), otf_GetData); + fsubExtended : efTransfer(@Extended(Data), otf_GetData); + fsubDouble : efTransfer(@Double(Data), otf_GetData); + fsubSingle : efTransfer(@Single(Data), otf_GetData); + fsubComp : efTransfer(@Comp(Data), otf_GetData); + fsubDate : efTransfer(@TStDate(Data), otf_GetData); + fsubTime : efTransfer(@TStTime(Data), otf_GetData); + else + raise EOvcException.Create(GetOrphStr(SCInvalidParamValue)); + end; + finally + Exclude(sefOptions, sefGettingValue); + end; +end; + +procedure TOvcBaseEntryField.IncreaseValue(Wrap : Boolean; Delta : Double); + {-increase the value of the field by Delta, wrapping if enabled} +begin + SendMessage(Handle, WM_SETREDRAW, 0, 0); + efIncDecValue(Wrap, +Delta); + SetSelection(0, 0); + SendMessage(Handle, WM_SETREDRAW, 1, 0); + Refresh; +end; + +function TOvcBaseEntryField.IsValid : Boolean; + {-returns true if the field is not marked as invalid} +begin + Result := not (sefInvalid in sefOptions); +end; + +procedure TOvcBaseEntryField.MergeWithPicture(const S : string); + {-combines S with the picture mask and updates the edit string} +begin + StrPLCopy(efEditSt, S, MaxLength); +end; + +procedure TOvcBaseEntryField.MoveCaret(Delta : Integer); + {-moves the caret to the right or left Value positions} +var + I : Integer; + Msg : TMessage; +begin + if not (sefHaveFocus in sefOptions) then + Exit; + + FillChar(Msg, SizeOf(Msg), 0); + if Delta > 0 then begin + for I := 1 to Delta do + efPerformEdit(Msg, ccRight) + end else if Delta < 0 then begin + for I := 1 to Abs(Delta) do + efPerformEdit(Msg, ccLeft) + end; +end; + +procedure TOvcBaseEntryField.MoveCaretToEnd; + {-move the caret to the end of the field} +begin + efCaretToEnd; +end; + +procedure TOvcBaseEntryField.MoveCaretToStart; + {-move the caret to the beginning of the field} +begin + efCaretToStart; +end; + +procedure TOvcBaseEntryField.OMGetDataSize(var Msg : TMessage); + {-return the fields data size} +begin + Msg.Result := DataSize; +end; + +procedure TOvcBaseEntryField.OMReportError(var Msg : TOMReportError); + {-report the error} +var + P : string; +begin + if Msg.Error = 0 then + Exit; + + case Msg.Error of + oeRangeError : P := GetOrphStr(SCRangeError); + oeInvalidNumber : P := GetOrphStr(SCInvalidNumber); + oeRequiredField : P := GetOrphStr(SCRequiredField); + oeInvalidDate : P := GetOrphStr(SCInvalidDate); + oeInvalidTime : P := GetOrphStr(SCInvalidTime); + oeBlanksInField : P := GetOrphStr(SCBlanksInField); + oePartialEntry : P := GetOrphStr(SCPartialEntry); + else + if Msg.Error >= oeCustomError then + P := Controller.ErrorText + else + P := GetOrphStr(SCDefaultEntryErrorText); + end; + + {update the error text} + if P <> Controller.ErrorText then + Controller.ErrorText := P; + + {do error notification} + DoOnError(Msg.Error, P); +end; + +procedure TOvcBaseEntryField.Paint; + {-draw the entry field control} +var + hCBM : hBitmap; + MemDC : hDC; + CR : TRect; +begin + inherited Paint; + + {get dimensions of client area} + CR.Top := 0; CR.Left := 0; + CR.Right := Width; CR.Bottom := Height; + + {create a compatible display context and bitmap} + MemDC := CreateCompatibleDC(Canvas.Handle); + hCBM := CreateCompatibleBitmap(Canvas.Handle, CR.Right, CR.Bottom); + SelectObject(MemDC, hCBM); + SetMapMode(MemDC, GetMapMode(Canvas.Handle)); + + {set text alignment} + SetTextAlign(MemDC, TA_LEFT or TA_TOP); + + {call our paint routine} + efPaintPrim(MemDC, CR, efHOffset); + + {copy everything to the original display context} + BitBlt(Canvas.Handle, 0, 0, CR.Right, CR.Bottom, MemDC, 0, 0, SrcCopy); + + efPaintBorders; + + {dispose of the bitmap and the extra display context} + DeleteDC(MemDC); + DeleteObject(hCBM); +end; + +procedure TOvcBaseEntryField.efPaintBorders; +var + R : TRect; + C : TCanvas; +begin + R.Left := 0; + R.Top := 0; + R.Right := Width; + R.Bottom := Height; + + C := Canvas; + if (FBorders.LeftBorder <> nil) then begin + if (FBorders.LeftBorder.Enabled) then begin + C.Pen.Color := FBorders.LeftBorder.PenColor; + C.Pen.Width := FBorders.LeftBorder.PenWidth; + C.Pen.Style := FBorders.LeftBorder.PenStyle; + + C.MoveTo(R.Left + (FBorders.LeftBorder.PenWidth div 2), R.Top); + C.LineTo(R.Left + (FBorders.LeftBorder.PenWidth div 2), R.Bottom); + end; + end; + + if (FBorders.RightBorder <> nil) then begin + if (FBorders.RightBorder.Enabled) then begin + C.Pen.Color := FBorders.RightBorder.PenColor; + C.Pen.Width := FBorders.RightBorder.PenWidth; + C.Pen.Style := FBorders.RightBorder.PenStyle; + + if ((FBorders.RightBorder.PenWidth mod 2) = 0) then begin + C.MoveTo(R.Right - (FBorders.RightBorder.PenWidth div 2), R.Top); + C.LineTo(R.Right - (FBorders.RightBorder.PenWidth div 2), R.Bottom); + end else begin + C.MoveTo(R.Right - (FBorders.RightBorder.PenWidth div 2) - 1, R.Top); + C.LineTo(R.Right - (FBorders.RightBorder.PenWidth div 2) - 1, R.Bottom); + end; + end; + end; + + if (FBorders.TopBorder <> nil) then begin + if (FBorders.TopBorder.Enabled) then begin + C.Pen.Color := FBorders.TopBorder.PenColor; + C.Pen.Width := FBorders.TopBorder.PenWidth; + C.Pen.Style := FBorders.TopBorder.PenStyle; + + C.MoveTo(R.Left, R.Top + (FBorders.TopBorder.PenWidth div 2)); + C.LineTo(R.Right, R.Top + (FBorders.TopBorder.PenWidth div 2)); + end; + end; + + if (FBorders.BottomBorder <> nil) then begin + if (FBorders.BottomBorder.Enabled) then begin + C.Pen.Color := FBorders.BottomBorder.PenColor; + C.Pen.Width := FBorders.BottomBorder.PenWidth; + C.Pen.Style := FBorders.BottomBorder.PenStyle; + + if ((FBorders.BottomBorder.PenWidth mod 2) = 0) then begin + C.MoveTo(R.Left, R.Bottom - (FBorders.BottomBorder.PenWidth div 2)); + C.LineTo(R.Right, R.Bottom - (FBorders.BottomBorder.PenWidth div 2)); + end else begin + C.MoveTo(R.Left, R.Bottom - (FBorders.BottomBorder.PenWidth div 2) - 1); + C.LineTo(R.Right, R.Bottom - (FBorders.BottomBorder.PenWidth div 2) - 1); + end; + end; + end; +end; + +procedure TOvcBaseEntryField.PasteFromClipboard; + {-pastes the contents of the clipboard in the edit field} +begin + if HandleAllocated then + Perform(WM_PASTE, 0, 0); +end; + +procedure TOvcBaseEntryField.ProcessCommand(Cmd, CharCode : Word); + {-process the specified command} +var + Msg : TMessage; +begin + FillChar(Msg, SizeOf(Msg), #0); + Msg.wParam := CharCode; + efPerformEdit(Msg, Cmd); +end; + +procedure TOvcBaseEntryField.ResetCaret; + {-move the caret to the beginning or end of the field, as appropriate} +begin + efResetCaret; +end; + +procedure TOvcBaseEntryField.Restore; + {-restore the previous contents of the field} +begin + if efSaveEdit = nil then + Exit; + + StrCopy(efEditSt, efSaveEdit); + efResetCaret; + SetSelection(0, MaxEditLen); + + {clear modified flag} + Exclude(sefOptions, sefModified); + Repaint; + DoOnChange; +end; + +procedure TOvcBaseEntryField.SelectAll; + {-selects the entire contents of the edit field} +begin + if HandleAllocated then + Perform(EM_SETSEL, 1, LongInt($FFFF0000)); +end; + +procedure TOvcBaseEntryField.SetAsBoolean(Value : Boolean); + {-sets the field value to a Boolean Value} +begin + if (efDataType mod fcpDivisor) in [fsubBoolean, fsubYesNo] then + SetValue(Value) + else + raise EInvalidDataType.Create; +end; + +procedure TOvcBaseEntryField.SetAsCents(Value : LongInt); + {-sets the field value given a LongInt Value representing pennies} +const + C = 100.0; +var + Re : Real; + Db : Double; + Si : Single; + Ex : Extended; +begin + case efDataType mod fcpDivisor of + fsubReal : + begin + Re := Value / C; + SetValue(Re); + end; + fsubDouble : + begin + Db := Value / C; + SetValue(Db); + end; + fsubSingle : + begin + Si := Value / C; + SetValue(Si); + end; + fsubExtended : + begin + Ex := Value / C; + SetValue(Ex); + end; + else + raise EInvalidDataType.Create; + end; +end; + +procedure TOvcBaseEntryField.SetAsDateTime(Value : TDateTime); + {-sets the field value to a Delphi DateTime value} +var + D : TStDate; + T : TStTime; + Day, + Month, + Year : Word; + Hour, + Min, + Sec, + MSec : Word; +begin + case (efDataType mod fcpDivisor) of + fsubDate : + begin + {$IFDEF ZeroDateAsNull} + if Value = 0 then + Value := BadDate; + {$ENDIF} + DecodeDate(Value, Year, Month, Day); + D := DMYToStDate(Day, Month, Year, GetEpoch); + if D = DateTimeToStDate(BadDate) then + D := BadDate; + SetValue(D); + end; + fsubTime : + begin + DecodeTime(Value, Hour, Min, Sec, MSec); + T := HMSToStTime(Hour, Min, Sec); + if (T <> 0) and (T = DateTimeToStTime(BadTime)) then + T := BadTime; + SetValue(T); + end; + else + raise EInvalidDataType.Create; + end; +end; + +procedure TOvcBaseEntryField.SetAsExtended(Value : Extended); + {-sets the field value to an Extended Value} +var + Co : Comp; +begin + case efDataType mod fcpDivisor of + fsubExtended : + SetValue(Value); + fsubComp : + begin + Co := Trunc(Value); + SetValue(Co); + end; + else + raise EInvalidDataType.Create; + end; +end; + +procedure TOvcBaseEntryField.SetAsFloat(Value : Double); + {-sets the field value to a Double Value} +var + Sg : Single; + Re : Real; + Co : Comp; + Ex : Extended; +begin + case efDataType mod fcpDivisor of + fsubReal : + begin + Re := Value; + SetValue(Re); + end; + fsubDouble : + SetValue(Value); + fsubSingle : + begin + Sg := Value; + SetValue(Sg); + end; + fsubExtended : + begin + Ex := Value; + SetValue(Ex); + end; + fsubComp : + begin + Co := Trunc(Value); + SetValue(Co); + end; + else + raise EInvalidDataType.Create; + end; +end; + +procedure TOvcBaseEntryField.SetAsInteger(Value : Longint); + {-sets the field value to a LongInt Value} +var + Wo : Word; + It : SmallInt absolute Wo; + By : Byte absolute Wo; + Si : ShortInt absolute Wo; +begin + case efDataType mod fcpDivisor of + fsubLongInt : + SetValue(Value); + fsubWord : + begin + Wo := LOWORD(Value); + SetValue(Wo); + end; + fsubInteger : + begin + It := SmallInt(LOWORD(Value)); + SetValue(It); + end; + fsubByte : + begin + By := Lo(LOWORD(Value)); + SetValue(By); + end; + fsubShortInt : + begin + Si := ShortInt(Lo(LOWORD(Value))); + SetValue(Si); + end; + else + raise EInvalidDataType.Create; + end; +end; + +procedure TOvcBaseEntryField.SetAsString(const Value : string); + {-sets the field value to a String Value} +var + R : TRangeType; + fSub : Byte; + B : Boolean; + Ch : AnsiChar; + S : string[MaxEditLen]; +begin + if sefUserValidating in sefOptions then + Exit; + + fSub := (efDataType mod fcpDivisor); + if fSub = fsubString then begin + S := Value; + SetValue(S) + end else if fSub in [fsubBoolean, fsubYesNo] then begin + B := False; + if Length(Value) > 0 then begin + Ch := UpCaseChar(Value[1]); + B := (Ch = FIntlSup.TrueChar) or (Ch = FIntlSup.YesChar); + end; + SetValue(B); + end else begin + {use range conversion routines to process string assignment} + if efStRangeToRange(Value, R) then begin + case (efDataType mod fcpDivisor) of + {assign result to proper sub-field in range type var} + fsubWord : R.rtWord := R.rtLong; + fsubInteger : R.rtInt := R.rtLong; + fsubByte : R.rtByte := R.rtLong; + fsubShortInt : R.rtSht := R.rtLong; + fsubDouble : R.rtDbl := R.rtExt; + fsubSingle : R.rtSgl := R.rtExt; + fsubComp : R.rtComp := R.rtExt; + end; + SetValue(R); + end else + raise EEntryFieldError.Create(GetOrphStr(SCInvalidNumber)); + end; +end; + +procedure TOvcBaseEntryField.SetAsVariant(Value : Variant); + {-sets the field value to a Variant value} +var + fSub : Byte; +begin + {what data type is this field} + fSub := efDataType mod fcpDivisor; + + case VarType(Value) of + varSmallInt, + varInteger : + case fSub of + fsubByte, + fsubShortInt, + fsubWord, + fsubInteger, + fsubLongInt : SetAsInteger(Value); + else + {try to convert it into a string} + SetAsString(VarAsType(Value, varString)); + end; + varSingle, + varDouble, + varCurrency : + case fSub of + fsubReal, + fsubDouble, + fsubSingle, + fsubExtended, + fsubComp : SetAsFloat(Value); + else + {try to convert it into a string} + SetAsString(VarAsType(Value, varString)); + end; + varDate : + if fSub = fsubDate then + SetAsDateTime(Value) + else + {try to convert it into a string} + SetAsString(VarAsType(Value, varString)); + varBoolean : + if fSub in [fsubBoolean, fsubYesNo] then + SetAsBoolean(Value) + else + {try to convert it into a string} + SetAsString(VarAsType(Value, varString)); + varString : SetAsString(Value); + end; +end; + +procedure TOvcBaseEntryField.SetAsStDate(Value : TStDate); + {-sets the field value to a Date Value} +begin + if (efDataType mod fcpDivisor) = fsubDate then + SetValue(Value) + else + raise EInvalidDataType.Create; +end; + +procedure TOvcBaseEntryField.SetAsStTime(Value : TStTime); + {-sets the field value to a Time Value} +begin + if efDataType mod fcpDivisor = fsubTime then + SetValue(Value) + else + raise EInvalidDataType.Create; +end; + +procedure TOvcBaseEntryField.SetAutoSize(Value : Boolean); +begin + if Value <> FAutoSize then begin + FAutoSize := Value; + + if not (csLoading in ComponentState) then + efAdjustSize; {adjust height based on font} + end; +end; + +procedure TOvcBaseEntryField.SetBorderStyle(Value : TBorderStyle); +begin + if FBorderStyle <> Value then begin + FBorderStyle := Value; +{$IFNDEF LCL} + RecreateWnd; +{$ELSE} + MyMisc.RecreateWnd(Self); +{$ENDIF} + end; +end; + +procedure TOvcBaseEntryField.SetBounds(ALeft, ATop, AWidth, AHeight : Integer); +begin + if FAutoSize and (AHeight <> Height) and + not (csLoading in ComponentState) then + FAutoSize := False; + + inherited SetBounds(ALeft, ATop, AWidth, AHeight); + + efCalcTopMargin; + + if HandleAllocated and (GetFocus = Handle) then + efPositionCaret(False); {adjust caret for new size} + Refresh; +end; + +procedure TOvcBaseEntryField.SetDecimalPlaces(Value : Byte); + {-set the number of decimal places for the edit field} +begin + if Value <> FDecimalPlaces then begin + FDecimalPlaces := Value; +{$IFNDEF LCL} + RecreateWnd; +{$ELSE} + MyMisc.RecreateWnd(Self); +{$ENDIF} + end; +end; + +procedure TOvcBaseEntryField.SetEpoch(Value : Integer); +begin + if Value <> FEpoch then + if (Value = 0) or ((Value >= MinYear) and (Value <= MaxYear)) then + FEpoch := Value; + if ControllerAssigned and (FEpoch = Controller.Epoch) then + FEpoch := 0; +end; + +procedure TOvcBaseEntryField.SetEverModified(Value : Boolean); + {-set the EverModified flag} +begin + if Value then + Include(sefOptions, sefEverModified) + else begin + Exclude(sefOptions, sefEverModified); + + {clear sefModified also} + Exclude(sefOptions, sefModified); + end; +end; + +procedure TOvcBaseEntryField.SetInsCaretType(const Value : TOvcCaret); + {-set the type of caret to use} +begin + if Value <> efCaret.InsCaretType then + efCaret.InsCaretType := Value; +end; + +procedure TOvcBaseEntryField.SetIntlSupport(Value : TOvcIntlSup); + {-set the international support object this field will use} +begin + if Assigned(Value) then + FIntlSup := Value + else + FIntlSup := OvcIntlSup; +end; + +procedure TOvcBaseEntryField.SetMaxLength(Value : Word); + {-set the maximum length of the edit field} +begin + if csLoading in ComponentState then + FMaxLength := Value + else if (FMaxLength <> Value) and + (Value > 0) and + (Value <= MaxEditLen) and + (Value >= efPicLen) then begin + FMaxLength := Value; + if StrLen(efEditSt) > FMaxLength then + efEditSt[FMaxLength] := #0; +{$IFNDEF LCL} + RecreateWnd; +{$ELSE} + MyMisc.RecreateWnd(Self); +{$ENDIF} + end; +end; + +procedure TOvcBaseEntryField.SetModified(Value : Boolean); + {-set the modified flag} +begin + if Value then begin + Include(sefOptions, sefModified); + + {set sefEverModified also} + Include(sefOptions, sefEverModified); + end else + Exclude(sefOptions, sefModified); +end; + +procedure TOvcBaseEntryField.SetOptions(Value : TOvcEntryFieldOptions); + {-set the options flags} +begin + if Value <> Options then begin + FOptions := Value; + if (efoForceInsert in FOptions) then + Exclude(FOptions, efoForceOvertype); + if (efoForceOvertype in FOptions) then + Exclude(FOptions, efoForceInsert); + if (efoRightJustify in FOptions) then + if efDataType mod fcpDivisor = fsubString then + Include(FOptions, efoTrimBlanks); + if (efoRightAlign in FOptions) then + efPositionCaret(True); + if not (efoTrimBlanks in FOptions) then begin + {if this is a string picture field then turn off right justify} + if efFieldClass = fcPicture then + if efDataType mod fcpDivisor = fsubString then + Exclude(FOptions, efoRightJustify); + end; + end; + efRemoveBadOptions; + Refresh; +end; + +procedure TOvcBaseEntryField.SetOvrCaretType(const Value : TOvcCaret); + {-set the type of caret to use} +begin + if Value <> efCaret.OvrCaretType then + efCaret.OvrCaretType := Value; +end; + +procedure TOvcBaseEntryField.SetPadChar(Value : AnsiChar); + {-set the character used to pad the end of the edit string} +begin + if Value <> FPadChar then begin + FPadChar := Value; + Refresh; + end; +end; + +procedure TOvcBaseEntryField.SetPasswordChar(Value : AnsiChar); + {-set the character used to mask password entry} +begin + if FPasswordChar <> Value then begin + FPasswordChar := Value; + if Value = #0 then + Exclude(FOptions, efoPasswordMode); + Refresh; + end; +end; + +procedure TOvcBaseEntryField.SetSelLength(Value : Integer); + {-set the extent of the selected text} +begin + SetSelection(efSelStart, efSelStart + Value); + Refresh; +end; + +procedure TOvcBaseEntryField.SetInitialValue; + {-resets the field value to its initial value} +begin + efSetInitialValue; +end; + +procedure TOvcBaseEntryField.SetInsertMode(Value : Boolean); + {-changes the field's insert mode} +begin + if Value <> (sefInsert in sefOptions) then begin + if Value then + Include(sefOptions, sefInsert) + else + Exclude(sefOptions, sefInsert); + Controller.InsertMode := Value; + efCaret.InsertMode := Value; + end; +end; + +procedure TOvcBaseEntryField.SetRangeHi(const Value : TRangeType); + {-set the high range for this field} +begin + case efDataType mod fcpDivisor of + fsubLongInt : efRangeHi.rtLong := Value.rtLong; + fsubWord : efRangeHi.rtLong := Value.rtWord; + fsubInteger : efRangeHi.rtLong := Value.rtInt; + fsubByte : efRangeHi.rtLong := Value.rtByte; + fsubShortInt : efRangeHi.rtLong := Value.rtSht; + fsubExtended : efRangeHi.rtExt := Value.rtExt; + fsubDouble : efRangeHi.rtExt := Value.rtDbl; + fsubSingle : efRangeHi.rtExt := Value.rtSgl; + fsubComp : efRangeHi.rtExt := Value.rtComp; + else + efRangeHi := Value; + end; + if (ValidateContents(true) > 0) + and (Parent <> nil) + and (Parent.Visible) + and (Parent.Enabled) then + SetFocus; +end; + +procedure TOvcBaseEntryField.SetRangeHiStr(const Value : string); + {-set the high field range from a string value} +var + R : TRangeType; +begin + R := efRangeHi; + if not (csLoading in ComponentState) then + if not efStRangeToRange(Value, R) then + raise EInvalidRangeValue.Create(efDataType mod fcpDivisor); + efRangeHi := R; + if (ValidateContents(true) > 0) + and (Parent <> nil) + and (Parent.Visible) + and (Parent.Enabled) then + SetFocus; +end; + +procedure TOvcBaseEntryField.SetRangeLo(const Value : TRangeType); + {-set the low range for this field} +begin + case efDataType mod fcpDivisor of + fsubLongInt : efRangeLo.rtLong := Value.rtLong; + fsubWord : efRangeLo.rtLong := Value.rtWord; + fsubInteger : efRangeLo.rtLong := Value.rtInt; + fsubByte : efRangeLo.rtLong := Value.rtByte; + fsubShortInt : efRangeLo.rtLong := Value.rtSht; + fsubExtended : efRangeLo.rtExt := Value.rtExt; + fsubDouble : efRangeLo.rtExt := Value.rtDbl; + fsubSingle : efRangeLo.rtExt := Value.rtSgl; + fsubComp : efRangeLo.rtExt := Value.rtComp; + else + efRangeLo := Value; + end; + if (ValidateContents(true) > 0) + and (Parent <> nil) + and (Parent.Visible) + and (Parent.Enabled) then + SetFocus; +end; + +procedure TOvcBaseEntryField.SetRangeLoStr(const Value : string); + {-set the low field range from a string value} +var + R : TRangeType; +begin + R := efRangeLo; + if not (csLoading in ComponentState) then + if not efStRangeToRange(Value, R) then + raise EInvalidRangeValue.Create(efDataType mod fcpDivisor); + efRangeLo := R; + if (ValidateContents(true) > 0) + and (Parent <> nil) + and (Parent.Visible) + and (Parent.Enabled) then + SetFocus; +end; + +procedure TOvcBaseEntryField.SetSelStart(Value : Integer); + {-set the starting position of the selection} +begin + SetSelection(Value, Value); + Refresh; +end; + +procedure TOvcBaseEntryField.SetSelText(const Value : string); + {-replace selected text with Value} +var + Msg : TMessage; + Buf : array[0..MaxEditLen] of AnsiChar; +begin + StrPCopy(Buf, Value); + Msg.lParam := LongInt(@Buf); + efPerformEdit(Msg, ccPaste); +end; + +procedure TOvcBaseEntryField.SetTextMargin(Value : Integer); + {-set the text margin} +begin + if (Value <> FTextMargin) and (Value >= 2) then begin + FTextMargin := Value; + Refresh; + end; +end; + +procedure TOvcBaseEntryField.SetUninitialized(Value : Boolean); + {-sets the Uninitialized option} +begin + if Value <> FUninitialized then begin + FUninitialized := Value; + efRemoveBadOptions; + end; +end; + +procedure TOvcBaseEntryField.SetUserData(Value : TOvcUserData); + {-sets pointer to user-defined mask data object} +begin + if Assigned(Value) then + FUserData := Value + else + FUserData := OvcUserData; +end; + +procedure TOvcBaseEntryField.SetValue(const Data); + {-changes the field value to the value in Data} +begin + if sefUserValidating in sefOptions then + Exit; + + HandleNeeded; + + {set the updating flag so OnChange doesn't get fired} + Include(sefOptions, sefUpdating); + try + case efDataType mod fcpDivisor of + fsubString : efTransfer(@ShortString(Data), otf_SetData); + fsubChar : efTransfer(@AnsiChar(Data), otf_SetData); + fsubBoolean : efTransfer(@Boolean(Data), otf_SetData); + fsubYesNo : efTransfer(@Boolean(Data), otf_SetData); + fsubLongInt : efTransfer(@LongInt(Data), otf_SetData); + fsubWord : efTransfer(@Word(Data), otf_SetData); + fsubInteger : efTransfer(@SmallInt(Data), otf_SetData); + fsubByte : efTransfer(@Byte(Data), otf_SetData); + fsubShortInt : efTransfer(@ShortInt(Data), otf_SetData); + fsubReal : efTransfer(@Real(Data), otf_SetData); + fsubExtended : efTransfer(@Extended(Data), otf_SetData); + fsubDouble : efTransfer(@Double(Data), otf_SetData); + fsubSingle : efTransfer(@Single(Data), otf_SetData); + fsubComp : efTransfer(@Comp(Data), otf_SetData); + fsubDate : efTransfer(@TStDate(Data), otf_SetData); + fsubTime : efTransfer(@TStTime(Data), otf_SetData); + else + raise EOvcException.Create(GetOrphStr(SCInvalidParamValue)); + end; + finally + Exclude(sefOptions, sefUpdating); + end; +end; + +procedure TOvcBaseEntryField.SetZeroDisplay(Value : TZeroDisplay); + {-set flag that determines if zeros are hidden} +begin + if Value <> FZeroDisplay then begin + FZeroDisplay := Value; + Refresh; + end; +end; + +procedure TOvcBaseEntryField.SetZeroDisplayValue(Value : Double); + {-set value used by ZeroDisplay logic} +begin + if Value <> FZeroDisplayValue then begin + FZeroDisplayValue := Value; + Refresh; + end; +end; + +function TOvcBaseEntryField.ValidateContents(ReportError : Boolean) : Word; + {-performs field validation, returns error code, and conditionally reports error} +var + WasValid : Boolean; +begin +{ - If the parent is not enabled or visible then don't attempt to } +{ validate the contents of the control. } + if (not (Enabled and Visible)) or (Parent = nil) + or (not (Parent.Enabled and Parent.Visible)) + then begin + Result := 0; + Exit; + end; + + FLastError := 0; + + {record current valid state} + WasValid := IsValid; + + {check for empty/uninitialized required field} + if (efoInputRequired in Options) and not efIsReadOnly then + if efFieldIsEmpty or (Uninitialized and not (sefModified in sefOptions)) then + FLastError := oeRequiredField; + + {ask the validation routine if there's an error} + if FLastError = 0 then begin + Include(sefOptions, sefValidating); + try + FLastError := efValidateField; + finally + Exclude(sefOptions, sefValidating); + end; + end; + + if ReportError and (FLastError <> 0) then + PostMessage(Handle, om_ReportError, FLastError, 0); + + {update invalid flag} + if FLastError = 0 then + Exclude(sefOptions, sefInvalid) + else if efoSoftValidation in Options then + Include(sefOptions, sefInvalid); + + {force field to repaint if valid state has changed} + if WasValid <> IsValid then + Invalidate; + + Result := FLastError; +end; + +function TOvcBaseEntryField.ValidateSelf : Boolean; + {-performs field validation, returns true if no errors, and reports error if not using SoftValidation} +begin + Result := ValidateContents(not (efoSoftValidation in Options)) = 0; +end; + +procedure TOvcBaseEntryField.WMChar(var Msg : TWMChar); +begin + inherited; + + if sefCharOk in sefOptions then + efPerformEdit(TMessage(Msg), ccChar); +end; + +procedure TOvcBaseEntryField.WMClear(var Msg : TWMClear); +begin + efPerformEdit(TMessage(Msg), ccCut); +end; + +procedure TOvcBaseEntryField.WMCopy(var Msg : TWMCopy); +begin + efPerformEdit(TMessage(Msg), ccCopy); +end; + +procedure TOvcBaseEntryField.WMCut(var Msg : TWMCut); +begin + efCopyPrim; + efPerformEdit(TMessage(Msg), ccCut); +end; + +procedure TOvcBaseEntryField.WMEraseBkGnd(var Msg : TWMEraseBkGnd); +begin + Msg.Result := 1; {don't erase background} +end; + +procedure TOvcBaseEntryField.WMGetDlgCode(var Msg : TWMGetDlgCode); +begin + inherited; + + if csDesigning in ComponentState then + Msg.Result := DLGC_STATIC + else + Msg.Result := Msg.Result or DLGC_WANTCHARS or DLGC_WANTARROWS; +end; + +procedure TOvcBaseEntryField.WMKeyDown(var Msg : TWMKeyDown); +var + Cmd : Word; +begin + inherited; + + if Msg.CharCode = 0 then + Exit; + + {don't process shift key by itself} + if Msg.CharCode = VK_SHIFT then + Exit; + + {see if this command should be processed by us} + Cmd := Controller.EntryCommands.Translate(TMessage(Msg)); + + {convert undo to restore since ctrl-Z is mapped to ccUndo by default} + {and cannot be mapped to more than one command in a command table} + if Cmd = ccUndo then + Cmd := ccRestore; + + if Cmd <> ccNone then begin + if (Cmd <> ccIns) or + not ((efoForceInsert in Options) or + (efoForceOvertype in Options)) then begin + case Cmd of + ccCut : WMCut(TWMCut(Msg)); + ccCopy : WMCopy(TWMCopy(Msg)); + ccPaste : WMPaste(TWMPaste(Msg)); + else + efPerformEdit(TMessage(Msg), Cmd); + end; + end; + end; +end; + +procedure TOvcBaseEntryField.WMKillFocus(var Msg : TWMKillFocus); +var + NewWindow : HWnd; + SaveModified : Boolean; +begin + {where is the focus going?} + NewWindow := Msg.FocusedWnd; + if NewWindow = Handle then + NewWindow := 0 + else if not efIsSibling(NewWindow) then + NewWindow := 0; + + {retain caret position if focus is moving } + {to a menu or a component not on this form} + if (NewWindow = 0) then + Include(sefOptions, sefRetainPos) + else + Exclude(sefOptions, sefRetainPos); + + {destroy caret} + efCaret.Linked := False; + + {if the mouse if currently captured, release it} + if MouseCapture then + MouseCapture := False; + + {perform default processing} + inherited; + + {set controller's insert mode flag for sibling fields' to access} + if not ((efoForceInsert in Options) or + (efoForceOvertype in Options)) then + {are we in insert mode} + Controller.InsertMode := sefInsert in sefOptions; + + {if no error is pending for this control...} + if not (sefErrorPending in sefOptions) and + not (sefIgnoreFocus in sefOptions) then begin + Include(sefOptions, sefValPending); + + {and focus is going to a control...} + if (NewWindow <> 0) then begin + if sefModified in sefOptions then + {clear the unitialized option} + Uninitialized := False; + + {that isn't a Cancel, Restore, or Help button...} + if not Controller.IsSpecialButton(Msg.FocusedWnd) then begin + {then validate this field} + efCanClose(True {validate}); + if sefErrorPending in sefOptions then + Include(sefOptions, sefValPending) + else + Exclude(sefOptions, sefValPending); + end else begin + {just call validate field and ignore the error, if any} + {this forces the field to redisplay using the proper format} + SaveModified := Modified; + efValidateField; + Modified := SaveModified; + end; + end; + end else begin + {set the validation pending flag on if an error is pending} + if sefErrorPending in sefOptions then + Include(sefOptions, sefValPending) + else + Exclude(sefOptions, sefValPending); + end; + + {we no longer have the focus} + Exclude(sefOptions, sefHaveFocus); + + {if we're not coming back...} + if (NewWindow <> 0) and not (sefRetainPos in sefOptions) and + not (sefIgnoreFocus in sefOptions) then begin + efPerformPostEditNotify(FindControl(Msg.FocusedWnd)); + end; + Exclude(sefOptions, sefIgnoreFocus); + + {reset the caret position} + if not (sefRetainPos in sefOptions) then + efCaretToStart; + + {redraw the field} + Refresh; +end; + +procedure TOvcBaseEntryField.WMLButtonDblClk(var Msg : TWMLButtonDblClk); +begin + if sefHaveFocus in sefOptions then + efPerformEdit(TMessage(Msg), ccDblClk); + + inherited; +end; + +procedure TOvcBaseEntryField.WMLButtonDown(var Msg : TWMLButtonDown); +begin + inherited; + + if not (sefHaveFocus in sefOptions) then begin + Include(sefOptions, sefNoHighlight); + SetSelection(0, 0); + if not Focused then + SetFocus; + end; + +// inherited; + + if sefHaveFocus in sefOptions then + efPerformEdit(TMessage(Msg), ccMouse); +end; + +procedure TOvcBaseEntryField.WMMouseActivate(var Msg : TWMMouseActivate); +begin + if csDesigning in ComponentState then + Exit; + + inherited; +end; + +procedure TOvcBaseEntryField.WMMouseMove(var Msg : TWMMouseMove); +begin + inherited; + + if MouseCapture then + if {$IFNDEF LCL} GetAsyncKeyState(GetLeftButton) {$ELSE} GetKeyState(GetLeftButton) {$ENDIF} and $8000 <> 0 then + efPerformEdit(TMessage(Msg), ccMouseMove); +end; + +procedure TOvcBaseEntryField.WMPaste(var Msg : TWMPaste); + {-paste text in the clipboard into the field} +var + H : THandle; +begin +{$IFNDEF LCL} + H := Clipboard.GetAsHandle(CF_TEXT); + if H <> 0 then begin + TMessage(Msg).lParam := LongInt(GlobalLock(H)); + efPerformEdit(TMessage(Msg), ccPaste); + GlobalUnlock(H); + end; +{$ENDIF} +end; + +procedure TOvcBaseEntryField.WMRButtonUp(var Msg : TWMRButtonDown); +var + P : TPoint; + M : TPopUpMenu; + MI : TMenuItem; +begin + if not (sefHaveFocus in sefOptions) then + if not Focused and CanFocus then + SetFocus; + + inherited; + if PopUpMenu = nil then begin + M := TPopupMenu.Create(Self); + try + MI := TMenuItem.Create(M); + MI.Caption := GetOrphStr(SCRestoreMI); + MI.Enabled := Modified; + MI.OnClick := DoRestoreClick; + M.Items.Add(MI); + + MI := TMenuItem.Create(M); + MI.Caption := '-'; + M.Items.Add(MI); + + MI := TMenuItem.Create(M); + MI.Caption := GetOrphStr(SCCutMI); + MI.Enabled := (SelectionLength > 0) and not efIsReadOnly; + MI.OnClick := DoCutClick; + M.Items.Add(MI); + + MI := TMenuItem.Create(M); + MI.Caption := GetOrphStr(SCCopyMI); + MI.Enabled := SelectionLength > 0; + MI.OnClick := DoCopyClick; + M.Items.Add(MI); + + MI := TMenuItem.Create(M); + MI.Caption := GetOrphStr(SCPasteMI); + MI.Enabled := not efIsReadOnly and Clipboard.HasFormat(CF_TEXT); + MI.OnClick := DoPasteClick; + M.Items.Add(MI); + + MI := TMenuItem.Create(M); + MI.Caption := GetOrphStr(SCDeleteMI); + MI.Enabled := (SelectionLength > 0) and not efIsReadOnly; + MI.OnClick := DoDeleteClick; + M.Items.Add(MI); + + MI := TMenuItem.Create(M); + MI.Caption := '-'; + M.Items.Add(MI); + + MI := TMenuItem.Create(M); + MI.Caption := GetOrphStr(SCSelectAllMI); + MI.Enabled := LongInt(StrLen(efEditSt)) > SelectionLength; + MI.OnClick := DoSelectAllClick; + M.Items.Add(MI); + + P.X := Msg.XPos; + P.Y := Msg.YPos; + P := ClientToScreen(P); + M.PopUp(P.X, P.Y); + + Application.ProcessMessages; + finally + M.Free; + end; + end; +end; + +procedure TOvcBaseEntryField.WMSetFocus(var Msg : TWMSetFocus); +var + Highlight, + Ignore, + FixHOfs, + ValPending : Boolean; + PF : TForm; + P : TPoint; +begin + if ((csLoading in ComponentState) or + (csDesigning in ComponentState)) then + Exit; + + {we have the focus} + Include(sefOptions, sefHaveFocus); + + {reset command processor} + Controller.EntryCommands.ResetCommandProcessor; + + {get validation state} + ValPending := sefValPending in sefOptions; + + {calling Show forces the parent to do whatever is necessary to} + {make sure that we are visible. In the case where the entry} + {field is on a non-visible notebook page that has had its} + {handle deallocated, this insures that the page is made visible} + {and that the window handles have been created} + + {if focus is retruning because of an error condition} + if ValPending then begin + + {tell the control that lost the focus to} + {cancel any special modes it might be in} + if Msg.FocusedWnd > 0 then begin + SendMessage(Msg.FocusedWnd, WM_CANCELMODE, 0, 0); + GetCursorPos(P); + {send a fake mouse up message to force release of mouse capture} + {this is necessary so that the TStringGrid exits highlight mode} + SendMessage(Msg.FocusedWnd, WM_LBUTTONUP, 0, MakeLong(P.X, P.Y)); + end; + + Show; + PF := TForm(GetParentForm(Self)); + if Assigned(PF) then + PF.FocusControl(Self); + end; + + {get the field's insert mode} + if not ((efoForceInsert in Options) or + (efoForceOvertype in Options)) then + if Controller.InsertMode then + Include(sefOptions, sefInsert) + else + Exclude(sefOptions, sefInsert); + + if sefRetainPos in sefOptions then begin + Highlight := False; + FixHOfs := False; + Ignore := False; + end else begin + Ignore := Controller.ErrorPending and {not us} (FLastError = 0); + if not Ignore then begin + if not ValPending then + Exclude(sefOptions, sefModified); + efPerformPreEditNotify(FindControl(Msg.FocusedWnd)); + {save a copy of the current edit string} + efSaveEditString; + end; + + if sefNoHighlight in sefOptions then begin + Highlight := False; + FixHOfs := False; + end else begin + Highlight := (not Ignore); + FixHOfs := True; + efResetCaret; + end; + end; + + if Ignore and not (efoSoftValidation in Options) then + Include(sefOptions, sefIgnoreFocus) + else + Exclude(sefOptions, sefIgnoreFocus); + + Exclude(sefOptions, sefErrorPending); + Exclude(sefOptions, sefRetainPos); + Exclude(sefOptions, sefNoHighlight); + Exclude(sefOptions, sefValPending); + + {clear controller's error pending flag} + if not Ignore then + Controller.ErrorPending := False; + + inherited; + + if (efoForceInsert in Options) then + Include(sefOptions, sefInsert) + else if (efoForceOvertype in Options) then + Exclude(sefOptions, sefInsert); + + efCaret.Linked := True; + efCaret.Visible := True; + efCaret.InsertMode := (sefInsert in sefOptions); + efPositionCaret(FixHOfs); + + if Highlight and (efoAutoSelect in Controller.EntryOptions) then + SetSelection(0, MaxEditLen); + + Refresh; +end; + +procedure TOvcBaseEntryField.WMSetFont(var Msg : TWMSetFont); +begin + inherited; + + {inherited WMSetFont sets our font. Set it as our canvas font} + Canvas.Font := Font; +end; + +procedure TOvcBaseEntryField.WMSetText(var Msg : TWMSetText); +begin + if HandleAllocated then begin + SetSelection(0, MaxEditLen); + efPerformEdit(TMessage(Msg), ccPaste); + end; +end; + +procedure TOvcBaseEntryField.WMSize(var Msg : TWMSize); +begin + inherited; + + Refresh; +end; + +procedure TOvcBaseEntryField.WMSysKeyDown(var Msg : TWMSysKeyDown); +var + Cmd : Word; +begin + inherited; + + {exit if this is a Tab key or an Alt key by itself} + if (Msg.CharCode = VK_TAB) or (Msg.CharCode = VK_ALT) then + Exit; + + {see if this command should be processed by us} + Cmd := Controller.EntryCommands.TranslateKey(Msg.CharCode, [ssAlt]); + + {convert undo to restore since ctrl-Z is mapped to ccUndo by default} + {and cannot be mapped to more than one command in a command table} + if Cmd = ccUndo then + Cmd := ccRestore; + + if Cmd <> ccNone then begin + case Cmd of + ccCut : WMCut(TWMCut(Msg)); + ccCopy : WMCopy(TWMCopy(Msg)); + ccPaste : WMPaste(TWMPaste(Msg)); + else + efPerformEdit(TMessage(Msg), Cmd); + end; + + {allow entering of characters using Alt-keypad numbers} + case Msg.CharCode of + vk_NumPad0, vk_NumPad1, vk_NumPad2, vk_NumPad3, vk_NumPad4, + vk_NumPad5, vk_NumPad6, vk_NumPad7, vk_NumPad8, vk_NumPad9: + begin + Include(sefOptions, sefCharOk); + Include(sefOptions, sefAcceptChar); + end; + end; + end; +end; + + +end. diff --git a/components/orpheus/ovcexcpt.pas b/components/orpheus/ovcexcpt.pas new file mode 100644 index 000000000..e6f42378f --- /dev/null +++ b/components/orpheus/ovcexcpt.pas @@ -0,0 +1,372 @@ +{*********************************************************} +{* OVCEXCPT.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovcexcpt; + {-Exceptions unit} + +interface + +uses + {$IFNDEF LCL} Windows, {$ELSE} LclIntf, {$ENDIF} + Classes, SysUtils, OvcData, OvcConst, OvcIntl; + +type + {*** Base Orpheus exeption class ***} + EOvcException = class(Exception) + public + ErrorCode : LongInt; + end; + + {*** General ***} + ENoTimersAvailable = class(EOvcException) + public + constructor Create; + end; + + {*** Controller ***} + EControllerError = class(EOvcException); + ENoControllerAssigned = class(EControllerError) + public + constructor Create; + end; + + {*** Command Processor ***} + ECmdProcessorError = class(EOvcException); + EDuplicateCommand = class(ECmdProcessorError) + public + constructor Create; + end; + + ETableNotFound = class(ECmdProcessorError) + public + constructor Create; + end; + + {*** Entry Fields ***} + EEntryFieldError = class(EOvcException); + EInvalidDataType = class(EEntryFieldError) + public + constructor Create; + end; + + EInvalidPictureMask = class(EEntryFieldError) + public + constructor Create(const Mask : string); + end; + + EInvalidRangeValue = class(EEntryFieldError) + public + constructor Create(DataType : Byte); + end; + + EInvalidDateForMask = class(EEntryFieldError) + public + constructor Create; + end; + + {*** Editors ***} + EEditorError = class(EOvcException) + public + constructor Create(const Msg : string; Error : Cardinal); + end; + + EInvalidLineOrCol = class(EEditorError) + public + constructor Create; + end; + + EInvalidLineOrPara = class(EEditorError) + public + constructor Create; + end; + + {*** Viewers ***} + EViewerError = class(EOvcException); + ERegionTooLarge = class(EViewerError) + public + constructor Create; + end; + + {*** Notebook ***} + ENotebookError = class(EOvcException); + EInvalidPageIndex = class(ENotebookError) + public + constructor Create; + end; + + EInvalidTabFont = class(ENotebookError) + public + constructor Create; + end; + + {*** Rotated Label ***} + ERotatedLabelError = class(EOvcException); + EInvalidLabelFont = class(ERotatedLabelError) + public + constructor Create; + end; + + {*** Timer Pool ***} + ETimerPoolError = class(EOvcException); + EInvalidTriggerHandle = class(ETimerPoolError) + public + constructor Create; + end; + + {*** Virtual ListBox ***} + EVirtualListBoxError = class(EOvcException); + EOnSelectNotAssigned = class(EVirtualListBoxError) + public + constructor Create; + end; + + EOnIsSelectedNotAssigned = class(EVirtualListBoxError) + public + constructor Create; + end; + + {*** Report View ***} + EReportViewError = class(EOvcException) { generic report view exception} + constructor Create(ErrorCode : Integer; Dummy : Byte); + constructor CreateFmt(ErrorCode : Integer; const Args : array of const; Dummy : Byte); + end; + EUnknownView = class(EReportViewError); { unknown view name } + EItemNotFound = class(EReportViewError); { attempt to change/remove nonexistent item} + EItemAlreadyAdded = class(EReportViewError); { attempt to re-add existing item } + EUpdatePending = class(EReportViewError); { operation is invalid while updates are pending } + EItemIsNotGroup = class(EReportViewError); { item at specified line is not a group (IsGroup = False) } + ELineNoOutOfRange = class(EReportViewError); { specified line is invalid (out of range) } + ENotMultiSelect = class(EReportViewError); { operation is invalid while MultiSelect is false } + EItemNotInIndex = class(EReportViewError); { specified data item is not in index } + ENoActiveView = class(EReportViewError); { no active view } + EOnCompareNotAsgnd = class(EReportViewError); { unassigned OnCompareFields } + EGetAsFloatNotAsg = class(EReportViewError); { unassigned OnGetFieldAsFloat } + EOnFilterNotAsgnd = class(EReportViewError); { unassigned OnFilter } + + {*** Sparse Array ***} + ESparseArrayError = class(EOvcException); + ESAEAtMaxSize = class(ESparseArrayError); + ESAEOutOfBounds = class(ESparseArrayError); + + {*** Fixed Font ***} + EFixedFontError = class(EOvcException); + EInvalidFixedFont = class(EFixedFontError) + public + constructor Create; + end; + + EInvalidFontParam = class(EFixedFontError) + public + constructor Create; + end; + + {*** MRU List ***} + EMenuMRUError = class(EOvcException); + +implementation + + +{*** General ***} + +constructor ENoTimersAvailable.Create; +begin + inherited Create(GetOrphStr(SCNoTimersAvail)); +end; + + +{*** Controller ***} + +constructor ENoControllerAssigned.Create; +begin + inherited Create(GetOrphStr(SCNoControllerAssigned)); +end; + + +{*** Command Processor ***} + +constructor ETableNotFound.Create; +begin + inherited Create(GetOrphStr(SCTableNotFound)); +end; + +constructor EDuplicateCommand.Create; +begin + inherited Create(GetOrphStr(SCDuplicateCommand)); +end; + + +{*** Entry Fields ***} + +constructor EInvalidDataType.Create; +begin + inherited Create(GetOrphStr(SCInvalidDataType)); +end; + +constructor EInvalidPictureMask.Create(const Mask : string); +begin + inherited CreateFmt(GetOrphStr(SCInvalidPictureMask), [Mask]); +end; + +constructor EInvalidRangeValue.Create(DataType : Byte); +var + S : string; +begin + case DataType of + fsubLongInt : inherited CreateFmt(GetOrphStr(SCInvalidRange), [Low(LongInt), High(LongInt)]); + fsubWord : inherited CreateFmt(GetOrphStr(SCInvalidRange), [Low(Word), High(Word)]); + fsubInteger : inherited CreateFmt(GetOrphStr(SCInvalidRange), [Low(SmallInt), High(SmallInt)]); + fsubByte : inherited CreateFmt(GetOrphStr(SCInvalidRange), [Low(Byte), High(Byte)]); + fsubShortInt : inherited CreateFmt(GetOrphStr(SCInvalidRange), [Low(ShortInt), High(ShortInt)]); + fsubReal : inherited Create(GetOrphStr(SCInvalidRealRange)); + fsubExtended : inherited Create(GetOrphStr(SCInvalidExtendedRange)); + fsubDouble : inherited Create(GetOrphStr(SCInvalidDoubleRange)); + fsubSingle : inherited Create(GetOrphStr(SCInvalidSingleRange)); + fsubComp : inherited Create(GetOrphStr(SCInvalidCompRange)); + fsubDate : + begin + S := OvcIntlSup.InternationalDate(True); + inherited CreateFmt(GetOrphStr(SCInvalidDateRange), [S]); + end; + fsubTime : + begin + S := OvcIntlSup.InternationalTime(False); + inherited CreateFmt(GetOrphStr(SCInvalidTimeRange), [S]); + end; + else + inherited Create(GetOrphStr(SCInvalidRangeValue)); + end; +end; + +constructor EInvalidDateForMask.Create; +begin + inherited Create(GetOrphStr(SCInvalidDateForMask)); +end; + + +{*** Editors ***} + +constructor EEditorError.Create(const Msg : string; Error : Cardinal); +begin + ErrorCode := Error; + inherited Create(Msg); +end; + +constructor EInvalidLineOrCol.Create; +begin + inherited Create(GetOrphStr(SCInvalidLineOrColumn), 0); +end; + +constructor EInvalidLineOrPara.Create; +begin + inherited Create(GetOrphStr(SCInvalidLineOrParaIndex), 0); +end; + + +{*** Viewers ***} + +constructor ERegionTooLarge.Create; +begin + inherited Create(GetOrphStr(SCRegionTooLarge)); +end; + + +{*** Notebook ***} + +constructor EInvalidPageIndex.Create; +begin + inherited Create(GetOrphStr(SCInvalidPageIndex)); +end; + +constructor EInvalidTabFont.Create; +begin + inherited Create(GetOrphStr(SCInvalidTabFont)); +end; + + +{*** Rotated Label ***} + +constructor EInvalidLabelFont.Create; +begin + inherited Create(GetOrphStr(SCInvalidLabelFont)); +end; + + +{*** Timer Pool ***} + +constructor EInvalidTriggerHandle.Create; +begin + inherited Create(GetOrphStr(SCBadTriggerHandle)); +end; + + +{*** Virtual ListBox ***} + +constructor EOnSelectNotAssigned.Create; +begin + inherited Create(GetOrphStr(SCOnSelectNotAssigned)); +end; + +constructor EOnIsSelectedNotAssigned.Create; +begin + inherited Create(GetOrphStr(SCOnIsSelectedNotAssigned)); +end; + + +{*** Fixed Font ***} + +constructor EInvalidFixedFont.Create; +begin + inherited Create(GetOrphStr(SCNonFixedFont)); +end; + +constructor EInvalidFontParam.Create; +begin + inherited Create(GetOrphStr(SCInvalidFontParam)); +end; + + +constructor EReportViewError.Create(ErrorCode : Integer; Dummy : Byte); +begin + inherited Create(GetOrphStr(ErrorCode)); +end; + +constructor EReportViewError.CreateFmt(ErrorCode : Integer; const Args : array of const; Dummy : Byte); +begin + inherited CreateFmt(GetOrphStr(ErrorCode),Args); +end; + +end. diff --git a/components/orpheus/ovcintl.pas b/components/orpheus/ovcintl.pas new file mode 100644 index 000000000..fed170480 --- /dev/null +++ b/components/orpheus/ovcintl.pas @@ -0,0 +1,1651 @@ +{*********************************************************} +{* OVCINTL.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovcintl; + {-International date/time support class} + +interface + +uses + {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, LclType, MyMisc, {$ENDIF} + Registry, Classes, Forms, SysUtils, OvcConst, OvcData, OvcStr, OvcDate; + +type + TCurrencySt = array[0..5] of AnsiChar; + + {.Z+} + TIntlData = packed record + {substitution strings for semi-literal mask characters} + CurrencyLtStr : TCurrencySt; {corresponding string for 'c'} + CurrencyRtStr : TCurrencySt; {corresponding string for 'C'} + DecimalChar : AnsiChar; {character used for decimal point} + CommaChar : AnsiChar; {character used for comma} + {format specifiers for currency masks} + CurrDigits : Byte; {number of dec places in currency} + SlashChar : AnsiChar; {date seperator} + {characters that represent boolean values} + TrueChar : AnsiChar; + FalseChar : AnsiChar; + YesChar : AnsiChar; + NoChar : AnsiChar; + end; + {.Z-} + +type + TOvcIntlSup = class(TObject) + {.Z+} + protected {private} + FAutoUpdate : Boolean; {true to reset settings when win.ini changes} + + {substitution strings for semi-literal mask characters} + FCurrencyLtStr : TCurrencySt; {corresponding string for 'c'} + FCurrencyRtStr : TCurrencySt; {corresponding string for 'C'} + FDecimalChar : AnsiChar; {character used for decimal point} + + {general international settings} + FCommaChar : AnsiChar; {character used for comma} + FCurrencyDigits : Byte; {number of dec places in currency} + FListChar : AnsiChar; {list serarater} + FSlashChar : AnsiChar; {character used to separate dates} + + {characters that represent boolean values} + FTrueChar : AnsiChar; + FFalseChar : AnsiChar; + FYesChar : AnsiChar; + FNoChar : AnsiChar; + + {event variables} + FOnWinIniChange : TNotifyEvent; {notify of win.ini changes} + + {internal working variables} + intlHandle : hWnd; {our window handle} + w1159 : array[0..5] of AnsiChar; + w2359 : array[0..5] of AnsiChar; + wColonChar : AnsiChar; + wCountry : PAnsiChar; + wCurrencyForm : Byte; + wldSub1 : array[0..5] of AnsiChar; + wldSub2 : array[0..5] of AnsiChar; + wldSub3 : array[0..5] of AnsiChar; + wLongDate : array[0..39] of AnsiChar; + wNegCurrencyForm : Byte; + wShortDate : array[0..29] of AnsiChar; + wTLZero : Boolean; + w12Hour : Boolean; + + {property methods} + function GetCountry : string; + function GetCurrencyLtStr : string; + function GetCurrencyRtStr : string; + procedure SetAutoUpdate(Value : Boolean); + procedure SetCurrencyLtStr(const Value : string); + procedure SetCurrencyRtStr(const Value : string); + + {internal methods} + procedure isExtractFromPicture(Picture, S : PAnsiChar; Ch : AnsiChar; + var I : Integer; Blank, Default : Integer); + procedure isIntlWndProc(var Msg : TMessage); + function isMaskCharCount(P : PAnsiChar; MC : AnsiChar) : Word; + procedure isMergeIntoPicture(Picture : PAnsiChar; Ch : AnsiChar; I : Integer); + procedure isMergePictureSt(Picture, P : PAnsiChar; MC : AnsiChar; SP : PAnsiChar); + procedure isPackResult(Picture, S : PAnsiChar); + procedure isSubstChar(Picture : PAnsiChar; OldCh, NewCh : AnsiChar); + procedure isSubstCharSim(P : PAnsiChar; OC, NC : AnsiChar); + function isTimeToTimeStringPrim(Dest, Picture : PAnsiChar; T : TStTime; + Pack : Boolean; t1159, t2359 : PAnsiChar) : PAnsiChar; + + public + constructor Create; + destructor Destroy; + override; + {.Z-} + + function CurrentDateString(const Picture : string; + Pack : Boolean) : string; + {.Z+} + function CurrentDatePChar(Dest : PAnsiChar; Picture : PAnsiChar; + Pack : Boolean) : PAnsiChar; + {-returns today's date as a string of the specified form} + {.Z-} + + function CurrentTimeString(const Picture : string; Pack : Boolean) : string; + {.Z+} + function CurrentTimePChar(Dest : PAnsiChar; Picture : PAnsiChar; Pack : Boolean) : PAnsiChar; + {-returns current time as a string of the specified form} + {.Z-} + + function DateToDateString(const Picture : string; Julian : TStDate; + Pack : Boolean) : string; + {.Z+} + function DateToDatePChar(Dest : PAnsiChar; Picture : PAnsiChar; Julian : TStDate; + Pack : Boolean) : PAnsiChar; + {.Z-} + {-convert Julian to a string of the form indicated by Picture} + + function DateStringToDMY(const Picture, S : string; var Day, Month, Year : Integer; + Epoch : Integer) : Boolean; + {.Z+} + function DatePCharToDMY(Picture, S : PAnsiChar; var Day, Month, Year : Integer; + Epoch : Integer) : Boolean; + {.Z-} + {-extract day, month, and year from S, returning true if string is valid} + + function DateStringIsBlank(const Picture, S : string) : Boolean; + {.Z+} + function DatePCharIsBlank(Picture, S : PAnsiChar) : Boolean; + {.Z-} + {-return True if the month, day, and year in S are all blank} + + function DateStringToDate(const Picture, S : string; Epoch : Integer) : TStDate; + {.Z+} + function DatePCharToDate(Picture, S : PAnsiChar; Epoch : Integer) : TStDate; + {.Z-} + {-convert St, a string of the form indicated by Picture, to a julian date. Picture and St must be of equal lengths} + + function DayOfWeekToString(WeekDay : TDayType) : string; + {.Z+} + function DayOfWeekToPChar(Dest : PAnsiChar; WeekDay : TDayType) : PAnsiChar; + {.Z-} + {-return a string for the specified day of the week} + + function DMYtoDateString(const Picture : string; + Day, Month, Year : Integer; Pack : Boolean; Epoch : Integer) : string; + {.Z+} + function DMYtoDatePChar(Dest : PAnsiChar; Picture : PAnsiChar; + Day, Month, Year : Integer; Pack : Boolean; Epoch : Integer) : PAnsiChar; + {.Z-} + {-merge the month, day, and year into the picture} + + function InternationalCurrency(FormChar : AnsiChar; MaxDigits : Byte; Float, + AddCommas, IsNumeric : Boolean) : string; + {.Z+} + function InternationalCurrencyPChar(Dest : PAnsiChar; FormChar : AnsiChar; + MaxDigits : Byte; Float, + AddCommas, IsNumeric : Boolean) : PAnsiChar; + {.Z-} + {-return a picture mask for a currency string, based on Windows' intl info} + + function InternationalDate(ForceCentury : Boolean) : string; + {.Z+} + function InternationalDatePChar(Dest : PAnsiChar; ForceCentury : Boolean) : PAnsiChar; + {.Z-} + {-return a picture mask for a short date string, based on Windows' international information} + + function InternationalLongDate(ShortNames : Boolean; ExcludeDOW : Boolean) : string; + {.Z+} + function InternationalLongDatePChar(Dest : PAnsiChar; ShortNames : Boolean; ExcludeDOW : Boolean) : PAnsiChar; + {.Z-} + {-return a picture mask for a date string, based on Windows' international information} + + function InternationalTime(ShowSeconds : Boolean) : string; + {.Z+} + function InternationalTimePChar(Dest : PAnsiChar; ShowSeconds : Boolean) : PAnsiChar; + {.Z-} + {-return a picture mask for a time string, based on Windows' international information} + + function MonthStringToMonth(const S : string; Width : Byte) : Byte; + {.Z+} + function MonthPCharToMonth(S : PAnsiChar; Width : Byte) : Byte; + {.Z-} + {-Convert the month name in S to a month (1..12)} + + function MonthToString(Month : Integer) : string; + {.Z+} + function MonthToPChar(Dest : PAnsiChar; Month : Integer) : PAnsiChar; + {.Z-} + {return month name as a string for Month} + + procedure ResetInternationalInfo; + {-read string resources and update internal info to match Windows'} + + function TimeStringToHMS(const Picture, S : string; var Hour, Minute, Second : Integer) : Boolean; + {.Z+} + function TimePCharToHMS(Picture, S : PAnsiChar; var Hour, Minute, Second : Integer) : Boolean; + {.Z-} + {-extract Hours, Minutes, Seconds from St, returning true if string is valid} + + function TimeStringToTime(const Picture, S : string) : TStTime; + {.Z+} + function TimePCharToTime(Picture, S : PAnsiChar) : TStTime; + {.Z-} + {-convert S, a string of the form indicated by Picture, to a Time variable} + + function TimeToTimeString(const Picture : string; T : TStTime; Pack : Boolean) : string; + {.Z+} + function TimeToTimePChar(Dest : PAnsiChar; Picture : PAnsiChar; T : TStTime; Pack : Boolean) : PAnsiChar; + {.Z-} + {-convert T to a string of the form indicated by Picture} + + function TimeToAmPmString(const Picture : string; T : TStTime; Pack : Boolean) : string; + {.Z+} + function TimeToAmPmPChar(Dest : PAnsiChar; Picture : PAnsiChar; T : TStTime; Pack : Boolean) : PAnsiChar; + {.Z-} + {-convert T to a string of the form indicated by Picture. Times are always displayed in am/pm format.} + + property AutoUpdate : Boolean + read FAutoUpdate write SetAutoUpdate; + property CurrencyLtStr : string + read GetCurrencyLtStr write SetCurrencyLtStr; + property CurrencyRtStr : string + read GetCurrencyRtStr write SetCurrencyRtStr; + property DecimalChar : AnsiChar + read FDecimalChar write FDecimalChar; + property CommaChar : AnsiChar + read FCommaChar write FCommaChar; + property Country : string + read GetCountry; + property CurrencyDigits : Byte + read FCurrencyDigits write FCurrencyDigits; + property ListChar : AnsiChar + read FListChar write FListChar; + property SlashChar : AnsiChar + read FSlashChar write FSlashChar; + property TrueChar : AnsiChar + read FTrueChar write FTrueChar; + property FalseChar : AnsiChar + read FFalseChar write FFalseChar; + property YesChar : AnsiChar + read FYesChar write FYesChar; + property NoChar : AnsiChar + read FNoChar write FNoChar; + property OnWinIniChange : TNotifyEvent + read FOnWinIniChange write FOnWinIniChange; + end; + +const + DefaultIntlData : TIntlData = ( + {substitution strings for semi-literal mask characters} + CurrencyLtStr : '$'; {corresponding string for 'c'} + CurrencyRtStr : ''; {corresponding string for 'C'} + DecimalChar : '.'; {character used for decimal point} + CommaChar : ','; {character used for comma} + {format specifiers for currency masks} + CurrDigits : 2; {number of dec places in currency} + SlashChar : '/'; {date seperator} + {characters that represent boolean values} + TrueChar : 'T'; + FalseChar : 'F'; + YesChar : 'Y'; + NoChar : 'N'); + +var + {global default international support object} + OvcIntlSup : TOvcIntlSup; + +implementation + +{*** Inline routines ***} + +{$IFDEF NoAsm} +function GetMaxWord(A, B : Word) : Word; +begin + if A >= B then + Result := A + else + Result := B; +end; +{$ELSE} +function GetMaxWord(A, B : Word) : Word; register; + {-Return the greater of A and B} +asm + and eax,0FFFFH {faster than movzx } + and edx,0FFFFH {faster than movzx } + cmp eax,edx {compare A and B } + jae @@001 {done if ax is greater or equal } + mov eax,edx {dx is larger, set result } +@@001: +end; +{$ENDIF} + +{*** TOvcIntlSup ***} + +constructor TOvcIntlSup.Create; +begin + inherited Create; + + FAutoUpdate := False; + + {substitution strings for semi-literal mask characters} + StrCopy(FCurrencyLtStr, DefaultIntlData.CurrencyLtStr); + StrCopy(FCurrencyRtStr, DefaultIntlData.CurrencyRtStr); + FDecimalChar := DefaultIntlData.DecimalChar; + FCommaChar := DefaultIntlData.CommaChar; + + {format specifiers for currency masks} + FCurrencyDigits := DefaultIntlData.CurrDigits; + FSlashChar := DefaultIntlData.SlashChar; + + {characters that represent boolean values} + FTrueChar := DefaultIntlData.TrueChar; + FFalseChar := DefaultIntlData.FalseChar; + FYesChar := DefaultIntlData.YesChar; + FNoChar := DefaultIntlData.NoChar; + + {get windows international information} + ResetInternationalInfo; +end; + +function TOvcIntlSup.CurrentDateString(const Picture : string; + Pack : Boolean) : string; + {-returns today's date as a string of the specified form} +begin + Result := DateToDateString(Picture, CurrentDate, Pack); +end; + +function TOvcIntlSup.CurrentDatePChar(Dest : PAnsiChar; Picture : PAnsiChar; + Pack : Boolean) : PAnsiChar; + {-returns today's date as a string of the specified form} +begin + Result := DateToDatePChar(Dest, Picture, CurrentDate, Pack); +end; + +function TOvcIntlSup.CurrentTimeString(const Picture : string; Pack : Boolean) : string; + {-returns current time as a string of the specified form} +begin + Result := TimeToTimeString(Picture, CurrentTime, Pack); +end; + +function TOvcIntlSup.CurrentTimePChar(Dest : PAnsiChar; Picture : PAnsiChar; Pack : Boolean) : PAnsiChar; + {-returns current time as a string of the specified form} +begin + Result := TimeToTimePChar(Dest, Picture, CurrentTime, Pack); +end; + +function TOvcIntlSup.DateStringIsBlank(const Picture, S : string) : Boolean; + {-return True if the month, day, and year in S are all blank} +var + Buf1 : array[0..255] of AnsiChar; + Buf2 : array[0..255] of AnsiChar; +begin + StrPCopy(Buf1, Picture); + StrPCopy(Buf2, S); + Result := DatePCharIsBlank(Buf1, Buf2); +end; + +function TOvcIntlSup.DatePCharIsBlank(Picture, S : PAnsiChar) : Boolean; + {-return True if the month, day, and year in S are all blank} +var + M, D, Y : Integer; +begin + isExtractFromPicture(Picture, S, pmMonthName, M, -2, 0); + if M = 0 then + isExtractFromPicture(Picture, S, pmMonth, M, -2, -2); + isExtractFromPicture(Picture, S, pmDay, D, -2, -2); + isExtractFromPicture(Picture, S, pmYear, Y, -2, -2); + Result := (M = -2) and (D = -2) and (Y = -2); +end; + +function TOvcIntlSup.DateStringToDate(const Picture, S : string; Epoch : Integer) : TStDate; + {-convert St, a string of the form indicated by Picture, to a julian date. + Picture and St must be of equal lengths} +var + Buf1 : array[0..255] of AnsiChar; + Buf2 : array[0..255] of AnsiChar; +begin + StrPCopy(Buf1, Picture); + StrPCopy(Buf2, S); + Result := DatePCharToDate(Buf1, Buf2, Epoch); +end; + +function TOvcIntlSup.DatePCharToDate(Picture, S : PAnsiChar; Epoch : Integer) : TStDate; + {-convert St, a string of the form indicated by Picture, to a julian date. + Picture and St must be of equal lengths} +var + Month, Day, Year : Integer; +begin + {extract day, month, year from St} + if DatePCharToDMY(Picture, S, Day, Month, Year, Epoch) then + {convert to julian date} + Result := DMYtoStDate(Day, Month, Year, Epoch) + else + Result := BadDate; +end; + +function TOvcIntlSup.DateStringToDMY(const Picture, S : string; var Day, Month, Year : Integer; + Epoch : Integer) : Boolean; + {-extract day, month, and year from S, returning true if string is valid} +var + Buf1 : array[0..255] of AnsiChar; + Buf2 : array[0..255] of AnsiChar; +begin + StrPCopy(Buf1, Picture); + StrPCopy(Buf2, S); + Result := DatePCharToDMY(Buf1, Buf2, Day, Month, Year, Epoch); +end; + +function TOvcIntlSup.DatePCharToDMY(Picture, S : PAnsiChar; var Day, Month, Year : Integer; + Epoch : Integer) : Boolean; + {-extract day, month, and year from S, returning true if string is valid} +begin + Result := False; + if StrLen(Picture) <> StrLen(S) then + Exit; + + isExtractFromPicture(Picture, S, pmMonthName, Month, -1, 0); + if Month = 0 then + isExtractFromPicture(Picture, S, pmMonth, Month, -1, DefaultMonth); + isExtractFromPicture(Picture, S, pmDay, Day, -1, 1); + isExtractFromPicture(Picture, S, pmYear, Year, -1, DefaultYear); + Result := ValidDate(Day, Month, Year, Epoch); +end; + +function TOvcIntlSup.DateToDateString(const Picture : string; + Julian : TStDate; Pack : Boolean) : string; + {-convert Julian to a string of the form indicated by Picture} +var + Buf1 : array[0..255] of AnsiChar; + Buf2 : array[0..255] of AnsiChar; +begin + StrPCopy(Buf1, Picture); + Result := StrPas(DateToDatePChar(Buf2, Buf1, Julian, Pack)); +end; + +function TOvcIntlSup.DateToDatePChar(Dest : PAnsiChar; Picture : PAnsiChar; + Julian : TStDate; Pack : Boolean) : PAnsiChar; + {-convert Julian to a string of the form indicated by Picture} +var + Month, Day, Year : Integer; +begin + Move(Picture[0], Dest[0], StrLen(Picture)+1); + if Julian = BadDate then begin + {map picture characters to spaces} + isSubstChar(Dest, pmMonth, ' '); + isSubstChar(Dest, pmMonthName, ' '); + isSubstChar(Dest, pmDay, ' '); + isSubstChar(Dest, pmYear, ' '); + isSubstChar(Dest, pmWeekDay, ' '); + isMergePictureSt(Picture, Dest, pmLongDateSub1, wldSub1); + isMergePictureSt(Picture, Dest, pmLongDateSub2, wldSub2); + isMergePictureSt(Picture, Dest, pmLongDateSub3, wldSub3); + + {map slashes} + isSubstChar(Dest, pmDateSlash, SlashChar); + + Result := Dest; + end else begin + {convert Julian to day/month/year} + StDateToDMY(Julian, Day, Month, Year); + {merge the month, day, and year into the picture} + Result := DMYtoDatePChar(Dest, Picture, Day, Month, Year, Pack, 0); + end; +end; + +function TOvcIntlSup.DayOfWeekToString(WeekDay : TDayType) : string; + {-return the day of the week specified by WeekDay as a string. Will + honor the international names as specified in the INI file.} +begin + Result := LongDayNames[Ord(WeekDay)+1]; +end; + +function TOvcIntlSup.DayOfWeekToPChar(Dest : PAnsiChar; WeekDay : TDayType) : PAnsiChar; + {-return the day of the week specified by WeekDay as a string in Dest. Will + honor the international names as specified in the INI file.} +begin + Result := Dest; + StrPCopy(Dest, LongDayNames[Ord(WeekDay)+1]); +end; + +destructor TOvcIntlSup.Destroy; +begin +{$IFNDEF LCL} + if intlHandle <> 0 then + {$IFDEF VERSION6} + Classes.DeallocateHWnd(intlHandle); + {$ELSE} + DeallocateHWnd(intlHandle); + {$ENDIF} +{$ENDIF} + StrDispose(wCountry); + inherited Destroy; +end; + +function TOvcIntlSup.DMYtoDateString(const Picture : string; Day, Month, + Year : Integer; Pack : Boolean; Epoch : Integer) : string; + {-merge the month, day, and year into the picture} +var + Buf1 : array[0..255] of AnsiChar; + Buf2 : array[0..255] of AnsiChar; +begin + StrPCopy(Buf1, Picture); + Result := StrPas(DMYtoDatePChar(Buf2, Buf1, Day, Month, Year, Pack, Epoch)); +end; + +function TOvcIntlSup.DMYtoDatePChar(Dest : PAnsiChar; Picture : PAnsiChar; Day, Month, + Year : Integer; Pack : Boolean; Epoch : Integer) : PAnsiChar; + {-merge the month, day, and year into the picture} +var + DOW : Integer; + EpochCent : Integer; +begin + Move(Picture[0], Dest[0], StrLen(Picture)+1); + + EpochCent := (Epoch div 100)*100; + if Word(Year) < 100 then begin + if Year < (Epoch mod 100) then + Inc(Year, EpochCent + 100) + else + Inc(Year, EpochCent) + end; + + DOW := Integer(DayOfWeekDMY(Day, Month, Year, Epoch)); + isMergeIntoPicture(Dest, pmMonth, Month); + isMergeIntoPicture(Dest, pmDay, Day); + isMergeIntoPicture(Dest, pmYear, Year); + isMergeIntoPicture(Dest, pmMonthName, Month); + isMergeIntoPicture(Dest, pmWeekDay, DOW); + + {map slashes} + isSubstChar(Dest, pmDateSlash, SlashChar); + + isMergePictureSt(Picture, Dest, pmLongDateSub1, wldSub1); + isMergePictureSt(Picture, Dest, pmLongDateSub2, wldSub2); + isMergePictureSt(Picture, Dest, pmLongDateSub3, wldSub3); + + if Pack then + isPackResult(Picture, Dest); + + Result := Dest; +end; + +function TOvcIntlSup.GetCountry : string; + {-return the country setting} +begin + Result := StrPas(wCountry); +end; + +function TOvcIntlSup.GetCurrencyLtStr : string; +begin + Result := StrPas(FCurrencyLtStr); +end; + +function TOvcIntlSup.GetCurrencyRtStr : string; +begin + Result := StrPas(FCurrencyRtStr); +end; + +function TOvcIntlSup.InternationalCurrency(FormChar : AnsiChar; MaxDigits : Byte; Float, + AddCommas, IsNumeric : Boolean) : string; + {-Return a picture mask for a currency string, based on Windows' intl info} +var + Buf1 : array[0..255] of AnsiChar; +begin + Result := StrPas(InternationalCurrencyPChar(Buf1, FormChar, MaxDigits, + Float, AddCommas, IsNumeric)); +end; + +function TOvcIntlSup.InternationalCurrencyPChar(Dest : PAnsiChar; FormChar : AnsiChar; + MaxDigits : Byte; Float, AddCommas, IsNumeric : Boolean) : PAnsiChar; + {-Return a picture mask for a currency string, based on Windows' intl info} +const + NP : array[0..1] of AnsiChar = pmNegParens+#0; + NH : array[0..1] of AnsiChar = pmNegHere+#0; +var + CLSlen, DLen, I, J : Word; + Tmp : array[0..10] of AnsiChar; +begin + Dest[0] := #0; + Result := Dest; + + if (MaxDigits = 0) then + Exit; + + {initialize Dest with the numeric part of the string to left of decimal point} + I := Pred(MaxDigits) div 3 ; + J := Word(MaxDigits)+(I*Ord(AddCommas)); + if J > 247 then + DLen := 247 + else + DLen := J; + FillChar(Dest[0], DLen, FormChar); + Dest[DLen] := #0; + + if AddCommas then begin + {insert commas at appropriate points} + J := 0; + for I := DLen-1 downto 0 do + if J < 3 then + Inc(J) + else begin + Dest[I] := pmComma; + J := 0; + end; + end; + + {add in the decimals} + if CurrencyDigits > 0 then begin + Dest[DLen] := pmDecimalPt; + FillChar(Dest[DLen+1], CurrencyDigits, FormChar); + Inc(DLen, CurrencyDigits+1); + Dest[DLen] := #0; + end; + + {do we need a minus before the currency symbol} + if (wNegCurrencyForm = 6) then + StrCat(Dest, NH); + + {see if we can do a floating currency symbol} + if Float then + Float := not Odd(wCurrencyForm); + + {plug in the picture characters for the currency symbol} + CLSlen := StrLen(FCurrencyLtStr); + if Float then + StrStInsertPrim(Dest, CharStrPChar(Tmp, pmFloatDollar, CLSlen), 0) + else if not Odd(wCurrencyForm) then + StrStInsertPrim(Dest, CharStrPChar(Tmp, pmCurrencyLt, CLSlen), 0) + else + StrCat(Dest, CharStrPChar(Tmp, pmCurrencyRt, StrLen(FCurrencyRtStr))); + + {plug in special minus characters} + if IsNumeric then + case wNegCurrencyForm of + 0, 4 : + StrCat(Dest, NP); + 3, 7, 10 : + if Odd(wCurrencyForm) then + StrCat(Dest, NH); + end; +end; + +function TOvcIntlSup.InternationalDate(ForceCentury : Boolean) : string; + {-return a picture mask for a short date string, based on Windows' international information} +var + Buf : array[0..255] of AnsiChar; +begin + InternationalDatePChar(Buf, ForceCentury); + Result := StrPas(Buf); +end; + +function TOvcIntlSup.InternationalDatePChar(Dest : PAnsiChar; + ForceCentury : Boolean) : PAnsiChar; + {-return a picture mask for a date string, based on Windows' int'l info} + + + procedure FixMask(MC : AnsiChar; DL : Integer); + var + I : Cardinal; + J, AL : Word; + MCT : AnsiChar; + Found : Boolean; + begin + {find number of matching characters} + MCT := MC; + + Found := StrChPos(Dest, MC, I); + if not Found then begin + MCT := UpCase(MC); + Found := StrChPos(Dest, MCT, I); + end; + if not Found then + Exit; + + {pad substring to desired length} + AL := isMaskCharCount(Dest, MCT); + if AL < DL then + for J := 1 to DL-AL do + StrChInsertPrim(Dest, MCT, I); + + + if MC <> pmYear then + {choose blank/zero padding} + case AL of + 1 : if MCT = MC then + isSubstCharSim(Dest, MCT, UpCase(MCT)); + 2 : if MCT <> MC then + isSubstCharSim(Dest, MCT, MC); + end; + end; + +begin + {copy Windows mask into our var} + StrCopy(Dest, wShortDate); + + {if single Day marker, make double} + FixMask(pmDay, 2); + + {if single Month marker, make double} + FixMask(pmMonth, 2); + + {force yyyy if desired} + FixMask(pmYear, 2 shl Ord(ForceCentury)); + + Result := Dest; +end; + +function TOvcIntlSup.InternationalLongDate(ShortNames : Boolean; ExcludeDOW : Boolean) : string; + {-return a picture mask for a date string, based on Windows' int'l info} +var + Buf : array[0..255] of AnsiChar; +begin + Result := StrPas(InternationalLongDatePChar(Buf, ShortNames, ExcludeDOW)); +end; + +function TOvcIntlSup.InternationalLongDatePChar(Dest : PAnsiChar; ShortNames : Boolean; + ExcludeDOW : Boolean) : PAnsiChar; + {-return a picture mask for a date string, based on Windows' int'l info} +var + I : Cardinal; + WC : Word; + Temp : array[0..80] of AnsiChar; + Stop : Boolean; + + function LongestMonthName : Word; + var + I : Word; + begin + Result := 0; + for I := 1 to 12 do + Result := GetMaxWord(Result, Length(LongMonthNames[I])); + end; + + function LongestDayName : Word; + var + D : TDayType; + begin + Result := 0; + for D := Sunday to Saturday do + Result := GetMaxWord(Result, Length(LongDayNames[Ord(D)+1])); + end; + + procedure FixMask(MC : AnsiChar; DL : Integer); + var + I : Cardinal; + J, AL : Word; + MCT : AnsiChar; + Found : Boolean; + begin + {find first matching mask character} + MCT := MC; + Found := StrChPos(Temp, MC, I); + if not Found then begin + MCT := UpCase(MC); + Found := StrChPos(Temp, MCT, I); + end; + if not Found then + Exit; + + {pad substring to desired length} + AL := isMaskCharCount(Temp, MCT); + if AL < DL then begin + for J := 1 to DL-AL do + StrChInsertPrim(Temp, MCT, I); + end else if (AL > DL) then + StrStDeletePrim(Temp, I, AL-DL); + + if MC <> pmYear then + {choose blank/zero padding} + case AL of + 1 : if MCT = MC then + isSubstCharSim(Temp, MCT, UpCase(MCT)); + 2 : if MCT <> MC then + isSubstCharSim(Temp, MCT, MC); + end; + end; + +begin + {copy Windows mask into temporary var} + StrCopy(Temp, wLongDate); + + if ExcludeDOW then begin + {remove day-of-week and any junk that follows} + if StrChPos(Temp, pmWeekDay, I) then begin + WC := 1; + Stop := False; + repeat + case LoCaseChar(Temp[I+WC]) of + #0, pmMonth, pmDay, pmYear, pmMonthName : Stop := True; + else + Inc(WC); + end; + until Stop; + StrStDeletePrim(Temp, I, WC); + end; + end else if ShortNames then + FixMask(pmWeekDay, 3) + else if isMaskCharCount(Temp, pmWeekday) = 4 then + FixMask(pmWeekDay, LongestDayName); + + {fix month names} + if ShortNames then + FixMask(pmMonthName, 3) + else if isMaskCharCount(Temp, pmMonthName) = 4 then + FixMask(pmMonthName, LongestMonthName); + + {if single Day marker, make double} + FixMask(pmDay, 2); + + {if single Month marker, make double} + FixMask(pmMonth, 2); + + {force yyyy} + FixMask(pmYear, 4); + + {copy result into Dest} + StrCopy(Dest, Temp); + Result := Dest; +end; + +function TOvcIntlSup.InternationalTime(ShowSeconds : Boolean) : string; + {-return a picture mask for a time string, based on Windows' int'l info} +var + Buf : array[0..255] of AnsiChar; +begin + Result := StrPas(InternationalTimePChar(Buf, ShowSeconds)); +end; + +function TOvcIntlSup.InternationalTimePChar(Dest : PAnsiChar; ShowSeconds : Boolean) : PAnsiChar; + {-return a picture mask for a time string, based on Windows' int'l info} +var + SL, ML : Word; + S : array[0..20] of AnsiChar; +begin + {format the default string} + StrCopy(S, 'hh:mm:ss'); + if not wTLZero then + S[0] := pmHourU; + + {show seconds?} + if not ShowSeconds then + S[5] := #0; + + {handle international AM/PM markers} + if w12Hour then begin + ML := GetMaxWord(StrLen(@w1159), StrLen(@w2359)); + if (ML <> 0) then begin + SL := StrLen(S); + S[SL] := ' '; + FillChar(S[SL+1], ML, pmAmPm); + S[SL+ML+1] := #0; + end; + end; + + StrCopy(Dest, S); + Result := Dest; +end; + +procedure TOvcIntlSup.isIntlWndProc(var Msg : TMessage); + {-window procedure to catch WM_WININICHANGE messages} +begin + with Msg do + if AutoUpdate and (Msg = WM_WININICHANGE) then + try + if Assigned(FOnWinIniChange) then + FOnWinIniChange(Self) + else + ResetInternationalInfo; + except + Application.HandleException(Self); + end + else + Result := DefWindowProc(intlHandle, Msg, wParam, lParam); +end; + +procedure TOvcIntlSup.isExtractFromPicture(Picture, S : PAnsiChar; + Ch : AnsiChar; var I : Integer; + Blank, Default : Integer); + {-extract the value of the subfield specified by Ch from S and return in + I. I will be set to -1 in case of an error, Blank if the subfield exists + in Picture but is empty, Default if the subfield doesn't exist in + Picture.} +var + PTmp : Array[0..20] of AnsiChar; + J, K, W : Cardinal; + Code : Integer; + Found, + UpFound : Boolean; +begin + {find the start of the subfield} + I := Default; + Found := StrChPos(Picture, Ch, J); + Ch := UpCaseChar(Ch); + UpFound := StrChPos(Picture, Ch, K); + + if not Found or (UpFound and (K < J)) then begin + J := K; + Found := UpFound; + end; + if not Found or (StrLen(S) <> StrLen(Picture)) then + Exit; + + {extract the substring} + PTmp[0] := #0; + W := 0; + K := 0; + while (UpCaseChar(Picture[J]) = Ch) and (J < StrLen(Picture)) do begin + if S[J] <> ' ' then begin + PTmp[k] := S[J]; + Inc(K); + PTmp[k] := #0; + end; + Inc(J); + Inc(W); + end; + + if StrLen(PTmp) = 0 then + I := Blank + else if Ch = pmMonthNameU then begin + I := MonthPCharToMonth(PTmp, W); + if I = 0 then + I := -1; + end else begin + {convert to a value} + Val(PTmp, I, Code); + if Code <> 0 then + I := -1; + end; +end; + +function TOvcIntlSup.isMaskCharCount(P : PAnsiChar; MC : AnsiChar) : Word; + {-return the number of mask characters (MC) in P} +var + I : Cardinal; +begin + if StrChPos(P, MC, I) then begin + Result := 1; + while P[I+Result] = MC do + Inc(Result); + end else + Result := 0; +end; + +procedure TOvcIntlSup.isMergePictureSt(Picture, P : PAnsiChar; MC : AnsiChar; SP : PAnsiChar); +var + I, J : Cardinal; +begin + if not StrChPos(Picture, MC, I) then + Exit; + J := 0; + while Picture[I] = MC do begin + if SP[J] = #0 then + P[I] := ' ' + else begin + P[I] := SP[J]; + Inc(J); + end; + Inc(I); + end; +end; + +procedure TOvcIntlSup.isMergeIntoPicture(Picture : PAnsiChar; Ch : AnsiChar; + I : Integer); + {-merge I into location in Picture indicated by format character Ch} +var + Tmp : string[MaxDateLen]; + TLen : Byte absolute Tmp; + J : Cardinal; + K, L : Word; + UCh, CPJ, CTI : AnsiChar; + Done : Boolean; +begin + {find the start of the subfield} + UCh := UpCaseChar(Ch); + if not StrChPos(Picture, Ch, J) then + if not StrChPos(Picture, UCh, J) then + Exit; + + {find the end of the subfield} + K := J; + while (J < StrLen(Picture)) and (UpCaseChar(Picture[J]) = UCh) do + Inc(J); + Dec(J); + + if (UCh = pmWeekDayU) or (UCh = pmMonthNameU) then begin + if UCh = pmWeekDayU then + case I of + Ord(Sunday)..Ord(Saturday) : + Tmp := LongDayNames[I+1]; + else + Tmp := ''; + end + else + case I of + 1..12 : + Tmp := LongMonthNames[I]; + else + Tmp := ''; + end; + K := Succ(J-K); + if K > TLen then + FillChar(Tmp[TLen+1], K-TLen, ' '); + TLen := K; + end else + {convert I to a string} + Str(I:MaxDateLen, Tmp); + + {now merge} + L := TLen; + Done := False; + CPJ := Picture[J]; + + while (UpCaseChar(CPJ) = UCh) and not Done do begin + CTI := Tmp[L]; + if (UCh = pmMonthNameU) or (UCh = pmWeekDayU) then begin + case CPJ of + pmMonthNameU, pmWeekDayU : + CTI := UpCaseChar(CTI); + end; + end + {change spaces to 0's if desired} + else if (CPJ >= 'a') and (CTI = ' ') then + CTI := '0'; + Picture[J] := CTI; + Done := (J = 0) or (L = 0); + if not Done then begin + Dec(J); + Dec(L); + end; + CPJ := Picture[J]; + end; +end; + +procedure TOvcIntlSup.isPackResult(Picture, S : PAnsiChar); + {-remove unnecessary blanks from S} +var + Temp : array[0..80] of AnsiChar; + I, J : Integer; +begin + FillChar(Temp, SizeOf(Temp), #0); + I := 0; + J := 0; + while Picture[I] <> #0 do begin + case Picture[I] of + pmMonthU, pmDayU, pmMonthName, pmMonthNameU, pmWeekDay, + pmWeekDayU, pmHourU, {pmMinU,} pmSecondU : + if S[I] <> ' ' then begin + Temp[J] := S[I]; + Inc(J); + end; + pmAmPm : + if S[I] <> ' ' then begin + Temp[J] := S[I]; + Inc(J); + end + else if (I > 0) and (Picture[I-1] = ' ') then begin + Dec(J); + Temp[J] := #0; + end; + else + Temp[J] := S[I]; + Inc(J); + end; + Inc(I); + end; + + StrCopy(S, Temp); +end; + +procedure TOvcIntlSup.isSubstChar(Picture : PAnsiChar; OldCh, NewCh : AnsiChar); + {-replace all instances of OldCh in Picture with NewCh} +var + I : Byte; + UpCh : AnsiChar; + Temp : Cardinal; +begin + UpCh := UpCaseChar(OldCh); + if StrChPos(Picture, OldCh, Temp) or + StrChPos(Picture, UpCh, Temp) then + for I := 0 to StrLen(Picture)-1 do + if UpCaseChar(Picture[I]) = UpCh then + Picture[I] := NewCh; +end; + +procedure TOvcIntlSup.isSubstCharSim(P : PAnsiChar; OC, NC : AnsiChar); +begin + while P^ <> #0 do begin + if P^ = OC then + P^ := NC; + Inc(P); + end; +end; + +function TOvcIntlSup.isTimeToTimeStringPrim(Dest, Picture : PAnsiChar; + T : TStTime; Pack : Boolean; + t1159, t2359 : PAnsiChar) : PAnsiChar; + {-convert T to a string of the form indicated by Picture} +var + I : Word; + Hours : Byte; + Minutes : Byte; + Seconds : Byte; + P : PAnsiChar; + TPos : Cardinal; + Found : Boolean; +begin + {merge the hours, minutes, and seconds into the picture} + StTimeToHMS(T, Hours, Minutes, Seconds); + StrCopy(Dest, Picture); + + P := nil; + + {check for TimeOnly} + Found := StrChPos(Dest, pmAmPm, TPos); + if Found then begin + if (Hours >= 12) then + P := t2359 + else + P := t1159; + if (t1159[0] <> #0) and (t2359[0] <> #0) then begin + {adjust hours} + case Hours of + 0 : Hours := 12; + 13..23 : Dec(Hours, 12); + end; + end; + end; + + if T = BadTime then begin + {map picture characters to spaces} + isSubstChar(Dest, pmHour, ' '); + isSubstChar(Dest, pmMinute, ' '); + isSubstChar(Dest, pmSecond, ' '); + end else begin + {merge the numbers into the picture} + isMergeIntoPicture(Dest, pmHour, Hours); + isMergeIntoPicture(Dest, pmMinute, Minutes); + isMergeIntoPicture(Dest, pmSecond, Seconds); + end; + + {map colons} + isSubstChar(Dest, pmTimeColon, wColonChar); + + {plug in AM/PM string if appropriate} + if Found then begin + if (t1159[0] = #0) and (t2359[0] = #0) then + isSubstCharSim(@Dest[TPos], pmAmPm, ' ') + else if (T = BadTime) and (t1159[0] = #0) then + isSubstCharSim(@Dest[TPos], pmAmPm, ' ') + else begin + I := 0; + while (Dest[TPos] = pmAmPm) and (P[I] <> #0) do begin + Dest[TPos] := P[I]; + Inc(I); + Inc(TPos); + end; + end; + end; + + if Pack and (T <> BadTime) then + isPackResult(Picture, Dest); + + Result := Dest; +end; + +function TOvcIntlSup.MonthStringToMonth(const S : string; Width : Byte) : Byte; + {-Convert the month name in MSt to a month (1..12)} +var + I : Word; + Mt : string[MaxDateLen]; + MLen : Byte absolute Mt; + St : string[MaxDateLen]; + SLen : Byte absolute St; +begin + Result := 0; + Mt := AnsiUpperCase(S); + if Width > MLen then + FillChar(Mt[MLen+1], Width-MLen, ' '); + MLen := Width; + + for I := 1 to 12 do begin + St := AnsiUpperCase(LongMonthNames[I]); + if Width > SLen then + FillChar(St[SLen+1], Width-SLen, ' '); + SLen := Width; + if Mt = St then begin + Result := I; + Break; + end; + end; +end; + +function TOvcIntlSup.MonthPCharToMonth(S : PAnsiChar; Width : Byte) : Byte; + {-convert the month name in S to a month (1..12)} +var + I : Word; + Mt : string[MaxDateLen]; + MLen : Byte absolute Mt; + St : string[MaxDateLen]; + SLen : Byte absolute St; +begin + Result := 0; + Mt := AnsiUpperCase(StrPas(S)); + if Width > MLen then + FillChar(Mt[MLen+1], Width-MLen, ' '); + MLen := Width; + + for I := 1 to 12 do begin + St := AnsiUpperCase(LongMonthNames[I]); + if Width > SLen then + FillChar(St[SLen+1], Width-SLen, ' '); + SLen := Width; + if Mt = St then begin + Result := I; + Break; + end; + end; +end; + +function TOvcIntlSup.MonthToString(Month : Integer) : string; + {-return month name as a string for Month} +begin + if (Month >= 1) and (Month <= 12) then + Result := LongMonthNames[Month] + else + Result := ''; +end; + +function TOvcIntlSup.MonthToPChar(Dest : PAnsiChar; Month : Integer) : PAnsiChar; + {-return month name as a string for Month} +begin + Result := Dest; + if (Month >= 1) and (Month <= 12) then + StrPCopy(Dest, LongMonthNames[Month]) + else + Dest[0] := #0; +end; + +procedure TOvcIntlSup.ResetInternationalInfo; + {-read Window's international information and string resources} +var + S : string; + I : Cardinal; + Buf : array[0..255] of AnsiChar; + R : TRegistry; + + procedure GetIntlString(S, Def, Buf : PAnsiChar; Size : Word); + begin + GetProfileString('intl', S, Def, Buf, Size); + end; + + function GetIntlChar(S, Def : PAnsiChar) : AnsiChar; + var + B : array[0..5] of AnsiChar; + begin + GetIntlString(S, Def, B, SizeOf(B)); + Result := B[0]; + if (Result = #0) then + Result := Def[0]; + end; + + procedure ExtractSubString(SubChar : AnsiChar; Dest : PAnsiChar); + var + I, Temp : Cardinal; + L : Word; + begin + FillChar(Dest^, SizeOf(wldSub1), 0); + if not StrChPos(wLongDate, '''', I) then + Exit; + + {delete the first quote} + StrChDeletePrim(wLongDate, I); + + {assure that there is another quote} + if not StrChPos(wLongDate, '''', Temp) then + Exit; + + {copy substring into Dest, replace substring with SubChar} + L := 0; + while wLongDate[I] <> '''' do + if L < SizeOf(wldSub1) then begin + Dest[L] := wLongDate[I]; + Inc(L); + wLongDate[I] := SubChar; + Inc(I); + end else + StrChDeletePrim(wLongDate, I); + + {delete the second quote} + StrChDeletePrim(wLongDate, I); + end; + +begin + FDecimalChar := GetIntlChar('sDecimal', + @DefaultIntlData.DecimalChar); + FCommaChar := GetIntlChar('sThousand', + @DefaultIntlData.CommaChar); + FCurrencyDigits := GetProfileInt('intl', 'iCurrDigits', + DefaultIntlData.CurrDigits); + if (FCommaChar = FDecimalChar) then begin + FDecimalChar := DefaultIntlData.DecimalChar; + FCommaChar := DefaultIntlData.CommaChar; + end; + wNegCurrencyForm := GetProfileInt('intl', 'iNegCurr', 0); + FListChar := GetIntlChar('sList', ','); + + GetIntlString('sCountry', '', Buf, SizeOf(Buf)); + wCountry := StrNew(Buf); + + GetIntlString('sCurrency', DefaultIntlData.CurrencyLtStr, + FCurrencyLtStr, SizeOf(FCurrencyLtStr)); + StrCopy(FCurrencyRtStr, FCurrencyLtStr); + + wCurrencyForm := GetProfileInt('intl', 'iCurrency', 0); + case wCurrencyForm of + 0 : {}; + 1 : {}; + 2 : StrCat(FCurrencyLtStr, ' '); + 3 : StrChInsertPrim(FCurrencyRtStr, ' ', 0); + end; + + wTLZero := GetProfileInt('intl', 'iTLZero', 0) <> 0; + w12Hour := LongTimeFormat[Length(LongTimeFormat)] = 'M'; + + wColonChar := GetIntlChar('sTTime', ':'); + FSlashChar := GetIntlChar('sDate', @DefaultIntlData.SlashChar); + GetIntlString('s1159', 'AM', w1159, SizeOf(w1159)); + GetIntlString('s2359', 'PM', w2359, SizeOf(w2359)); + + {get short date mask and fix it up} +{$IFDEF MSWINDOWS} + R := TRegistry.Create; + try + R.RootKey := HKEY_CURRENT_USER; + if R.OpenKey('Control Panel\International', False) then begin + try + if R.ValueExists('sShortDate') then + StrPCopy(wShortDate, R.ReadString('sShortDate')) + else + GetIntlString('sShortDate', 'MM/dd/yy', + wShortDate, SizeOf(wShortDate)); + finally + R.CloseKey; + end; + end else + GetIntlString('sShortDate', 'MM/dd/yy', + wShortDate, SizeOf(wShortDate)); + finally + R.Free; + end; +{$ELSE} + GetIntlString('sShortDate', 'MM/dd/yy', + wShortDate, SizeOf(wShortDate)); +{$ENDIF} + + I := 0; + while wShortDate[I] <> #0 do begin + if wShortDate[I] = SlashChar then + wShortDate[I] := '/'; + Inc(I); + end; + + {get long date mask and fix it up} + GetIntlString('sLongDate', 'dddd, MMMM dd, yyyy', + wLongDate, SizeOf(wLongDate)); + ExtractSubString(pmLongDateSub1, wldSub1); + ExtractSubString(pmLongDateSub2, wldSub2); + ExtractSubString(pmLongDateSub3, wldSub3); + + {replace ddd/dddd with www/wwww} + if StrStPos(wLongDate, 'ddd', I) then + while wLongDate[I] = 'd' do begin + wLongDate[I] := 'w'; + Inc(I); + end; + + {replace MMM/MMMM with nnn/nnnn} + if StrStPos(wShortDate, 'MMM', I) then + while wShortDate[I] = 'M' do begin + wShortDate[I] := 'n'; + Inc(I); + end; + + {replace MMM/MMMM with nnn/nnnn} + if StrStPos(wLongDate, 'MMM', I) then + while wLongDate[I] = 'M' do begin + wLongDate[I] := 'n'; + Inc(I); + end; + + {deal with oddities concerning . and ,} + I := 0; + while wLongDate[I] <> #0 do begin + case wLongDate[I] of + '.', ',' : + if wLongDate[I+1] <> ' ' then begin + StrChInsertPrim(wLongDate, ' ', I+1); + Inc(I); + end; + end; + Inc(I); + end; + + {get Y/N and T/F values} + S := GetOrphStr(SCYes); + if Length(S) = 1 then + YesChar := S[1]; + S := GetOrphStr(SCNo); + if Length(S) = 1 then + NoChar := S[1]; + S := GetOrphStr(SCTrue); + if Length(S) = 1 then + TrueChar := S[1]; + S := GetOrphStr(SCFalse); + if Length(S) = 1 then + FalseChar := S[1]; +end; + +procedure TOvcIntlSup.SetAutoUpdate(Value : Boolean); + {-set the AutoUpdate option} +begin + if Value <> FAutoUpdate then begin + FAutoUpdate := Value; +// AllocateHWnd not available in LCL to create non-visual window that +// responds to messages sent to control. But not needed? +{$IFNDEF LCL} + if FAutoUpdate then + {allocate our window handle} + {$IFDEF VERSION6} + intlHandle := Classes.AllocateHWnd(isIntlWndProc) + {$ELSE} + intlHandle := AllocateHWnd(isIntlWndProc) + {$ENDIF} + else begin + {deallocate our window handle} + if intlHandle <> 0 then + {$IFDEF VERSION6} + Classes.DeallocateHWnd(intlHandle); + {$ELSE} + DeallocateHWnd(intlHandle); + {$ENDIF} + intlHandle := 0; + end; +{$ENDIF} + end; +end; + +procedure TOvcIntlSup.SetCurrencyLtStr(const Value : string); +begin + StrPLCopy(FCurrencyLtStr, Value, SizeOf(FCurrencyLtStr)-1); +end; + +procedure TOvcIntlSup.SetCurrencyRtStr(const Value : string); +begin + StrPLCopy(FCurrencyRtStr, Value, SizeOf(FCurrencyRtStr)-1); +end; + +function TOvcIntlSup.TimeStringToHMS(const Picture, S : string; + var Hour, Minute, Second : Integer) : Boolean; + {-extract Hours, Minutes, Seconds from St, returning true if string is valid} +var + Buf1 : array[0..255] of AnsiChar; + Buf2 : array[0..255] of AnsiChar; +begin + StrPCopy(Buf1, Picture); + StrPCopy(Buf2, S); + Result := TimePCharToHMS(Buf1, Buf2, Hour, Minute, Second); +end; + +function TOvcIntlSup.TimePCharToHMS(Picture, S : PAnsiChar; + var Hour, Minute, Second : Integer) : Boolean; + {-extract Hours, Minutes, Seconds from St, returning true if string is valid} +var + I, J : Cardinal; + Tmp, + t1159, + t2359 : array[0..20] of AnsiChar; +begin + Result := False; + if StrLen(Picture) <> StrLen(S) then + Exit; + + {extract hours, minutes, seconds from St} + isExtractFromPicture(Picture, S, pmHour, Hour, -1, 0); + isExtractFromPicture(Picture, S, pmMinute, Minute, -1, 0); + isExtractFromPicture(Picture, S, pmSecond, Second, -1, 0); + if (Hour = -1) or (Minute = -1) or (Second = -1) then begin + Result := False; + Exit; + end; + + {check for TimeOnly} + if StrChPos(Picture, pmAmPm, I) and (w1159[0] <> #0) + and (w2359[0] <> #0) then begin + Tmp[0] := #0; + J := 0; + while Picture[I] = pmAmPm do begin + Tmp[J] := S[I]; + Inc(J); + Inc(I); + end; + Tmp[J] := #0; + TrimTrailPrimPChar(Tmp); + + StrCopy(t1159, w1159); + t1159[J] := #0; + StrCopy(t2359, w2359); + t2359[J] := #0; + + if (Tmp[0] = #0) then + Hour := -1 + else if StrIComp(Tmp, t2359) = 0 then begin + if (Hour < 12) then + Inc(Hour, 12) + else if (Hour = 0) or (Hour > 12) then + {force BadTime} + Hour := -1; + end else if StrIComp(Tmp, t1159) = 0 then begin + if Hour = 12 then + Hour := 0 + else if (Hour = 0) or (Hour > 12) then + {force BadTime} + Hour := -1; + end else + {force BadTime} + Hour := -1; + end; + + Result := ValidTime(Hour, Minute, Second); +end; + +function TOvcIntlSup.TimeToAmPmString(const Picture : string; T : TStTime; Pack : Boolean) : string; + {-convert T to a string of the form indicated by Picture. Times are always displayed in am/pm format.} +var + Buf1 : array[0..255] of AnsiChar; + Buf2 : array[0..255] of AnsiChar; +begin + StrPCopy(Buf1, Picture); + Result := StrPas(TimeToAmPmPChar(Buf2, Buf1, T, Pack)); +end; + +function TOvcIntlSup.TimeToAmPmPChar(Dest : PAnsiChar; Picture : PAnsiChar; T : TStTime; Pack : Boolean) : PAnsiChar; + {-convert T to a string of the form indicated by Picture. Times are always displayed in am/pm format.} +const + t1159 = 'AM'#0; + t2359 = 'PM'#0; +var + PLen : Byte; + Temp : Cardinal; +begin + Move(Picture[0], Dest[0], StrLen(Picture)+1); + if not StrChPos(Dest, pmAmPm, Temp) then begin + PLen := StrLen(Dest); + Dest[PLen] := pmAmPm; + Dest[PLen+1] := #0; + end; + Result := isTimeToTimeStringPrim(Dest, Dest, T, Pack, t1159, t2359); +end; + +function TOvcIntlSup.TimeStringToTime(const Picture, S : string) : TStTime; + {-convert S, a string of the form indicated by Picture, to a Time variable} +var + Buf1 : array[0..255] of AnsiChar; + Buf2 : array[0..255] of AnsiChar; +begin + StrPCopy(Buf1, Picture); + StrPCopy(Buf2, S); + Result := TimePCharToTime(Buf1, Buf2); +end; + +function TOvcIntlSup.TimePCharToTime(Picture, S : PAnsiChar) : TStTime; + {-convert S, a string of the form indicated by Picture, to a Time variable} +var + Hours, Minutes, Seconds : Integer; +begin + if TimePCharToHMS(Picture, S, Hours, Minutes, Seconds) then + Result := HMStoStTime(Hours, Minutes, Seconds) + else + Result := BadTime; +end; + +function TOvcIntlSup.TimeToTimeString(const Picture : string; T : TStTime; Pack : Boolean) : string; + {-convert T to a string of the form indicated by Picture} +var + Buf1 : array[0..255] of AnsiChar; + Buf2 : array[0..255] of AnsiChar; +begin + StrPCopy(Buf1, Picture); + Result := StrPas(TimeToTimePChar(Buf2, Buf1, T, Pack)); +end; + +function TOvcIntlSup.TimeToTimePChar(Dest : PAnsiChar; Picture : PAnsiChar; T : TStTime; Pack : Boolean) : PAnsiChar; + {-convert T to a string of the form indicated by Picture} +begin + Result := isTimeToTimeStringPrim(Dest, Picture, T, Pack, w1159, w2359); +end; + +procedure DestroyGlobalIntlSup; far; +begin + OvcIntlSup.Free; +end; + + +initialization + {create instance of default user data class} + OvcIntlSup := TOvcIntlSup.Create; + +finalization + DestroyGlobalIntlSup; +end. diff --git a/components/orpheus/ovclabel.pas b/components/orpheus/ovclabel.pas new file mode 100644 index 000000000..a58753c9d --- /dev/null +++ b/components/orpheus/ovclabel.pas @@ -0,0 +1,839 @@ +{*********************************************************} +{* OVCLABEL.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovclabel; + {-label component} + +interface + +uses + {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, LclType, MyMisc, {$ENDIF} + Classes, Controls, Graphics, StdCtrls, SysUtils, + OvcMisc, OvcVer; + +type + {preset "looks"} + TOvcAppearance = (apNone, apCustom, apFlying, apRaised, apSunken, apShadow); + {preset color schemes} + TOvcColorScheme = (csCustom, csText, csWindows, csEmbossed, csGold, csSteel); + {options for varying the shadow/highlight for the label} + TOvcGraduateStyle = (gsNone, gsHorizontal, gsVertical); + {directions for shading (highlights and shadows)} + TOvcShadeDirection = (sdNone, sdUp, sdUpRight, sdRight, sdDownRight, sdDown, + sdDownLeft, sdLeft, sdUpLeft); + {options for varying the text of the label} + TOvcShadeStyle = (ssPlain, ssExtrude, ssGraduated); + + TOvcDepth = 0..255; + +const + lblDefAppearance = apRaised; + lblDefAutoSize = False; + lblDefColorScheme = csWindows; +{$IFNDEF LCL} + lblDefFontName = 'Times New Roman'; +{$ELSE} + lblDefFontName = 'default'; +{$ENDIF} + lblDefFontSize = 20; + lblDefGraduateFromColor = clGray; + lblDefGraduateStyle = gsNone; + lblDefHighlightColor = clWhite; + lblDefHighlightDepth = 1; + lblDefHighlightDirection = sdUpLeft; + lblDefHighlightStyle = ssPlain; + lblDefShadowColor = clBlack; + lblDefShadowDepth = 1; + lblDefShadowDirection = sdDownRight; + lblDefShadowStyle = ssPlain; + lblDefTransparent = True; + lblDefWordWrap = True; + +type + TOvcCustomSettings = class(TPersistent) + private + {.Z+} + {property variables} + FGraduateFromColor : TColor; + FGraduateStyle : TOvcGraduateStyle; + FHighlightColor : TColor; + FHighlightDepth : TOvcDepth; + FHighlightDirection : TOvcShadeDirection; + FHighlightStyle : TOvcShadeStyle; + FShadowColor : TColor; + FShadowDepth : TOvcDepth; + FShadowDirection : TOvcShadeDirection; + FShadowStyle : TOvcShadeStyle; + + {event variables} + FOnColorChange : TNotifyEvent; + FOnStyleChange : TNotifyEvent; + + {internal variables} + FUpdating : Boolean; + + {internal methods} + procedure DoOnColorChange; + procedure DoOnStyleChange; + + {property methods} + procedure SetGraduateFromColor(Value : TColor); + procedure SetGraduateStyle(Value : TOvcGraduateStyle); + procedure SetHighlightColor(Value : TColor); + procedure SetHighlightDepth(Value : TOvcDepth); + procedure SetHighlightDirection(Value : TOvcShadeDirection); + procedure SetHighlightStyle(Value : TOvcShadeStyle); + procedure SetShadowColor(Value : TColor); + procedure SetShadowDepth(Value : TOvcDepth); + procedure SetShadowDirection(Value : TOvcShadeDirection); + procedure SetShadowStyle(Value : TOvcShadeStyle); + {.Z-} + public + procedure Assign(Source : TPersistent); + override; + + procedure BeginUpdate; + procedure EndUpdate; + + {.Z+} + property OnColorChange : TNotifyEvent + read FOnColorChange write FOnColorChange; + property OnStyleChange : TNotifyEvent + read FOnStyleChange write FOnStyleChange; + {.Z-} + + published + property GraduateFromColor : TColor + read FGraduateFromColor write SetGraduateFromColor default lblDefGraduateFromColor; + property GraduateStyle : TOvcGraduateStyle + read FGraduateStyle write SetGraduateStyle default lblDefGraduateStyle; + property HighlightColor : TColor + read FHighlightColor write SetHighlightColor default lblDefHighlightColor; + property HighlightDepth : TOvcDepth + read FHighlightDepth write SetHighlightDepth default lblDefHighlightDepth; + property HighlightDirection : TOvcShadeDirection + read FHighlightDirection write SetHighlightDirection default lblDefHighlightDirection; + property HighlightStyle : TOvcShadeStyle + read FHighlightStyle write SetHighlightStyle default lblDefHighlightStyle; + property ShadowColor : TColor + read FShadowColor write SetShadowColor default lblDefShadowColor; + property ShadowDepth : TOvcDepth + read FShadowDepth write SetShadowDepth default lblDefShadowDepth; + property ShadowDirection : TOvcShadeDirection + read FShadowDirection write SetShadowDirection default lblDefShadowDirection; + property ShadowStyle : TOvcShadeStyle + read FShadowStyle write SetShadowStyle default lblDefShadowStyle; + end; + + TOvcCustomLabel = class(TCustomLabel) + {.Z+} + protected {private} + {property variables} + FAppearance : TOvcAppearance; + FColorScheme : TOvcColorScheme; + FCustomSettings : TOvcCustomSettings; + + {interal variables} + eslSchemes : array [TOvcColorScheme, (cpHighlight, cpShadow, cpFace)] of TColor; + SettingColorScheme : Boolean; + SettingAppearance : Boolean; + + {property methods} + function GetAbout : string; + function GetWordWrap : Boolean; + procedure SetAppearance(Value : TOvcAppearance); + procedure SetColorScheme(Value : TOvcColorScheme); + procedure SetWordWrap(Value : Boolean); + procedure SetAbout(const Value : string); + + {internal methods} + procedure PaintPrim(CR : TRect; Flags : Word); + procedure ColorChanged(Sender : TObject); + procedure StyleChanged(Sender : TObject); + + protected + procedure Paint; + override; + {.Z-} + + {protected properties} {can be published by descendants} + property About : string + read GetAbout write SetAbout stored False; + property Appearance : TOvcAppearance + read FAppearance write SetAppearance default lblDefAppearance; + property ColorScheme : TOvcColorScheme + read FColorScheme write SetColorScheme default lblDefColorScheme; + property CustomSettings : TOvcCustomSettings + read FCustomSettings write FCustomSettings; + property WordWrap : Boolean + read GetWordWrap write SetWordWrap default lblDefWordWrap; + public + {.Z+} + constructor Create(AOwner : TComponent); + override; + destructor Destroy; + override; + +{ - Hdc changed to TOvcHdc for BCB Compatibility } + procedure PaintTo(DC : TOvcHdc{Hdc}; CR : TRect; Flags : Word); + + property AutoSize; + {.Z-} + end; + + TOvcLabel = class(TOvcCustomLabel) + published + {properties} + property About; + property Align; + property Alignment; + {$IFDEF VERSION 4} + property Anchors; + {$ENDIF} + property Appearance; + property Caption; + property Color; + property ColorScheme; + property Cursor; + property CustomSettings; + property DragCursor; + property DragMode; + property Enabled; + property FocusControl; + property Font; + property ParentColor; + property ParentFont default False; + property ParentShowHint; + property ShowAccelChar; + property ShowHint; + property Transparent + default lblDefTransparent; + property Visible; + property WordWrap; + + {events} + property OnClick; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEndDrag; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + end; + + +implementation + +{*** TOvcCustomSettings ***} + +procedure TOvcCustomSettings.Assign(Source : TPersistent); +var + LS : TOvcCustomSettings absolute Source; +begin + if Assigned(Source) and (Source is TOvcCustomSettings) then begin + FGraduateFromColor := LS.GraduateFromColor; + FGraduateStyle := LS.GraduateStyle; + FHighlightColor := LS.HighlightColor; + FHighlightDepth := LS.HighlightDepth; + FHighlightDirection := LS.HighlightDirection; + FHighlightStyle := LS.HighlightStyle; + FShadowColor := LS.ShadowColor; + FShadowDepth := LS.ShadowDepth; + FShadowDirection := LS.ShadowDirection; + FShadowStyle := LS.ShadowStyle; + end else + inherited Assign(Source); +end; + +procedure TOvcCustomSettings.BeginUpdate; +begin + FUpdating := True; +end; + +procedure TOvcCustomSettings.EndUpdate; +begin + FUpdating := False; + DoOnColorChange; + DoOnStyleChange; +end; + +procedure TOvcCustomSettings.DoOnColorChange; +begin + if not FUpdating and Assigned(FOnColorChange) then + FOnColorChange(Self); +end; + +procedure TOvcCustomSettings.DoOnStyleChange; +begin + if not FUpdating and Assigned(FOnStyleChange) then + FOnStyleChange(Self); +end; + +procedure TOvcCustomSettings.SetGraduateFromColor(Value : TColor); +begin + if Value <> FGraduateFromColor then begin + FGraduateFromColor := Value; + DoOnColorChange; + end; +end; + +procedure TOvcCustomSettings.SetGraduateStyle(Value : TOvcGraduateStyle); +begin + if Value <> FGraduateStyle then begin + FGraduateStyle := Value; + DoOnStyleChange; + end; +end; + +procedure TOvcCustomSettings.SetHighlightColor(Value : TColor); +begin + if Value <> FHighlightColor then begin + FHighlightColor := Value; + DoOnColorChange; + end; +end; + +procedure TOvcCustomSettings.SetHighlightDepth(Value : TOvcDepth); +begin + if Value <> FHighlightDepth then begin + FHighlightDepth := Value; + DoOnStyleChange; + end; +end; + +procedure TOvcCustomSettings.SetHighlightDirection(Value : TOvcShadeDirection); +begin + if Value <> FHighlightDirection then begin + FHighlightDirection := Value; + DoOnStyleChange; + end; +end; + +procedure TOvcCustomSettings.SetHighlightStyle(Value : TOvcShadeStyle); +begin + if Value <> FHighlightStyle then begin + FHighlightStyle := Value; + DoOnStyleChange; + end; +end; + +procedure TOvcCustomSettings.SetShadowColor(Value : TColor); +begin + if Value <> FShadowColor then begin + FShadowColor := Value; + DoOnColorChange; + end; +end; + +procedure TOvcCustomSettings.SetShadowDepth(Value : TOvcDepth); +begin + if Value <> FShadowDepth then begin + FShadowDepth := Value; + DoOnStyleChange; + end; +end; + +procedure TOvcCustomSettings.SetShadowDirection(Value : TOvcShadeDirection); +begin + if Value <> FShadowDirection then begin + FShadowDirection := Value; + DoOnStyleChange; + end; +end; + +procedure TOvcCustomSettings.SetShadowStyle(Value : TOvcShadeStyle); +begin + if Value <> FShadowStyle then begin + FShadowStyle := Value; + DoOnStyleChange; + end; +end; + + +{*** TOvcCustomLabel ***} + +constructor TOvcCustomLabel.Create(AOwner : TComponent); +begin + inherited Create(AOwner); + + eslSchemes[csWindows, cpHighlight] := lblDefHighlightColor; + eslSchemes[csWindows, cpFace] := clGray; + eslSchemes[csWindows, cpShadow] := lblDefShadowColor; + + eslSchemes[csText, cpHighlight] := clWhite; + eslSchemes[csText, cpFace] := clBlack; + eslSchemes[csText, cpShadow] := clGray; + + eslSchemes[csEmbossed, cpHighlight] := clWhite; + eslSchemes[csEmbossed, cpFace] := clSilver; + eslSchemes[csEmbossed, cpShadow] := clBlack; + + eslSchemes[csGold, cpHighlight] := clYellow; + eslSchemes[csGold, cpFace] := clOlive; + eslSchemes[csGold, cpShadow] := clBlack; + + eslSchemes[csSteel, cpHighlight] := clAqua; + eslSchemes[csSteel, cpFace] := clTeal; + eslSchemes[csSteel, cpShadow] := clNavy; + + eslSchemes[csCustom, cpHighlight] := eslSchemes[csWindows,cpHighlight]; + eslSchemes[csCustom, cpFace] := eslSchemes[csWindows,cpFace]; + eslSchemes[csCustom, cpShadow] := eslSchemes[csWindows,cpShadow]; + + {initialize defaults} + FAppearance := lblDefAppearance; + FColorScheme := lblDefColorScheme; + FCustomSettings := TOvcCustomSettings.Create; + FCustomSettings.FGraduateFromColor := lblDefGraduateFromColor; + FCustomSettings.FGraduateStyle := lblDefGraduateStyle; + FCustomSettings.FHighlightColor := eslSchemes[csWindows, cpHighlight]; + FCustomSettings.FHighlightDepth := lblDefHighlightDepth; + FCustomSettings.FHighlightDirection := lblDefHighlightDirection; + FCustomSettings.FHighlightStyle := lblDefHighlightStyle; + FCustomSettings.FShadowColor := eslSchemes[csWindows, cpShadow]; + FCustomSettings.FShadowDepth := lblDefShadowDepth; + FCustomSettings.FShadowDirection := lblDefShadowDirection; + FCustomSettings.FShadowStyle := lblDefShadowStyle; + FCustomSettings.OnColorChange := ColorChanged; + FCustomSettings.OnStyleChange := StyleChanged; + + AutoSize := lblDefAutoSize; + Height := 35; + Width := 150; + Transparent := lblDefTransparent; + Font.Name := lblDefFontName; + Font.Size := lblDefFontSize; + Font.Color := eslSchemes[FColorScheme, cpFace]; + WordWrap := lblDefWordWrap; + + SettingColorScheme := False; + SettingAppearance := False; +end; + +destructor TOvcCustomLabel.Destroy; +begin + FCustomSettings.Free; + FCustomSettings := nil; + + inherited Destroy; +end; + +function TOvcCustomLabel.GetAbout : string; +begin + Result := OrVersionStr; +end; + +function TOvcCustomLabel.GetWordWrap : Boolean; +begin + Result := inherited WordWrap; +end; + +procedure TOvcCustomLabel.Paint; +const + Alignments : array [TAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER); + Wrap : array[Boolean] of Word = (0, DT_WORDBREAK); + Prefix : array[Boolean] of Word = (DT_NOPREFIX, 0); +begin + PaintPrim(ClientRect, Wrap[WordWrap] or DT_EXPANDTABS or + Alignments[Alignment] or Prefix[ShowAccelChar]); +end; + +procedure TOvcCustomLabel.PaintPrim(CR : TRect; Flags : Word); +const + DrawingOffset : array [TOvcShadeDirection, (ioX, ioY)] of -1..1 = + ((0,0),(0,-1),(+1,-1),(+1,0),(+1,+1),(0,+1),(-1,+1),(-1,0),(-1,-1)); + BandCount = 16; +var + I : Integer; + MinOffset : Integer; + MaxOffset : Integer; + IX, IY : Integer; + IU, IV : Integer; + Limit : Integer; + Adjustment : Integer; + AdjustR : Double; + AdjustG : Double; + AdjustB : Double; + Step : Double; + RctTemp : TRect; + FromR : Byte; + FromG : Byte; + FromB : Byte; + ToR : Byte; + ToG : Byte; + ToB : Byte; + BmpTemp : TBitmap; + BmpWork : TBitmap; + CnvWork : TCanvas; + Buf : PChar; +begin + if not Assigned(FCustomSettings) then + Exit; + + {get offsets based on shadow and highlight directions and depths} + MinOffset := MinI(MinI(MinI(MinI(DrawingOffset[FCustomSettings.HighlightDirection, ioX] * FCustomSettings.HighlightDepth, + DrawingOffset[FCustomSettings.ShadowDirection, ioX] * FCustomSettings.ShadowDepth), + DrawingOffset[FCustomSettings.HighlightDirection, ioY] * FCustomSettings.HighlightDepth), + DrawingOffset[FCustomSettings.ShadowDirection, ioY] * FCustomSettings.ShadowDepth), 0); + MaxOffset := MaxI(MaxI(MaxI(MaxI(DrawingOffset[FCustomSettings.HighlightDirection, ioX] * FCustomSettings.HighlightDepth, + DrawingOffset[FCustomSettings.ShadowDirection, ioX] * FCustomSettings.ShadowDepth), + DrawingOffset[FCustomSettings.HighlightDirection, ioY] * FCustomSettings.HighlightDepth), + DrawingOffset[FCustomSettings.ShadowDirection, ioY] * FCustomSettings.ShadowDepth), 0); + + if Flags and DT_CENTER <> 0 then + Adjustment := (MaxOffset - MinOffset) div 2 + else if Flags and DT_RIGHT <> 0 then + Adjustment := MaxOffset - MinOffset + else + Adjustment := 0; + + {create temporary drawing surfaces} + BmpTemp := TBitmap.Create; + BmpWork := TBitmap.Create; + try + BmpTemp.Height := CR.Bottom-CR.Top; + BmpTemp.Width := CR.Right-CR.Left; + BmpTemp.Canvas.Font := Self.Font; + + BmpWork.Height := CR.Bottom-CR.Top; + BmpWork.Width := CR.Right-CR.Left; + BmpWork.Canvas.Font := Self.Font; + + {get copy of our canvas} + BmpWork.Canvas.CopyRect(CR, Self.Canvas, CR); + + {set starting point for text - IX, IY} + IX := 0; IY := 0; + if not Transparent then begin + BmpWork.Canvas.Brush.Color := Self.Color; + BmpWork.Canvas.Brush.Style := bsSolid; + BmpWork.Canvas.FillRect(CR); + end; + BmpWork.Canvas.Brush.Style := bsClear; + + Buf := StrAlloc(GetTextLen+1); + try + {get label's caption} + GetTextBuf(Buf, GetTextLen+1); + + {prepare for extruding shadow, if requested} + GetRGB(FCustomSettings.ShadowColor, FromR, FromG, FromB); + AdjustR := 0; + AdjustG := 0; + AdjustB := 0; + Limit := FCustomSettings.ShadowDepth; + if (FCustomSettings.ShadowStyle <> ssPlain) and (FCustomSettings.ShadowDepth > 1) then begin + Limit := 1; + {find changes in RGB colors} + if FCustomSettings.ShadowStyle = ssGraduated then begin + GetRGB(Font.Color, ToR, ToG, ToB); + AdjustR := (ToR - FromR) / (FCustomSettings.ShadowDepth - 1); + AdjustG := (ToG - FromG) / (FCustomSettings.ShadowDepth - 1); + AdjustB := (ToB - FromB) / (FCustomSettings.ShadowDepth - 1); + end; + end; + CnvWork := BmpWork.Canvas; + + {process for each copy of the shadow} + for I := FCustomSettings.ShadowDepth downto Limit do begin + CnvWork.Font.Color := + RGB(FromR + Round(AdjustR * (FCustomSettings.ShadowDepth - I)), + FromG + Round(AdjustG * (FCustomSettings.ShadowDepth - I)), + FromB + Round(AdjustB * (FCustomSettings.ShadowDepth - I))); + {create a rect that is offset for the shadow} + RctTemp:= Rect( + CR.Left - MinOffset -Adjustment + DrawingOffset[FCustomSettings.ShadowDirection, ioX] * I, + CR.Top - MinOffset + DrawingOffset[FCustomSettings.ShadowDirection, ioY] * I, + CR.Right - MinOffset - Adjustment + DrawingOffset[FCustomSettings.ShadowDirection, ioX] * I, + CR.Bottom - MinOffset + DrawingOffset[FCustomSettings.ShadowDirection, ioY] * I); + {draw shadow text with alignment} + DrawText(CnvWork.Handle, Buf, StrLen(Buf), RctTemp, Flags); + end; + + {prepare for extruding highlight, if requested} + GetRGB(FCustomSettings.HighlightColor, FromR, FromG, FromB); + AdjustR := 0; + AdjustG := 0; + AdjustB := 0; + Limit := FCustomSettings.HighlightDepth; + if (FCustomSettings.HighlightStyle <> ssPlain) and (FCustomSettings.HighlightDepth > 1) then begin + Limit := 1; + if FCustomSettings.HighlightStyle = ssGraduated then begin {find changes in RGB Colors} + GetRGB(Font.Color, ToR, ToG, ToB); + AdjustR := (ToR - FromR) / (FCustomSettings.HighlightDepth - 1); + AdjustG := (ToG - FromG) / (FCustomSettings.HighlightDepth - 1); + AdjustB := (ToB - FromB) / (FCustomSettings.HighlightDepth - 1); + end; + end; + + CnvWork := BmpWork.Canvas; + + {process for each copy of the highlight} + for I := FCustomSettings.HighlightDepth downto Limit do begin + CnvWork.Font.Color := + RGB(FromR + Round(AdjustR * (FCustomSettings.HighlightDepth - I)), + FromG + Round(AdjustG * (FCustomSettings.HighlightDepth - I)), + FromB + Round(AdjustB * (FCustomSettings.HighlightDepth - I))); + {create a rect that is offset for the highlight} + RctTemp:= Rect( + CR.Left - MinOffset - Adjustment + DrawingOffset[FCustomSettings.HighlightDirection, ioX] * I, + CR.Top - MinOffset + DrawingOffset[FCustomSettings.HighlightDirection, ioY] * I, + CR.Right - MinOffset - Adjustment + DrawingOffset[FCustomSettings.HighlightDirection, ioX] * I, + CR.Bottom - MinOffset + DrawingOffset[FCustomSettings.HighlightDirection, ioY] * I); + {draw highlight text with alignment} + DrawText(CnvWork.Handle, Buf, StrLen(Buf), RctTemp, Flags); + end; + + if FCustomSettings.GraduateStyle <> gsNone then begin + {copy original canvas to work area} + BmpTemp.Canvas.CopyRect(CR, BmpWork.Canvas, CR); + {choose an unusual color} + BmpTemp.Canvas.Font.Color := $00FE09F1; + BmpTemp.Canvas.Brush.Style := bsClear; + CnvWork := BmpTemp.Canvas; + end else begin + BmpWork.Canvas.Font.Color := Font.Color; {restore original font Color} + CnvWork := BmpWork.Canvas; + end; + + {create a rect that is offset for the original text} + RctTemp:= Rect(CR.Left - MinOffset - Adjustment, + CR.Top - MinOffset, + CR.Right - MinOffset - Adjustment, + CR.Bottom - MinOffset); + + {draw original text with alignment} + DrawText(CnvWork.Handle, Buf, StrLen(Buf), RctTemp, Flags); + finally + StrDispose(Buf); + end; + + if FCustomSettings.GraduateStyle <> gsNone then begin + {transfer graduations from temporary canvas} + {calculate start point and extent} + Limit := BmpWork.Canvas.TextWidth(Caption); + IV := IY - MinOffset; + + if Flags and DT_CENTER <> 0 then + IU := (CR.Right-CR.Left - Limit) div 2 - MinOffset - Adjustment + else if Flags and DT_RIGHT <> 0 then + IU := CR.Bottom-CR.Top - MaxOffset - Limit + else + IU := IX - MinOffset; + + if FCustomSettings.GraduateStyle = gsVertical then + Limit := CR.Bottom-CR.Top-1 + else + Dec(Limit); + + {calculate change in color at each step} + GetRGB(FCustomSettings.GraduateFromColor, FromR, FromG, FromB); + GetRGB(Font.Color, ToR, ToG, ToB); + AdjustR := (ToR - FromR) / Pred(BandCount); + AdjustG := (ToG - FromG) / Pred(BandCount); + AdjustB := (ToB - FromB) / Pred(BandCount); + + Step := Limit / Pred(BandCount); + + {and draw it onto the canvas} + BmpWork.Canvas.Brush.Style := bsSolid; + for I := 0 to Pred(BandCount) do begin + BmpWork.Canvas.Brush.Color := RGB(FromR + Round(AdjustR * I), + FromG + Round(AdjustG * I), + FromB + Round(AdjustB * I)); + if FCustomSettings.GraduateStyle = gsVertical then + RctTemp := Rect(0, IV + Round(I*Step), CR.Right-CR.Left, IV + Round((I+1)*Step)) + else + RctTemp := Rect(IU + Round(I*Step), 0, IU + Round((I+1)*Step), CR.Bottom-CR.Top); +{$IFNDEF LCL} + BmpWork.Canvas.BrushCopy(RctTemp, BmpTemp, RctTemp, BmpTemp.Canvas.Font.Color); +{$ELSE} + BrushCopy(BmpWork.Canvas, RctTemp, BmpTemp, RctTemp, BmpTemp.Canvas.Font.Color); +{$ENDIF} + end; + end; + + Canvas.CopyRect(CR, BmpWork.Canvas, CR); + finally + BmpTemp.Free; + BmpWork.Free; + end; +end; + +{ - Hdc changed to TOvcHdc for BCB compatibility} +procedure TOvcCustomLabel.PaintTo(DC : TOvcHdc {Hdc}; CR : TRect; Flags : Word); +begin + Canvas.Handle := DC; + try + if not Transparent then begin + Canvas.Brush.Color := Self.Color; + Canvas.Brush.Style := bsSolid; + {clear complete client area} + Canvas.FillRect(Rect(0, 0, CR.Right, CR.Bottom)); + end; + Canvas.Brush.Style := bsClear; + PaintPrim(CR, Flags) + finally + Canvas.Handle := 0; + end; +end; + +procedure TOvcCustomLabel.SetAppearance(Value : TOvcAppearance); +begin + if FAppearance <> Value then begin + SettingAppearance := True; + try + FAppearance := Value; + FCustomSettings.BeginUpdate; + try + FCustomSettings.HighlightColor := eslSchemes[ColorScheme,cpHighlight]; + case FAppearance of + apRaised: + begin + FCustomSettings.HighlightDirection := sdUpLeft; + FCustomSettings.ShadowDirection := sdDownRight; + FCustomSettings.HighlightDepth := 1; + FCustomSettings.ShadowDepth := 1; + end; + apSunken: + begin + FCustomSettings.HighlightDirection := sdDownRight; + FCustomSettings.ShadowDirection := sdUpLeft; + FCustomSettings.HighlightDepth := 1; + FCustomSettings.ShadowDepth := 1; + end; + apShadow: + begin + FCustomSettings.HighlightDirection := sdNone; + FCustomSettings.ShadowDirection := sdDownRight; + FCustomSettings.HighlightDepth := 0; + FCustomSettings.ShadowDepth := 2; + end; + apFlying: + begin + FCustomSettings.HighlightDirection := sdDownRight; + FCustomSettings.ShadowDirection := sdDownRight; + FCustomSettings.HighlightDepth :=1; + FCustomSettings.ShadowDepth :=5; + {flying has two shadows} + FCustomSettings.HighlightColor := eslSchemes[ColorScheme, cpShadow]; + end; + apNone: + begin + FCustomSettings.HighlightDirection := sdNone; + FCustomSettings.ShadowDirection := sdNone; + FCustomSettings.HighlightDepth :=0; + FCustomSettings.ShadowDepth :=0; + end; + end; + finally + FCustomSettings.EndUpdate; + end; + finally + SettingAppearance := False; + Perform(CM_TEXTCHANGED, 0, 0); + end; + end; +end; + +procedure TOvcCustomLabel.SetColorScheme(Value : TOvcColorScheme); +begin + if FColorScheme <> Value then begin + SettingColorScheme := True; + try + FColorScheme := Value; + FCustomSettings.BeginUpdate; + try + FCustomSettings.HighlightColor := eslSchemes[FColorScheme, cpHighlight]; + Font.Color := eslSchemes[FColorScheme, cpFace]; + FCustomSettings.ShadowColor := eslSchemes[FColorScheme, cpShadow]; + if FColorScheme <> csCustom then begin + eslSchemes[csCustom, cpHighlight] := eslSchemes[FColorScheme, cpHighlight]; + eslSchemes[csCustom, cpFace] := eslSchemes[FColorScheme, cpFace]; + eslSchemes[csCustom, cpShadow] := eslSchemes[FColorScheme, cpShadow]; + end; + finally + FCustomSettings.EndUpdate; + end; + finally + SettingColorScheme := False; + Perform(CM_TEXTCHANGED, 0, 0); + end; + end; +end; + +procedure TOvcCustomLabel.ColorChanged(Sender : TObject); +begin + if csLoading in ComponentState then + Exit; + + Invalidate; + + if not SettingColorScheme then + FColorScheme := csCustom; + + if not SettingColorScheme then + Perform(CM_COLORCHANGED, 0, 0); +end; + +procedure TOvcCustomLabel.StyleChanged(Sender : TObject); +begin + if csLoading in ComponentState then + Exit; + + Invalidate; + + if not SettingAppearance then begin + FAppearance := apCustom; + Perform(CM_TEXTCHANGED, 0, 0); + end; +end; + +procedure TOvcCustomLabel.SetAbout(const Value : string); +begin +end; + +procedure TOvcCustomLabel.SetWordWrap(Value : Boolean); +begin + if Value <> WordWrap then begin + inherited WordWrap := Value; + Invalidate; + end; +end; + +end. diff --git a/components/orpheus/ovclbl0.lfm b/components/orpheus/ovclbl0.lfm new file mode 100644 index 000000000..a64e7b05b --- /dev/null +++ b/components/orpheus/ovclbl0.lfm @@ -0,0 +1,382 @@ +object frmOvcLabel: TfrmOvcLabel + Left = 328 + Top = 198 + BorderStyle = bsDialog + Caption = 'Style Manager' + ClientHeight = 456 + Height = 456 + ClientWidth = 577 + Width = 577 + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Style = [] + OnCreate = FormCreate + PixelsPerInch = 96 + TextHeight = 13 + object Panel1: TPanel + Left = 0 + Top = 0 + Width = 577 + Height = 97 + Align = alTop + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Style = [] + ParentFont = False + TabOrder = 0 + object OvcLabel: TOvcLabel + Left = 1 + Top = 1 + Width = 575 + Height = 95 + Align = alClient + Alignment = taCenter + Appearance = apCustom + Caption = 'Orpheus Labels' + ColorScheme = csCustom + Font.Charset = DEFAULT_CHARSET + Font.Color = clGray + Font.Height = -27 + Font.Style = [] + ParentFont = False + end + end + object Button1: TButton + Left = 418 + Top = 427 + Width = 75 + Height = 25 + Caption = 'OK' + Default = True + ModalResult = 1 + TabOrder = 4 + end + object Button2: TButton + Left = 500 + Top = 427 + Width = 75 + Height = 25 + Cancel = True + Caption = 'Cancel' + ModalResult = 2 + TabOrder = 5 + end + object Panel2: TPanel + Left = 0 + Top = 364 + Width = 393 + Height = 91 + TabOrder = 3 + object Label1: TLabel + Left = 4 + Top = 4 + Width = 57 + Height = 13 + Caption = 'Style Name:' + end + object Label2: TLabel + Left = 256 + Top = 5 + Width = 61 + Height = 13 + Caption = 'Appearance:' + end + object Label3: TLabel + Left = 256 + Top = 48 + Width = 69 + Height = 13 + Caption = 'Color Scheme:' + end + object SchemeCb: TComboBox + Left = 4 + Top = 20 + Width = 233 + Height = 21 + Style = csDropDownList + ItemHeight = 13 + Items.Strings = ( + 'one' + 'two') + MaxLength = 255 + Sorted = True + TabOrder = 0 + OnChange = SchemeCbChange + end + object SaveAsBtn: TButton + Left = 4 + Top = 55 + Width = 75 + Height = 25 + Caption = 'Save &As...' + TabOrder = 1 + OnClick = SaveAsBtnClick + end + object DeleteBtn: TButton + Left = 161 + Top = 55 + Width = 75 + Height = 25 + Caption = '&Delete' + TabOrder = 2 + OnClick = DeleteBtnClick + end + object AppearanceCb: TComboBox + Left = 256 + Top = 20 + Width = 126 + Height = 21 + ItemHeight = 13 + TabOrder = 3 + OnChange = AppearanceCbChange + end + object ColorSchemeCb: TComboBox + Left = 256 + Top = 62 + Width = 126 + Height = 21 + ItemHeight = 13 + TabOrder = 4 + OnChange = ColorSchemeCbChange + end + end + object Panel3: TPanel + Left = 0 + Top = 97 + Width = 577 + Height = 189 + TabOrder = 1 + object Label4: TLabel + Left = 152 + Top = 83 + Width = 70 + Height = 13 + Caption = 'Gradient Color:' + end + object Label5: TLabel + Left = 294 + Top = 83 + Width = 71 + Height = 13 + Caption = 'Highlight Color:' + end + object Label6: TLabel + Left = 437 + Top = 83 + Width = 69 + Height = 13 + Caption = 'Shadow Color:' + end + object HighlightDirectionLbl: TLabel + Left = 304 + Top = 128 + Width = 50 + Height = 32 + AutoSize = False + Caption = 'Highlight Direction:' + WordWrap = True + end + object ShadowDirectionLbl: TLabel + Left = 447 + Top = 128 + Width = 50 + Height = 32 + AutoSize = False + Caption = 'Shadow Direction:' + WordWrap = True + end + object Label7: TLabel + Left = 8 + Top = 65 + Width = 53 + Height = 13 + Caption = 'Text Color/' + end + object Label8: TLabel + Left = 8 + Top = 78 + Width = 86 + Height = 13 + Caption = 'Gradient To Color:' + end + object GraduateRg: TRadioGroup + Left = 150 + Top = 3 + Width = 137 + Height = 73 + Caption = 'Text &Gradient Style' + ItemIndex = 0 + Items.Strings = ( + 'None' + 'Horizontal' + 'Vertical') + OnClick = GraduateRgClick + end + object ShadowRg: TRadioGroup + Left = 436 + Top = 3 + Width = 137 + Height = 73 + Caption = '&Shadow Style' + ItemIndex = 0 + Items.Strings = ( + 'Plain' + 'Extrude' + 'Graduate') + OnClick = ShadowRgClick + end + object HighlightRg: TRadioGroup + Left = 293 + Top = 3 + Width = 137 + Height = 73 + Caption = '&Highlight Style' + ItemIndex = 0 + Items.Strings = ( + 'Plain' + 'Extrude' + 'Graduate') + OnClick = HighlightRgClick + end + object FromColorCcb: TOvcColorComboBox + Left = 151 + Top = 99 + Width = 137 + Height = 22 + ItemHeight = 12 + SelectedColor = clBlack + TabOrder = 4 + Text = 'Black' + OnChange = FromColorCcbChange + end + object HighlightColorCcb: TOvcColorComboBox + Left = 293 + Top = 99 + Width = 137 + Height = 22 + ItemHeight = 12 + SelectedColor = clBlack + TabOrder = 5 + Text = 'Black' + OnChange = HighlightColorCcbChange + end + object ShadowColorCcb: TOvcColorComboBox + Left = 436 + Top = 99 + Width = 137 + Height = 22 + ItemHeight = 12 + SelectedColor = clBlack + TabOrder = 6 + Text = 'Black' + OnChange = ShadowColorCcbChange + end + object FontColorCcb: TOvcColorComboBox + Left = 7 + Top = 99 + Width = 137 + Height = 22 + ItemHeight = 12 + SelectedColor = clBlack + TabOrder = 0 + Text = 'Black' + OnChange = FontColorCcbChange + end + end + object Panel4: TPanel + Left = 0 + Top = 286 + Width = 577 + Height = 78 + TabOrder = 2 + object Label9: TLabel + Left = 20 + Top = 8 + Width = 105 + Height = 13 + Alignment = taRightJustify + AutoSize = False + Caption = 'Font Size: ' + end + object FontSizeLbl: TLabel + Left = 500 + Top = 8 + Width = 6 + Height = 13 + Caption = '0' + end + object HighlightDepthLbl: TLabel + Left = 500 + Top = 32 + Width = 6 + Height = 13 + Caption = '0' + end + object ShadowDepthLbl: TLabel + Left = 500 + Top = 56 + Width = 6 + Height = 13 + Caption = '0' + end + object Label10: TLabel + Left = 20 + Top = 32 + Width = 105 + Height = 13 + Alignment = taRightJustify + AutoSize = False + Caption = 'Highlight Depth: ' + end + object Label11: TLabel + Left = 20 + Top = 56 + Width = 105 + Height = 13 + Alignment = taRightJustify + AutoSize = False + Caption = 'Shadow Depth: ' + end + object FontSizeSb: TScrollBar + Left = 132 + Top = 8 + Width = 357 + Height = 14 + TabOrder = 0 + OnChange = FontSizeSbChange + end + object ShadowDepthSb: TScrollBar + Left = 132 + Top = 56 + Width = 357 + Height = 14 + Max = 50 + TabOrder = 2 + OnChange = ShadowDepthSbChange + end + object HighlightDepthSb: TScrollBar + Left = 132 + Top = 32 + Width = 357 + Height = 14 + Max = 50 + TabOrder = 1 + OnChange = HighlightDepthSbChange + end + end + object OvcController1: TOvcController + EntryCommands.TableList = ( + 'Default' + True + () + 'WordStar' + False + () + 'Grid' + False + ()) + Epoch = 1900 + end +end diff --git a/components/orpheus/ovclbl0.lrs b/components/orpheus/ovclbl0.lrs new file mode 100644 index 000000000..656aefb8b --- /dev/null +++ b/components/orpheus/ovclbl0.lrs @@ -0,0 +1,92 @@ +LazarusResources.Add('TfrmOvcLabel','FORMDATA',[ + 'TPF0'#12'TfrmOvcLabel'#11'frmOvcLabel'#4'Left'#3'H'#1#3'Top'#3#198#0#11'Bord' + +'erStyle'#7#8'bsDialog'#7'Caption'#6#13'Style Manager'#12'ClientHeight'#3#200 + +#1#6'Height'#3#200#1#11'ClientWidth'#3'A'#2#5'Width'#3'A'#2#12'Font.Charset' + +#7#15'DEFAULT_CHARSET'#10'Font.Color'#7#12'clWindowText'#11'Font.Height'#2 + +#245#10'Font.Style'#11#0#8'OnCreate'#7#10'FormCreate'#13'PixelsPerInch'#2'`' + +#10'TextHeight'#2#13#0#6'TPanel'#6'Panel1'#4'Left'#2#0#3'Top'#2#0#5'Width'#3 + +'A'#2#6'Height'#2'a'#5'Align'#7#5'alTop'#12'Font.Charset'#7#15'DEFAULT_CHARS' + +'ET'#10'Font.Color'#7#12'clWindowText'#11'Font.Height'#2#245#10'Font.Style' + +#11#0#10'ParentFont'#8#8'TabOrder'#2#0#0#9'TOvcLabel'#8'OvcLabel'#4'Left'#2#1 + +#3'Top'#2#1#5'Width'#3'?'#2#6'Height'#2'_'#5'Align'#7#8'alClient'#9'Alignmen' + +'t'#7#8'taCenter'#10'Appearance'#7#8'apCustom'#7'Caption'#6#14'Orpheus Label' + +'s'#11'ColorScheme'#7#8'csCustom'#12'Font.Charset'#7#15'DEFAULT_CHARSET'#10 + +'Font.Color'#7#6'clGray'#11'Font.Height'#2#229#10'Font.Style'#11#0#10'Parent' + +'Font'#8#0#0#0#7'TButton'#7'Button1'#4'Left'#3#162#1#3'Top'#3#171#1#5'Width' + +#2'K'#6'Height'#2#25#7'Caption'#6#2'OK'#7'Default'#9#11'ModalResult'#2#1#8'T' + +'abOrder'#2#4#0#0#7'TButton'#7'Button2'#4'Left'#3#244#1#3'Top'#3#171#1#5'Wid' + +'th'#2'K'#6'Height'#2#25#6'Cancel'#9#7'Caption'#6#6'Cancel'#11'ModalResult'#2 + +#2#8'TabOrder'#2#5#0#0#6'TPanel'#6'Panel2'#4'Left'#2#0#3'Top'#3'l'#1#5'Width' + +#3#137#1#6'Height'#2'['#8'TabOrder'#2#3#0#6'TLabel'#6'Label1'#4'Left'#2#4#3 + +'Top'#2#4#5'Width'#2'9'#6'Height'#2#13#7'Caption'#6#11'Style Name:'#0#0#6'TL' + +'abel'#6'Label2'#4'Left'#3#0#1#3'Top'#2#5#5'Width'#2'='#6'Height'#2#13#7'Cap' + +'tion'#6#11'Appearance:'#0#0#6'TLabel'#6'Label3'#4'Left'#3#0#1#3'Top'#2'0'#5 + +'Width'#2'E'#6'Height'#2#13#7'Caption'#6#13'Color Scheme:'#0#0#9'TComboBox'#8 + +'SchemeCb'#4'Left'#2#4#3'Top'#2#20#5'Width'#3#233#0#6'Height'#2#21#5'Style'#7 + +#14'csDropDownList'#10'ItemHeight'#2#13#13'Items.Strings'#1#6#3'one'#6#3'two' + +#0#9'MaxLength'#3#255#0#6'Sorted'#9#8'TabOrder'#2#0#8'OnChange'#7#14'SchemeC' + +'bChange'#0#0#7'TButton'#9'SaveAsBtn'#4'Left'#2#4#3'Top'#2'7'#5'Width'#2'K'#6 + +'Height'#2#25#7'Caption'#6#11'Save &As...'#8'TabOrder'#2#1#7'OnClick'#7#14'S' + +'aveAsBtnClick'#0#0#7'TButton'#9'DeleteBtn'#4'Left'#3#161#0#3'Top'#2'7'#5'Wi' + +'dth'#2'K'#6'Height'#2#25#7'Caption'#6#7'&Delete'#8'TabOrder'#2#2#7'OnClick' + +#7#14'DeleteBtnClick'#0#0#9'TComboBox'#12'AppearanceCb'#4'Left'#3#0#1#3'Top' + +#2#20#5'Width'#2'~'#6'Height'#2#21#10'ItemHeight'#2#13#8'TabOrder'#2#3#8'OnC' + +'hange'#7#18'AppearanceCbChange'#0#0#9'TComboBox'#13'ColorSchemeCb'#4'Left'#3 + +#0#1#3'Top'#2'>'#5'Width'#2'~'#6'Height'#2#21#10'ItemHeight'#2#13#8'TabOrder' + +#2#4#8'OnChange'#7#19'ColorSchemeCbChange'#0#0#0#6'TPanel'#6'Panel3'#4'Left' + +#2#0#3'Top'#2'a'#5'Width'#3'A'#2#6'Height'#3#189#0#8'TabOrder'#2#1#0#6'TLabe' + +'l'#6'Label4'#4'Left'#3#152#0#3'Top'#2'S'#5'Width'#2'F'#6'Height'#2#13#7'Cap' + +'tion'#6#15'Gradient Color:'#0#0#6'TLabel'#6'Label5'#4'Left'#3'&'#1#3'Top'#2 + +'S'#5'Width'#2'G'#6'Height'#2#13#7'Caption'#6#16'Highlight Color:'#0#0#6'TLa' + +'bel'#6'Label6'#4'Left'#3#181#1#3'Top'#2'S'#5'Width'#2'E'#6'Height'#2#13#7'C' + +'aption'#6#13'Shadow Color:'#0#0#6'TLabel'#21'HighlightDirectionLbl'#4'Left' + +#3'0'#1#3'Top'#3#128#0#5'Width'#2'2'#6'Height'#2' '#8'AutoSize'#8#7'Caption' + +#6#20'Highlight Direction:'#8'WordWrap'#9#0#0#6'TLabel'#18'ShadowDirectionLb' + +'l'#4'Left'#3#191#1#3'Top'#3#128#0#5'Width'#2'2'#6'Height'#2' '#8'AutoSize'#8 + +#7'Caption'#6#17'Shadow Direction:'#8'WordWrap'#9#0#0#6'TLabel'#6'Label7'#4 + +'Left'#2#8#3'Top'#2'A'#5'Width'#2'5'#6'Height'#2#13#7'Caption'#6#11'Text Col' + +'or/'#0#0#6'TLabel'#6'Label8'#4'Left'#2#8#3'Top'#2'N'#5'Width'#2'V'#6'Height' + +#2#13#7'Caption'#6#18'Gradient To Color:'#0#0#11'TRadioGroup'#10'GraduateRg' + +#4'Left'#3#150#0#3'Top'#2#3#5'Width'#3#137#0#6'Height'#2'I'#7'Caption'#6#20 + +'Text &Gradient Style'#9'ItemIndex'#2#0#13'Items.Strings'#1#6#4'None'#6#10'H' + +'orizontal'#6#8'Vertical'#0#7'OnClick'#7#15'GraduateRgClick'#0#0#11'TRadioGr' + +'oup'#8'ShadowRg'#4'Left'#3#180#1#3'Top'#2#3#5'Width'#3#137#0#6'Height'#2'I' + +#7'Caption'#6#13'&Shadow Style'#9'ItemIndex'#2#0#13'Items.Strings'#1#6#5'Pla' + +'in'#6#7'Extrude'#6#8'Graduate'#0#7'OnClick'#7#13'ShadowRgClick'#0#0#11'TRad' + +'ioGroup'#11'HighlightRg'#4'Left'#3'%'#1#3'Top'#2#3#5'Width'#3#137#0#6'Heigh' + +'t'#2'I'#7'Caption'#6#16'&Highlight Style'#9'ItemIndex'#2#0#13'Items.Strings' + +#1#6#5'Plain'#6#7'Extrude'#6#8'Graduate'#0#7'OnClick'#7#16'HighlightRgClick' + +#0#0#17'TOvcColorComboBox'#12'FromColorCcb'#4'Left'#3#151#0#3'Top'#2'c'#5'Wi' + +'dth'#3#137#0#6'Height'#2#22#10'ItemHeight'#2#12#13'SelectedColor'#7#7'clBla' + +'ck'#8'TabOrder'#2#4#4'Text'#6#5'Black'#8'OnChange'#7#18'FromColorCcbChange' + +#0#0#17'TOvcColorComboBox'#17'HighlightColorCcb'#4'Left'#3'%'#1#3'Top'#2'c'#5 + +'Width'#3#137#0#6'Height'#2#22#10'ItemHeight'#2#12#13'SelectedColor'#7#7'clB' + +'lack'#8'TabOrder'#2#5#4'Text'#6#5'Black'#8'OnChange'#7#23'HighlightColorCcb' + +'Change'#0#0#17'TOvcColorComboBox'#14'ShadowColorCcb'#4'Left'#3#180#1#3'Top' + ,#2'c'#5'Width'#3#137#0#6'Height'#2#22#10'ItemHeight'#2#12#13'SelectedColor'#7 + +#7'clBlack'#8'TabOrder'#2#6#4'Text'#6#5'Black'#8'OnChange'#7#20'ShadowColorC' + +'cbChange'#0#0#17'TOvcColorComboBox'#12'FontColorCcb'#4'Left'#2#7#3'Top'#2'c' + +#5'Width'#3#137#0#6'Height'#2#22#10'ItemHeight'#2#12#13'SelectedColor'#7#7'c' + +'lBlack'#8'TabOrder'#2#0#4'Text'#6#5'Black'#8'OnChange'#7#18'FontColorCcbCha' + +'nge'#0#0#0#6'TPanel'#6'Panel4'#4'Left'#2#0#3'Top'#3#30#1#5'Width'#3'A'#2#6 + +'Height'#2'N'#8'TabOrder'#2#2#0#6'TLabel'#6'Label9'#4'Left'#2#20#3'Top'#2#8#5 + +'Width'#2'i'#6'Height'#2#13#9'Alignment'#7#14'taRightJustify'#8'AutoSize'#8#7 + +'Caption'#6#11'Font Size: '#0#0#6'TLabel'#11'FontSizeLbl'#4'Left'#3#244#1#3 + +'Top'#2#8#5'Width'#2#6#6'Height'#2#13#7'Caption'#6#1'0'#0#0#6'TLabel'#17'Hig' + +'hlightDepthLbl'#4'Left'#3#244#1#3'Top'#2' '#5'Width'#2#6#6'Height'#2#13#7'C' + +'aption'#6#1'0'#0#0#6'TLabel'#14'ShadowDepthLbl'#4'Left'#3#244#1#3'Top'#2'8' + +#5'Width'#2#6#6'Height'#2#13#7'Caption'#6#1'0'#0#0#6'TLabel'#7'Label10'#4'Le' + +'ft'#2#20#3'Top'#2' '#5'Width'#2'i'#6'Height'#2#13#9'Alignment'#7#14'taRight' + +'Justify'#8'AutoSize'#8#7'Caption'#6#17'Highlight Depth: '#0#0#6'TLabel'#7'L' + +'abel11'#4'Left'#2#20#3'Top'#2'8'#5'Width'#2'i'#6'Height'#2#13#9'Alignment'#7 + +#14'taRightJustify'#8'AutoSize'#8#7'Caption'#6#14'Shadow Depth: '#0#0#10'TSc' + +'rollBar'#10'FontSizeSb'#4'Left'#3#132#0#3'Top'#2#8#5'Width'#3'e'#1#6'Height' + +#2#14#8'TabOrder'#2#0#8'OnChange'#7#16'FontSizeSbChange'#0#0#10'TScrollBar' + +#13'ShadowDepthSb'#4'Left'#3#132#0#3'Top'#2'8'#5'Width'#3'e'#1#6'Height'#2#14 + +#3'Max'#2'2'#8'TabOrder'#2#2#8'OnChange'#7#19'ShadowDepthSbChange'#0#0#10'TS' + +'crollBar'#16'HighlightDepthSb'#4'Left'#3#132#0#3'Top'#2' '#5'Width'#3'e'#1#6 + +'Height'#2#14#3'Max'#2'2'#8'TabOrder'#2#1#8'OnChange'#7#22'HighlightDepthSbC' + +'hange'#0#0#0#14'TOvcController'#14'OvcController1'#23'EntryCommands.TableLi' + +'st'#1#6#7'Default'#9#1#0#6#8'WordStar'#8#1#0#6#4'Grid'#8#1#0#0#5'Epoch'#3'l' + +#7#0#0#0 +]); diff --git a/components/orpheus/ovclbl0.pas b/components/orpheus/ovclbl0.pas new file mode 100644 index 000000000..c4acc7e11 --- /dev/null +++ b/components/orpheus/ovclbl0.pas @@ -0,0 +1,610 @@ +{*********************************************************} +{* OVCLBL0.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovclbl0; + +interface + +uses + {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, LclType, LResources, Buttons, {$ENDIF} + SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, ExtCtrls, + {$IFNDEF LCL} {$IFDEF VERSION6} DesignIntf, DesignEditors, {$ELSE} DsgnIntf, {$ENDIF} {$ELSE} PropEdits, ComponentEditors, {$ENDIF} + Menus, IniFiles, OvcLbl2, TypInfo, OvcCmbx, OvcClrCb, OvcLabel, OvcBase, + OvcData; + +type + TfrmOvcLabel = class(TForm) + Panel1: TPanel; + OvcLabel: TOvcLabel; + Button1: TButton; + Button2: TButton; + Panel2: TPanel; + Label1: TLabel; + Label2: TLabel; + Label3: TLabel; + SchemeCb: TComboBox; + SaveAsBtn: TButton; + DeleteBtn: TButton; + Panel3: TPanel; + Label4: TLabel; + Label5: TLabel; + Label6: TLabel; + Label7: TLabel; + Label8: TLabel; + GraduateRg: TRadioGroup; + ShadowRg: TRadioGroup; + HighlightRg: TRadioGroup; + FromColorCcb: TOvcColorComboBox; + HighlightColorCcb: TOvcColorComboBox; + ShadowColorCcb: TOvcColorComboBox; + HighlightDirectionLbl: TLabel; + ShadowDirectionLbl: TLabel; + FontColorCcb: TOvcColorComboBox; + Panel4: TPanel; + Label9: TLabel; + Label10: TLabel; + Label11: TLabel; + FontSizeSb: TScrollBar; + FontSizeLbl: TLabel; + HighlightDepthLbl: TLabel; + ShadowDepthLbl: TLabel; + ShadowDepthSb: TScrollBar; + HighlightDepthSb: TScrollBar; + AppearanceCb: TComboBox; + ColorSchemeCb: TComboBox; + OvcController1: TOvcController; + procedure FontSizeSbChange(Sender: TObject); + procedure HighlightDepthSbChange(Sender: TObject); + procedure ShadowDepthSbChange(Sender: TObject); + procedure GraduateRgClick(Sender: TObject); + procedure HighlightRgClick(Sender: TObject); + procedure ShadowRgClick(Sender: TObject); + procedure FromColorCcbChange(Sender: TObject); + procedure HighlightColorCcbChange(Sender: TObject); + procedure ShadowColorCcbChange(Sender: TObject); + procedure FontColorCcbChange(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure SaveAsBtnClick(Sender: TObject); + procedure DeleteBtnClick(Sender: TObject); + procedure SchemeCbChange(Sender: TObject); + procedure AppearanceCbChange(Sender: TObject); + procedure ColorSchemeCbChange(Sender: TObject); + private + public + HighlightDirectionDp : TOvcDirectionPicker; + ShadowDirectionDp : TOvcDirectionPicker; + SettingScheme : Boolean; + SettingCb : Boolean; + + procedure DeleteScheme(const S : string); + procedure HighlightDirectionChange(Sender: TObject); + procedure ShadowDirectionChange(Sender: TObject); + procedure SchemeChange; + end; + +type + {component editor for the notebook pages} +{$IFNDEF LCL} + TOvcLabelEditor = class(TDefaultEditor) +{$ELSE} + TOvcLabelEditor = class(TDefaultComponentEditor) +{$ENDIF} + public + procedure ExecuteVerb(Index : Integer); + override; + function GetVerb(Index : Integer) : AnsiString; + override; + function GetVerbCount : Integer; + override; + end; + + {property editor for the special settings class} + TOvcCustomSettingsProperty = class(TClassProperty) + public + procedure Edit; + override; + function GetAttributes : TPropertyAttributes; + override; + end; + +function EditOvcLabel(L : TOvcLabel) : Boolean; + + +implementation + +uses + OvcLbl1; + +{$IFNDEF LCL} +{$R *.DFM} +{$ENDIF} + +const + IniFileName = 'orpheus.ini'; +// Note: Location of this file needs to consider platform differences. +// Currently creates it in Lazarus folder (Windows) or root folder (OS X). + +function EditOvcLabel(L : TOvcLabel) : Boolean; +var + D : TfrmOvcLabel; +begin + Result := False; + D := TfrmOvcLabel.Create(Application); + try + D.OvcLabel.Font.Assign(L.Font); + D.OvcLabel.CustomSettings.Assign(L.CustomSettings); + + D.FontSizeSb.Position := L.Font.Size; + D.HighlightDepthSB.Position := L.CustomSettings.HighlightDepth; + D.ShadowDepthSB.Position := L.CustomSettings.ShadowDepth; + + D.GraduateRg.ItemIndex := Ord(L.CustomSettings.GraduateStyle); + D.HighlightRg.ItemIndex := Ord(L.CustomSettings.HighlightStyle); + D.ShadowRg.ItemIndex := Ord(L.CustomSettings.ShadowStyle); + + D.FontColorCcb.SelectedColor := L.Font.Color; + D.FromColorCcb.SelectedColor := L.CustomSettings.GraduateFromColor; + D.HighlightColorCcb.SelectedColor := L.CustomSettings.HighlightColor; + D.ShadowColorCcb.SelectedColor := L.CustomSettings.ShadowColor; + + D.HighlightDirectionDp.Direction := Ord(L.CustomSettings.HighlightDirection)-1; + D.ShadowDirectionDp.Direction := Ord(L.CustomSettings.ShadowDirection)-1; + + if D.ShowModal = mrOK then begin + L.CustomSettings.BeginUpdate; + try + L.Font.Assign(D.OvcLabel.Font); + L.CustomSettings.Assign(D.OvcLabel.CustomSettings); + finally + L.CustomSettings.EndUpdate; + end; + Result := True; + end; + finally + D.Free; + end; +end; + + +{*** TOvcLabelEditor ***} + +procedure TOvcLabelEditor.ExecuteVerb(Index : Integer); +begin + if EditOvcLabel(TOvcLabel(Component)) then +{$IFNDEF LCL} + Designer.Modified; +{$ELSE} + Modified; +{$ENDIF} +end; + +function TOvcLabelEditor.GetVerb(Index : Integer) : AnsiString; +begin + Result := 'Style Manager...'; +end; + +function TOvcLabelEditor.GetVerbCount : Integer; +begin + Result := 1; +end; + + +{*** TOvcCustomSettingsProperty ***} + +procedure TOvcCustomSettingsProperty.Edit; +var + I : Integer; + C : TComponent; + L : TOvcLabel; + M : TOvcLabel; +begin + C := TComponent(GetComponent(0)); + if C is TOvcCustomLabel then begin + L := TOvcLabel(C); + if EditOvcLabel(L) then begin + {if more than one component selected, apply changes to others} + for I := 2 to PropCount do begin + M := TOvcLabel(GetComponent(Pred(I))); + M.CustomSettings.BeginUpdate; + try + M.Font.Assign(L.Font); + M.CustomSettings.Assign(L.CustomSettings); + finally + M.CustomSettings.EndUpdate; + end; + M.Invalidate; + end; +{$IFNDEF LCL} + Designer.Modified; +{$ELSE} + Modified; +{$ENDIF} + end; + end; +end; + +function TOvcCustomSettingsProperty.GetAttributes: TPropertyAttributes; +begin + Result := [paSubProperties, paMultiSelect, paDialog, paReadOnly] +end; + + +{*** TOvcLabelFrm ***} + +procedure TfrmOvcLabel.FontSizeSbChange(Sender: TObject); +begin + OvcLabel.Font.Size := FontSizeSb.Position; + FontSizeLbl.Caption := IntToStr(OvcLabel.Font.Size); + SchemeChange; +end; + +procedure TfrmOvcLabel.HighlightDepthSbChange(Sender: TObject); +begin + OvcLabel.CustomSettings.HighlightDepth := HighlightDepthSb.Position; + HighlightDepthLbl.Caption := IntToStr(OvcLabel.CustomSettings.HighlightDepth); + SchemeChange; +end; + +procedure TfrmOvcLabel.ShadowDepthSbChange(Sender: TObject); +begin + OvcLabel.CustomSettings.ShadowDepth := ShadowDepthSb.Position; + ShadowDepthLbl.Caption := IntToStr(OvcLabel.CustomSettings.ShadowDepth); + SchemeChange; +end; + +procedure TfrmOvcLabel.GraduateRgClick(Sender: TObject); +begin + case GraduateRg.ItemIndex of + 0 : OvcLabel.CustomSettings.GraduateStyle := gsNone; + 1 : OvcLabel.CustomSettings.GraduateStyle := gsHorizontal; + 2 : OvcLabel.CustomSettings.GraduateStyle := gsVertical; + end; + SchemeChange; +end; + +procedure TfrmOvcLabel.HighlightRgClick(Sender: TObject); +begin + case HighlightRg.ItemIndex of + 0 : OvcLabel.CustomSettings.HighlightStyle := ssPlain; + 1 : OvcLabel.CustomSettings.HighlightStyle := ssExtrude; + 2 : OvcLabel.CustomSettings.HighlightStyle := ssGraduated; + end; + SchemeChange; +end; + +procedure TfrmOvcLabel.ShadowRgClick(Sender: TObject); +begin + case ShadowRg.ItemIndex of + 0 : OvcLabel.CustomSettings.ShadowStyle := ssPlain; + 1 : OvcLabel.CustomSettings.ShadowStyle := ssExtrude; + 2 : OvcLabel.CustomSettings.ShadowStyle := ssGraduated; + end; + SchemeChange; +end; + +procedure TfrmOvcLabel.FromColorCcbChange(Sender: TObject); +begin + OvcLabel.CustomSettings.GraduateFromColor := FromColorCcb.SelectedColor; + SchemeChange; +end; + +procedure TfrmOvcLabel.HighlightColorCcbChange(Sender: TObject); +begin + OvcLabel.CustomSettings.HighlightColor := HighlightColorCcb.SelectedColor; + SchemeChange; +end; + +procedure TfrmOvcLabel.ShadowColorCcbChange(Sender: TObject); +begin + OvcLabel.CustomSettings.ShadowColor := ShadowColorCcb.SelectedColor; + SchemeChange; +end; + +procedure TfrmOvcLabel.FontColorCcbChange(Sender: TObject); +begin + OvcLabel.Font.Color := FontColorCcb.SelectedColor; + SchemeChange; +end; + +procedure TfrmOvcLabel.FormCreate(Sender: TObject); +var + Ini : TIniFile; + A : TOvcAppearance; + C : TOvcColorScheme; +begin + Top := (Screen.Height - Height) div 3; + Left := (Screen.Width - Width) div 2; + + {load scheme names into combo box} + Ini := TIniFile.Create(IniFileName); + try + SchemeCb.Items.Clear; + Ini.ReadSection('Schemes', SchemeCb.Items); + finally + Ini.Free; + end; + + {create direction pickers} + HighlightDirectionDp := TOvcDirectionPicker.Create(Self); + HighlightDirectionDp.Top := HighlightDirectionLbl.Top; + HighlightDirectionDp.Left := HighlightDirectionLbl.Left + HighlightDirectionLbl.Width; + HighlightDirectionDp.Width := 50; + HighlightDirectionDp.Height := 50; + HighlightDirectionDp.NumDirections := 8; + HighlightDirectionDp.OnChange := HighlightDirectionChange; + HighlightDirectionDp.Parent := HighlightDirectionLbl.Parent; + HighlightDirectionDp.Visible := True; + + ShadowDirectionDp := TOvcDirectionPicker.Create(Self); + ShadowDirectionDp.Top := ShadowDirectionLbl.Top; + ShadowDirectionDp.Left := ShadowDirectionLbl.Left + ShadowDirectionLbl.Width; + ShadowDirectionDp.Width := 50; + ShadowDirectionDp.Height := 50; + ShadowDirectionDp.NumDirections := 8; + ShadowDirectionDp.OnChange := ShadowDirectionChange; + ShadowDirectionDp.Parent := ShadowDirectionLbl.Parent; + ShadowDirectionDp.Visible := True; + + {initialize appearance and color scheme ComboBoxes using rtti} + for A := Low(TOvcAppearance) to High(TOvcAppearance) do + AppearanceCb.Items.Add(GetEnumName(TypeInfo(TOvcAppearance), Ord(A))); + for C := Low(TOvcColorScheme) to High(TOvcColorScheme) do + ColorSchemeCb.Items.Add(GetEnumName(TypeInfo(TOvcColorScheme), Ord(C))); +end; + +procedure TfrmOvcLabel.SaveAsBtnClick(Sender: TObject); +var + Ini : TIniFile; + S : string; +begin + with TfrmSaveScheme.Create(Self) do begin + if (ShowModal = mrOK) and (SchemeNameEd.Text > '') then begin + S := SchemeNameEd.Text; + Ini := TIniFile.Create(IniFileName); + try + {delete scheme} + DeleteScheme(S); + + {add scheme name to list of schemes} + Ini.WriteInteger('Schemes', S, 0); + + {create new scheme section and add values} + Ini.WriteInteger(S, 'GraduateStyle', Ord(OvcLabel.CustomSettings.GraduateStyle)); + Ini.WriteInteger(S, 'HighlightStyle', Ord(OvcLabel.CustomSettings.HighlightStyle)); + Ini.WriteInteger(S, 'ShadowStyle', Ord(OvcLabel.CustomSettings.ShadowStyle)); + Ini.WriteString(S, 'GraduateFromColor', ColorToString(OvcLabel.CustomSettings.GraduateFromColor)); + Ini.WriteString(S, 'HighlightColor', ColorToString(OvcLabel.CustomSettings.HighlightColor)); + Ini.WriteString(S, 'ShadowColor', ColorToString(OvcLabel.CustomSettings.ShadowColor)); + Ini.WriteInteger(S, 'HighlightDirection', Ord(OvcLabel.CustomSettings.HighlightDirection)); + Ini.WriteInteger(S, 'ShadowDirection', Ord(OvcLabel.CustomSettings.ShadowDirection)); + Ini.WriteString(S, 'FontColor', ColorToString(OvcLabel.Font.Color)); + Ini.WriteString(S, 'FontName', OvcLabel.Font.Name); + Ini.WriteInteger(S, 'FontPitch', Ord(OvcLabel.Font.Pitch)); + Ini.WriteInteger(S, 'FontSize', OvcLabel.Font.Size); + Ini.WriteBool(S, 'FontBold', fsBold in OvcLabel.Font.Style); + Ini.WriteBool(S, 'FontItalic', fsItalic in OvcLabel.Font.Style); + Ini.WriteBool(S, 'FontUnderline', fsUnderline in OvcLabel.Font.Style); + Ini.WriteBool(S, 'FontStrikeOut', fsStrikeOut in OvcLabel.Font.Style); + Ini.WriteInteger(S, 'HighlightDepth', OvcLabel.CustomSettings.HighlightDepth); + Ini.WriteInteger(S, 'ShadowDepth', OvcLabel.CustomSettings.ShadowDepth); + finally + Ini.Free; + end; + + {add item to the ComboBox, if its not there already} + if SchemeCb.Items.IndexOf(S) < 0 then + SchemeCb.Items.Add(S); + end; + Free; + end; +end; + +procedure TfrmOvcLabel.DeleteBtnClick(Sender: TObject); +var + I : Integer; +begin + I := SchemeCb.ItemIndex; + if I > -1 then begin + DeleteScheme(SchemeCb.Items[I]); + {delete the entry from the combo box} + SchemeCb.Items.Delete(I); + end; +end; + +procedure TfrmOvcLabel.DeleteScheme(const S : string); +var + Ini : TIniFile; +begin + {delete the scheme entry from the ini file} + Ini := TIniFile.Create(IniFileName); + try + {delete the section} + Ini.EraseSection(S); + {delete the scheme name} + Ini.DeleteKey('Schemes', S); + finally + Ini.Free; + end; +end; + +procedure TfrmOvcLabel.SchemeCbChange(Sender: TObject); +var + I : Integer; + Ini : TIniFile; + S : string; +begin + I := SchemeCb.ItemIndex; + if I > -1 then begin + S := SchemeCb.Items[I]; + Ini := TIniFile.Create(IniFileName); + SettingScheme := True; + try + OvcLabel.CustomSettings.GraduateStyle := TOvcGraduateStyle(Ini.ReadInteger(S, 'GraduateStyle', 0)); + OvcLabel.CustomSettings.HighlightStyle := TOvcShadeStyle(Ini.ReadInteger(S, 'HighlightStyle', 0)); + OvcLabel.CustomSettings.ShadowStyle := TOvcShadeStyle(Ini.ReadInteger(S, 'ShadowStyle', 0)); + OvcLabel.CustomSettings.GraduateFromColor := StringToColor(Ini.ReadString(S, 'GraduateFromColor', '0')); + OvcLabel.CustomSettings.HighlightColor := StringToColor(Ini.ReadString(S, 'HighlightColor', '0')); + OvcLabel.CustomSettings.ShadowColor := StringToColor(Ini.ReadString(S, 'ShadowColor', '0')); + OvcLabel.CustomSettings.HighlightDirection := TOvcShadeDirection(Ini.ReadInteger(S, 'HighlightDirection', 0)); + OvcLabel.CustomSettings.ShadowDirection := TOvcShadeDirection(Ini.ReadInteger(S, 'ShadowDirection', 0)); + OvcLabel.CustomSettings.HighlightDepth := Ini.ReadInteger(S, 'HighlightDepth', 1); + OvcLabel.CustomSettings.ShadowDepth := Ini.ReadInteger(S, 'ShadowDepth', 1); + + OvcLabel.Font.Color := StringToColor(Ini.ReadString(S, 'FontColor', '0')); +{$IFNDEF LCL} + OvcLabel.Font.Name := Ini.ReadString(S, 'FontName', 'Times New Roman'); +{$ELSE} + OvcLabel.Font.Name := Ini.ReadString(S, 'FontName', 'default'); +{$ENDIF} + OvcLabel.Font.Pitch := TFontPitch(Ini.ReadInteger(S, 'FontPitch', 0)); + OvcLabel.Font.Size := Ini.ReadInteger(S, 'FontSize', 10); + OvcLabel.Font.Style := []; + if Ini.ReadBool(S, 'FontBold', False) then + OvcLabel.Font.Style := OvcLabel.Font.Style + [fsBold]; + if Ini.ReadBool(S, 'FontItalic', False) then + OvcLabel.Font.Style := OvcLabel.Font.Style + [fsItalic]; + if Ini.ReadBool(S, 'FontUnderline', False) then + OvcLabel.Font.Style := OvcLabel.Font.Style + [fsUnderline]; + if Ini.ReadBool(S, 'FontStrikeOut', False) then + OvcLabel.Font.Style := OvcLabel.Font.Style + [fsStrikeOut]; + + FontSizeSb.Position := OvcLabel.Font.Size; + HighlightDepthSB.Position := OvcLabel.CustomSettings.HighlightDepth; + ShadowDepthSB.Position := OvcLabel.CustomSettings.ShadowDepth; + GraduateRg.ItemIndex := Ord(OvcLabel.CustomSettings.GraduateStyle); + HighlightRg.ItemIndex := Ord(OvcLabel.CustomSettings.HighlightStyle); + ShadowRg.ItemIndex := Ord(OvcLabel.CustomSettings.ShadowStyle); + FontColorCcb.SelectedColor := OvcLabel.Font.Color; + FromColorCcb.SelectedColor := OvcLabel.CustomSettings.GraduateFromColor; + HighlightColorCcb.SelectedColor := OvcLabel.CustomSettings.HighlightColor; + ShadowColorCcb.SelectedColor := OvcLabel.CustomSettings.ShadowColor; + HighlightDirectionDp.Direction := Ord(OvcLabel.CustomSettings.HighlightDirection)-1; + ShadowDirectionDp.Direction := Ord(OvcLabel.CustomSettings.ShadowDirection)-1; + finally + SettingScheme := False; + Ini.Free; + end; + end; +end; + +procedure TfrmOvcLabel.HighlightDirectionChange(Sender: TObject); +begin + OvcLabel.CustomSettings.HighlightDirection := + TOvcShadeDirection(HighlightDirectionDp.Direction+1); + SchemeChange; +end; + +procedure TfrmOvcLabel.ShadowDirectionChange(Sender: TObject); +begin + OvcLabel.CustomSettings.ShadowDirection := + TOvcShadeDirection(ShadowDirectionDp.Direction+1); + SchemeChange; +end; + +procedure TfrmOvcLabel.SchemeChange; +begin + if not SettingScheme then + SchemeCb.ItemIndex := -1; + + if not SettingCb then begin + AppearanceCb.ItemIndex := -1; + ColorSchemeCb.ItemIndex := -1; + end; +end; + + +procedure TfrmOvcLabel.AppearanceCbChange(Sender: TObject); +begin + if AppearanceCb.ItemIndex > -1 then begin + SettingScheme := True; + SettingCb := True; + try + OvcLabel.Appearance := TOvcAppearance(AppearanceCb.ItemIndex); + + FontSizeSb.Position := OvcLabel.Font.Size; + HighlightDepthSB.Position := OvcLabel.CustomSettings.HighlightDepth; + ShadowDepthSB.Position := OvcLabel.CustomSettings.ShadowDepth; + GraduateRg.ItemIndex := Ord(OvcLabel.CustomSettings.GraduateStyle); + HighlightRg.ItemIndex := Ord(OvcLabel.CustomSettings.HighlightStyle); + ShadowRg.ItemIndex := Ord(OvcLabel.CustomSettings.ShadowStyle); + FontColorCcb.SelectedColor := OvcLabel.Font.Color; + FromColorCcb.SelectedColor := OvcLabel.CustomSettings.GraduateFromColor; + HighlightColorCcb.SelectedColor := OvcLabel.CustomSettings.HighlightColor; + ShadowColorCcb.SelectedColor := OvcLabel.CustomSettings.ShadowColor; + HighlightDirectionDp.Direction := Ord(OvcLabel.CustomSettings.HighlightDirection)-1; + ShadowDirectionDp.Direction := Ord(OvcLabel.CustomSettings.ShadowDirection)-1; + finally + SettingCb := False; + SettingScheme := False; + end; + end; +end; + +procedure TfrmOvcLabel.ColorSchemeCbChange(Sender: TObject); +begin + if ColorSchemeCb.ItemIndex > -1 then begin + SettingScheme := True; + SettingCb := True; + try + OvcLabel.ColorScheme := TOvcColorScheme(ColorSchemeCb.ItemIndex); + + FontSizeSb.Position := OvcLabel.Font.Size; + HighlightDepthSB.Position := OvcLabel.CustomSettings.HighlightDepth; + ShadowDepthSB.Position := OvcLabel.CustomSettings.ShadowDepth; + GraduateRg.ItemIndex := Ord(OvcLabel.CustomSettings.GraduateStyle); + HighlightRg.ItemIndex := Ord(OvcLabel.CustomSettings.HighlightStyle); + ShadowRg.ItemIndex := Ord(OvcLabel.CustomSettings.ShadowStyle); + FontColorCcb.SelectedColor := OvcLabel.Font.Color; + FromColorCcb.SelectedColor := OvcLabel.CustomSettings.GraduateFromColor; + HighlightColorCcb.SelectedColor := OvcLabel.CustomSettings.HighlightColor; + ShadowColorCcb.SelectedColor := OvcLabel.CustomSettings.ShadowColor; + HighlightDirectionDp.Direction := Ord(OvcLabel.CustomSettings.HighlightDirection)-1; + ShadowDirectionDp.Direction := Ord(OvcLabel.CustomSettings.ShadowDirection)-1; + finally + SettingCb := False; + SettingScheme := False; + end; + end; +end; + +initialization +{$IFDEF LCL} +{$I ovclbl0.lrs} {Include form's resource file} +{$ENDIF} + +end. diff --git a/components/orpheus/ovclbl1.lfm b/components/orpheus/ovclbl1.lfm new file mode 100644 index 000000000..864ce1840 --- /dev/null +++ b/components/orpheus/ovclbl1.lfm @@ -0,0 +1,52 @@ +object frmSaveScheme: TfrmSaveScheme + Left = 347 + Top = 298 + BorderStyle = bsDialog + Caption = 'Save Style' + ClientHeight = 85 + Height = 85 + ClientWidth = 348 + Width = 348 + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Style = [] + OnCreate = FormCreate + PixelsPerInch = 96 + TextHeight = 13 + object Label1: TLabel + Left = 4 + Top = 8 + Width = 85 + Height = 13 + Caption = 'Save this style as:' + end + object SchemeNameEd: TEdit + Left = 4 + Top = 24 + Width = 341 + Height = 21 + MaxLength = 255 + TabOrder = 0 + end + object OkBtn: TButton + Left = 192 + Top = 56 + Width = 75 + Height = 25 + Caption = 'OK' + Default = True + ModalResult = 1 + TabOrder = 1 + end + object CancelBtn: TButton + Left = 272 + Top = 56 + Width = 75 + Height = 25 + Cancel = True + Caption = 'Cancel' + ModalResult = 2 + TabOrder = 2 + end +end diff --git a/components/orpheus/ovclbl1.lrs b/components/orpheus/ovclbl1.lrs new file mode 100644 index 000000000..cc4a92fa6 --- /dev/null +++ b/components/orpheus/ovclbl1.lrs @@ -0,0 +1,15 @@ +LazarusResources.Add('TfrmSaveScheme','FORMDATA',[ + 'TPF0'#14'TfrmSaveScheme'#13'frmSaveScheme'#4'Left'#3'['#1#3'Top'#3'*'#1#11'B' + +'orderStyle'#7#8'bsDialog'#7'Caption'#6#10'Save Style'#12'ClientHeight'#2'U' + +#6'Height'#2'U'#11'ClientWidth'#3'\'#1#5'Width'#3'\'#1#12'Font.Charset'#7#15 + +'DEFAULT_CHARSET'#10'Font.Color'#7#12'clWindowText'#11'Font.Height'#2#245#10 + +'Font.Style'#11#0#8'OnCreate'#7#10'FormCreate'#13'PixelsPerInch'#2'`'#10'Tex' + +'tHeight'#2#13#0#6'TLabel'#6'Label1'#4'Left'#2#4#3'Top'#2#8#5'Width'#2'U'#6 + +'Height'#2#13#7'Caption'#6#19'Save this style as:'#0#0#5'TEdit'#12'SchemeNam' + +'eEd'#4'Left'#2#4#3'Top'#2#24#5'Width'#3'U'#1#6'Height'#2#21#9'MaxLength'#3 + +#255#0#8'TabOrder'#2#0#0#0#7'TButton'#5'OkBtn'#4'Left'#3#192#0#3'Top'#2'8'#5 + +'Width'#2'K'#6'Height'#2#25#7'Caption'#6#2'OK'#7'Default'#9#11'ModalResult'#2 + +#1#8'TabOrder'#2#1#0#0#7'TButton'#9'CancelBtn'#4'Left'#3#16#1#3'Top'#2'8'#5 + +'Width'#2'K'#6'Height'#2#25#6'Cancel'#9#7'Caption'#6#6'Cancel'#11'ModalResul' + +'t'#2#2#8'TabOrder'#2#2#0#0#0 +]); diff --git a/components/orpheus/ovclbl1.pas b/components/orpheus/ovclbl1.pas new file mode 100644 index 000000000..ee926c1cc --- /dev/null +++ b/components/orpheus/ovclbl1.pas @@ -0,0 +1,77 @@ +{*********************************************************} +{* OVCLBL1.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovclbl1; + +interface + +uses + {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, LclType, LResources, Buttons, {$ENDIF} + SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls; + +type + TfrmSaveScheme = class(TForm) + Label1: TLabel; + SchemeNameEd: TEdit; + OkBtn: TButton; + CancelBtn: TButton; + procedure FormCreate(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +implementation + +{$IFNDEF LCL} +{$R *.DFM} +{$ENDIF} + +procedure TfrmSaveScheme.FormCreate(Sender: TObject); +begin + Top := (Screen.Height - Height) div 3; + Left := (Screen.Width - Width) div 2; +end; + +initialization +{$IFDEF LCL} +{$I ovclbl1.lrs} {Include form's resource file} +{$ENDIF} + +end. diff --git a/components/orpheus/ovclbl2.pas b/components/orpheus/ovclbl2.pas new file mode 100644 index 000000000..ea78150c5 --- /dev/null +++ b/components/orpheus/ovclbl2.pas @@ -0,0 +1,290 @@ +{*********************************************************} +{* OVCLABEL.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovclbl2; + {-direction picker component} + +interface + +uses + {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, LclType, LResources, {$ENDIF} + Classes, Controls, Graphics, OvcBase, OvcData, OvcMisc; + +type + TOvcCustomDirectionPicker = class(TOvcGraphicControl) + protected {private} + {property variables} + FDirection : Integer; + FNumDirections : Integer; + FSelectedBitmap : TBitmap; + FShowCenter : Boolean; + FDirectionBitmap : TBitmap; + + {event variables} + FOnChange : TNotifyEvent; + + {property methods} + procedure SetDirection(Value : Integer); + procedure SetSelectedBitmap(Value : TBitmap); + procedure SetNumDirections(Value : Integer); + procedure SetShowCenter(Value : Boolean); + procedure SetDirectionBitmap(Value : TBitmap); + + protected + procedure MouseDown(Button : TMouseButton; Shift : TShiftState; X, Y : Integer); + override; + procedure Paint; + override; + + property Direction : Integer + read FDirection write SetDirection default 0; + property NumDirections : Integer + read FNumDirections write SetNumDirections default 8; + property SelectedBitmap : TBitmap + read FSelectedBitmap write SetSelectedBitmap; + property ShowCenter : Boolean + read FShowCenter write SetShowCenter default True; + property DirectionBitmap : TBitmap + read FDirectionBitmap write SetDirectionBitmap; + + property OnChange : TNotifyEvent + read FOnChange write FOnChange; + + public + constructor Create(AComponent : TComponent); + override; + destructor Destroy; + override; + end; + + TOvcDirectionPicker = class(TOvcCustomDirectionPicker) + published + property Direction; + property Enabled; + property SelectedBitmap; + property NumDirections; + property ShowCenter; + property DirectionBitmap; + + property OnChange; + property OnClick; + property OnDblClick; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + end; + + +implementation + + +const + DToR = Pi / 180; + +constructor TOvcCustomDirectionPicker.Create(AComponent : TComponent); +begin + inherited Create(AComponent); + + ControlStyle := [csClickEvents, csDoubleClicks]; + + Width := 50; + Height := 50; + + FDirection := -1; + FNumDirections := 8; + FShowCenter := True; + + {create and load the bitmap images} + {resource are in ovcreg.rc} + FDirectionBitmap := TBitmap.Create; +{$IFNDEF LCL} + FDirectionBitmap.Handle := LoadBitmap(HInstance, 'ORBLUEDOT'); +{$ELSE} + FDirectionBitmap.LoadFromLazarusResource('ORBLUEDOT'); +{$ENDIF} + FSelectedBitmap := TBitmap.Create; +{$IFNDEF LCL} + FSelectedBitmap.Handle := LoadBitmap(HInstance, 'ORREDDOT'); +{$ELSE} + FSelectedBitmap.LoadFromLazarusResource('ORREDDOT'); +{$ENDIF} +end; + +destructor TOvcCustomDirectionPicker.Destroy; +begin + {destroy bitmaps} + FDirectionBitmap.Free; + FDirectionBitmap := nil; + FSelectedBitmap.Free; + FSelectedBitmap := nil; + + inherited Destroy; +end; + +procedure TOvcCustomDirectionPicker.MouseDown(Button : TMouseButton; Shift : TShiftState; X, Y : Integer); +var + I : Integer; + BW : Integer; + Angle : Extended; + Diameter : Integer; + Radius : Integer; + X1, Y1 : Integer; + Distance : Integer; + BestDirection : Integer; + BestDistance : Integer; +begin + inherited MouseDown(Button, Shift, X, Y); + + if (Button = mbLeft) and Enabled then begin + BW := MaxI(FDirectionBitmap.Width, FDirectionBitmap.Height); + Diameter := MinI(Height, Width)-2*BW; + Radius := Diameter div 2; + + if FShowCenter then begin + {initialize at center (-1)} + BestDistance := Round(Sqrt(Sqr(Radius+BW-X) + Sqr(Radius+BW-Y))); + BestDirection := -1; + end else begin + BestDistance := Width*2; + BestDirection := FDirection; + end; + + for I := 0 to Pred(FNumDirections) do begin + Angle := (I * (360/FNumDirections) + 90) * DToR; + X1 := Round(Radius * (1-Cos(Angle))) + BW; + Y1 := Round(Radius * (1-Sin(Angle))) + BW; + Distance := Round(Sqrt(Sqr(X1-X) + Sqr(Y1-Y))); + if Distance < BestDistance then begin + BestDistance := Distance; + BestDirection := I; + end; + end; + + Direction := BestDirection; + end; +end; + +procedure TOvcCustomDirectionPicker.Paint; +var + I : Integer; + BW : Integer; + BW2 : Integer; + Angle : Extended; + Diameter : Integer; + Radius : Integer; + X, Y : Integer; +begin + BW := MaxI(FDirectionBitmap.Width, FDirectionBitmap.Height); + Diameter := MinI(Height, Width)-2*BW; + Radius := Diameter div 2; + + if FShowCenter then + Canvas.Draw(Radius+BW, Radius+BW, FDirectionBitmap); + for I := 0 to Pred(FNumDirections) do begin + Angle := (I * (360/FNumDirections) + 90) * DToR; + X := Round(Radius * (1-Cos(Angle))); + Y := Round(Radius * (1-Sin(Angle))); + Canvas.Draw(X+BW, Y+BW, FDirectionBitmap); + end; + + {draw the dot for the selected direction} + BW2 := (MaxI(FSelectedBitmap.Width, FSelectedBitmap.Height)-BW) div 2; {adjustment for larger bitmap} + if FDirection = -1 then begin + if FShowCenter then + Canvas.Draw(Radius+BW-BW2, Radius+BW-BW2, FSelectedBitmap) + end else begin + Angle := (FDirection * (360/FNumDirections) + 90) * DToR; + X := Round(Radius * (1-Cos(Angle))); + Y := Round(Radius * (1-Sin(Angle))); + Canvas.Draw(X+BW-BW2, Y+BW-BW2, FSelectedBitmap); + end; +end; + +procedure TOvcCustomDirectionPicker.SetDirection(Value : Integer); +begin + if csLoading in ComponentState then begin + FDirection := Value; + Exit; + end; + + if (Value <> FDirection) and (Value >= -1) and (Value < FNumDirections) then begin + FDirection := Value; + Invalidate; + if Assigned(FOnChange) then + FOnChange(Self); + end; +end; + +procedure TOvcCustomDirectionPicker.SetSelectedBitmap(Value : TBitmap); +begin + if Assigned(Value) then + FSelectedBitmap.Assign(Value) + else + FSelectedBitmap.ReleaseHandle; + Invalidate; +end; + +procedure TOvcCustomDirectionPicker.SetNumDirections(Value : Integer); +begin + if (Value <> FNumDirections) and (Value >= 2) then begin + FNumDirections := Value; + Invalidate; + end; +end; + +procedure TOvcCustomDirectionPicker.SetShowCenter(Value : Boolean); +begin + if Value <> FShowCenter then begin + FShowCenter := Value; + Invalidate; + end; +end; + +procedure TOvcCustomDirectionPicker.SetDirectionBitmap(Value : TBitmap); +begin + if Assigned(Value) then + FDirectionBitmap.Assign(Value) + else + FDirectionBitmap.ReleaseHandle; + Invalidate; +end; + + +initialization + if Classes.GetClass(TOvcDirectionPicker.ClassName) = nil then + Classes.RegisterClass(TOvcDirectionPicker); +end. diff --git a/components/orpheus/ovcmisc.pas b/components/orpheus/ovcmisc.pas new file mode 100644 index 000000000..630d9837b --- /dev/null +++ b/components/orpheus/ovcmisc.pas @@ -0,0 +1,1115 @@ +{*********************************************************} +{* OVCMISC.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C) 1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +(*Changes) + + 10/20/01- Hdc changed to TOvcHdc for BCB Compatibility + 10/20/01- HWnd changed to TOvcHWnd for BCB Compatibility +*) + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovcmisc; + {-Miscellaneous functions and procedures} + +interface + +uses + {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, LclType, MyMisc, {$ENDIF} + Buttons, Classes, Controls, ExtCtrls, Forms, Graphics, + SysUtils, {$IFNDEF LCL} Consts, {$ELSE} LclStrConsts, {$ENDIF} OvcData; + +{ Hdc needs to be an Integer for BCB compatibility } +{$IFDEF CBuilder} +type + TOvcHdc = Integer; + TOvcHWND = Cardinal; +{$ELSE} +type + TOvcHdc = HDC; + TOvcHWND = HWND; +{$ENDIF} + +{$IFNDEF LCL} +function LoadBaseBitmap(lpBitmapName : PAnsiChar) : HBITMAP; + {-load and return the handle to bitmap resource} +{$ENDIF} +function LoadBaseCursor(lpCursorName : PAnsiChar) : HCURSOR; + {-load and return the handle to cursor resource} +function CompStruct(const S1, S2; Size : Cardinal) : Integer; + {-compare two fixed size structures} +function DefaultEpoch : Integer; + {-return the current century} +function DrawButtonFrame(Canvas : TCanvas; const Client : TRect; + IsDown, IsFlat : Boolean; Style : TButtonStyle) : TRect; + {-produce a button similar to DrawFrameControl} +procedure FixRealPrim(P : PAnsiChar; DC : AnsiChar); + {-get a PChar string representing a real ready for Val()} +function GetDisplayString(Canvas : TCanvas; const S : string; + MinChars, MaxWidth : Integer) : string; + {-given a string, a minimum number of chars to display, and a max width, + find the string that can be displayed in that width - add ellipsis to + the end if necessary and possible} +function GetLeftButton: Byte; + {-return the mapped left button} + +{ - HWnd changed to TOvcHWnd for BCB Compatibility } +function GetNextDlgItem(Ctrl : TOvcHWnd{hWnd}) : hWnd; + + {-get handle of next control in the same form} +procedure GetRGB(Clr : TColor; var IR, IG, IB : Byte); + {-return component parts of the rgb value} +function GetShiftFlags : Byte; + {-get current shift flags, the high order bit is set if the key is down} +function CreateRotatedFont(F : TFont; Angle : Integer) : hFont; + {-create a rotated font based on the font object F} +function GetTopTextMargin(Font : TFont; BorderStyle : TBorderStyle; + Height : Integer; Ctl3D : Boolean) : Integer; + {-return the pixel top margin size} +function ExtractWord(N : Integer; const S : string; WordDelims : TCharSet) : string; + {-return the Nth word from S} +function IsForegroundTask : Boolean; + {-returns true if this task is currently in the foreground} +function TrimLeft(const S : string) : string; + {-return a string with leading white space removed} +function TrimRight(const S : string) : string; + {-return a string with trailing white space removed} +function QuotedStr(const S : string) : string; + {-return a quoted string string with internal quotes escaped} +function WordCount(const S : string; const WordDelims : TCharSet) : Integer; + {-return the word count given a set of word delimiters} +function WordPosition(const N : Integer; const S : string; const WordDelims : TCharSet) : Integer; + {-return start position of N'th word in S} +function PtrDiff(const P1, P2) : Word; + {-return the difference between P1 and P2} +procedure PtrInc(var P; Delta : Word); + {-increase P by Delta} +procedure PtrDec(var P; Delta : Word); + {-decrease P by Delta} +procedure FixTextBuffer(InBuf, OutBuf : PChar; OutSize : Integer); + {-replace orphan linefeeds with cr/lf pairs} + +{ - Hdc changed to TOvcHdc for BCB Compatibility } +procedure TransStretchBlt(DstDC: TOvcHdc{HDC}; DstX, DstY, DstW, DstH: Integer; + SrcDC: TOvcHdc{HDC}; SrcX, SrcY, SrcW, SrcH: Integer; + MaskDC: TOvcHdc{HDC}; + MaskX, MaskY : Integer); +function MaxL(A, B : LongInt) : LongInt; +function MinL(A, B : LongInt) : LongInt; +function MinI(X, Y : Integer) : Integer; + {-return the minimum of two integers} +function MaxI(X, Y : Integer) : Integer; + {-return the maximum of two integers} + +{function GenerateComponentName(PF : TCustomForm; const Root : string) : string;} +function GenerateComponentName(PF : TWinControl; const Root : string) : string; + {-return a component name unique for this form} +function PartialCompare(const S1, S2 : string) : Boolean; + {-compare minimum length of S1 and S2 strings} + +function PathEllipsis(const S : string; MaxWidth : Integer) : string; +function CreateDisabledBitmap(FOriginal : TBitmap; OutlineColor : TColor) : TBitmap; +procedure CopyParentImage(Control : TControl; Dest : TCanvas); +procedure DrawTransparentBitmap(Dest : TCanvas; X, Y, W, H : Integer; + Rect : TRect; Bitmap : TBitmap; TransparentColor : TColor); +function WidthOf(const R : TRect) : Integer; + {returnd R.Right - R.Left} +function HeightOf(const R : TRect) : Integer; + {returnd R.Bottom - R.Top} +procedure DebugOutput(const S : string); + {use OutputDebugString()} + +implementation + +uses + OvcBase, OvcStr; + +{$IFNDEF LCL} +function LoadBaseBitmap(lpBitmapName : PAnsiChar) : HBITMAP; +begin + Result := LoadBitmap(FindClassHInstance(TOvcCustomControlEx), lpBitmapName); +end; +{$ENDIF} + +function LoadBaseCursor(lpCursorName : PAnsiChar) : HCURSOR; +begin + Result := LoadCursor(FindClassHInstance(TOvcCustomControlEx), lpCursorName); +end; + +{$IFDEF NoAsm} +function CompStruct(const S1, S2; Size : Cardinal) : Integer; +// Since CompStruct currently only used elsewhere to determine if +// two structures are different, just use CompareMem and don't +// worry about whether "greater than" or "less than". +begin + if CompareMem(@S1, @S2, Size) then {Structures identical?} + Result := 0 + else {Structures not identical, so just return as though S1 > S2} + Result := 1; +end; + +{$ELSE} +function CompStruct(const S1, S2; Size : Cardinal) : Integer; register; + {-compare two fixed size structures} +asm + push esi + push edi + + mov esi, eax {pointer to S1} + mov edi, edx {pointer to S2} + + xor eax, eax {eax holds temporary result (Equal)} + + or ecx, ecx {size is already in ecx} + jz @@CSDone {make sure size isn't zero} + + cld {go forward} + repe cmpsb {compare until no match or ecx = 0} + + je @@CSDone {if equal, result is already in eax} + inc eax {prepare for greater} + ja @@CSDone {S1 greater? return +1} + mov eax, -1 {else S1 less, return -1} + +@@CSDone: + + pop edi + pop esi +end; +{$ENDIF} + +procedure FixRealPrim(P : PAnsiChar; DC : AnsiChar); + {-Get a string representing a real ready for Val()} +var + DotPos : Cardinal; + EPos : Cardinal; + Len : Word; + Found : Boolean; + EFound : Boolean; +begin + TrimAllSpacesPChar(P); + + Len := StrLen(P); + if Len > 0 then begin + if P[Len-1] = DC then begin + Dec(Len); + P[Len] := #0; + TrimAllSpacesPChar(P); + end; + + {Val doesn't accept alternate decimal point chars} + Found := StrChPos(P, DC, DotPos); + {replace with '.'} + if Found and (DotPos > 0) then + P[DotPos] := '.' + else + Found := StrChPos(P, pmDecimalPt, DotPos); + + if Found then begin + {check for 'nnnn.'} + if LongInt(DotPos) = Len-1 then begin + P[Len] := '0'; + Inc(Len); + P[Len] := #0; + end; + + {check for '.nnnn'} + if DotPos = 0 then begin + StrChInsertPrim(P, '0', 0); + Inc(Len); + Inc(DotPos); + end; + + {check for '-.nnnn'} + if (Len > 1) and (P^ = '-') and (DotPos = 1) then begin + StrChInsertPrim(P, '0', 1); + Inc(DotPos); + end; + + end; + + {fix up numbers with exponents} + EFound := StrChPos(P, 'E', EPos); + if EFound and (EPos > 0) then begin + if not Found then begin + StrChInsertPrim(P, '.', EPos); + DotPos := EPos; + Inc(EPos); + end; + if EPos-DotPos < 12 then + StrStInsertPrim(P, '00000', EPos); + end; + + {remove blanks before and after '.' } + if Found then begin + while (DotPos > 0) and (P[DotPos-1] = ' ') do begin + StrStDeletePrim(P, DotPos-1, 1); + Dec(DotPos); + end; + while P[DotPos+1] = ' ' do + StrStDeletePrim(P, DotPos+1, 1); + end; + + end else begin + {empty string = '0'} + P[0] := '0'; + P[1] := #0; + end; +end; + +function GetLeftButton: Byte; +const + RLButton : array[Boolean] of Word = (VK_LBUTTON, VK_RBUTTON); +begin + Result := RLButton[GetSystemMetrics(SM_SWAPBUTTON) <> 0]; +end; + +{ - HWnd changed to TOvcHWnd for BCB Compatibility } +function GetNextDlgItem(Ctrl : TOvcHWnd{hWnd}) : hWnd; + {-Get handle of next control in the same form} +begin + {asking for previous returns next} + Result := GetNextWindow(Ctrl, GW_HWNDPREV); + if Result = 0 then begin + {asking for last returns first} + Result := GetWindow(Ctrl, GW_HWNDLAST); + if Result = 0 then + Result := Ctrl; + end; +end; + +procedure GetRGB(Clr : TColor; var IR, IG, IB : Byte); +begin + if (Clr < 0) then begin + Clr := Clr + MaxLongInt + 1; + Clr := GetSysColor(Clr); + end; + IR := GetRValue(Clr); + IG := GetGValue(Clr); + IB := GetBValue(Clr); +end; + +function GetShiftFlags : Byte; + {-get current shift flags, the high order bit is set if the key is down} +begin + Result := (Ord(GetKeyState(VK_CONTROL) < 0) * ss_Ctrl) + + (Ord(GetKeyState(VK_SHIFT ) < 0) * ss_Shift) + + (Ord(GetKeyState(VK_ALT ) < 0) * ss_Alt); +end; + +function CreateRotatedFont(F : TFont; Angle : Integer) : hFont; + {-create a rotated font based on the font object F} +var + LF : TLogFont; +begin + FillChar(LF, SizeOf(LF), #0); + with LF do begin + lfHeight := F.Height; + lfWidth := 0; + lfEscapement := Angle*10; + lfOrientation := 0; + if fsBold in F.Style then + lfWeight := FW_BOLD + else + lfWeight := FW_NORMAL; + lfItalic := Byte(fsItalic in F.Style); + lfUnderline := Byte(fsUnderline in F.Style); + lfStrikeOut := Byte(fsStrikeOut in F.Style); + lfCharSet := DEFAULT_CHARSET; + StrPCopy(lfFaceName, F.Name); + lfQuality := DEFAULT_QUALITY; + {everything else as default} + lfOutPrecision := OUT_DEFAULT_PRECIS; + lfClipPrecision := CLIP_DEFAULT_PRECIS; + case F.Pitch of + fpVariable : lfPitchAndFamily := VARIABLE_PITCH; + fpFixed : lfPitchAndFamily := FIXED_PITCH; + else + lfPitchAndFamily := DEFAULT_PITCH; + end; + end; + Result := CreateFontIndirect(LF); +end; + +function GetTopTextMargin(Font : TFont; BorderStyle : TBorderStyle; + Height : Integer; Ctl3D : Boolean) : Integer; + {-return the pixel top margin size} +var + I : Integer; + DC : hDC; + Metrics : TTextMetric; + SaveFont : hFont; + SysMetrics : TTextMetric; +begin + DC := GetDC(0); + try + GetTextMetrics(DC, SysMetrics); + SaveFont := SelectObject(DC, Font.Handle); + GetTextMetrics(DC, Metrics); + SelectObject(DC, SaveFont); + finally + ReleaseDC(0, DC); + end; + I := SysMetrics.tmHeight; + if I > Metrics.tmHeight then + I := Metrics.tmHeight; + + if NewStyleControls then begin + if BorderStyle = bsNone then begin + Result := 0; + if I >= Height-2 then + Result := (Height-I-2) div 2 - Ord(Odd(Height-I)); + end else if Ctl3D then begin + Result := 1; + if I >= Height-4 then + Result := (Height-I-4) div 2 - 1; + end else begin + Result := 1; + if I >= Height-4 then + Result := (Height-I-4) div 2 - Ord(Odd(Height-I)); + end; + end else begin + Result := (Height-Metrics.tmHeight-1) div 2; + if I > Height-2 then begin + Dec(Result, 2); + if BorderStyle = bsNone then + Inc(Result, 1); + end; + end; +end; + +function PtrDiff(const P1, P2) : Word; + {-return the difference between P1 and P2} +begin + {P1 and P2 are assumed to point within the same buffer} + Result := PAnsiChar(P1) - PAnsiChar(P2); +end; + +procedure PtrInc(var P; Delta : Word); + {-increase P by Delta} +begin + Inc(PAnsiChar(P), Delta); +end; + +procedure PtrDec(var P; Delta : Word); + {-increase P by Delta} +begin + Dec(PAnsiChar(P), Delta); +end; + +{$IFDEF NoAsm} +function MinI(X, Y : Integer) : Integer; +begin + if X < Y then + Result := X + else + Result := Y; +end; + +function MaxI(X, Y : Integer) : Integer; +begin + if X >= Y then + Result := X + else + Result := Y; +end; + +{$ELSE} +function MinI(X, Y : Integer) : Integer; +asm + cmp eax, edx + jle @@Exit + mov eax, edx +@@Exit: +end; + +function MaxI(X, Y : Integer) : Integer; +asm + cmp eax, edx + jge @@Exit + mov eax, edx +@@Exit: +end; +{$ENDIF} + +function MaxL(A, B : LongInt) : LongInt; +begin + if (A < B) then + Result := B + else + Result := A; +end; + +function MinL(A, B : LongInt) : LongInt; +begin + if (A < B) then + Result := A + else + Result := B; +end; + +function TrimLeft(const S : string) : string; +var + I, L : Integer; +begin + L := Length(S); + I := 1; + while (I <= L) and (S[I] <= ' ') do + Inc(I); + Result := Copy(S, I, Length(S)-I+1); +end; + +function TrimRight(const S : string) : string; +var + I : Integer; +begin + I := Length(S); + while (I > 0) and (S[I] <= ' ') do + Dec(I); + Result := Copy(S, 1, I); +end; + +function QuotedStr(const S: string): string; +var + I : Integer; +begin + Result := S; + for I := Length(Result) downto 1 do + if Result[I] = '''' then Insert('''', Result, I); + Result := '''' + Result + ''''; +end; + +function WordCount(const S : string; const WordDelims : TCharSet) : Integer; +var + SLen, I : Integer; +begin + Result := 0; + I := 1; + SLen := Length(S); + while I <= SLen do begin + while (I <= SLen) and (S[I] in WordDelims) do + Inc(I); + if I <= SLen then + Inc(Result); + while (I <= SLen) and not(S[I] in WordDelims) do + Inc(I); + end; +end; + +function ExtractWord(N : Integer; const S : string; WordDelims : TCharSet) : string; +var + I : Word; + Len : Integer; +begin + Len := 0; + I := WordPosition(N, S, WordDelims); + if I <> 0 then + { find the end of the current word } + while (I <= Length(S)) and not(S[I] in WordDelims) do begin + { add the I'th character to result } + Inc(Len); + SetLength(Result, Len); + Result[Len] := S[I]; + Inc(I); + end; + SetLength(Result, Len); +end; + +function WordPosition(const N : Integer; const S : string; const WordDelims : TCharSet) : Integer; +var + Count, I : Integer; +begin + Count := 0; + I := 1; + Result := 0; + while (I <= Length(S)) and (Count <> N) do begin + {skip over delimiters} + while (I <= Length(S)) and (S[I] in WordDelims) do + Inc(I); + {if we're not beyond end of S, we're at the start of a word} + if I <= Length(S) then + Inc(Count); + {if not finished, find the end of the current word} + if Count <> N then + while (I <= Length(S)) and not (S[I] in WordDelims) do + Inc(I) + else + Result := I; + end; +end; + +function DrawButtonFrame(Canvas : TCanvas; const Client : TRect; + IsDown, IsFlat : Boolean; Style : TButtonStyle) : TRect; +var + NewStyle : Boolean; +begin + Result := Client; + NewStyle := (Style = bsNew) or (NewStyleControls and (Style = bsAutoDetect)); + if IsDown then begin + if NewStyle then begin + Frame3D(Canvas, Result, clWindowFrame, clBtnHighlight, 1); + if not IsFlat then + Frame3D(Canvas, Result, clBtnShadow, clBtnFace, 1); + end else begin + if IsFlat then + Frame3D(Canvas, Result, clWindowFrame, clBtnHighlight, 1) + else begin + Frame3D(Canvas, Result, clWindowFrame, clWindowFrame, 1); + Canvas.Pen.Color := clBtnShadow; + Canvas.PolyLine([Point(Result.Left, Result.Bottom - 1), + Point(Result.Left, Result.Top), Point(Result.Right, Result.Top)]); + end; + end; + end else begin + if NewStyle then begin + if IsFlat then + Frame3D(Canvas, Result, clBtnHighlight, clBtnShadow, 1) + else begin + Frame3D(Canvas, Result, clBtnHighlight, clWindowFrame, 1); + Frame3D(Canvas, Result, clBtnFace, clBtnShadow, 1); + end; + end else begin + if IsFlat then + Frame3D(Canvas, Result, clBtnHighlight, clWindowFrame, 1) + else begin + Frame3D(Canvas, Result, clWindowFrame, clWindowFrame, 1); + Frame3D(Canvas, Result, clBtnHighlight, clBtnShadow, 1); + end; + end; + end; + InflateRect(Result, -1, -1); +end; + +function GetDisplayString(Canvas : TCanvas; const S : string; + MinChars, MaxWidth : Integer) : string; +var + iDots, EllipsisWidth, Extent, Len, Width : Integer; + ShowEllipsis : Boolean; +begin + {be sure that the Canvas Font is set before entering this routine} + EllipsisWidth := Canvas.TextWidth('...'); + Len := Length(S); + Result := S; + Extent := Canvas.TextWidth(Result); + ShowEllipsis := False; + Width := MaxWidth; + while (Extent > Width) do begin + ShowEllipsis := True; + Width := MaxWidth - EllipsisWidth; + if Len > MinChars then begin + Delete(Result, Len, 1); + dec(Len); + end else + break; + Extent := Canvas.TextWidth(Result); + end; + if ShowEllipsis then begin + Result := Result + '...'; + inc(Len, 3); + Extent := Canvas.TextWidth(Result); + iDots := 3; + while (iDots > 0) and (Extent > MaxWidth) do begin + Delete(Result, Len, 1); + Dec(Len); + Extent := Canvas.TextWidth(Result); + Dec(iDots); + end; + end; +end; + +type + PCheckTaskInfo = ^TCheckTaskInfo; + TCheckTaskInfo = packed record + FocusWnd: HWnd; + Found: Boolean; + end; + +{ - HWnd changed to TOvcHWnd for BCB Compatibility } +function CheckTaskWindow(Window: TOvcHWnd{HWnd}; + Data: Longint): WordBool; stdcall; +begin + Result := True; + if PCheckTaskInfo(Data)^.FocusWnd = Window then begin + Result := False; + PCheckTaskInfo(Data)^.Found := True; + end; +end; + +function IsForegroundTask : Boolean; +var + Info : TCheckTaskInfo; +begin + Info.FocusWnd := GetActiveWindow; + Info.Found := False; +{$IFNDEF DARWIN} + EnumThreadWindows(GetCurrentThreadID, @CheckTaskWindow, Longint(@Info)); +{$ELSE} + EnumThreadWindows(LongWord(GetCurrentThreadID), @CheckTaskWindow, Longint(@Info)); +{$ENDIF} + Result := Info.Found; +end; + +procedure FixTextBuffer(InBuf, OutBuf : PChar; OutSize : Integer); +var + I, P : Integer; +begin + P := 0; + for I := 0 to StrLen(InBuf) do begin + if (InBuf[I] = #10) and ((I = 0) or (InBuf[I-1] <> #13)) then begin + OutBuf[P] := #13; + Inc(P); + end; + OutBuf[P] := InBuf[I]; + {is outbuf full?} + if P = OutSize-1 then begin + {if so, terminate and exit} + OutBuf[OutSize] := #0; + Break; + end; + Inc(P); + end; +end; + +{ - Hdc changed to TOvcHdc for BCB Compatibility } +procedure TransStretchBlt(DstDC: TOvcHdc{HDC}; DstX, DstY, DstW, DstH: Integer; + SrcDC: TOvcHdc{HDC}; SrcX, SrcY, SrcW, SrcH: Integer; + MaskDC: TOvcHdc{HDC}; + MaskX, MaskY : Integer); +var + MemDC : HDC; + MemBmp : HBITMAP; + Save : THandle; + crText, crBack : TColorRef; + SystemPalette16, SavePal : HPALETTE; +begin + SavePal := 0; + MemDC := CreateCompatibleDC(0); + try + MemBmp := CreateCompatibleBitmap(SrcDC, SrcW, SrcH); + Save := SelectObject(MemDC, MemBmp); + SystemPalette16 := GetStockObject(DEFAULT_PALETTE); + SavePal := SelectPalette(SrcDC, SystemPalette16, False); + SelectPalette(SrcDC, SavePal, False); + if SavePal <> 0 then + SavePal := SelectPalette(MemDC, SavePal, True) + else + SavePal := SelectPalette(MemDC, SystemPalette16, True); + RealizePalette(MemDC); + + StretchBlt(MemDC, 0, 0, SrcW, SrcH, MaskDC, MaskX, MaskY, + SrcW, SrcH, SrcCopy); + StretchBlt(MemDC, 0, 0, SrcW, SrcH, SrcDC, SrcX, SrcY, SrcW, SrcH, + SrcErase); + crText := SetTextColor(DstDC, $0); + crBack := SetBkColor(DstDC, $FFFFFF); + StretchBlt(DstDC, DstX, DstY, DstW, DstH, MaskDC, MaskX, MaskY, + SrcW, SrcH, SrcAnd); + StretchBlt(DstDC, DstX, DstY, DstW, DstH, MemDC, 0, 0, + SrcW, SrcH, SrcInvert); + SetTextColor(DstDC, crText); + SetBkColor(DstDC, crBack); + if Save <> 0 then + SelectObject(MemDC, Save); + DeleteObject(MemBmp); + finally + if SavePal <> 0 then + SelectPalette(MemDC, SavePal, False); + DeleteDC(MemDC); + end; +end; + +function DefaultEpoch : Integer; +var + ThisYear : Word; + ThisMonth : Word; + ThisDay : Word; +begin + DecodeDate(SysUtils.Date, ThisYear, ThisMonth, ThisDay); + Result := (ThisYear div 100) * 100; +end; + +{function GenerateComponentName(PF : TCustomForm; const Root : string) : string;} +function GenerateComponentName(PF : TWinControl; const Root : string) : string; +var + I : Integer; +begin + if not IsValidIdent(Root) then + raise EComponentError.CreateFmt('''''%s'''' is not a valid component name', + [Root]); + I := 0; + repeat + Inc(I); + Result := Root + IntToStr(I); + until (PF.FindComponent(Result) = nil); +end; + +function PartialCompare(const S1, S2 : string) : Boolean; +var + L : Integer; +begin + {and empty string matches nothing} + Result := False; + L := MinI(Length(S1), Length(S2)); + if L > 0 then + Result := AnsiUpperCase(Copy(S1, 1, L)) = AnsiUpperCase(Copy(S2, 1, L)); +end; + +function PathEllipsis(const S : string; MaxWidth : Integer) : string; + { PathEllipsis function. Trims a path down to the } + { specified number of pixels. For example, } + { 'd:\program files\my stuff\some long document.txt' } + { becomes 'd:\...\some long...' or a variation thereof } + { depending on the value of MaxWidth. } +var + R : TRect; + BM : TBitmap; + NCM : TNonClientMetrics; +begin + if MaxWidth = 0 then begin + Result := S; + Exit; + end; + NCM.cbSize := SizeOf(NCM); + SystemParametersInfo( + SPI_GETNONCLIENTMETRICS, NCM.cbSize, @NCM, 0); + BM := TBitmap.Create; + try + BM.Canvas.Font.Handle := CreateFontIndirect(NCM.lfMenuFont); + if BM.Canvas.TextWidth(S) < MaxWidth then begin + Result := S; + Exit; + end; + Result := ExtractFilePath(S); + Delete(Result, Length(Result), 1); + while BM.Canvas.TextWidth(Result + '\...\' + ExtractFileName(S)) > MaxWidth do begin + { Start trimming the path, working backwards } + Result := ExtractFilePath(Result); + Delete(Result, Length(Result), 1); + { Only drive letter left so break out of loop. } + if Length(Result) = 2 then + Break; + end; + { Add the filename back onto the modified path. } + Result := Result + '\...\' + ExtractFileName(S); + { Still too long? } + if BM.Canvas.TextWidth(Result) > MaxWidth then begin + R := Rect(0, 0, MaxWidth, 0); + DrawText(BM.Canvas.Handle, PChar(Result), -1, + R, DT_SINGLELINE or DT_END_ELLIPSIS or DT_MODIFYSTRING or DT_CALCRECT); + end; + finally + BM.Free; + end; +end; + +function CreateDisabledBitmap(FOriginal : TBitmap; OutlineColor : TColor) : TBitmap; + {-create TBitmap object with disabled glyph} +const + ROP_DSPDxax = $00E20746; +var + MonoBmp : TBitmap; + IRect : TRect; +begin + IRect := Rect(0, 0, FOriginal.Width, FOriginal.Height); + Result := TBitmap.Create; + try + Result.Width := FOriginal.Width; + Result.Height := FOriginal.Height; + MonoBmp := TBitmap.Create; + try + with MonoBmp do begin + Assign(FOriginal); + HandleType := bmDDB; + Canvas.Brush.Color := OutlineColor; + if Monochrome then begin + Canvas.Font.Color := clWhite; + Monochrome := False; + Canvas.Brush.Color := clWhite; + end; + Monochrome := True; + end; + with Result.Canvas do begin + Brush.Color := clBtnFace; + FillRect(IRect); + Brush.Color := clBtnHighlight; + SetTextColor(Handle, clBlack); + SetBkColor(Handle, clWhite); + BitBlt(Handle, 1, 1, WidthOf(IRect), HeightOf(IRect), + MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax); + Brush.Color := clBtnShadow; + SetTextColor(Handle, clBlack); + SetBkColor(Handle, clWhite); + BitBlt(Handle, 0, 0, WidthOf(IRect), HeightOf(IRect), + MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax); + end; + finally + MonoBmp.Free; + end; + except + Result.Free; + raise; + end; +end; + +type + TParentControl = class(TWinControl); + +procedure CopyParentImage(Control : TControl; Dest : TCanvas); +var + I : Integer; + Count : Integer; + X, Y : Integer; + OldDC : Integer; + DC : hDC; + R : TRect; + SelfR : TRect; + CtlR : TRect; +begin + if Control.Parent = nil then + Exit; + + Count := Control.Parent.ControlCount; + DC := Dest.Handle; + SelfR := Bounds(Control.Left, Control.Top, Control.Width, Control.Height); + X := -Control.Left; Y := -Control.Top; + + {copy parent control image} + OldDC := SaveDC(DC); + SetViewportOrgEx(DC, X, Y, nil); + IntersectClipRect(DC, 0, 0, Control.Parent.ClientWidth, Control.Parent.ClientHeight); + TParentControl(Control.Parent).PaintWindow(DC); + RestoreDC(DC, OldDC); + + {copy images of graphic controls} + for I := 0 to Count - 1 do begin + if (Control.Parent.Controls[I] <> nil) and + not (Control.Parent.Controls[I] is TWinControl) then begin + if Control.Parent.Controls[I] = Control then + Break; + with Control.Parent.Controls[I] do begin + CtlR := Bounds(Left, Top, Width, Height); + if Bool(IntersectRect(R, SelfR, CtlR)) and Visible then begin + OldDC := SaveDC(DC); + SetViewportOrgEx(DC, Left + X, Top + Y, nil); + IntersectClipRect(DC, 0, 0, Width, Height); + Perform(WM_PAINT, DC, 0); + RestoreDC(DC, OldDC); + end; + end; + end; + end; +end; + +{ - Hdc changed to TOvcHdc for BCB Compatibility } +procedure DrawTransparentBitmapPrim(DC : TOvcHdc{HDC}; Bitmap : HBitmap; + xStart, yStart, Width, Height : Integer; Rect : TRect; + TransparentColor : TColorRef); + {-draw transparent bitmap} +var +{$IFNDEF LCL} + BM : Windows.TBitmap; +{$ELSE} + BM : LclType.tagBITMAP; +{$ENDIF} + cColor : TColorRef; + bmAndBack : hBitmap; + bmAndObject : hBitmap; + bmAndMem : hBitmap; + bmSave : hBitmap; + bmBackOld : hBitmap; + bmObjectOld : hBitmap; + bmMemOld : hBitmap; + bmSaveOld : hBitmap; + hdcMem : hDC; + hdcBack : hDC; + hdcObject : hDC; + hdcTemp : hDC; + hdcSave : hDC; + ptSize : TPoint; + ptRealSize : TPoint; + ptBitSize : TPoint; + ptOrigin : TPoint; +begin + hdcTemp := CreateCompatibleDC(DC); + SelectObject(hdcTemp, Bitmap); + GetObject(Bitmap, SizeOf(BM), @BM); + ptRealSize.x := MinL(Rect.Right - Rect.Left, BM.bmWidth - Rect.Left); + ptRealSize.y := MinL(Rect.Bottom - Rect.Top, BM.bmHeight - Rect.Top); + DPtoLP(hdcTemp, ptRealSize, 1); + ptOrigin.x := Rect.Left; + ptOrigin.y := Rect.Top; + + {convert from device to logical points} + DPtoLP(hdcTemp, ptOrigin, 1); + {get width of bitmap} + ptBitSize.x := BM.bmWidth; + {get height of bitmap} + ptBitSize.y := BM.bmHeight; + DPtoLP(hdcTemp, ptBitSize, 1); + + if (ptRealSize.x = 0) or (ptRealSize.y = 0) then begin + ptSize := ptBitSize; + ptRealSize := ptSize; + end else + ptSize := ptRealSize; + if (Width = 0) or (Height = 0) then begin + Width := ptSize.x; + Height := ptSize.y; + end; + + {create DCs to hold temporary data} + hdcBack := CreateCompatibleDC(DC); + hdcObject := CreateCompatibleDC(DC); + hdcMem := CreateCompatibleDC(DC); + hdcSave := CreateCompatibleDC(DC); + {create a bitmap for each DC} + {monochrome DC} + bmAndBack := CreateBitmap(ptSize.x, ptSize.y, 1, 1, nil); + bmAndObject := CreateBitmap(ptSize.x, ptSize.y, 1, 1, nil); + bmAndMem := CreateCompatibleBitmap(DC, MaxL(ptSize.x, Width), MaxL(ptSize.y, Height)); + bmSave := CreateCompatibleBitmap(DC, ptBitSize.x, ptBitSize.y); + {select a bitmap object to store pixel data} + bmBackOld := SelectObject(hdcBack, bmAndBack); + bmObjectOld := SelectObject(hdcObject, bmAndObject); + bmMemOld := SelectObject(hdcMem, bmAndMem); + bmSaveOld := SelectObject(hdcSave, bmSave); + + SetMapMode(hdcTemp, GetMapMode(DC)); + + {save the bitmap sent here, it will be overwritten} + BitBlt(hdcSave, 0, 0, ptBitSize.x, ptBitSize.y, hdcTemp, 0, 0, SRCCOPY); + + {set the background color of the source DC to the color,} + {contained in the parts of the bitmap that should be transparent} + cColor := SetBkColor(hdcTemp, TransparentColor); + + {create the object mask for the bitmap by performing a BitBlt()} + {from the source bitmap to a monochrome bitmap} + BitBlt(hdcObject, 0, 0, ptSize.x, ptSize.y, hdcTemp, ptOrigin.x, ptOrigin.y, SRCCOPY); + + {set the background color of the source DC back to the original color} + SetBkColor(hdcTemp, cColor); + + {create the inverse of the object mask} + BitBlt(hdcBack, 0, 0, ptSize.x, ptSize.y, hdcObject, 0, 0, NOTSRCCOPY); + + {copy the background of the main DC to the destination} + BitBlt(hdcMem, 0, 0, Width, Height, DC, xStart, yStart, SRCCOPY); + + {mask out the places where the bitmap will be placed} + StretchBlt(hdcMem, 0, 0, Width, Height, hdcObject, 0, 0, ptSize.x, ptSize.y, SRCAND); + + {mask out the transparent colored pixels on the bitmap} + BitBlt(hdcTemp, ptOrigin.x, ptOrigin.y, ptSize.x, ptSize.y, hdcBack, 0, 0, SRCAND); + + {XOR the bitmap with the background on the destination DC} + StretchBlt(hdcMem, 0, 0, Width, Height, hdcTemp, ptOrigin.x, ptOrigin.y, ptSize.x, ptSize.y, SRCPAINT); + + {copy the destination to the screen} + BitBlt(DC, xStart, yStart, MaxL(ptRealSize.x, Width), MaxL(ptRealSize.y, Height), hdcMem, 0, 0, SRCCOPY); + + {place the original bitmap back into the bitmap sent} + BitBlt(hdcTemp, 0, 0, ptBitSize.x, ptBitSize.y, hdcSave, 0, 0, SRCCOPY); + + {delete the memory bitmaps} + DeleteObject(SelectObject(hdcBack, bmBackOld)); + DeleteObject(SelectObject(hdcObject, bmObjectOld)); + DeleteObject(SelectObject(hdcMem, bmMemOld)); + DeleteObject(SelectObject(hdcSave, bmSaveOld)); + + {delete the memory DCs} + DeleteDC(hdcMem); + DeleteDC(hdcBack); + DeleteDC(hdcObject); + DeleteDC(hdcSave); + DeleteDC(hdcTemp); +end; + +procedure DrawTransparentBitmap(Dest : TCanvas; X, Y, W, H : Integer; + Rect : TRect; Bitmap : TBitmap; TransparentColor : TColor); +var + MemImage : TBitmap; + R : TRect; +begin + MemImage := TBitmap.Create; + try + R := Bounds(0, 0, Bitmap.Width, Bitmap.Height); + if TransparentColor = clNone then begin + + if (WidthOf(Rect) <> 0) and (HeightOf(Rect) <> 0) then + R := Rect; + MemImage.Width := WidthOf(R); + MemImage.Height := HeightOf(R); + MemImage.Canvas.CopyRect(Bounds(0, 0, MemImage.Width, MemImage.Height), + Bitmap.Canvas, R); + + if (W = 0) or (H = 0) then + Dest.Draw(X, Y, MemImage) + else + Dest.StretchDraw(Bounds(X, Y, W, H), MemImage); + + end else begin + MemImage.Width := WidthOf(R); + MemImage.Height := HeightOf(R); + MemImage.Canvas.CopyRect(R, Bitmap.Canvas, R); + if TransparentColor = clDefault then + TransparentColor := MemImage.Canvas.Pixels[0, MemImage.Height - 1]; + DrawTransparentBitmapPrim(Dest.Handle, MemImage.Handle, X, Y, W, H, + Rect, ColorToRGB(TransparentColor and not $02000000)); + end; + finally + MemImage.Free; + end; +end; + + +function WidthOf(const R : TRect) : Integer; +begin + Result := R.Right - R.Left; +end; + +function HeightOf(const R : TRect) : Integer; +begin + Result := R.Bottom - R.Top; +end; + +procedure DebugOutput(const S : string); +begin + OutputDebugString(PChar(S)); + OutputDebugString(#13#10); +end; + + +end. diff --git a/components/orpheus/ovcnf.pas b/components/orpheus/ovcnf.pas new file mode 100644 index 000000000..c84b904b1 --- /dev/null +++ b/components/orpheus/ovcnf.pas @@ -0,0 +1,1808 @@ +{*********************************************************} +{* OVCNF.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovcnf; + {-Numeric field visual component} + +interface + +uses + {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, LclType, MyMisc, {$ENDIF} + Classes, Controls, Forms, Graphics, Menus, SysUtils, + OvcBase, OvcCaret, OvcColor, OvcConst, OvcData, OvcEF, OvcExcpt, + OvcMisc, OvcPB, OvcStr; + +type + {numeric field types} + TNumericDataType = ( + nftLongInt, nftWord, nftInteger, nftByte, nftShortInt, nftReal, + nftExtended, nftDouble, nftSingle, nftComp); + +type + TOvcCustomNumericField = class(TOvcPictureBase) + {.Z+} + protected {private} + {property instance variables} + FNumericDataType : TNumericDataType; + FPictureMask : string; + + {private instance variables} + nfMaxLen : Word; {maximum length of numeric string} + nfMaxDigits : Word; {maximum # of digits to left of decimal} + nfPlaces : Word; {# of decimal places} + nfMinus : Boolean; {true if number is negative} + nfTmp : TEditString; {temporary input string} + + function nfGetDataType(Value : TNumericDataType) : Byte; + {-return a Byte value representing the data type of this field} + procedure nfReloadTmp; + {-reload Tmp from efEditSt, etc.} + procedure nfResetFieldProperties(FT : TNumericDataType); + {-reset field properties} + procedure nfSetDefaultRanges; + {-set default range values based on the field type} + procedure nfSetMaxLength(Mask : PAnsiChar); + {-determine and set MaxLength} + + procedure WMSetFocus(var Msg : TWMSetFocus); + message WM_SETFOCUS; + procedure WMKillFocus(var Msg : TWMKillFocus); + message WM_KILLFOCUS; + + protected + {VCL methods} + procedure CreateParams(var Params : TCreateParams); + override; + procedure CreateWnd; + override; + + procedure efCaretToEnd; + override; + {-move the caret to the end of the field} + procedure efCaretToStart; + override; + {-move the caret to the beginning of the field} + procedure efChangeMask(Mask : PAnsiChar); + override; + {-change the picture mask} + procedure efEdit(var Msg : TMessage; Cmd : Word); + override; + {-process the specified editing command} + function efGetDisplayString(Dest : PAnsiChar; Size : Word) : PAnsiChar; + override; + {-return the display string in Dest and a pointer as the result} + procedure efIncDecValue(Wrap : Boolean; Delta : Double); + override; + {-increment field by Delta} + function efTransfer(DataPtr : Pointer; TransferFlag : Word) : Word; + override; + {-transfer data to/from the entry fields} + procedure pbRemoveSemiLits; + override; + {-remove semi-literal mask characters from the edit string} + + {virtual property methods} + procedure efSetCaretPos(Value : Integer); + override; + {-set position of caret within the field} + procedure nfSetDataType(Value : TNumericDataType); + virtual; + {-set the data type for this field} + procedure nfSetPictureMask(const Value : string); + virtual; + {-set the picture mask} + + public + procedure Assign(Source : TPersistent); + override; + constructor Create(AOwner: TComponent); + override; + + function efValidateField : Word; + override; + {-validate contents of field; result is error code or 0} + {.Z-} + + {public properties} + property DataType : TNumericDataType + read FNumericDataType + write nfSetDataType; + + property PictureMask : string + read FPictureMask + write nfSetPictureMask; + end; + + TOvcNumericField = class(TOvcCustomNumericField) + published + {inherited properties} + property DataType; {needs to loaded before most other properties} + {$IFDEF VERSION4} + property Anchors; + property Constraints; + property DragKind; + {$ENDIF} + property AutoSize; + property BorderStyle; + property CaretIns; + property CaretOvr; + property Color; + property Controller; + property Ctl3D; + property Borders; + property DragCursor; + property DragMode; + property EFColors; + property Enabled; + property Font; + property LabelInfo; + property Options; + property PadChar; + property ParentColor; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PictureMask; + property PopupMenu; + property RangeHi stored False; + property RangeLo stored False; + property ShowHint; + property TabOrder; + property TabStop default True; + property Tag; + property TextMargin; + property Uninitialized; + property Visible; + property ZeroDisplay; + property ZeroDisplayValue; + + {inherited events} + property AfterEnter; + property AfterExit; + property OnChange; + property OnClick; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEndDrag; + property OnEnter; + property OnError; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnMouseWheel; + property OnStartDrag; + property OnUserCommand; + property OnUserValidation; + end; + + +implementation + + +{*** TOvcCustomNumericField ***} + +procedure TOvcCustomNumericField.Assign(Source : TPersistent); +var + NF : TOvcCustomNumericField absolute Source; +begin + if (Source <> nil) and (Source is TOvcCustomNumericField) then begin + DataType := NF.DataType; + AutoSize := NF.AutoSize; + BorderStyle := NF.BorderStyle; + Color := NF.Color; + EFColors.Error.Assign(NF.EFColors.Error); + EFColors.Highlight.Assign(NF.EFColors.Highlight); + Options := NF.Options; + PadChar := NF.PadChar; + PictureMask := NF.PictureMask; + RangeHi := NF.RangeHi; + RangeLo := NF.RangeLo; + TextMargin := NF.TextMargin; + Uninitialized := NF.Uninitialized; + ZeroDisplay := NF.ZeroDisplay; + ZeroDisplayValue := NF.ZeroDisplayValue; + end else + inherited Assign(Source); +end; + +constructor TOvcCustomNumericField.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + + FNumericDataType := nftLongInt; + FPictureMask := 'iiiiiiiiiii'; + efFieldClass := fcNumeric; + efDataType := nfGetDataType(FNumericDataType); + efRangeHi.rtLong := High(LongInt); + efRangeLo.rtLong := Low(LongInt); +end; + +procedure TOvcCustomNumericField.CreateParams(var Params: TCreateParams); +begin + inherited CreateParams(Params); + + pfSelPos := 0; + + {get current picture string} + StrPLCopy(efPicture, FPictureMask, MaxPicture); + + {set MaxLength based on picture mask} + nfSetMaxLength(efPicture); + + FillChar(nfTmp, SizeOf(nfTmp), #0); + pfSemiLits := 0; + pbCalcWidthAndPlaces(nfMaxLen, nfPlaces); + + {adjust max length for decimal point if needed} + nfMaxDigits := nfMaxLen; + if nfPlaces <> 0 then + Dec(nfMaxDigits, nfPlaces+1); +end; + +procedure TOvcCustomNumericField.CreateWnd; +var + P : array[0..MaxEditLen+1] of Byte; +begin + {save field data} + if efSaveData then + efTransfer(@P, otf_GetData); + + inherited CreateWnd; + + {try to optimize InitPictureFlags} + pbOptimizeInitPictureFlags; + + pfSemiLits := 0; + nfSetDefaultRanges; + efSetInitialValue; + + {if we saved the field data, restore it} + if efSaveData then + efTransfer(@P, otf_SetData); + + {set save data flag} + efSaveData := True; +end; + +procedure TOvcCustomNumericField.efCaretToEnd; + {-move the caret to the end of the field} +begin + efHPos := efEditEnd + 1; +end; + +procedure TOvcCustomNumericField.efCaretToStart; + {-move the caret to the beginning of the field} +begin + efHPos := efEditEnd + 1; +end; + +procedure TOvcCustomNumericField.efChangeMask(Mask : PAnsiChar); + {-change the picture mask} +begin + inherited efChangeMask(Mask); + + pfSemiLits := 0; + pbCalcWidthAndPlaces(nfMaxLen, nfPlaces); + + {set MaxLength based on picture mask} + nfSetMaxLength(Mask); + nfMaxDigits := nfMaxLen; + if nfPlaces <> 0 then + Dec(nfMaxDigits, nfPlaces+1); +end; + +procedure TOvcCustomNumericField.efEdit(var Msg : TMessage; Cmd : Word); + {-process the specified editing command} +label + ExitPoint; +var + MF : Byte; + Ch : AnsiChar; + HaveSel : Boolean; + PicChar : AnsiChar; + StLen : Word; + StBgn : Word; + StEnd : Word; + DotPos : Cardinal; + Found : Boolean; + + function MinusVal : Byte; + begin + if nfMinus then + Result := 1 + else + Result := 0; + end; + + procedure ClearString; + {-clear the string being edited} + begin + nfTmp[0] := #0; + nfMinus := False; + StLen := 0; + end; + + function CharIsOK : Boolean; + {-return true if Ch can be added to the string} + begin + Result := (Ch >= ' '); + end; + + function CheckAutoAdvance(SP : Integer) : Boolean; + {-see if we need to auto-advance to next/previous field} + begin + Result := False; + if (SP < 0) and + (efoAutoAdvanceLeftRight in Controller.EntryOptions) then begin + efMoveFocusToPrevField; + Result := True; + end else if (SP > 0) then + if (Cmd = ccChar) and + (efoAutoAdvanceChar in Controller.EntryOptions) then begin + efMoveFocusToNextField; + Result := True; + end else if (Cmd <> ccChar) and + (efoAutoAdvanceLeftRight in Controller.EntryOptions) then begin + efMoveFocusToNextField; + Result := True; + end; + end; + + procedure DeleteChar; + {-delete char at end of string} + begin + if (StLen = 0) then + if not nfMinus then + Exit + else + nfMinus := False + else begin + {remove the last character} + nfTmp[StLen-1] := #0; + Dec(StLen); + + {if all that's left is a 0, remove it} + if (StLen = 1) and (nfTmp[0] = '0') then + nfTmp[0] := #0; + end; + MF := 10; + end; + + procedure DeleteSel; + begin + ClearString; + efSelStart := 0; + efSelEnd := 0; + MF := 10; + end; + + function InsertChar : Boolean; + {-insert Ch} + var + tDotPos : Cardinal; + tFound : Boolean; + + function DigitCount : Word; + {-return number of digits to left of decimal place in St} + begin + if tFound then + Result := tDotPos + MinusVal + else + Result := StLen + MinusVal; + end; + + begin + Result := False; + + {reject spaces} + if (Ch = ' ') then + Exit; + + {ok to add decimal point?} + tFound := StrChPos(nfTmp, pmDecimalPt, tDotPos); + if (Ch = pmDecimalPt) then + if not Found or tFound then + Exit; + + if (Ch = '-') then begin + {minus sign treated as toggle} + if nfMinus then + nfMinus := False + else begin + nfMinus := (DigitCount < nfMaxDigits) and (StLen < nfMaxLen); + if not nfMinus then + Exit; + end + end else if (StLen+MinusVal < nfMaxLen) then begin + {don't allow initial zeros} + if (Ch = '0') and (StLen = 0) then begin + Result := True; + Exit; + end; + + {check for too many digits to left of decimal point} + if Found and (Ch <> pmDecimalPt) then + if not tFound and (DigitCount >= nfMaxDigits) then + Exit; + + {append the character} + nfTmp[StLen] := Ch; + Inc(StLen); + nfTmp[StLen] := #0; + end else if (nfMaxLen = 1) then + if (Ch = pmDecimalPt) then + Exit + else + {overwrite the character} + nfTmp[0] := Ch + else + Exit; + + Result := True; + end; + + procedure Adjust; + {-adjust display string to show correct number of decimal places} + var + Delta : Integer; + ActPlaces : Integer; + DP : Cardinal; + Len : Word; + ExDec : TEditString; + begin + Len := StrLen(nfTmp); + if not StrChPos(nfTmp, pmDecimalPt, DP) then + Delta := nfPlaces+1 + else begin + ActPlaces := Len-Succ(DP); + Delta := nfPlaces-ActPlaces; + end; + + if Delta = 0 then + Exit; + + if Delta > 0 then begin + StrStDeletePrim(efEditSt, StEnd-Pred(Delta), Delta); + StrStInsertPrim(efEditSt, CharStrPChar(ExDec, ' ', Delta), StBgn); + end else begin + Delta := -Delta; + StrStCopy(ExDec, nfTmp, DP+nfPlaces+1, Delta); + StrStDeletePrim(efEditSt, StBgn, Delta); + StrStInsertPrim(efEditSt, ExDec, StEnd-Pred(Delta)); + end; + end; + + procedure UpdateEditSt; + {-update efEditSt} + begin + StrCopy(efEditSt, nfTmp); + case efEditSt[0] of + #0 : + begin + {string is empty, put in a 0} + efEditSt[0] := '0'; + efEditSt[1] := #0; + end; + '.' : + StrChInsertPrim(efEditSt, '0', 0); + end; + + {prepend the minus sign} + if nfMinus then + StrChInsertPrim(efEditSt, '-', 0); + + pbMergePicture(efEditSt, efEditSt); + if Found then + Adjust; + end; + + procedure UpdateSel(Delta : Integer); + begin + if Delta <> 0 then begin + efSelStart := 0; + efSelEnd := MaxEditLen; + end else begin + efSelStart := 0; + efSelEnd := 0; + end; + end; + + procedure PastePrim(P : PAnsiChar); + begin + if HaveSel then + DeleteSel; + while P^ <> #0 do begin + Ch := P^; + if (Ch = '(') then + if StrScan(efPicture, pmNegParens) <> nil then + if StrScan(P, ')') <> nil then + Ch := '-'; + if (Ch <> '-') or not nfMinus then + if (StLen+MinusVal <= nfMaxLen) then begin + if Ch = IntlSupport.DecimalChar then + Ch := pmDecimalPt + else if Ch = pmDecimalPt then + Ch := #0; + if efCharOK(PicChar, Ch, #255, True) then + if InsertChar then + MF := 10 + end; + Inc(P); + end; + end; + +begin {edit} + HaveSel := efSelStart <> efSelEnd; + MF := Ord(HaveSel); + + case Cmd of + ccAccept : ; + else + if not (sefFixSemiLits in sefOptions) then + pbRemoveSemiLits; + + Exclude(sefOptions, sefLiteral); + end; + + StBgn := efEditBegin; + StEnd := efEditEnd; + StLen := StrLen(nfTmp); + PicChar := efNthMaskChar(efHPos-1); + Found := StrChPos(efPicture, pmDecimalPt, DotPos); + + Exclude(sefOptions, sefCharOK); + case Cmd of + ccChar : + begin + Ch := AnsiChar(Lo(Msg.wParam)); + if not (sefAcceptChar in sefOptions) then + Exit + else begin + Exclude(sefOptions, sefAcceptChar); + if HaveSel and CharIsOk then + DeleteSel; + if StLen+MinusVal <= nfMaxLen then begin + if Ch = IntlSupport.DecimalChar then + Ch := pmDecimalPt + else if Ch = pmDecimalPt then + Ch := #0; + if not efCharOK(PicChar, Ch, #255, True) then + efConditionalBeep + else begin + if InsertChar then begin + if (Ch <> '-') and (StLen+MinusVal = nfMaxLen) then + CheckAutoAdvance(1); + MF := 10; + end else + efConditionalBeep; + end; + end else if not CheckAutoAdvance(1) then + efConditionalBeep; + end; + end; + ccLeft, ccWordLeft : + CheckAutoAdvance(-1); + ccRight, ccWordRight : + CheckAutoAdvance(1); + ccUp : + if (efoAutoAdvanceUpDown in Controller.EntryOptions) then + efMoveFocusToPrevField + else if (efoArrowIncDec in Options) and + not (efoReadOnly in Options) then + IncreaseValue(True, 1) + else + CheckAutoAdvance(-1); + ccDown : + if (efoAutoAdvanceUpDown in Controller.EntryOptions) then + efMoveFocusToNextField + else if (efoArrowIncDec in Options) and not (efoReadOnly in Options) then + DecreaseValue(True, 1) + else + CheckAutoAdvance(1); + ccMouse : + begin + efSelStart := 0; + efSelEnd := 0; + end; + ccDblClk : + SetSelection(0, MaxEditLen); + ccHome, ccEnd : {do nothing}; + ccBack, ccDel : + if HaveSel then + DeleteSel + else + DeleteChar; + ccDelWord : + if HaveSel then + DeleteSel; + ccExtendLeft : + UpdateSel(-1); + ccExtendRight : + UpdateSel(+1); + ccExtWordLeft, ccExtendHome : + UpdateSel(-MaxEditLen); + ccExtWordRight, ccExtendEnd : + UpdateSel(+MaxEditLen); + ccCut : + if HaveSel then + DeleteSel; + ccCopy : efCopyPrim; + ccPaste : + {for some reason, a paste action within the IDE} + {gets passed to the control. filter it out} + if not (csDesigning in ComponentState) then + PastePrim(PAnsiChar(Msg.lParam)); + ccDelLine : + begin + ClearString; + MF := 10; + end; + ccIns : + begin + if sefInsert in sefOptions then + Exclude(sefOptions, sefInsert) + else + Include(sefOptions, sefInsert); + efCaret.InsertMode := (sefInsert in sefOptions); + end; + ccRestore : + begin + Restore; + nfReloadTmp; + end; + ccAccept : + begin + Include(sefOptions, sefCharOK); + Include(sefOptions, sefAcceptChar); + Exit; + end; + ccCtrlChar : {}; + ccDec : + DecreaseValue(True, 1); + ccInc : + IncreaseValue(True, 1); + ccSuppress, ccPartial : + goto ExitPoint; + else + Include(sefOptions, sefCharOK); + end; + Exclude(sefOptions, sefAcceptChar); + + case Cmd of + ccMouse : {}; + ccRestore, ccDblClk, + ccExtendLeft, ccExtendRight, ccExtendEnd, + ccExtendHome, ccExtWordLeft, ccExtWordRight : + Inc(MF); + ccCut, ccCopy, ccPaste : {}; + else + efSelStart := efHPos; + efSelEnd := efHPos; + end; + + +ExitPoint: + if MF >= 10 then begin + UpdateEditSt; + efFieldModified; + end; + if efPositionCaret(True) then + Inc(MF); + if MF > 0 then + Invalidate; +end; + +function TOvcCustomNumericField.efGetDisplayString(Dest : PAnsiChar; Size : Word) : PAnsiChar; + {-return the display string in Dest and a pointer as the result} +var + I, J : Cardinal; + Found : Boolean; +begin + Result := inherited efGetDisplayString(Dest, Size); + + if Uninitialized and not (sefHaveFocus in sefOptions) then + Exit; + + Found := StrChPos(Dest, '-', I); + if StrChPos(efPicture, pmNegParens, J) then + if not Found then + Dest[J] := ' ' + else begin + Dest[I] := '('; + Dest[J] := ')'; + end; + + if StrChPos(efPicture, pmNegHere, J) then + if not Found then + Dest[J] := ' ' + else begin + Dest[J] := '-'; + J := efEditBegin; + if J = I then + Dest[I] := ' ' + else begin + StrChDeletePrim(Dest, I); + StrChInsertPrim(Dest, ' ', J); + end; + end; + + TrimAllSpacesPChar(Dest); +end; + +procedure TOvcCustomNumericField.efIncDecValue(Wrap : Boolean; Delta : Double); + {-increment field by Delta} +var + Code : Integer; + + procedure IncDecValueLongInt; + var + L : LongInt; + S : TEditString; + begin + pbStripPicture(S, efEditSt); + + if efStr2Long(S, L) then begin + if (Delta < 0) and (L <= efRangeLo.rtLong) then + if Wrap then + L := efRangeHi.rtLong + else + Exit + else if (Delta > 0) and (L >= efRangeHi.rtLong) then + if Wrap then + L := efRangeLo.rtLong + else + Exit + else + Inc(L, Trunc(Delta)); + + {insure valid value} + if L < efRangeLo.rtLong then + L := efRangeLo.rtLong; + if L > efRangeHi.rtLong then + L := efRangeHi.rtLong; + + efTransfer(@L, otf_SetData); + nfReloadTmp; + efPerformRepaint(True); + end; + end; + + procedure IncDecValueReal; + var + Re : Real; + S : TEditString; + begin + pbStripPicture(S, efEditSt); + + FixRealPrim(S, IntlSupport.DecimalChar); +{$IFNDEF FPC} + Val(S, Re, Code); +{$ELSE} + Val(string(S), Re, Code); +{$ENDIF} + + if Code = 0 then begin + if (Delta < 0) and (Re <= efRangeLo.rtReal) then + if Wrap then + Re := efRangeHi.rtReal + else + Exit + else if (Delta > 0) and (Re >= efRangeHi.rtReal) then + if Wrap then + Re := efRangeLo.rtReal + else + Exit + else + Re := Re + Delta; + + {insure valid value} + if Re < efRangeLo.rtReal then + Re := efRangeLo.rtReal; + if Re > efRangeHi.rtReal then + Re := efRangeHi.rtReal; + + efTransfer(@Re, otf_SetData); + nfReloadTmp; + efPerformRepaint(True); + end; + end; + + procedure IncDecValueExtended; + var + Ex : Extended; + S : TEditString; + begin + pbStripPicture(S, efEditSt); + + FixRealPrim(S, IntlSupport.DecimalChar); +{$IFNDEF FPC} + Val(S, Ex, Code); +{$ELSE} + Val(string(S), Ex, Code); +{$ENDIF} + + if Code = 0 then begin + if (Delta < 0) and (Ex <= efRangeLo.rtExt) then + if Wrap then + Ex := efRangeHi.rtExt + else + Exit + else if (Delta > 0) and (Ex >= efRangeHi.rtExt) then + if Wrap then + Ex := efRangeLo.rtExt + else + Exit + else + Ex := Ex + Delta; + + {insure valid value} + if Ex < efRangeLo.rtExt then + Ex := efRangeLo.rtExt; + if Ex > efRangeHi.rtExt then + Ex := efRangeHi.rtExt; + + efTransfer(@Ex, otf_SetData); + nfReloadTmp; + efPerformRepaint(True); + end; + end; + + procedure IncDecValueDouble; + var + Db : Double; + S : TEditString; + begin + pbStripPicture(S, efEditSt); + + FixRealPrim(S, IntlSupport.DecimalChar); +{$IFNDEF FPC} + Val(S, Db, Code); +{$ELSE} + Val(string(S), Db, Code); +{$ENDIF} + + if Code = 0 then begin + if (Delta < 0) and (Db <= efRangeLo.rtExt) then + if Wrap then + Db := efRangeHi.rtExt + else + Exit + else if (Delta > 0) and (Db >= efRangeHi.rtExt) then + if Wrap then + Db := efRangeLo.rtExt + else + Exit + else + Db := Db + Delta; + + {insure valid value} + if Db < efRangeLo.rtExt then + Db := efRangeLo.rtExt; + if Db > efRangeHi.rtExt then + Db := efRangeHi.rtExt; + + efTransfer(@Db, otf_SetData); + nfReloadTmp; + efPerformRepaint(True); + end; + end; + + procedure IncDecValueSingle; + var + Si : Single; + S : TEditString; + begin + pbStripPicture(S, efEditSt); + + FixRealPrim(S, IntlSupport.DecimalChar); +{$IFNDEF FPC} + Val(S, Si, Code); +{$ELSE} + Val(string(S), Si, Code); +{$ENDIF} + + if Code = 0 then begin + if (Delta < 0) and (Si <= efRangeLo.rtExt) then + if Wrap then + Si := efRangeHi.rtExt + else + Exit + else if (Delta > 0) and (Si >= efRangeHi.rtExt) then + if Wrap then + Si := efRangeLo.rtExt + else + Exit + else + Si := Si + Delta; + + {insure valid value} + if Si < efRangeLo.rtExt then + Si := efRangeLo.rtExt; + if Si > efRangeHi.rtExt then + Si := efRangeHi.rtExt; + + efTransfer(@Si, otf_SetData); + nfReloadTmp; + efPerformRepaint(True); + end; + end; + + procedure IncDecValueComp; + var +{$IFNDEF FPC} + Co : Comp; +{$ELSE} + {$IFDEF CPU86} + Co : Comp; + {$ELSE} + Co : Double; + {$ENDIF} +{$ENDIF} + S : TEditString; + begin + pbStripPicture(S, efEditSt); + + FixRealPrim(S, IntlSupport.DecimalChar); +{$IFNDEF FPC} + Val(S, Co, Code); +{$ELSE} + Val(string(S), Co, Code); +{$ENDIF} + + if Code = 0 then begin + if (Delta < 0) and (Co <= efRangeLo.rtExt) then + if Wrap then + Co := efRangeHi.rtExt + else + Exit + else if (Delta > 0) and (Co >= efRangeHi.rtExt) then + if Wrap then + Co := efRangeLo.rtExt + else + Exit + else + Co := Co + Delta; + + {insure valid value} + if Co < efRangeLo.rtExt then + Co := efRangeLo.rtExt; + if Co > efRangeHi.rtExt then + Co := efRangeHi.rtExt; + + efTransfer(@Co, otf_SetData); + nfReloadTmp; + efPerformRepaint(True); + end; + end; + +begin + if not (sefHaveFocus in sefOptions) then + Exit; + + case FNumericDataType of + nftLongInt, + nftWord, + nftInteger, + nftByte, + nftShortInt : IncDecValueLongInt; + nftReal : IncDecValueReal; + nftExtended : IncDecValueExtended; + nftDouble : IncDecValueDouble; + nftSingle : IncDecValueSingle; + nftComp : IncDecValueComp; + end; + efPositionCaret(False); +end; + +procedure TOvcCustomNumericField.efSetCaretPos(Value : Integer); + {-set position of caret within the field} +begin + {do nothing} +end; + +function TOvcCustomNumericField.efTransfer(DataPtr : Pointer; TransferFlag : Word) : Word; + {-transfer data to/from the entry fields} +var + E : Extended; + + procedure TransferLongInt; + var + S : TEditString; + begin + if TransferFlag = otf_GetData then begin + pbStripPicture(S, efEditSt); + + if not efStr2Long(S, LongInt(DataPtr^)) then + LongInt(DataPtr^) := 0; + end else begin + efLong2Str(S, LongInt(DataPtr^)); + pbMergePicture(efEditSt, S); + end; + end; + + procedure TransferWord; + var + L : LongInt; + S : TEditString; + begin + if TransferFlag = otf_GetData then begin + pbStripPicture(S, efEditSt); + + if efStr2Long(S, L) then + Word(DataPtr^) := L + else + Word(DataPtr^) := 0; + end else begin + efLong2Str(S, Word(DataPtr^)); + pbMergePicture(efEditSt, S); + end; + end; + + procedure TransferInteger; + var + L : LongInt; + S : TEditString; + begin + if TransferFlag = otf_GetData then begin + pbStripPicture(S, efEditSt); + + if efStr2Long(S, L) then + SmallInt(DataPtr^) := L + else + SmallInt(DataPtr^) := 0; + end else begin + efLong2Str(S, SmallInt(DataPtr^)); + pbMergePicture(efEditSt, S); + end; + end; + + procedure TransferByte; + var + L : LongInt; + S : TEditString; + begin + if TransferFlag = otf_GetData then begin + pbStripPicture(S, efEditSt); + + if efStr2Long(S, L) then + Byte(DataPtr^) := L + else + Byte(DataPtr^) := 0; + end else begin + efLong2Str(S, Byte(DataPtr^)); + pbMergePicture(efEditSt, S); + end; + end; + + procedure TransferShortInt; + var + L : LongInt; + S : TEditString; + begin + if TransferFlag = otf_GetData then begin + pbStripPicture(S, efEditSt); + + if efStr2Long(S, L) then + ShortInt(DataPtr^) := L + else + ShortInt(DataPtr^) := 0; + end else begin + efLong2Str(S, ShortInt(DataPtr^)); + pbMergePicture(efEditSt, S); + end; + end; + + procedure TransferReal; + var + Code : Integer; + Places : Word; + R : Real; + S : TEditString; + Width : Word; + begin + if TransferFlag = otf_GetData then begin + pbStripPicture(S, efEditSt); + + FixRealPrim(S, IntlSupport.DecimalChar); +{$IFNDEF FPC} + Val(S, R, Code); +{$ELSE} + Val(string(S), R, Code); +{$ENDIF} + + if Code <> 0 then + R := 0; + Real(DataPtr^) := R; + end else begin + pbCalcWidthAndPlaces(Width, Places); + Str(Real(DataPtr^):Width:Places, S); + if DecimalPlaces <> 0 then + TrimTrailingZerosPChar(S) + else + TrimAllSpacesPChar(S); + pbMergePicture(efEditSt, S); + end; + end; + + procedure TransferExtended; + var + Code : Integer; + Places : Word; + S : TEditString; + Width : Word; + begin + if TransferFlag = otf_GetData then begin + pbStripPicture(S, efEditSt); + + FixRealPrim(S, IntlSupport.DecimalChar); +{$IFNDEF FPC} + Val(S, E, Code); +{$ELSE} + Val(string(S), E, Code); +{$ENDIF} + + if Code <> 0 then + E := 0; + Extended(DataPtr^) := E; + end else begin + pbCalcWidthAndPlaces(Width, Places); + Str(Extended(DataPtr^):Width:Places, S); + if DecimalPlaces <> 0 then + TrimTrailingZerosPChar(S) + else + TrimAllSpacesPChar(S); + pbMergePicture(efEditSt, S); + end; + end; + + procedure TransferDouble; + var + D : Double; + Code : Integer; + Places : Word; + S : TEditString; + Width : Word; + begin + if TransferFlag = otf_GetData then begin + pbStripPicture(S, efEditSt); + + FixRealPrim(S, IntlSupport.DecimalChar); +{$IFNDEF FPC} + Val(S, D, Code); +{$ELSE} + Val(string(S), D, Code); +{$ENDIF} + + if Code <> 0 then + D := 0; + Double(DataPtr^) := D; + end else begin + pbCalcWidthAndPlaces(Width, Places); + Str(Double(DataPtr^):Width:Places, S); + if DecimalPlaces <> 0 then + TrimTrailingZerosPChar(S) + else + TrimAllSpacesPChar(S); + pbMergePicture(efEditSt, S); + end; + end; + + procedure TransferSingle; + var + Code : Integer; + G : Single; + Places : Word; + S : TEditString; + Width : Word; + begin + if TransferFlag = otf_GetData then begin + pbStripPicture(S, efEditSt); + + FixRealPrim(S, IntlSupport.DecimalChar); +{$IFNDEF FPC} + Val(S, G, Code); +{$ELSE} + Val(string(S), G, Code); +{$ENDIF} + + if Code <> 0 then + G := 0; + Single(DataPtr^) := G; + end else begin + pbCalcWidthAndPlaces(Width, Places); + Str(Single(DataPtr^):Width:Places, S); + if DecimalPlaces <> 0 then + TrimTrailingZerosPChar(S) + else + TrimAllSpacesPChar(S); + pbMergePicture(efEditSt, S); + end; + end; + + procedure TransferComp; + var +{$IFNDEF FPC} + C : Comp; +{$ELSE} + {$IFDEF CPU86} + C : Comp; + {$ELSE} + C : Double; + {$ENDIF} +{$ENDIF} + Code : Integer; + Places : Word; + S : TEditString; + Width : Word; + begin + if TransferFlag = otf_GetData then begin + pbStripPicture(S, efEditSt); + + FixRealPrim(S, IntlSupport.DecimalChar); +{$IFNDEF FPC} + Val(S, C, Code); +{$ELSE} + Val(string(S), C, Code); +{$ENDIF} + + if Code <> 0 then + C := 0; +{$IFNDEF FPC} + Comp(DataPtr^) := C; +{$ELSE} + {$IFDEF CPU86} + Comp(DataPtr^) := C; + {$ELSE} + Double(DataPtr^) := C; + {$ENDIF} +{$ENDIF} + end else begin + pbCalcWidthAndPlaces(Width, Places); +{$IFNDEF FPC} + Str(Comp(DataPtr^):Width:Places, S); +{$ELSE} + {$IFDEF CPU86} + Str(Comp(DataPtr^):Width:Places, S); + {$ELSE} + Str(Double(DataPtr^):Width:Places, S); + {$ENDIF} +{$ENDIF} + if DecimalPlaces <> 0 then + TrimTrailingZerosPChar(S) + else + TrimAllSpacesPChar(S); + pbMergePicture(efEditSt, S); + end; + end; + +begin {transfer} + if DataPtr = nil then begin + Result := 0; + Exit; + end; + + case FNumericDataType of + nftLongInt : TransferLongInt; + nftWord : TransferWord; + nftInteger : TransferInteger; + nftByte : TransferByte; + nftShortInt : TransferShortInt; + nftReal : TransferReal; + nftExtended : TransferExtended; + nftDouble : TransferDouble; + nftSingle : TransferSingle; + nftComp : TransferComp; + end; + Result := inherited efTransfer(DataPtr, TransferFlag); +end; + +function TOvcCustomNumericField.efValidateField : Word; + {-validate contents of field; result is error code or 0} + + procedure ValidateLongInt; + var + L : LongInt; + S : TEditString; + begin + pbStripPicture(S, efEditSt); + + if not efStr2Long(S, L) then + Result := oeInvalidNumber + else if (L < efRangeLo.rtLong) or (L > efRangeHi.rtLong) then + Result := oeRangeError + else begin + if sefHaveFocus in sefOptions then + if not (sefGettingValue in sefOptions) then begin + efTransfer(@L, otf_SetData); + Invalidate; + end; + end; + end; + + procedure ValidateWord; + var + L : LongInt; + W : Word; + S : TEditString; + begin + pbStripPicture(S, efEditSt); + + if not efStr2Long(S, L) then + Result := oeInvalidNumber + else if (L < efRangeLo.rtLong) or (L > efRangeHi.rtLong) then + Result := oeRangeError + else begin + if sefHaveFocus in sefOptions then + if not (sefGettingValue in sefOptions) then begin + W := L; + efTransfer(@W, otf_SetData); + Invalidate; + end; + end; + end; + + procedure ValidateInteger; + var + L : LongInt; + I : Integer; + S : TEditString; + begin + pbStripPicture(S, efEditSt); + + if not efStr2Long(S, L) then + Result := oeInvalidNumber + else if (L < efRangeLo.rtLong) or (L > efRangeHi.rtLong) then + Result := oeRangeError + else begin + if sefHaveFocus in sefOptions then + if not (sefGettingValue in sefOptions) then begin + I := L; + efTransfer(@I, otf_SetData); + Invalidate; + end; + end; + end; + + procedure ValidateByte; + var + L : LongInt; + B : Byte; + S : TEditString; + begin + pbStripPicture(S, efEditSt); + + if not efStr2Long(S, L) then + Result := oeInvalidNumber + else if (L < efRangeLo.rtLong) or (L > efRangeHi.rtLong) then + Result := oeRangeError + else begin + if sefHaveFocus in sefOptions then + if not (sefGettingValue in sefOptions) then begin + B := L; + efTransfer(@B, otf_SetData); + Invalidate; + end; + end; + end; + + procedure ValidateShortInt; + var + L : LongInt; + Si : Byte; + S : TEditString; + begin + pbStripPicture(S, efEditSt); + + if not efStr2Long(S, L) then + Result := oeInvalidNumber + else if (L < efRangeLo.rtLong) or (L > efRangeHi.rtLong) then + Result := oeRangeError + else begin + if sefHaveFocus in sefOptions then + if not (sefGettingValue in sefOptions) then begin + Si := L; + efTransfer(@Si, otf_SetData); + Invalidate; + end; + end; + end; + + procedure ValidateReal; + var + R : Real; + Code : Integer; + S : TEditString; + begin + {convert efEditSt to a real} + pbStripPicture(S, efEditSt); + + FixRealPrim(S, IntlSupport.DecimalChar); +{$IFNDEF FPC} + Val(S, R, Code); +{$ELSE} + Val(string(S), R, Code); +{$ENDIF} + + if Code <> 0 then + Result := oeInvalidNumber + else if (R < efRangeLo.rtReal) or (R > efRangeHi.rtReal) then + Result := oeRangeError + else begin + if sefHaveFocus in sefOptions then + if not (sefGettingValue in sefOptions) then begin + efTransfer(@R, otf_SetData); + Invalidate; + end; + end; + end; + + procedure ValidateExtended; + var + E : Extended; + Code : Integer; + S : TEditString; + begin + {convert efEditSt to an extended} + pbStripPicture(S, efEditSt); + + FixRealPrim(S, IntlSupport.DecimalChar); +{$IFNDEF FPC} + Val(S, E, Code); +{$ELSE} + Val(string(S), E, Code); +{$ENDIF} + + if Code <> 0 then + Result := oeInvalidNumber + else if (E < efRangeLo.rtExt) or (E > efRangeHi.rtExt) then + Result := oeRangeError + else begin + if sefHaveFocus in sefOptions then + if not (sefGettingValue in sefOptions) then begin + efTransfer(@E, otf_SetData); + Invalidate; + end; + end; + end; + + procedure ValidateDouble; + var + E : Extended; + D : Double; + Code : Integer; + S : TEditString; + begin + {convert efEditSt to an extended} + pbStripPicture(S, efEditSt); + + FixRealPrim(S, IntlSupport.DecimalChar); +{$IFNDEF FPC} + Val(S, E, Code); +{$ELSE} + Val(string(S), E, Code); +{$ENDIF} + + if Code <> 0 then + Result := oeInvalidNumber + else if (E < efRangeLo.rtExt) or (E > efRangeHi.rtExt) then + Result := oeRangeError + else begin + if sefHaveFocus in sefOptions then + if not (sefGettingValue in sefOptions) then begin + D := E; + efTransfer(@D, otf_SetData); + Invalidate; + end; + end; + end; + + procedure ValidateSingle; + var + E : Extended; + Si : Single; + Code : Integer; + S : TEditString; + begin + {convert efEditSt to an extended} + pbStripPicture(S, efEditSt); + + FixRealPrim(S, IntlSupport.DecimalChar); +{$IFNDEF FPC} + Val(S, E, Code); +{$ELSE} + Val(string(S), E, Code); +{$ENDIF} + + if Code <> 0 then + Result := oeInvalidNumber + else if (E < efRangeLo.rtExt) or (E > efRangeHi.rtExt) then + Result := oeRangeError + else begin + if sefHaveFocus in sefOptions then + if not (sefGettingValue in sefOptions) then begin + Si := E; + efTransfer(@Si, otf_SetData); + Invalidate; + end; + end; + end; + + procedure ValidateComp; + var + E : Extended; +{$IFNDEF FPC} + C : Comp; +{$ELSE} + {$IFDEF CPU86} + C : Comp; + {$ELSE} + C : Double; + {$ENDIF} +{$ENDIF} + Code : Integer; + S : TEditString; + begin + {convert efEditSt to an comp} + pbStripPicture(S, efEditSt); + + FixRealPrim(S, IntlSupport.DecimalChar); +{$IFNDEF FPC} + Val(S, C, Code); +{$ELSE} + Val(string(S), C, Code); +{$ENDIF} + + E := C; + if Code <> 0 then + Result := oeInvalidNumber + else if (E < efRangeLo.rtExt) or (E > efRangeHi.rtExt) then + Result := oeRangeError + else begin + if sefHaveFocus in sefOptions then + if not (sefGettingValue in sefOptions) then begin + efTransfer(@C, otf_SetData); + Invalidate; + end; + end; + end; + +begin {validate} + Result := 0; + case FNumericDataType of + nftLongInt : ValidateLongInt; + nftWord : ValidateWord; + nftInteger : ValidateInteger; + nftByte : ValidateByte; + nftShortInt : ValidateShortInt; + nftReal : ValidateReal; + nftExtended : ValidateExtended; + nftDouble : ValidateDouble; + nftSingle : ValidateSingle; + nftComp : ValidateComp; + end; + + if not (sefUserValidating in sefOptions) then begin + {user may retrieve data from field. flag that we are doing} + {user validation to avoid calling this routine recursively} + Include(sefOptions, sefUserValidating); + DoOnUserValidation(Result); + Exclude(sefOptions, sefUserValidating); + end; +end; + +function TOvcCustomNumericField.nfGetDataType(Value: TNumericDataType) : Byte; + {-return a Byte value representing the type of this field} +begin + case Value of + nftLongInt : Result := fidNumericLongInt; + nftWord : Result := fidNumericWord; + nftInteger : Result := fidNumericInteger; + nftByte : Result := fidNumericByte; + nftShortInt : Result := fidNumericShortInt; + nftReal : Result := fidNumericReal; + nftExtended : Result := fidNumericExtended; + nftDouble : Result := fidNumericDouble; + nftSingle : Result := fidNumericSingle; + nftComp : Result := fidNumericComp; + else + raise EOvcException.Create(GetOrphStr(SCInvalidParamValue)); + end; +end; + +procedure TOvcCustomNumericField.nfReloadTmp; + {-reload Tmp from efEditSt, etc.} +begin + {load nfTmp} + pbStripPicture(nfTmp, efEditSt); + + TrimAllSpacesPChar(nfTmp); + + {remove the minus sign if there is one} + nfMinus := (nfTmp[0] = '-'); + if nfMinus then + StrChDeletePrim(nfTmp, 0); + + {want a blank string if it's a zero} + if (nfTmp[0] = '0') and (nfTmp[1] = #0) then + nfTmp[0] := #0; +end; + +procedure TOvcCustomNumericField.nfResetFieldProperties(FT: TNumericDataType); + {-reset field properties} +begin + DecimalPlaces := 0; + case FT of + nftLongInt : PictureMask := 'iiiiiiiiiii'; + nftWord : PictureMask := '99999'; + nftInteger : PictureMask := 'iiiiii'; + nftByte : PictureMask := '999'; + nftShortInt : PictureMask := 'iiii'; + nftReal : PictureMask := '##########'; + nftExtended : PictureMask := '##########'; + nftDouble : PictureMask := '##########'; + nftSingle : PictureMask := '##########'; + nftComp : PictureMask := 'iiiiiiiiii'; + else + raise EOvcException.Create(GetOrphStr(SCInvalidParamValue)); + end; +end; + +procedure TOvcCustomNumericField.nfSetDataType(Value: TNumericDataType); + {-set the data type for this field} +begin + if FNumericDataType <> Value then begin + FNumericDataType := Value; + efDataType := nfGetDataType(FNumericDataType); + efSetDefaultRange(efDataType); + + {set defaults for this field type} + nfResetFieldProperties(FNumericDataType); + if HandleAllocated then begin + {don't save data through create window} + efSaveData := False; +{$IFNDEF LCL} + RecreateWnd; +{$ELSE} + MyMisc.RecreateWnd(Self); +{$ENDIF} + end; + end; +end; + +procedure TOvcCustomNumericField.nfSetDefaultRanges; + {-set default range values based on the field type} +begin + case FNumericDataType of + nftLongInt, nftWord, nftInteger, nftByte, nftShortInt : + if efRangeLo.rtLong = efRangeHi.rtLong then + efSetDefaultRange(efDataType); + nftReal : + if efRangeLo.rtReal = efRangeHi.rtReal then + efSetDefaultRange(efDataType); + nftExtended, nftDouble, nftSingle, nftComp : + if efRangeLo.rtExt = efRangeHi.rtExt then + efSetDefaultRange(efDataType); + else + efSetDefaultRange(efDataType); + end; +end; + +procedure TOvcCustomNumericField.nfSetMaxLength(Mask : PChar); + {-determine and set MaxLength} +var + C : Cardinal; +begin + FMaxLength := StrLen(Mask); + + {decrease this if Mask has special characters that} + {should not be considered part of the display string} + if StrChPos(Mask, pmNegParens, C) then + Dec(FMaxLength); + if StrChPos(Mask, pmNegHere, C) then + Dec(FMaxLength); +end; + +procedure TOvcCustomNumericField.nfSetPictureMask(const Value: string); + {-set the picture mask} +var + Buf : TPictureMask; +begin + if (FPictureMask <> Value) and (Value <> '') then begin + + {test for blatantly invalid masks} + if csDesigning in ComponentState then begin + {check for masks like "999.99" or "iii.ii" in fields editing floating data types} + if (efDataType mod fcpDivisor) in [fsubReal, fsubExtended, fsubDouble, fsubSingle] then + if (Pos(pmDecimalPt, Value) > 0) and + ((Pos(pmPositive, Value) > 0) or (Pos(pmWhole, Value) > 0)) then + raise EInvalidPictureMask.Create(Value); + end; + + FPictureMask := Value; + if csDesigning in ComponentState then begin + StrPLCopy(efPicture, FPictureMask, MaxPicture); + efPicLen := StrLen(efPicture); + {set MaxLength based on picture mask} + nfSetMaxLength(efPicture); + pbOptimizeInitPictureFlags; + efInitializeDataSize; + Repaint; + end else begin + StrPLCopy(Buf, FPictureMask, MaxPicture); + efChangeMask(Buf); +{$IFNDEF LCL} + RecreateWnd; +{$ELSE} + MyMisc.RecreateWnd(Self); +{$ENDIF} + end; + end; +end; + +procedure TOvcCustomNumericField.pbRemoveSemiLits; + {-remove semi-literal mask characters from the edit string} +begin + if (sefHexadecimal in sefOptions) or (sefOctal in sefOptions) or + (sefBinary in sefOptions) then + Include(sefOptions, sefFixSemiLits) + else + Exclude(sefOptions, sefFixSemiLits); +end; + +procedure TOvcCustomNumericField.WMKillFocus(var Msg : TWMKillFocus); +begin + inherited; + + {are we giving up the focus?} + if not (sefRetainPos in sefOptions) then + FillChar(nfTmp, SizeOf(nfTmp), #0); +end; + +procedure TOvcCustomNumericField.WMSetFocus(var Msg : TWMSetFocus); +begin + inherited; + nfReloadTmp; + efResetCaret; +end; + + +end. diff --git a/components/orpheus/ovcpb.pas b/components/orpheus/ovcpb.pas new file mode 100644 index 000000000..bdf5e64a1 --- /dev/null +++ b/components/orpheus/ovcpb.pas @@ -0,0 +1,1006 @@ +{*********************************************************} +{* OVCPB.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovcpb; + {-Base picture field class, Picture and Numeric fields are derived from this} + +interface + +uses + {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, LclType, MyMisc, {$ENDIF} + Classes, Graphics, SysUtils, OvcConst, + OvcData, OvcEF, OvcStr; + +type + TOvcPictureBase = class(TOvcBaseEntryField) + {.Z+} + protected {private} + pfSemiLits : Byte; {# of semi-literals in field} + pfPicFlags : TPictureFlags; {picture flags array} + pfSelPos : Integer; {current position of selection highlight} + + {windows message methods} + procedure WMSetFocus(var Msg : TWMSetFocus); + message WM_SETFOCUS; + procedure WMKillFocus(var Msg : TWMKillFocus); + message WM_KILLFOCUS; + + protected + procedure CreateWnd; + override; + + function efCanClose(DoValidation : Boolean) : Boolean; + override; + {-return True if window can be closed} + procedure efCaretToEnd; + override; + {-move the caret to the end of the field} + procedure efCaretToStart; + override; + {-move the caret to the beginning of the field} + procedure efChangeMask(Mask : PAnsiChar); + override; + {-change the picture mask} + function efEditBegin : Word; + override; + {-return offset of first editable position in field} + function efEditEnd : Word; + {-return offset of last editable position in field} + function efFieldIsEmpty : Boolean; + override; + {-return True if the field is empty} + function efGetDisplayString(Dest : PAnsiChar; Size : Word) : PAnsiChar; + override; + {-return the display string in Dest and a pointer as the result} + procedure efRemoveBadOptions; + override; + {-remove inappropriate options for this field and data type} + procedure efSetCaretPos(Value : Integer); + override; + {-set position of caret within the field} + + function pbCalcLength : Word; + {-calculate length of efEditSt} + procedure pbCalcWidthAndPlaces(var Width, Places : Word); + {-calculate width and decimal places for a numeric field} + procedure pbFixDecimalPoint(P : PAnsiChar); + {-fix decimal points for real numbers before merging} + procedure pbFixNumber(DotPos, StBgn, StEnd : Integer; FirstHalf, SecondHalf : Boolean); + {-fix the first and/or second half of a numeric field} + function pbIsLiteral(N : Word) : Boolean; + {-return True if N'th mask character is a literal. N is 0-based} + procedure pbInitPictureFlags; + {-initialize picture mask flags} + function pbIsNumber : Boolean; + {-return True if field is treated as numeric by MergePicture} + function pbIsSemiLiteral(N : Word) : Boolean; + {-return True if N'th mask character is a semi-literal. N is 0-based} + procedure pbMergePicture(const Dest, Src : PAnsiChar); + {-merge Src with efPicture and return result in Dest} + procedure pbOptimizeInitPictureFlags; + {-see if we can optimize InitPictureFlags} + procedure pbRemoveSemiLits; + virtual; + {-remove semi-literal mask characters from the edit string} + procedure pbRestoreSemiLits; + {-restore semi-literal mask characters in the edit string} + procedure pbStripLiterals(Dest, Src : PAnsiChar); + {-strip literal mask characters from source and put result in Dest} + procedure pbStripPicture(const Dest, Src : PAnsiChar); + {-strip the mask characters from Src and put result in Dest} + + public + {interfaced for internal use only--to allow validation} + {helper routines access to the picture flags array} + procedure pbGetPictureFlags(var Flags : TPictureFlags); + {-return an array of the fields picture flags} + function GetStrippedEditString : string; + override; + {-return edit string stripped of literals and semi-literals} + procedure MergeWithPicture(const S : string); + override; + {-combines S with the picture mask and updates the edit string} + function ValidateContents(ReportError : Boolean) : Word; + override; + {.Z-} + end; + + +implementation + + +{*** TOvcPictureBase ***} + +procedure TOvcPictureBase.CreateWnd; +begin + pbInitPictureFlags; + + inherited CreateWnd; + + {set flags for Real fields and clear DecimalPlaces if decimal point is in mask} + case efDataType mod fcpDivisor of + fsubReal, fsubExtended, fsubDouble, fsubSingle, fsubComp : + begin + Include(sefOptions, sefRealVar); + if StrScan(efPicture, pmDecimalPt) <> nil then + DecimalPlaces := 0; + end; + end; +end; + +procedure TOvcPictureBase.pbGetPictureFlags(var Flags : TPictureFlags); + {-return an array of the fields picture flags} +begin + Flags := pfPicFlags; +end; + +function TOvcPictureBase.pbIsLiteral(N : Word) : Boolean; + {-return True if N'th mask character is a literal. N is 0-based} +begin + Result := pfPicFlags[N] = pflagLiteral; +end; + +function TOvcPictureBase.pbIsSemiLiteral(N : Word) : Boolean; + {-return True if N'th mask character is a semi-literal. N is 0-based} +begin + Result := pfPicFlags[N] = pflagSemiLit; +end; + +procedure TOvcPictureBase.pbFixNumber(DotPos, StBgn, StEnd : Integer; FirstHalf, SecondHalf : Boolean); + {-fix the first and/or second half of a numeric field} +var + I, J, K : Integer; + SaveHP : Word; + + function StartOfSubField : Word; + begin + Result := efHPos; + while (Result > StBgn) and not pbIsLiteral(Result - 1) do + Dec(Result); + end; + + function EndOfSubField : Word; + begin + Result := efHPos; + while (Result < StEnd) and not pbIsLiteral(Result + 1) do + Inc(Result); + end; + +begin + SaveHP := efHPos; + + if FirstHalf then begin + {bring numbers to left of decimal flush right} + if DotPos = -1 then + efHPos := StEnd + else + efHPos := DotPos-1; + K := EndOfSubField; + J := StartOfSubField; + I := J; + while efEditSt[I] = ' ' do + Inc(I); + while I <= K do begin + if efEditSt[I] = ' ' then begin + StrStDeletePrim(efEditSt, I, 1); + StrChInsertPrim(efEditSt, ' ', J); + end; + Inc(I); + end; + + {make sure it isn't all blanks to left of decimal} + if efEditSt[K] = ' ' then + efEditSt[K] := '0'; + end; + + if (DotPos <> -1) and SecondHalf then begin + efHPos := DotPos+1; + + {bring numbers to right of decimal flush left} + J := EndOfSubField; + if efHPos <= J then begin + K := J; + J := StartOfSubField; + I := K; + while efEditSt[I] = ' ' do begin + efEditSt[I] := '0'; + Dec(I); + end; + while I >= J do begin + if efEditSt[I] = ' ' then begin + StrStDeletePrim(efEditSt, I, 1); + StrChInsertPrim(efEditSt, '0', K); + end; + Dec(I); + end; + end; + end; + + efHPos := SaveHP; +end; + +procedure TOvcPictureBase.pbStripLiterals(Dest, Src : PAnsiChar); + {-strip literal mask characters from source and put result in Dest} +var + I : Word; +begin + for I := 0 to MaxLength-1 do begin + if not pbIsLiteral(I) then begin + Dest^ := Src^; + Inc(Dest); + end; + Inc(Src); + end; + Dest^ := #0; +end; + +procedure TOvcPictureBase.pbFixDecimalPoint(P : PAnsiChar); + {-fix decimal points for real numbers before merging} +var + PT : PAnsiChar; +begin + PT := StrScan(P, pmDecimalPt); + if PT <> nil then + PT^ := IntlSupport.DecimalChar; +end; + +procedure TOvcPictureBase.pbRestoreSemiLits; + {-restore semi-literal mask characters in the edit string} +var + P : PChar; +begin + if not (sefFixSemiLits in sefOptions) then + Exit; + + Exclude(sefOptions, sefFixSemiLits); + pbStripPicture(efEditSt, efEditSt); + P := StrScan(efEditSt, IntlSupport.DecimalChar); + if P <> nil then + P^ := pmDecimalPt; + pbMergePicture(efEditSt, efEditSt); + Invalidate; +end; + +procedure TOvcPictureBase.pbInitPictureFlags; +var + I : Word; +begin + if sefNoLiterals in sefOptions then begin + FillChar(pfPicFlags, MaxLength, pflagFormat); + pfPicFlags[MaxLength] := pflagLiteral; + end else begin + FillChar(pfPicFlags, MaxLength+1, pflagLiteral); + for I := 0 to MaxLength-1 do + if efNthMaskChar(I) in PictureChars then + pfPicFlags[I] := pflagFormat + else + case efNthMaskChar(I) of + pmFloatDollar, pmComma : + pfPicFlags[I] := pflagSemiLit; + end; + end; +end; + +function TOvcPictureBase.pbIsNumber : Boolean; + {-return True if field is treated as numeric by MergePicture} +begin + Result := + (pfSemiLits <> 0) or + (sefNumeric in sefOptions) or + (sefHexadecimal in sefOptions) or + (sefOctal in sefOptions) or + (sefBinary in sefOptions) or + (StrScan(efPicture, pmDecimalPt) <> nil) or + (StrScan(efPicture, pmCurrencyLt) <> nil) or + (StrScan(efPicture, pmCurrencyRt) <> nil); +end; + +function TOvcPictureBase.pbCalcLength : Word; + {-calculate length of efEditSt} +var + I : Integer; +begin + I := efEditEnd; + while (I >= 0) and ((efEditSt[I] = ' ') or pbIsLiteral(I)) do + Dec(I); + Result := I + 1; +end; + +function TOvcPictureBase.efGetDisplayString(Dest : PAnsiChar; Size : Word) : PAnsiChar; + {-return the display string in Dest} +var + I : Integer; +begin + Result := inherited efGetDisplayString(Dest, Size); + + if Uninitialized and not (sefHaveFocus in sefOptions) then begin + FillChar(Dest[0], MaxLength, ' '); + Dest[MaxLength] := #0; + Exit; + end; + + if (efoPasswordMode in Options) or (PadChar <> ' ') then begin + I := MaxLength-1; + while I >= 0 do begin + while (I >= 0) and pbIsLiteral(I) do + Dec(I); + + if efFieldClass <> fcNumeric then + while (I >= 0) and (not pbIsLiteral(I)) and (Dest[I] = ' ') do begin + Dest[I] := PadChar; + Dec(I); + end; + + while (I >= 0) and (not pbIsLiteral(I)) and (Dest[I] <> ' ') do begin + if (efoPasswordMode in Options) then + Dest[I] := PasswordChar; + Dec(I); + end; + + if efFieldClass = fcNumeric then + while (I >= 0) and (not pbIsLiteral(I)) and (Dest[I] = ' ') do begin + Dest[I] := PadChar; + Dec(I); + end; + end; + end; +end; + +function TOvcPictureBase.efFieldIsEmpty : Boolean; + {-return True if the field is empty} +var + I : Word; +begin + I := 0; + Result := True; + while (I+1 <= MaxLength) and Result do + if (not pbIsLiteral(I)) and (efEditSt[I] <> ' ') then + Result := False + else + Inc(I); +end; + +procedure TOvcPictureBase.efRemoveBadOptions; + {-remove inappropriate options for this field and data type} +begin + if csLoading in ComponentState then + Exit; + + case efDataType of + fidPictureString : + if not (sefNoLiterals in sefOptions) then begin + Exclude( FOptions, efoRightJustify ); + Exclude( FOptions, efoTrimBlanks ); + end; + else + inherited efRemoveBadOptions; + end; +end; + +procedure TOvcPictureBase.efSetCaretPos(Value : Integer); + {-set position of caret within the field} +begin + if not (sefHaveFocus in sefOptions) then + Exit; + + if Value < efEditBegin then + efHPos := efEditBegin + else if Value > efEditEnd then + efHPos := efEditEnd + 1 + else begin + while pbIsLiteral(Value) do + Dec(Value); + efHPos := Value; + end; + efPositionCaret(True); +end; + +procedure TOvcPictureBase.efCaretToStart; + {-move the caret to the beginning of the field} +begin + efHPos := efEditBegin; + efHOffset := 0; +end; + +procedure TOvcPictureBase.efCaretToEnd; + {-move the caret to the end of the field} +var + StEnd : Word; +begin + efHPos := pbCalcLength; + StEnd := efEditEnd; + while (efHPos < StEnd) and pbIsLiteral(efHPos) do + Inc(efHPos); +end; + +function TOvcPictureBase.efEditBegin : Word; + {-return offset of first editable position in field} +var + I : Word; +begin + I := 0; + while (I < MaxLength-1) and (pfPicFlags[I] = pflagLiteral) do + Inc(I); + Result := I + pfSemiLits; +end; + +function TOvcPictureBase.efEditEnd : Word; + {-return offset of last editable position in field} +begin + Result := MaxLength - 1; + while (Result > 0) and (pfPicFlags[Result] = pflagLiteral) do + Dec(Result); +end; + +procedure TOvcPictureBase.efChangeMask(Mask : PAnsiChar); + {-change the picture mask} +var + I : Cardinal; + Buf : array[0..MaxEditLen] of Char; +begin + {save current value} + pbStripPicture(Buf, efEditSt); + + inherited efChangeMask(Mask); + + {disallow 'p' and 'g' in picture fields} + if efFieldClass <> fcNumeric then begin + if StrChPos(efPicture, pmNegParens, I) then + StrChDeletePrim(efPicture, I); + if StrChPos(efPicture, pmNegHere, I) then + StrChDeletePrim(efPicture, I); + end; + + efPicLen := StrLen(efPicture); + if (MaxLength < efPicLen) or + ((MaxLength <> efPicLen) and (efFieldClass = fcNumeric)) then begin + if not (csLoading in ComponentState) then + MaxLength := efPicLen; + end; + + {clear the edit string} + FillChar(efEditSt, MaxEditLen, #0); + + {see if we can optimize InitPictureFlags} + pbOptimizeInitPictureFlags; + + {restore value} + pbMergePicture(efEditSt, Buf); +end; + +function TOvcPictureBase.GetStrippedEditString : string; + {-return edit string stripped of literals and semi-literals} +var + Buf : TEditString; +begin + {get copy of edit string and limit to MaxEditLen} + StrLCopy(Buf, efEditSt, MaxEditLen); + + {strip the copy of the edit string} + pbStripPicture(Buf, Buf); + Result := StrPas(Buf); +end; + +procedure TOvcPictureBase.MergeWithPicture(const S : string); + {-combines S with the picture mask and updates the edit string} +var + Buf : TEditString; +begin + HandleNeeded; + StrPCopy(Buf, S); + pbMergePicture(efEditSt, Buf); +end; + +function TOvcPictureBase.efCanClose(DoValidation : Boolean) : Boolean; + {-return True if window can be closed} +var + DotPos : Cardinal; +begin + if efFieldClass = fcPicture then + if ((sefModified in sefOptions) and (sefHaveFocus in sefOptions)) then + if StrChPos(efPicture, pmDecimalPt, DotPos) then + pbFixNumber(DotPos, efEditBegin, efEditEnd, True, True); + Result := inherited efCanClose(DoValidation); +end; + +procedure TOvcPictureBase.pbRemoveSemiLits; + {-remove semi-literal mask characters from the edit string} +var + I : Cardinal; + B : Word; + E : Word; + P : Word; + D : Word; + Buf : array[0..255] of Char; +begin + if pfSemiLits = 0 then begin + if (sefHexadecimal in sefOptions) or (sefOctal in sefOptions) or + (sefBinary in sefOptions) then + Include(sefOptions, sefFixSemiLits); + Exit; + end; + + Include(sefOptions, sefFixSemiLits); + + B := efEditBegin; + E := efEditEnd; + P := B - pfSemiLits; + + if StrScan(efPicture, pmFloatDollar) <> nil then begin + StrPCopy(Buf, IntlSupport.CurrencyLtStr); + if StrStPos(efEditSt, Buf, I) then begin + D := StrLen(Buf); + StrStDeletePrim(efEditSt, I, D); + StrInsertChars(efEditSt, ' ', P, D); + Inc(P, D); + end; + end; + + if StrScan(efPicture, pmComma) <> nil then + for I := P{B} to E do + if (efEditSt[I] = IntlSupport.CommaChar) then begin + StrStDeletePrim(efEditSt, I, 1); + StrChInsertPrim(efEditSt, ' ', P); + Inc(P); + end; +end; + +procedure TOvcPictureBase.pbCalcWidthAndPlaces(var Width, Places : Word); + {-calculate width and decimal places for a numeric field} +var + I : Word; + DotPos : Cardinal; +begin + pbInitPictureFlags; + + {find position of period and calculate decimal places} + if not StrChPos(efPicture, pmDecimalPt, DotPos) then + Places := DecimalPlaces + else begin + Places := 0; + I := DotPos+1; + while (pfPicFlags[I] = pflagFormat) do begin + Inc(Places); + Inc(I); + end; + end; + + {calculate width} + I := 0; + Width := 0; + while pbIsLiteral(I) or pbIsSemiLiteral(I) do + Inc(I); + while (pfPicFlags[I] = pflagFormat) or (efNthMaskChar(I) = pmComma) do begin + Inc(Width, Ord(pfPicFlags[I] = pflagFormat)); + Inc(I); + end; + + {add decimal places and period} + if (DotPos <> $FFFF) and (Places <> 0) then + Inc(Width, Places + 1); +end; + +procedure TOvcPictureBase.pbOptimizeInitPictureFlags; + {-see if we can optimize InitPictureFlags} +var + I : Word; +begin + pfSemiLits := 0; + Exclude(sefOptions, sefNoLiterals); + pbInitPictureFlags; + Include(sefOptions, sefNoLiterals); + for I := 0 to MaxLength-1 do + case pfPicFlags[I] of + pflagLiteral : + Exclude(sefOptions, sefNoLiterals); + pflagSemiLit : + begin + Inc(pfSemiLits); + Exclude(sefOptions, sefNoLiterals); + end; + end; + + {if we have literals, turn off TrimBlanks and RightJustify} + if not (sefNoLiterals in sefOptions) then begin + Exclude( FOptions, efoTrimBlanks ); + Exclude( FOptions, efoRightJustify ); + end; +end; + +procedure TOvcPictureBase.pbMergePicture(const Dest, Src : PAnsiChar); + {-merge Src with efPicture and return result in Dest} +var + SrcLen : Integer; + DestLen : Integer; + DotPosP : Cardinal; + DotPosS : Cardinal; + FloatPos : Integer; + FP : Cardinal; + I : Cardinal; + J, K, N : Integer; + PicChar : AnsiChar; + NeedFloat : Boolean; + CurLeftMax : Byte; + CurLeftLen : Byte; + IsNum : Boolean; + NeedMinus : Boolean; + FoundP : Boolean; + FoundS : Boolean; + CopyOfSrc : TEditString; + Buf : array[0..255] of Char; + + procedure HandleOtherCases; + begin + if NeedFloat then begin + Dec(CurLeftLen); + Dest[I] := IntlSupport.CurrencyLtStr[CurLeftLen+1]; + NeedFloat := CurLeftLen <> 0; + end else if NeedMinus then begin + Dest[I] := '-'; + NeedMinus := False; + end else if (sefHexadecimal in sefOptions) or (sefOctal in sefOptions) or + (sefBinary in sefOptions) then + Dest[I] := '0' + else + Dest[I] := ' '; + end; + +begin + {get initial size of Src} + SrcLen := StrLen(Src); + + if SrcLen = 0 then + CopyOfSrc[0] := #0 + else + StrCopy(CopyOfSrc, Src); + + {copy picture mask into Dest} + StrCopy(Dest, efPicture); + + {mask may be artificially short -- extend with last character of mask} + if MaxLength > efPicLen then begin + FillChar(Dest[efPicLen], MaxLength-efPicLen, Dest[efPicLen-1]); + Dest[MaxLength] := #0; + end; + DestLen := MaxLength; + + {get position of decimal point} + FoundP := StrChPos(efPicture, pmDecimalPt, DotPosP); + + {is it a numeric string?} + IsNum := pbIsNumber; + + {take care of currency strings} + if StrChPos(efPicture, pmCurrencyLt, I) then begin + K := I; + while (K+1 < DestLen) and (efNthMaskChar(K+1) = pmCurrencyLt) do + Inc(K); + StrPCopy(Buf, IntlSupport.CurrencyLtStr); + J := StrLen(Buf); + for N := K downto I do + if J > 0 then begin + Dec(J); + Dest[N] := Buf[J]; + end else + Dest[N] := ' '; + end; + + if StrChPos(efPicture, pmCurrencyRt, I) then begin + J := 0; + StrPCopy(Buf, IntlSupport.CurrencyRtStr); + K := StrLen(Buf); + while (LongInt(I+1) <= DestLen) and (efNthMaskChar(I) = pmCurrencyRt) do begin + if J < K then begin + Dest[I] := Buf[J]; + Inc(J); + end else + Dest[I] := ' '; + Inc(I); + end; + end; + + if IsNum then begin + {we need to fill in the FloatDollar positions too, if any} + if StrChPos(efPicture, pmFloatDollar, FP) then begin + FloatPos := FP; + CurLeftLen := Length(IntlSupport.CurrencyLtStr); + CurLeftMax := 1; + while efNthMaskChar(FloatPos+1) = pmFloatDollar do begin + Inc(FloatPos); + Inc(CurLeftMax); + end; + if CurLeftMax < CurLeftLen then + CurLeftLen := CurLeftMax; + end else begin + CurLeftLen := 0; + FloatPos := -1; + end; + + {trim leading and trailing blanks} + TrimAllSpacesPChar(CopyOfSrc); + + {check for a minus sign} + NeedMinus := (CopyOfSrc[0] = '-'); + if NeedMinus then + StrStDeletePrim(CopyOfSrc, 0, 1); + + {it's a numeric field--align the decimal points} + FoundS := StrChPos(CopyOfSrc, pmDecimalPt, DotPosS); + + {see if we need a floating dollar sign} + SrcLen := StrLen(CopyOfSrc); + NeedFloat := (SrcLen <> 0) and (CurLeftLen <> 0); + + {if there's no tail, pretend there's a dot beyond the end of CopyOfSrc} + if not FoundS then + K := SrcLen + else + K := DotPosS; + + {copy the tail of the string} + if not FoundP then + I := DestLen + else + I := DotPosP+1; + J := K+1; + while (J+1 <= SrcLen) and (LongInt(I+1) <= DestLen) and not pbIsLiteral(I) do begin + Dest[I] := CopyOfSrc[J]; + Inc(I); + Inc(J); + end; + + {pad to end with 0's} + while (LongInt(I+1) <= DestLen) and not pbIsLiteral(I) do begin + Dest[I] := '0'; + Inc(I); + end; + + {handle trailing substitution characters} + while (LongInt(I+1) <= DestLen) and pbIsLiteral(I) do begin + PicChar := efNthMaskChar(I); + case PicChar of + Subst1..Subst8 : Dest[I] := UserData.SubstChars[PicChar]; + end; + Inc(I); + end; + + {merge the head of the string} + if not FoundP then + J := DestLen-1 + else + J := DotPosP; + + if FoundS then + SrcLen := DotPosS; + + for I := J downto 0 do begin + PicChar := efNthMaskChar(I); + case pfPicFlags[I] of + pflagFormat, + pflagSemiLit : + if PicChar = pmComma then begin + if (SrcLen <> 0) then begin + if IntlSupport.CommaChar <> #0 then + Dest[I] := IntlSupport.CommaChar + else + StrStDeletePrim(Dest, I, 1); + end else + HandleOtherCases; + end else if (SrcLen > 0) and (Integer(I) > FloatPos) then begin + Dec(SrcLen); + Dest[I] := CopyOfSrc[SrcLen]; + end else + HandleOtherCases; + pflagLiteral : + case PicChar of + Subst1..Subst8 : + Dest[I] := UserData.SubstChars[PicChar]; + pmDecimalPt : + Dest[I] := IntlSupport.DecimalChar; + end; + end; + end; + + {put in a 0 before the dot if necessary} + if FoundP and (Dest[DotPosP-1] = ' ') then + Dest[DotPosP-1] := '0'; + end else begin + {deal with problem w/ reals w/ variable # of places} + if (sefRealVar in sefOptions) and (SrcLen > DestLen) then + if StrScan(CopyOfSrc, pmDecimalPt) <> nil then begin + TrimTrailingZerosPChar(CopyOfSrc); + SrcLen := StrLen(CopyOfSrc); + end; + + if efoRightJustify in Options then begin + {fill in the characters from CopyOfSrc} + J := SrcLen-1; + for I := DestLen-1 downto 0 do begin + PicChar := efNthMaskChar(I); + case pfPicFlags[I] of + pflagLiteral : + case PicChar of + Subst1..Subst8 : + Dest[I] := UserData.SubstChars[PicChar]; + end; + else + if (J = -1) then + Dest[I] := ' ' + else begin + Dest[I] := CopyOfSrc[J]; + efFixCase(PicChar, AnsiChar(Dest[I]), #255); + Dec(J); + end; + end; + end; + end else begin + {fill in the characters from CopyOfSrc} + J := 0; + for I := 0 to DestLen-1 do begin + PicChar := efNthMaskChar(I); + case pfPicFlags[I] of + pflagLiteral : + case PicChar of + Subst1..Subst8 : + Dest[I] := UserData.SubstChars[PicChar]; + end; + else + if (J <= SrcLen-1) then begin + Dest[I] := CopyOfSrc[J]; + efFixCase(PicChar, AnsiChar(Dest[I]), #255); + Inc(J); + end else + Dest[I] := ' '; + end; + end; + end; + + if sefRealVar in sefOptions then + pbFixDecimalPoint(Dest); + end; + + Dest[DestLen] := #0; +end; + +procedure TOvcPictureBase.pbStripPicture(const Dest, Src : PAnsiChar); + {-strip the mask characters from Src and put result in Dest} +var + SLen : Byte; + Found : Boolean; + P : PAnsiChar; + DotPos : Cardinal; + I : Integer; + CLT : array[0..5] of AnsiChar; +begin + {this won't work if string isn't the same length as the picture mask} + if StrLen(Src) <> MaxLength then begin + if Pointer(Dest) <> Pointer(Src) then + StrCopy(Dest, Src); + Exit; + end; + + {check for fixed decimal point} + Found := StrChPos(efPicture, pmDecimalPt, DotPos); + + {copy all non-literals from Src into Dest. Note: it's OK if Dest *is* Src} + SLen := 0; + for I := 0 to MaxLength-1 do + if (Found and (I = LongInt(DotPos))) or not pbIsLiteral(I) then begin + Inc(SLen); + Dest[SLen-1] := Src[I]; + end; + Dest[SLen] := #0; + + {remove floating dollar sign} + P := StrScan(efPicture, pmFloatDollar); + if P <> nil then begin + I := 1; + + {find end of currency mask} + while P[1] = pmFloatDollar do begin + Inc(I); + Inc(P); + end; + StrPCopy(CLT, IntlSupport.CurrencyLtStr); + CLT[I] := #0; + P := StrPos(Dest, CLT); + if P <> nil then + StrStDeletePrim(P, 0, I); + end; + + {remove commas} + if (StrScan(efPicture, pmComma) <> nil) and + (IntlSupport.CommaChar <> #0) then + repeat + P := StrScan(Dest, IntlSupport.CommaChar); + if P <> nil then + StrStDeletePrim(P, 0, 1); + until (P = nil); + + {fix up decimal point} + if Found then begin + P := StrScan(Dest, IntlSupport.DecimalChar); + if P <> nil then + P^ := pmDecimalPt; + end; +end; + +function TOvcPictureBase.ValidateContents(ReportError : Boolean) : Word; +var + DotPos : Cardinal; +begin + if efFieldClass = fcPicture then + if sefModified in sefOptions then begin + if StrChPos(efPicture, pmDecimalPt, DotPos) then + pbFixNumber(DotPos, efEditBegin, efEditEnd, True, True); + end; + + Result := inherited ValidateContents(ReportError); +end; + +procedure TOvcPictureBase.WMSetFocus(var Msg : TWMSetFocus); +var + B : Boolean; +begin + pbInitPictureFlags; + B := sefRetainPos in sefOptions; + inherited; + if not B then + pfSelPos := efSelEnd; +end; + +procedure TOvcPictureBase.WMKillFocus(var Msg : TWMKillFocus); +var + DotPos : Cardinal; +begin + if efFieldClass = fcPicture then + if sefModified in sefOptions then begin + if StrChPos(efPicture, pmDecimalPt, DotPos) then + pbFixNumber(DotPos, efEditBegin, efEditEnd, True, True); + end; + + inherited; + + {are we giving up the focus?} + if not (sefRetainPos in sefOptions) then begin + {restore semi-literal characters} + pbRestoreSemiLits; + end; +end; + +end. diff --git a/components/orpheus/ovcreg.lrs b/components/orpheus/ovcreg.lrs new file mode 100644 index 000000000..70257c4cb --- /dev/null +++ b/components/orpheus/ovcreg.lrs @@ -0,0 +1,1599 @@ +LazarusResources.Add('TOVCCONTROLLER','BMP',[ + 'BM'#246#6#0#0#0#0#0#0'6'#0#0#0'('#0#0#0#24#0#0#0#24#0#0#0#1#0#24#0#0#0#0#0 + +#192#6#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#128#128#0#0#0#0#128#128#0#0#0#0 + +#128#128#0#0#0#0#128#128#0#0#0#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#0#0#0#0#0#0#0#0#0#0#0#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#0#0#0#0#0#0#128#128#0#0#0#0#128#128#0#0 + +#0#0#0#0#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#0#0#0#0#0#0#0#0 + +#0#0#0#255#0#0#255#0#0#0#0#0#0#0#0#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#0#0#0#0#0#0#128#128#0#0#0#0#128#128#0#0#0#0#0#0#0#128#128#0#128#128#0#128 + +#128#0#0#0#0#0#0#0#0#0#255#0#0#255#0#0#255#0#0#255#0#0#255#0#0#255#0#0#0#0#0 + +#0#0#0#0#128#128#0#128#128#0#128#128#0#0#0#0#128#128#0#128#128#0#0#0#0#0#0#0 + +#128#128#0#0#0#0#128#128#0#0#0#0#0#0#0#0#0#255#0#0#255#0#0#255#0#0#255#0#0 + +#255#0#0#0#0#0#0#0#0#0#0#0#255#0#0#0#0#0#0#0#0#0#128#128#0#128#128#0#0#0#0#0 + +#0#0#0#0#0#128#128#0#0#0#0#128#128#0#128#128#0#0#0#0#0#0#0#0#0#255#0#0#255#0 + +#0#255#0#0#255#0#0#0#0#0#0#0#0#0#0#0#0#128#128#0#128#128#0#0#0#0#0#0#0#0#0#0 + +#128#128#0#128#128#0#128#128#0#0#0#0#0#0#0#128#128#0#128#128#0#0#0#0#0#0#0#0 + +#0#255#0#0#255#0#0#255#0#0#255#0#0#255#0#0#0#0#0#0#0#0#0#255#255#0#128#128#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#128#128#0#128#128#0#128#128#0#128#128#0#0#0#0 + +#0#0#0#128#128#0#0#0#0#0#0#255#0#0#255#0#0#255#0#0#255#0#0#0#0#0#0#0#0#0#0#0 + +#0#128#128#0#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#128#128#0#128#128 + +#0#128#128#0#128#128#0#128#128#0#128#128#0#0#0#0#0#0#255#0#0#255#0#0#255#0#0 + +#255#0#0#0#0#0#0#0#0#0#128#128#0#128#128#0#0#0#0#255#255#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#0#0#0#0 + +#0#255#0#0#255#0#0#255#0#0#255#0#0#0#0#0#0#0#0#0#128#128#0#0#0#0#0#0#0#0#0#0 + +#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#0#0#0#128#128#0#128#128#0#128#128 + +#0#128#128#0#128#128#0#0#0#255#0#0#255#0#0#255#0#0#255#0#0#0#0#0#0#0#0#0#128 + +#128#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#0#0#0#0#0#0#0#0#0#0#0#0#255#0#0#255#0 + +#0#0#128#128#0#128#128#0#128#128#0#128#128#0#0#0#0#0#0#255#0#0#255#0#0#255#0 + +#0#0#0#0#0#0#0#0#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#0#0#0#0#0#0 + +#0#0#0#255#0#0#255#0#0#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#0 + +#0#0#0#0#255#0#0#255#0#0#0#0#0#0#0#0#0#128#128#0#0#0#0#255#255#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#255#255#0#0#0#0#0#0#255#0#0#255#0#0#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#0#0#0#0#0#255#0#0#255#0#0#0#0#0#0#0#0#0#128#128#0 + +#0#0#0#0#0#0#0#0#0#255#255#0#0#0#0#0#0#0#0#0#0#255#255#0#0#0#255#0#0#255#0#0 + +#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#0#0#255#0#0 + +#255#0#0#255#0#0#0#0#0#0#128#128#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#0#0 + +#0#0#0#0#0#255#255#255#0#0#255#0#0#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#0#0#255#0#0#255#0#0#0#0#0#0#0#0#0#128#128#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#0#0#0#0#255#255#255#0#0#0#128#128 + +#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#0#0#0#0#0#255 + +#0#0#0#0#0#0#0#0#0#128#128#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#255#255#0#255#255#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#0#0#255#0#0#255#0#0#0#0#0#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#0#0#0#255#255#0#0#0#0#128#128#0#128#128#0#128#128 + +#0#128#128#0#128#128#0#0#0#255#0#0#0#0#0#0#0#0#0#128#128#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#255#0#0#255#0#0#0#128#128#0#0#0#0#255#255#0#0#0#0#255 + +#255#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#0#0#255#0#0#0#0#0#0 + +#128#128#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#0#0#255#0#0#0#128#128 + +#0#128#128#0#255#255#0#0#0#0#255#255#0#128#128#0#128#128#0#128#128#0#128#128 + +#0#128#128#0#128#128#0#0#0#255#0#0#0#0#0#0#128#128#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#255#0#0#255#0#0#255#0#0#0#128#128#0#128#128#0#128#128#0#0#0#0#255#255#0 + +#128#128#0#255#255#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#0#0 + +#255#0#0#0#0#0#0#128#128#0#0#0#0#0#0#0#0#0#0#0#0#255#0#0#255#0#0#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#0#0#0#0#0#0#0#0#0#128#128 + +#0#128#128#0#128#128#0#128#128#0#128#128#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#255#0#0#255#0#0#255#0#0#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#0#0#0#0#0#0#0#0#255#0#0#255#0#0#255#0#0 + +#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#0#0#255#0#0#255#0#0#255#0#0#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128 +]); +LazarusResources.Add('TOVCTCSTRING','BMP',[ + 'BM'#246#6#0#0#0#0#0#0'6'#0#0#0'('#0#0#0#24#0#0#0#24#0#0#0#1#0#24#0#0#0#0#0 + +#192#6#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#0#0#0#0#0#0#0#0#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0 + +#0#0#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#0#0#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#0#0 + +#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255 + +#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#0#0 + +#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#0#0#0 + +#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#0#0#0#0#0 + +#0#0#0#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255 + +#0#255#255#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255 + +#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0 + +#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255 + +#255#0#0#0#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255 + +#0#0#0#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255 + +#0#255#255#0#255#255#0#255#255#0#0#0#0#0#0#0#0#0#0#255#255#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#255#255#0#0#0#0#0#0#0#0#0#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0 + +#0#0#0#0#255#255#255#255#255#255#255#0#0#255#0#0#255#0#0#255#255#255#255#255 + +#255#255#255#255#255#0#0#255#0#0#255#0#0#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0 + +#255#255#255#0#0#0#0#0#0#255#255#255#255#0#0#255#255#255#255#255#255#255#255 + +#255#255#0#0#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255#0#0 + +#255#255#255#255#255#255#255#255#255#255#0#0#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#0#0#255#255#255#0#0#0#0#0#0#255#255#255#255#0#0#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0#255#255#255#0#0#0#0 + +#0#0#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#0#0#255#0#0#255#0#0#255#0#0#255#0#0#255#255#255#255#255#255#255 + +#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0#255 + +#255#255#0#0#0#0#0#0#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255 + +#255#0#0#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255#0#0#255 + +#255#255#255#255#255#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#0#0#255#255#255#0#0#0#0#0#0#255#255#255#255#255#255#255#0#0 + +#255#0#0#255#0#0#255#255#255#255#255#255#255#255#255#255#0#0#255#0#0#255#0#0 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#0#0#255#255#255#0#0#0#0#0#0#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + ,#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0 + +#255#255#255#0#0#0#0#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#0#0#255#0#0#255#0#0#255#255#255#255#255#255 + +#255#0#0#255#0#0#255#0#0#255#255#255#0#0#0#0#0#0#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0 +]); +LazarusResources.Add('TOVCTCCOLHEAD','BMP',[ + 'BM'#246#6#0#0#0#0#0#0'6'#0#0#0'('#0#0#0#24#0#0#0#24#0#0#0#1#0#24#0#0#0#0#0 + +#192#6#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#0#0#0#0#0#0#0#0#0#255#255#0#255#255#0#255#255#0#0#0#0#0#0#0 + +#0#0#0#255#255#0#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#0#0#0#0#255#255#0 + +#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255 + +#255#0#0#0#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#0 + +#0#0#255#255#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#0#0#0 + +#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#0#0#0#255#255 + +#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#0#0#0#255#255#0 + +#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#0#0#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#0#0#0#255#255#0#255#255 + +#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0 + +#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#0#0#0#255 + +#255#0#255#255#0#255#255#0#0#0#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255 + +#0#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#0#255#255#0#255#255#0#0#0#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255 + +#255#0#0#0#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#255#255#0#0#0#0 + +#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255 + +#255#0#255#255#0#0#0#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#0#0#0 + +#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255 + +#255#0#0#0#0#255#255#0#255#255#0#255#255#0#255#255#0#0#0#0#0#0#0#0#0#0#255 + +#255#0#255#255#0#255#255#0#0#0#0#0#0#0#0#0#0#255#255#0#255#255#0#0#0#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#0#0#0#255#255 + +#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#0#0#0#0#0#0#255#255#255#255#255#255#255#0#0#255#0#0#255#0#0#255#255#255 + +#255#255#255#255#255#255#255#0#0#255#0#0#255#0#0#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#0#0#255#255#255#0#0#0#0#0#0#255#255#255#255#0#0#255#255#255#255#255#255 + +#255#255#255#255#0#0#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255 + +#255#0#0#255#255#255#255#255#255#255#255#255#255#0#0#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#0#0#255#255#255#0#0#0#0#0#0#255#255#255#255#0#0 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0#255#255#255 + +#0#0#0#0#0#0#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#0#0#255#0#0#255#0#0#255#0#0#255#0#0#255#255#255#255#255 + +#255#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#0#0#255#255#255#0#0#0#0#0#0#255#255#255#255#0#0#255#255#255#255#255#255#255 + +#255#255#255#0#0#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255 + +#0#0#255#255#255#255#255#255#255#255#255#255#0#0#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#0#0#255#255#255#0#0#0#0#0#0#255#255#255#255#255#255 + +#255#0#0#255#0#0#255#0#0#255#255#255#255#255#255#255#255#255#255#0#0#255#0#0 + +#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#0#0#255#255#255#0#0#0#0#0#0#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + ,#255#255#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#0#0#255#255#255#0#0#0#0#0#0#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#0#0#255#0#0#255#0#0#255#255#255#255 + +#255#255#255#0#0#255#0#0#255#0#0#255#255#255#0#0#0#0#0#0#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0 +]); +LazarusResources.Add('TOVCTCROWHEAD','BMP',[ + 'BM'#246#6#0#0#0#0#0#0'6'#0#0#0'('#0#0#0#24#0#0#0#24#0#0#0#1#0#24#0#0#0#0#0 + +#192#6#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#0#0#0 + +#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#0#0#0#0#0#0#0#0#0 + +#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#0#0 + +#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#0 + +#0#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0 + +#0#0#0#0#0#0#255#255#0#0#0#0#0#0#0#255#255#0#0#0#0#255#255#0#255#255#0#0#0#0 + +#255#255#0#255#255#0#0#0#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#0#0 + +#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#0#0#0#0#0#0#255#255#0#0#0#0 + +#0#0#0#255#255#0#0#0#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#0#0#0#0 + +#0#0#0#0#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0 + +#0#0#0#255#255#0#0#0#0#255#255#0#0#0#0#255#255#0#0#0#0#255#255#0#0#0#0#255 + +#255#0#255#255#0#0#0#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#0#0#0 + +#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#0#0 + +#0#255#255#0#0#0#0#255#255#0#0#0#0#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255 + +#0#255#255#0#0#0#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#0#0#0#255 + +#255#0#255#255#0#255#255#0#0#0#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255 + +#0#0#0#0#255#255#0#0#0#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#0#0#0 + +#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255 + +#255#0#0#0#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#0 + +#0#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#0#0#0#0#0#0#0#0#0#255#255 + +#0#255#255#0#255#255#0#255#255#0#0#0#0#0#0#0#0#0#0#255#255#0#255#255#0#0#0#0 + +#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#0#0#0#255#255#0#255#255#0#0#0 + +#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#0#0#0#0#0#0#255#255#255#255#255#255#255#0#0#255#0#0#255#0#0#255 + +#255#255#255#255#255#255#255#255#255#0#0#255#0#0#255#0#0#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#0#0#255#255#255#0#0#0#0#0#0#255#255#255#255#0#0#255#255#255#255 + +#255#255#255#255#255#255#0#0#255#255#255#255#0#0#255#255#255#255#255#255#255 + +#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255#0#0#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#0#0#255#255#255#0#0#0#0#0#0#255#255#255 + +#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0#255 + +#255#255#0#0#0#0#0#0#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#0#0#255#0#0#255#0#0#255#0#0#255#0#0#255#255#255 + +#255#255#255#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#0#0#255#255#255#0#0#0#0#0#0#255#255#255#255#0#0#255#255#255#255#255 + +#255#255#255#255#255#0#0#255#255#255#255#0#0#255#255#255#255#255#255#255#255 + +#255#255#0#0#255#255#255#255#255#255#255#255#255#255#0#0#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#0#0#255#255#255#0#0#0#0#0#0#255#255#255#255 + +#255#255#255#0#0#255#0#0#255#0#0#255#255#255#255#255#255#255#255#255#255#0#0 + +#255#0#0#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#0#0#255#255#255#0#0#0#0#0#0 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255 + ,#255#255#255#0#0#255#255#255#0#0#0#0#0#0#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#0#0#255#0#0#255#0#0#255#255 + +#255#255#255#255#255#0#0#255#0#0#255#0#0#255#255#255#0#0#0#0#0#0#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0 +]); +LazarusResources.Add('TOVCTCCOMBOBOX','BMP',[ + 'BM'#246#6#0#0#0#0#0#0'6'#0#0#0'('#0#0#0#24#0#0#0#24#0#0#0#1#0#24#0#0#0#0#0 + +#192#6#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#0#0#192#192#192#192#192#192#192#192#192#192#192#192#192#192 + +#192#192#192#192#192#192#192#0#0#0#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#0#0#192#192#192#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#192#192#192#0#0#0#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#0#0#192#192#192#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#192#192#192#0#0#0#0#255#255#0#255#255#0#255#255 + +#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#0#0#192#192#192#192#192#192 + +#192#192#192#0#0#0#192#192#192#192#192#192#192#192#192#0#0#0#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#0#0#192#192#192 + +#192#192#192#0#0#0#0#0#0#0#0#0#192#192#192#192#192#192#0#0#0#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#0#0#192#192#192 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#192#192#192#0#0#0#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#0#0#192#192#192#192#192 + +#192#128#128#128#0#0#0#128#128#128#192#192#192#192#192#192#0#0#0#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#0#0#192 + +#192#192#192#192#192#128#128#128#0#0#0#128#128#128#192#192#192#192#192#192#0 + +#0#0#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#0#0#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192 + +#192#192#192#192#192#0#0#0#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255 + +#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0#0#0#0#0 + +#255#255#255#255#255#255#255#0#0#255#0#0#255#0#0#255#255#255#255#255#255#255 + +#255#255#255#0#0#255#0#0#255#0#0#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0#255#255 + +#255#0#0#0#0#0#0#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255 + +#0#0#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255#0#0#255#255 + +#255#255#255#255#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#0#0#255#255#255#0#0#0#0#0#0#255#255#255#255#0#0#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#0#0#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#0#0#255#255#255#0#0#0#0#0#0#255 + +#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#0#0#255#0#0#255#0#0#255#0#0#255#0#0#255#255#255#255#255#255#255#255#255 + +#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0#255#255#255 + +#0#0#0#0#0#0#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255#0#0 + +#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255#0#0#255#255#255 + +#255#255#255#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#0#0#255#255#255#0#0#0#0#0#0#255#255#255#255#255#255#255#0#0#255#0#0 + +#255#0#0#255#255#255#255#255#255#255#255#255#255#0#0#255#0#0#255#0#0#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#0#0#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#0#0#255#255#255#0#0#0#0#0#0#255#255#255#255#255#255 + ,#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0#255#255 + +#255#0#0#0#0#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#0#0#255#0#0#255#0#0#255#255#255#255#255#255#255#0#0 + +#255#0#0#255#0#0#255#255#255#0#0#0#0#0#0#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +]); +LazarusResources.Add('TOVCTCSIMPLEFIELD','BMP',[ + 'BM'#246#6#0#0#0#0#0#0'6'#0#0#0'('#0#0#0#24#0#0#0#24#0#0#0#1#0#24#0#0#0#0#0 + +#192#6#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#0#0#0#0#0#0#0#0#0#255#255#0#255#255#0#0#0#0#0#0#0 + +#0#0#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#0#0#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#0#0#0#255#255 + +#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#0#0#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#0#0#0#255#255#0#255 + +#255#0#0#0#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#0#0#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255 + +#0#0#0#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#0#0#0#0#0#0#0#0#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#0#0#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#0#0#0#255#255 + +#0#0#0#0#255#255#0#0#0#0#255#255#0#0#0#0#255#255#0#255#255#0#0#0#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#0#0#0#0#0#0#255#255#0#0#0#0#0 + +#0#0#255#255#0#0#0#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#0#0#0#255#255#0#255#255#0#0#0#0#0#0#0#255#255#0#0#0#0#0#0#0#255#255#0#0#0#0 + +#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#0#0#0#0#0#0#0#0#0#255#255#0#0#0#0#0#0#0#0#0#0#255#255#0#0#0#0#255 + +#255#0#255#255#0#255#255#0#0#0#0#255#255#0#0#0#0#0#0#0#0#0#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#0#0#0#0#0#0#255#255#255#255#255#255#255#0#0#255#0#0#255#0#0#255#255 + +#255#255#255#255#255#255#255#255#0#0#255#0#0#255#0#0#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#0#0#255#255#255#0#0#0#0#0#0#255#255#255#255#0#0#255#255#255#255#255 + +#255#255#255#255#255#0#0#255#255#255#255#0#0#255#255#255#255#255#255#255#255 + +#255#255#0#0#255#255#255#255#255#255#255#255#255#255#0#0#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#0#0#255#255#255#0#0#0#0#0#0#255#255#255#255 + +#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0#255#255 + +#255#0#0#0#0#0#0#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#0#0#255#0#0#255#0#0#255#0#0#255#0#0#255#255#255#255 + +#255#255#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#0#0#255#255#255#0#0#0#0#0#0#255#255#255#255#0#0#255#255#255#255#255#255 + +#255#255#255#255#0#0#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255 + +#255#0#0#255#255#255#255#255#255#255#255#255#255#0#0#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#0#0#255#255#255#0#0#0#0#0#0#255#255#255#255#255 + +#255#255#0#0#255#0#0#255#0#0#255#255#255#255#255#255#255#255#255#255#0#0#255 + +#0#0#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#0#0#255#255#255#0#0#0#0#0#0#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + ,#255#255#255#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#0#0#255#255#255#0#0#0#0#0#0#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#0#0#255#0#0#255#0#0#255#255#255 + +#255#255#255#255#0#0#255#0#0#255#0#0#255#255#255#0#0#0#0#0#0#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0 +]); +LazarusResources.Add('TOVCTCCHECKBOX','BMP',[ + 'BM'#246#6#0#0#0#0#0#0'6'#0#0#0'('#0#0#0#24#0#0#0#24#0#0#0#1#0#24#0#0#0#0#0 + +#192#6#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255 + +#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#0#0#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#0#0#0#0#255#255#0#255#255#0#255#255 + +#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#0#0#255#255#255#0#0#0#0#0#0 + +#255#255#255#0#0#0#0#0#0#255#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#0#0#255#255#255#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#255#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#0#0#255#255#255#255#255#255#0#0#0#192 + +#192#192#0#0#0#255#255#255#255#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#0#0#255#255#255#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#255#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#0#0#255#255#255#0#0#0#0#0#0#255#255#255 + +#0#0#0#0#0#0#255#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#0#0#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#0#0#0#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255 + +#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#0#0#0#0#0#0#255#255#255#255#255#255#255#0#0#255#0#0 + +#255#0#0#255#255#255#255#255#255#255#255#255#255#0#0#255#0#0#255#0#0#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#0#0#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#0#0#255#255#255#0#0#0#0#0#0#255#255#255#255#0#0#255 + +#255#255#255#255#255#255#255#255#255#0#0#255#255#255#255#0#0#255#255#255#255 + +#255#255#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255#0#0#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#0#0#255#255#255#0#0#0#0#0#0 + +#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#0#0#255#255#255#0#0#0#0#0#0#255#255#255#255#0#0#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#0#0#255#0#0#255#0#0#255#0#0#255#0#0 + +#255#255#255#255#255#255#255#255#255#255#0#0#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#0#0#255#255#255#0#0#0#0#0#0#255#255#255#255#0#0#255#255 + +#255#255#255#255#255#255#255#255#0#0#255#255#255#255#0#0#255#255#255#255#255 + +#255#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255#0#0#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#0#0#255#255#255#0#0#0#0#0#0#255 + +#255#255#255#255#255#255#0#0#255#0#0#255#0#0#255#255#255#255#255#255#255#255 + +#255#255#0#0#255#0#0#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0#255#255#255 + +#0#0#0#0#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + ,#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#0#0#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#0#0#255#255#255#0#0#0#0#0#0#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0#255#0#0#255 + +#0#0#255#255#255#255#255#255#255#0#0#255#0#0#255#0#0#255#255#255#0#0#0#0#0#0 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +]); +LazarusResources.Add('TOVCTABLE','BMP',[ + 'BM'#246#6#0#0#0#0#0#0'6'#0#0#0'('#0#0#0#24#0#0#0#24#0#0#0#1#0#24#0#0#0#0#0 + +#192#6#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#0#128#0#128#128#0#128#128#0#128#128#0#128#128#0#0 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#0#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#0#128 + +#0#128#128#0#128#128#0#128#128#0#0#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#0#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#0 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#0#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#0#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#0#128#0#128#128#0#128#128#0#128#128#0#128#128 + +#0#128#128#0#128#128#0#0#128#0#128#128#0#128#128#0#128#128#0#128#128#0#0#128 + +#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#0#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#0#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#0#128#0#128#128#0#128#128#0#128#128#0#0#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#128#128#0#0#128#0#0#128#0#128#128#0#0#128#0#0 + +#128#0#128#128#0#128#128#0#0#0#0#128#128#0#128#128#0#128#128#0#128#128#128 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#128#128 + +#128#0#128#128#0#128#128#0#0#0#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#0#0#0#128#128#0#128#128#0#128#128#0#128 + +#128#128#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128 + +#128#128#128#0#128#128#0#128#128#0#0#0#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#0#0#128#128#128#128#128#128 + +#128#128#128#128#128#128#0#0#255#0#0#255#0#0#255#0#0#255#0#0#255#0#0#255#0#0 + +#255#0#0#255#128#128#128#128#128#128#0#0#0#0#128#128#0#0#128#0#0#128#0#128 + +#128#0#0#128#0#0#128#0#128#128#0#128#128#0#0#0#0#128#128#0#128#128#0#128#128 + +#0#128#128#0#0#255#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#0#255#0#128#128#0#128#128#0#0#0#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#0#0#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#0#255#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#0#255#0#128#128#0#128#128#0#0#0#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#0#0#128#128#128#128#128 + +#128#128#128#128#128#128#128#0#0#255#0#0#255#0#0#255#0#0#255#0#0#255#0#0#255 + +#0#0#255#0#0#255#128#128#128#128#128#128#0#0#0#0#128#128#0#0#128#0#0#128#0 + +#128#128#0#0#128#0#0#128#0#128#128#0#128#128#0#0#0#0#128#128#0#128#128#0#128 + +#128#0#128#128#128#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128 + +#0#128#128#128#128#128#0#128#128#0#128#128#0#0#0#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#0#0#0#128#128#0#128 + +#128#0#128#128#0#128#128#128#128#128#0#128#128#0#128#128#0#128#128#0#128#128 + +#0#128#128#0#128#128#128#128#128#0#128#128#0#128#128#0#0#0#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#0#0#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#0#0#0#0#128#128#0#0#128#0#0#128#0#128#128#0#0#128#0#0#128#0#128 + +#128#0#128#128#0#0#0#255#0#0#255#0#0#255#0#0#255#0#0#128#128#128#255#0#0#255 + +#0#0#255#0#0#255#0#0#255#0#0#255#0#0#128#128#128#255#0#0#255#0#0#0#0#0#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#0#0#255#0#0#255#0#0#255#0#0#255#0#0#128#128#128#255#0#0#255#0#0#255#0#0#255 + ,#0#0#255#0#0#255#0#0#128#128#128#255#0#0#255#0#0#0#0#0#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#128#128#0#0#128#0#0#128#0#128#128#0#0#128#0#0#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128 +]); +LazarusResources.Add('TOVCURL','BMP',[ + 'BM'#246#6#0#0#0#0#0#0'6'#0#0#0'('#0#0#0#24#0#0#0#24#0#0#0#1#0#24#0#0#0#0#0 + +#192#6#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#0#0#0#0#0#0#0#0#0#0#0#0#128#128#128#0#0#0#0#0#0#0#0#0#0#0#0#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#0#0#0#192#192#192#255#255#255#192#192#192#255#255#255#0#0#0#255#255 + +#255#192#192#192#255#255#255#192#192#192#0#0#0#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#0#0#0#192#192#192#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#192#192#192#0#0#0#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#0#0#0#255#255#255#0#0#0#128#128#128#0#0 + +#0#192#192#192#192#192#192#192#192#192#0#0#0#128#128#128#0#0#0#255#255#255#0 + +#0#0#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#0#0#0#192#192 + +#192#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#192#192#192#0#0#0 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#0#0#0#128#0#0#0#0#0#192#192#192 + +#255#255#255#192#192#192#255#255#255#0#0#0#255#255#255#192#192#192#255#255 + +#255#192#192#192#0#0#0#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#0#0#0 + +#255#0#0#255#0#0#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#128#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#0#0#255#0#0 + +#255#0#0#255#0#0#0#128#0#0#128#0#0#128#0#0#128#0#255#0#0#128#0#0#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#255#0#0#255#0#0#255#0#0#255#0#0#0#128#0#0#128#0#0#128#0#0#128#0#128#128 + +#0#255#0#0#0#0#0#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#255#0#0#255#0#0#0#128#0#0#128#0#0#128#0#0#128#0#0#128#0 + +#0#128#0#255#0#0#255#0#0#0#0#0#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#255#0#0#0#128#0#0#128#0#0#128#0#0#128#0 + +#0#128#0#128#0#0#128#128#0#128#0#0#0#128#0#0#0#0#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#255#0#0#192#192#192#0 + +#128#0#0#128#0#128#0#0#0#128#0#0#128#0#255#0#0#0#128#0#0#128#0#0#0#0#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#255#0#0#255#255#255#192#192#192#255#0#0#255#0#0#255#0#0#255#0#0#0 + +#128#0#0#128#0#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#255#255#255#192#192#192#255#255 + ,#255#0#128#0#0#128#0#0#128#0#0#128#0#0#128#0#0#0#0#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#0#192#192#192#0#128#0#0#128#0#0#128#0#0 + +#0#0#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128 +]); +LazarusResources.Add('TOVCSIMPLEFIELD','BMP',[ + 'BM'#246#6#0#0#0#0#0#0'6'#0#0#0'('#0#0#0#24#0#0#0#24#0#0#0#1#0#24#0#0#0#0#0 + +#192#6#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#128#128#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#0#0#255#255#255#255#255#255#255#255#255#255 + +#255#255#0#0#0#255#255#255#255#255#255#255#255#255#255#255#255#0#0#0#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#0#0#0#0#0#0#0#0#0#0#0#255 + +#255#255#255#255#255#255#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#128#128#0#128#128 + +#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#0#0#255#255#255#0#0#0#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#0#0#255#255#255#0#0#0#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#0#0#255#255#255#0#0#0#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#0#0#255#255#255#0#0#0#0#128#128#0#128#128#0 + +#128#128#255#0#0#255#0#0#255#0#0#255#0#0#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#0#0#255#255#255#0#0#0#0#128#128#0#128#128#255 + +#0#0#255#0#0#0#128#128#0#128#128#255#0#0#255#0#0#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#0#0#255#255#255#0#0#0#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#255#0#0#255#0#0#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#0#0#255#255#255#0#0#0#0#128#128#0#128 + +#128#0#128#128#255#0#0#255#0#0#255#0#0#255#0#0#0#128#128#0#128#128#0#128#128 + +#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#0#0#255#255#255#0#0#0#0#128#128#0#128 + +#128#255#0#0#255#0#0#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#0#0#255#255#255#0#0#0#0#128#128#0 + +#128#128#255#0#0#255#0#0#0#128#128#0#128#128#255#0#0#255#0#0#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#0#0#255#255#255#0#0#0#0#128#128#0 + +#128#128#0#128#128#255#0#0#255#0#0#255#0#0#255#0#0#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#0#0#255#255#255#0#0#0#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#0#0#255#255#255#0#0#0#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#255#255#255#255#255 + +#255#0#0#0#0#0#0#0#0#0#0#0#0#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#0#0#255#255#255#255#255#255#255#255#255#255#255#255#0#0#0#255#255 + +#255#255#255#255#255#255#255#255#255#255#0#0#0#0#128#128#0#128#128#0#128#128 + +#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#128#128#0#0#0#0#0#0 + ,#0#0#0#0#0#0#0#0#0#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128 +]); +LazarusResources.Add('TO32FLEXEDIT','BMP',[ + 'BM'#246#6#0#0#0#0#0#0'6'#0#0#0'('#0#0#0#24#0#0#0#24#0#0#0#1#0#24#0#0#0#0#0 + +#192#6#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#128#128 + +#128#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#128#128#128 + +#128#128#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192 + +#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192 + +#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192 + +#192#192#192#192#192#192#192#192#0#0#0#0#128#128#128#128#128#192#192#192#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#0#0#0#0#128 + +#128#128#128#128#192#192#192#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#255#255#255#192#192#192#192#192#192#192#192#192#192#192#192#192#192 + +#192#192#192#192#0#0#0#0#128#128#128#128#128#192#192#192#0#255#255#0#255#255 + +#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#255#255#255#192#192#192#192#192#192#192 + +#192#192#192#192#192#192#192#192#192#192#192#0#0#0#0#128#128#128#128#128#192 + +#192#192#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#255#255#0#255#255#255#255#255#192#192#192#192#192 + +#192#192#192#192#192#192#192#192#192#192#192#192#192#0#0#0#0#128#128#128#128 + +#128#192#192#192#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#255#255#255 + +#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#0#0 + +#0#0#128#128#128#128#128#192#192#192#0#255#255#0#255#255#0#0#0#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#255#255#255#192#192#192#192#192#192#192#192#192#192#192#192#192#192 + +#192#192#192#192#0#0#0#0#128#128#128#128#128#192#192#192#0#255#255#0#255#255 + +#0#0#0#0#0#0#0#0#0#0#255#255#0#255#255#0#0#0#0#0#0#0#0#0#0#255#255#0#255#255 + +#0#255#255#255#255#255#192#192#192#0#0#0#192#192#192#0#0#0#192#192#192#0#0#0 + +#0#0#0#0#128#128#128#128#128#192#192#192#0#255#255#0#255#255#0#0#0#0#255#255 + +#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#255#255 + +#0#255#255#255#255#255#192#192#192#192#192#192#192#192#192#192#192#192#192 + +#192#192#192#192#192#0#0#0#0#128#128#128#128#128#192#192#192#0#255#255#0#255 + +#255#0#0#0#0#255#255#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255 + +#0#255#255#0#255#255#0#255#255#255#255#255#192#192#192#192#192#192#192#192 + +#192#192#192#192#192#192#192#192#192#192#0#0#0#0#128#128#128#128#128#192#192 + +#192#0#255#255#0#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#255#255#0#255#255#255#255#255#192#192#192#192#192#192#192#192#192 + +#192#192#192#192#192#192#192#192#192#0#0#0#0#128#128#128#128#128#192#192#192 + +#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#255#255#255#192#192 + +#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#0#0#0#0#128 + +#128#128#128#128#192#192#192#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#0#0#0#0#128#128#128#128#128#192#192#192#192#192#192#192#192 + +#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192 + +#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192 + +#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#0#0#0#0 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#0#128#128#0#128#128 + +#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + ,#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128 +]); +LazarusResources.Add('TO32TCFLEXEDIT','BMP',[ + 'BM'#246#6#0#0#0#0#0#0'6'#0#0#0'('#0#0#0#24#0#0#0#24#0#0#0#1#0#24#0#0#0#0#0 + +#192#6#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#0#0#0#128#128#0#128#128#0#128#128#0#128#128#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#128#128#0#0#0#0#0#0#0#0#0#0#0#0#0#128#128#0#128#128#0#0#0#0#128#128#0#128 + +#128#0#128#128#0#0#0#0#128#128#0#128#128#0#128#128#0#0#0#0#128#128#0#128#128 + +#0#128#128#0#128#128#0#0#0#0#128#128#0#128#128#0#128#128#0#128#128#0#0#0#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#0#0#0#128#128#0 + +#0#0#0#128#128#0#128#128#0#128#128#0#128#128#0#0#0#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#0#0#0#128#128#0#128#128#0#128#128#0#128#128#0#0#0#0#128#128 + +#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#0#0#0#128#128#0#0#0#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#0#0#0#0#0#0#0#0#0#128#128#0#128#128 + +#0#0#0#0#128#128#0#128#128#0#128#128#0#128#128#0#0#0#0#0#0#0#0#0#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#0#0#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#0#0#0#128#128#0#128#128#0#128#128#0#128#128#0#0#0#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#0#0#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#0#0#0#128#128#0#0#0#0#128#128#0#128#128#0#128#128 + +#0#128#128#0#0#0#0#128#128#0#128#128#0#128#128#0#128#128#0#0#0#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#0#0#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#0#0#0#128#128#0#0#0#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#0#0#0#0#0#0#0#0#0#0#0#0#128#128#0#0#0#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#0#0#0#0#0#0#0#0#0#0#0#0#128#128#0#128#128#0#0#0#0#128#128#0#128 + +#128#0#128#128#0#0#0#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#128#128#128#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#0#0#0#128#128#128#192#192#192#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#128#128#128#0#0#0#128#128#128#192#192#192 + +#0#255#255#0#255#255#128#0#0#128#0#0#128#0#0#0#255#255#0#255#255#0#255#255 + +#128#0#0#128#0#0#128#0#0#0#255#255#0#255#255#0#255#255#128#0#0#0#255#255#0 + +#255#255#0#255#255#128#0#0#0#255#255#128#128#128#0#0#0#128#128#128#192#192 + +#192#0#255#255#128#0#0#0#255#255#0#255#255#0#255#255#128#0#0#0#255#255#128#0 + +#0#0#255#255#0#255#255#0#255#255#128#0#0#0#255#255#0#255#255#128#0#0#0#255 + +#255#0#255#255#0#255#255#128#0#0#0#255#255#128#128#128#0#0#0#128#128#128#192 + +#192#192#0#255#255#128#0#0#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255 + +#128#0#0#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#128#0#0 + +#0#255#255#0#255#255#0#255#255#128#0#0#0#255#255#128#128#128#0#0#0#128#128 + +#128#192#192#192#0#255#255#128#0#0#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#128#0#0#128#0#0#128#0#0#128#0#0#128#0#0#0#255#255#0#255#255#128#0#0 + +#0#255#255#0#255#255#0#255#255#128#0#0#0#255#255#128#128#128#0#0#0#128#128 + +#128#192#192#192#0#255#255#128#0#0#0#255#255#0#255#255#0#255#255#128#0#0#0 + +#255#255#128#0#0#0#255#255#0#255#255#0#255#255#128#0#0#0#255#255#0#255#255 + +#128#0#0#0#255#255#0#255#255#0#255#255#128#0#0#0#255#255#128#128#128#0#0#0 + +#128#128#128#192#192#192#0#255#255#0#255#255#128#0#0#128#0#0#128#0#0#0#255 + +#255#0#255#255#0#255#255#128#0#0#128#0#0#128#0#0#0#255#255#0#255#255#0#255 + +#255#128#0#0#0#255#255#0#255#255#0#255#255#128#0#0#0#255#255#128#128#128#0#0 + +#0#128#128#128#192#192#192#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255 + +#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#128#0#0#0#255#255#0#255#255#0#255#255#128#0#0#0#255#255#128 + +#128#128#0#0#0#128#128#128#192#192#192#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#128#0#0#128#0#0#128#0#0#0#255#255#128#0#0#128#0#0#128#0#0#0#255#255 + ,#128#128#128#0#0#0#128#128#128#192#192#192#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#128#128#128#0#0#0#128#128#128#192#192#192#192#192#192#192 + +#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192 + +#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192 + +#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#128 + +#128#128#0#0#0#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 +]); +LazarusResources.Add('TOVCTCMEMO','BMP',[ + 'BM'#246#6#0#0#0#0#0#0'6'#0#0#0'('#0#0#0#24#0#0#0#24#0#0#0#1#0#24#0#0#0#0#0 + +#192#6#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#0#0#0 + +#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#255 + +#255#0#0#0#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#0#0#0#0 + +#0#0#0#0#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0 + +#0#0#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255 + +#0#255#255#0#255#255#0#0#0#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#0 + +#0#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0 + +#0#0#0#255#255#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255 + +#255#0#0#0#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0 + +#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#0#0#0#255#255 + +#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#0#0#0 + +#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#0#0 + +#0#255#255#0#0#0#0#255#255#0#0#0#0#255#255#0#0#0#0#0#0#0#0#0#0#255#255#0#255 + +#255#0#0#0#0#255#255#0#0#0#0#255#255#0#0#0#0#255#255#0#0#0#0#255#255#0#255 + +#255#0#255#255#0#0#0#0#255#255#0#255#255#0#0#0#0#0#0#0#255#255#0#0#0#0#0#0#0 + +#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#255#255#0#0#0#0#0#0#0#255#255 + +#0#0#0#0#0#0#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0 + +#255#255#0#0#0#0#0#0#0#255#255#0#0#0#0#0#0#0#255#255#0#0#0#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#0#0#0#0#0#0#255#255#0#0#0#0#0#0#0#255#255#0#0#0#0 + +#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#0#0#0#255#255#0#255 + +#255#0#255#255#0#0#0#0#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#0#0#0#0#255 + +#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#0#0#0#0#0#0#0#0#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#0#0#0#0#0#0#255#255#255#255#255#255#255#0#0#255#0#0#255#0#0 + +#255#255#255#255#255#255#255#255#255#255#0#0#255#0#0#255#0#0#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#0#0#255#255#255#0#0#0#0#0#0#255#255#255#255#0#0#255#255#255 + +#255#255#255#255#255#255#255#0#0#255#255#255#255#0#0#255#255#255#255#255#255 + +#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255#0#0#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#0#0#255#255#255#0#0#0#0#0#0#255#255 + +#255#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0 + +#255#255#255#0#0#0#0#0#0#255#255#255#255#0#0#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#0#0#255#0#0#255#0#0#255#0#0#255#0#0#255#255 + +#255#255#255#255#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#0#0#255#255#255#0#0#0#0#0#0#255#255#255#255#0#0#255#255#255#255 + +#255#255#255#255#255#255#0#0#255#255#255#255#0#0#255#255#255#255#255#255#255 + +#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255#0#0#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#0#0#255#255#255#0#0#0#0#0#0#255#255#255 + +#255#255#255#255#0#0#255#0#0#255#0#0#255#255#255#255#255#255#255#255#255#255 + +#0#0#255#0#0#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0#255#255#255#0#0#0#0 + +#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255 + ,#255#255#255#255#0#0#255#255#255#0#0#0#0#0#0#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0#255#0#0#255#0#0#255 + +#255#255#255#255#255#255#0#0#255#0#0#255#0#0#255#255#255#0#0#0#0#0#0#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0 +]); +LazarusResources.Add('TOVCTCBITMAP','BMP',[ + 'BM'#246#6#0#0#0#0#0#0'6'#0#0#0'('#0#0#0#24#0#0#0#24#0#0#0#1#0#24#0#0#0#0#0 + +#192#6#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#0#0#0#0#0#0#0#0#0 + +#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255 + +#255#0#0#0#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#0#0 + +#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#0 + +#0#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#0#0#0#255 + +#255#0#0#0#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#0#0#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#0#0#0#255#255 + +#0#0#0#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#0#0#0#0#0#0 + +#0#0#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#0#0#0#0#0#0#0#0#0#255#255#0#255#255#0#0#0#0#255#255#0#0 + +#0#0#255#255#0#0#0#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#0#0#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#0#0#0#255#255#0#255#255#0#0#0#0#255#255#0#0#0#0#0#0#0#255#255#0#0#0#0#0#0#0 + +#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255 + +#255#0#0#0#0#255#255#0#0#0#0#0#0#0#255#255#0#0#0#0#0#0#0#255#255#0#255#255#0 + +#0#0#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#0#0#0#0#0#0#0#0#0#255#255#0#255#255#0#0 + +#0#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#0#0#0#0#0#0#0#0 + +#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#0#0#0#0#0#0#255#255#255#255#255#255#255#0#0#255#0#0 + +#255#0#0#255#255#255#255#255#255#255#255#255#255#0#0#255#0#0#255#0#0#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#0#0#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#0#0#255#255#255#0#0#0#0#0#0#255#255#255#255#0#0#255 + +#255#255#255#255#255#255#255#255#255#0#0#255#255#255#255#0#0#255#255#255#255 + +#255#255#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255#0#0#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#0#0#255#255#255#0#0#0#0#0#0 + +#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#0#0#255#255#255#0#0#0#0#0#0#255#255#255#255#0#0#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#0#0#255#0#0#255#0#0#255#0#0#255#0#0 + +#255#255#255#255#255#255#255#255#255#255#0#0#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#0#0#255#255#255#0#0#0#0#0#0#255#255#255#255#0#0#255#255 + +#255#255#255#255#255#255#255#255#0#0#255#255#255#255#0#0#255#255#255#255#255 + +#255#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255#0#0#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#0#0#255#255#255#0#0#0#0#0#0#255 + +#255#255#255#255#255#255#0#0#255#0#0#255#0#0#255#255#255#255#255#255#255#255 + +#255#255#0#0#255#0#0#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0#255#255#255 + +#0#0#0#0#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + ,#255#255#255#255#255#255#255#255#255#255#255#0#0#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#0#0#255#255#255#0#0#0#0#0#0#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0#255#0#0#255 + +#0#0#255#255#255#255#255#255#255#0#0#255#0#0#255#0#0#255#255#255#0#0#0#0#0#0 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +]); +LazarusResources.Add('TOVCTCGLYPH','BMP',[ + 'BM'#246#6#0#0#0#0#0#0'6'#0#0#0'('#0#0#0#24#0#0#0#24#0#0#0#1#0#24#0#0#0#0#0 + +#192#6#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#0#0#0#0#255#255 + +#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#255#255#0#0#0#0 + +#255#255#0#255#255#0#0#0#0#0#0#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255 + +#0#0#0#0#255#255#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0 + +#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255 + +#255#0#0#0#0#0#0#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#0#0#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#0#0 + +#0#255#255#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#0#0#0#0 + +#0#0#255#255#0#0#0#0#0#0#0#0#0#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255 + +#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#0#0#0#0#0#0#0#0#0#255#255#0 + +#255#255#0#0#0#0#255#255#0#255#255#0#0#0#0#0#0#0#255#255#0#255#255#0#255#255 + +#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#0 + +#0#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#0#0#0#255#255#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#0#0#0 + +#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#0#0#0#255#255#0#255#255#0#0#0 + +#0#255#255#0#255#255#0#0#0#0#255#255#0#0#0#0#255#255#0#255#255#0#0#0#0#0#0#0 + +#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#0#0#0#255#255#0#255#255#0#255 + +#255#0#0#0#0#255#255#0#0#0#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#0 + +#0#0#255#255#0#0#0#0#255#255#0#255#255#0#0#0#0#255#255#0#0#0#0#0#0#0#0#0#0 + +#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255 + +#255#0#0#0#0#255#255#0#0#0#0#0#0#0#0#0#0#255#255#0#255#255#0#0#0#0#255#255#0 + +#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#0#0#0#0#0#0#255#255#255#255#255#255#255#0#0#255#0#0#255#0#0 + +#255#255#255#255#255#255#255#255#255#255#0#0#255#0#0#255#0#0#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#0#0#255#255#255#0#0#0#0#0#0#255#255#255#255#0#0#255#255#255 + +#255#255#255#255#255#255#255#0#0#255#255#255#255#0#0#255#255#255#255#255#255 + +#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255#0#0#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#0#0#255#255#255#0#0#0#0#0#0#255#255 + +#255#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0 + +#255#255#255#0#0#0#0#0#0#255#255#255#255#0#0#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#0#0#255#0#0#255#0#0#255#0#0#255#0#0#255#255 + +#255#255#255#255#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#0#0#255#255#255#0#0#0#0#0#0#255#255#255#255#0#0#255#255#255#255 + +#255#255#255#255#255#255#0#0#255#255#255#255#0#0#255#255#255#255#255#255#255 + +#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255#0#0#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#0#0#255#255#255#0#0#0#0#0#0#255#255#255 + +#255#255#255#255#0#0#255#0#0#255#0#0#255#255#255#255#255#255#255#255#255#255 + +#0#0#255#0#0#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0#255#255#255#0#0#0#0 + +#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255 + ,#255#255#255#255#0#0#255#255#255#0#0#0#0#0#0#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0#255#0#0#255#0#0#255 + +#255#255#255#255#255#255#0#0#255#0#0#255#0#0#255#255#255#0#0#0#0#0#0#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0 +]); +LazarusResources.Add('TOVCTCICON','BMP',[ + 'BM'#246#6#0#0#0#0#0#0'6'#0#0#0'('#0#0#0#24#0#0#0#24#0#0#0#1#0#24#0#0#0#0#0 + +#192#6#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#0#0#0#0#0#0#0#0#0#255#255#0#255#255#0#0#0#0#0#0#0#0#0#0#255 + +#255#0#255#255#0#255#255#0#0#0#0#0#0#0#0#0#0#255#255#0#255#255#0#0#0#0#255 + +#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#0#0 + +#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#0 + +#0#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#0#0#0#255#255#0#255#255#0 + +#0#0#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255 + +#255#0#0#0#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255 + +#0#255#255#0#255#255#0#0#0#0#255#255#0#0#0#0#255#255#0#0#0#0#0#0#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#0#0#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255 + +#255#0#0#0#0#255#255#0#0#0#0#255#255#0#0#0#0#0#0#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255 + +#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#0#0#0 + +#255#255#0#0#0#0#0#0#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#255#255 + +#0#255#255#0#0#0#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#0#0 + +#0#0#0#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#0 + +#0#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0 + +#0#0#0#255#255#0#255#255#0#255#255#0#0#0#0#255#255#0#0#0#0#255#255#0#255#255 + +#0#0#0#0#255#255#0#255#255#0#255#255#0#255#255#0#0#0#0#0#0#0#0#0#0#255#255#0 + +#255#255#0#0#0#0#0#0#0#0#0#0#255#255#0#255#255#0#255#255#0#0#0#0#0#0#0#0#0#0 + +#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#0#0#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255 + +#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0#0#0#0#0 + +#255#255#255#255#255#255#255#0#0#255#0#0#255#0#0#255#255#255#255#255#255#255 + +#255#255#255#0#0#255#0#0#255#0#0#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0#255#255 + +#255#0#0#0#0#0#0#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255 + +#0#0#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255#0#0#255#255 + +#255#255#255#255#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#0#0#255#255#255#0#0#0#0#0#0#255#255#255#255#0#0#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#0#0#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#0#0#255#255#255#0#0#0#0#0#0#255 + +#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#0#0#255#0#0#255#0#0#255#0#0#255#0#0#255#255#255#255#255#255#255#255#255 + +#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0#255#255#255 + +#0#0#0#0#0#0#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255#0#0 + +#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255#0#0#255#255#255 + +#255#255#255#255#255#255#255#0#0#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#0#0#255#255#255#0#0#0#0#0#0#255#255#255#255#255#255#255#0#0#255#0#0 + +#255#0#0#255#255#255#255#255#255#255#255#255#255#0#0#255#0#0#255#0#0#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#0#0#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#0#0#255#255#255#0#0#0#0#0#0#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + ,#255#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0#255#255 + +#255#0#0#0#0#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#0#0#255#0#0#255#0#0#255#255#255#255#255#255#255#0#0 + +#255#0#0#255#0#0#255#255#255#0#0#0#0#0#0#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 +]); +LazarusResources.Add('TOVCROTATEDLABEL','BMP',[ + 'BM'#246#6#0#0#0#0#0#0'6'#0#0#0'('#0#0#0#24#0#0#0#24#0#0#0#1#0#24#0#0#0#0#0 + +#192#6#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#0#0#0#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#0#0#0#128 + +#128#128#0#0#0#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#0#0#0#128#128#128#128#128#128#128#128#128#0#0#0 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#0#0#0#128#128#128#128#128#128#128#128#128#0#0#0#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#0#0#0#128#128#128#128#128#128#0#0#0#128#128#128#128 + +#128#128#0#0#0#0#0#0#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#0#0#0#128#128 + +#128#128#128#128#128#128#128#0#0#0#0#0#0#128#128#128#128#128#128#128#128#128 + +#0#0#0#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#0#0#0#128#128#128#128#128#128#0#0#0#128 + +#128#128#128#128#128#128#128#128#0#0#0#0#0#0#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#0#0#0#0#0#0#128#128#128#128#128#128#128#128#128#0#0#0#128#128#128 + +#128#128#128#0#0#0#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#0#0#0#128#128#128#128#128#128#128#128#128#128#128#128#0 + +#0#0#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#0#0#0#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#0#0#0#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#0#0#0#0#0#0#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#0#0#0#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#0#0#0#128#128#128#128 + +#128#128#0#0#0#128#128#128#128#128#128#128#128#128#0#0#0#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + ,#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#0#0#0#128#128#128#128#128#128#128#128#128#128#128#128#0#0#0#0#0#0#0 + +#0#0#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 +]); +LazarusResources.Add('TOVCSPINNER','BMP',[ + 'BM'#246#6#0#0#0#0#0#0'6'#0#0#0'('#0#0#0#24#0#0#0#24#0#0#0#1#0#24#0#0#0#0#0 + +#192#6#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#128#128#0#128#128#128#128#128#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#128#128#0#128#128#0#128#128#0#128#128 + +#255#255#255#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192 + +#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192 + +#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192 + +#0#0#0#0#128#128#0#128#128#0#128#128#0#128#128#255#255#255#192#192#192#192 + +#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192 + +#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192 + +#192#192#192#192#192#192#192#192#192#192#192#192#0#0#0#0#128#128#0#128#128#0 + +#128#128#0#128#128#255#255#255#192#192#192#192#192#192#192#192#192#192#192 + +#192#192#192#192#192#192#192#192#192#192#192#192#192#255#255#255#192#192#192 + +#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192 + +#192#192#192#192#192#0#0#0#0#128#128#0#128#128#0#128#128#0#128#128#255#255 + +#255#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192 + +#192#192#192#128#128#128#0#0#0#255#255#255#192#192#192#192#192#192#192#192 + +#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#0#0#0#0#128 + +#128#0#128#128#0#128#128#0#128#128#255#255#255#192#192#192#192#192#192#192 + +#192#192#192#192#192#192#192#192#192#192#192#192#192#192#128#128#128#0#0#0 + +#255#255#255#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192 + +#192#192#192#192#192#192#192#192#0#0#0#0#128#128#0#128#128#0#128#128#0#128 + +#128#255#255#255#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192 + +#192#192#192#128#128#128#0#0#0#0#0#0#0#0#0#255#255#255#192#192#192#192#192 + +#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#0#0#0#0#128 + +#128#0#128#128#0#128#128#0#128#128#255#255#255#192#192#192#192#192#192#192 + +#192#192#192#192#192#192#192#192#192#192#192#128#128#128#0#0#0#0#0#0#0#0#0 + +#255#255#255#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192 + +#192#192#192#192#192#0#0#0#0#128#128#0#128#128#0#128#128#0#128#128#255#255 + +#255#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#128#128#128 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#192#192#192#192#192#192#192#192 + +#192#192#192#192#192#192#192#192#192#192#0#0#0#0#128#128#0#128#128#0#128#128 + +#0#128#128#255#255#255#192#192#192#192#192#192#192#192#192#192#192#192#192 + +#192#192#128#128#128#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#192#192#192 + +#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#0#0#0#0#128#128 + +#0#128#128#0#128#128#0#128#128#255#255#255#192#192#192#192#192#192#192#192 + +#192#192#192#192#128#128#128#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255 + +#255#255#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#0#0#0#0 + +#128#128#0#128#128#0#128#128#0#128#128#255#255#255#192#192#192#192#192#192 + +#192#192#192#192#192#192#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#255#255#255#192#192#192#192#192 + +#192#192#192#192#192#192#192#192#192#192#0#0#0#0#128#128#0#128#128#0#128#128 + +#0#128#128#255#255#255#192#192#192#192#192#192#192#192#192#192#192#192#192 + +#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192 + +#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192 + +#192#192#192#0#0#0#0#128#128#0#128#128#0#128#128#0#128#128#255#255#255#192 + +#192#192#192#192#192#192#192#192#192#192#192#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#0#0#0#0#128#128 + +#0#128#128#0#128#128#0#128#128#255#255#255#192#192#192#192#192#192#192#192 + +#192#192#192#192#128#128#128#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255 + +#255#255#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#0#0#0#0 + +#128#128#0#128#128#0#128#128#0#128#128#255#255#255#192#192#192#192#192#192 + +#192#192#192#192#192#192#192#192#192#128#128#128#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#255#255#255#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192 + +#192#192#192#0#0#0#0#128#128#0#128#128#0#128#128#0#128#128#255#255#255#192 + +#192#192#192#192#192#192#192#192#192#192#192#192#192#192#128#128#128#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#255#255#255#192#192#192#192#192#192#192#192#192#192 + +#192#192#192#192#192#192#192#192#0#0#0#0#128#128#0#128#128#0#128#128#0#128 + +#128#255#255#255#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192 + +#192#192#192#128#128#128#0#0#0#0#0#0#0#0#0#255#255#255#192#192#192#192#192 + +#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#0#0#0#0#128 + +#128#0#128#128#0#128#128#0#128#128#255#255#255#192#192#192#192#192#192#192 + +#192#192#192#192#192#192#192#192#192#192#192#128#128#128#0#0#0#0#0#0#0#0#0 + ,#255#255#255#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192 + +#192#192#192#192#192#0#0#0#0#128#128#0#128#128#0#128#128#0#128#128#255#255 + +#255#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192 + +#192#192#192#128#128#128#0#0#0#255#255#255#192#192#192#192#192#192#192#192 + +#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#0#0#0#0#128 + +#128#0#128#128#0#128#128#0#128#128#255#255#255#192#192#192#192#192#192#192 + +#192#192#192#192#192#192#192#192#192#192#192#192#192#192#128#128#128#0#0#0 + +#255#255#255#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192 + +#192#192#192#192#192#192#192#192#0#0#0#0#128#128#0#128#128#0#128#128#0#128 + +#128#255#255#255#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192 + +#192#192#192#192#192#192#192#192#192#255#255#255#192#192#192#192#192#192#192 + +#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192 + +#192#0#0#0#0#128#128#0#128#128#0#128#128#0#128#128#255#255#255#192#192#192 + +#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192 + +#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192#192 + +#192#192#192#192#192#192#192#192#192#192#192#192#192#0#0#0#0#128#128#0#128 + +#128#0#128#128#0#128#128#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#128#128#128#0#128#128#0#128#128 +]); +LazarusResources.Add('TOVCLABEL','BMP',[ + 'BM'#246#6#0#0#0#0#0#0'6'#0#0#0'('#0#0#0#24#0#0#0#24#0#0#0#1#0#24#0#0#0#0#0 + +#192#6#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#0#0#0#128#128#0#128#128#0#128#128#0#128#128#0#0#0#0#128#128#0#128#128 + +#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#0#0#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#0#0#0#0#0#0#128#128 + +#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#0#0#0#0#0#0#128#128 + +#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#0#0#0#0#0#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#0#0#0#0#0#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128 + +#0#128#128#0#128#128#0#0#0#0#0#0#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#0#0#0 + +#0#0#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#0#0#0#0#0#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#0#0#0#0#0#0#128#128 + +#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#0#0#0#0#0#0#0#0#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#0#0#0#0#0#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#0#0#0#0#0#0#0#0#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128 + +#0#128#128#0#128#128#0#0#0#0#0#0#0#0#0#0#0#0#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#0#0#0#0#0#0#0#0#0#0#0#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#0#0#0#0#0#0#0#0#0#0#0#128#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#0#0#0#0#0#128#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#128#128#128#0#0#0#0#0#0#128#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#128#128#128#0#0#0#0#0#0#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#0#0#0#0#0#0#0#0#0#128#128#0#128#128 + +#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#0#0#0#0#0#128#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#128#128#128#0#0#0#0#0#0#128#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#128#128#128#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#0#0#0#0#0#128#128#128#0#128#128#0#128#128#0#128#128#128#128 + +#128#0#0#0#0#0#0#128#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#128#128#128#0#0#0#0#0#0#0#128#128#0#128#128#0#128#128#0#0 + +#0#0#0#0#0#0#0#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#0#0#0#0#0#128#128#128#0#128#128#128#128#128#0#0#0 + +#0#0#0#128#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#128#128#128#0#0#0#0#0#0#0#128#128#0#0#0#0#0#0#0 + +#0#0#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#128#128#128 + +#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#128#128#128#0#0#0#0#0#0#0#0#0#0#0#0#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + ,#128#128#0#128#128#0#128#128#0#0#0#0#0#0#0#0#0#0#0#0#128#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128 +]); +LazarusResources.Add('TOVCVIRTUALLISTBOX','BMP',[ + 'BM'#246#6#0#0#0#0#0#0'6'#0#0#0'('#0#0#0#24#0#0#0#24#0#0#0#1#0#24#0#0#0#0#0 + +#192#6#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#128#128#0#128#128 + +#0#128#128#0#128#128#0#128#128#0#0#0#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#0#0#0#0#0#0#0#128#128#0#128#128#0#128#128#0#128#128#0#0#0#255 + +#255#255#128#0#0#128#0#0#128#0#0#128#0#0#128#0#0#128#0#0#128#0#0#128#0#0#255 + +#255#255#255#255#255#255#255#255#255#255#255#128#0#0#255#255#255#255#255#255 + +#255#255#255#0#0#0#128#128#128#0#0#0#0#128#128#0#128#128#0#128#128#0#0#0#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#128#0#0#128 + +#0#0#128#0#0#255#255#255#255#255#255#0#0#0#128#128#128#0#0#0#0#128#128#0#128 + +#128#0#128#128#0#0#0#255#255#255#128#0#0#128#0#0#128#0#0#128#0#0#128#0#0#128 + +#0#0#128#0#0#128#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#0#0#0#128#128#128#0#0#0#0#128#128#0 + +#128#128#0#128#128#0#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#0#0#0#128#128#128#0#0#0#0#128 + +#128#0#128#128#0#128#128#0#0#0#255#255#255#128#0#0#128#0#0#128#0#0#128#0#0 + +#128#0#0#128#0#0#128#0#0#128#0#0#255#255#255#255#255#255#255#255#255#128#128 + +#128#255#255#255#128#128#128#255#255#255#255#255#255#0#0#0#128#128#128#0#0#0 + +#0#128#128#0#128#128#0#128#128#0#0#0#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#128#128#128#255#255#255#128#128#128#255#255#255#128#128#128 + +#255#255#255#0#0#0#128#128#128#0#0#0#0#128#128#0#128#128#0#128#128#0#0#0#255 + +#255#255#128#0#0#128#0#0#128#0#0#128#0#0#128#0#0#128#0#0#128#0#0#128#0#0#255 + +#255#255#255#255#255#255#255#255#128#128#128#255#255#255#128#128#128#255#255 + +#255#255#255#255#0#0#0#128#128#128#0#0#0#0#128#128#0#128#128#0#128#128#0#0#0 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#128#128#128#255#255 + +#255#128#128#128#255#255#255#128#128#128#255#255#255#0#0#0#128#128#128#0#0#0 + +#0#128#128#0#128#128#0#128#128#0#0#0#255#255#255#128#0#0#128#0#0#128#0#0#128 + +#0#0#128#0#0#128#0#0#128#0#0#128#0#0#255#255#255#255#255#255#255#255#255#128 + +#128#128#255#255#255#128#128#128#255#255#255#255#255#255#0#0#0#128#128#128#0 + +#0#0#0#128#128#0#128#128#0#128#128#0#0#0#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#128#128#128#255#255#255#128#128#128#255#255#255#128#128 + +#128#255#255#255#0#0#0#128#128#128#0#0#0#0#128#128#0#128#128#0#128#128#0#0#0 + +#255#255#255#128#0#0#128#0#0#128#0#0#128#0#0#128#0#0#128#0#0#128#0#0#128#0#0 + +#255#255#255#255#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#0#0#0#128 + +#128#128#0#0#0#0#128#128#0#128#128#0#128#128#0#0#0#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#0#0#0#128#128#128#0#0#0#0#128#128#0#128#128#0 + +#128#128#0#0#0#255#255#255#128#0#0#128#0#0#128#0#0#128#0#0#128#0#0#128#0#0 + +#128#0#0#128#0#0#255#255#255#255#255#255#255#255#255#128#0#0#128#0#0#128#0#0 + +#255#255#255#255#255#255#0#0#0#128#128#128#0#0#0#0#128#128#0#128#128#0#128 + +#128#0#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#128#0#0#255#255#255#255#255#255#255#255#255#0#0#0#128#128 + +#128#0#0#0#0#128#128#0#128#128#0#128#128#0#0#0#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#0#0#0#128#128#128#0#0#0#0#128#128#0#128#128#0#128 + +#128#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#128#128#128#0#0#0#0#128#128#0#128 + ,#128#0#128#128#0#128#128#0#0#0#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128#128 + +#128#128#128#128#128#0#0#0#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0 + +#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128#128#0#128 + +#128 +]); +LazarusResources.Add('ORREDDOT','BMP',[ + 'BM>'#1#0#0#0#0#0#0'6'#0#0#0'('#0#0#0#7#0#0#0#11#0#0#0#1#0#24#0#0#0#0#0#8#1#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#0#0#0#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0#0#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#0#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#0#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#0#0#0#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#255#255#255#0#0#0#255#255#0#0#0#255#0#0#255#0#0#255#0#0#255#0#0#0#255#255 + +#255#0#0#0#255#255#0#0#0#255#0#0#255#0#0#255#0#0#255#0#0#0#255#255#255#0#0#0 + +#255#255#0#0#0#255#0#0#255#0#0#255#0#0#255#0#0#0#255#255#255#0#0#0#255#255#0 + +#0#0#255#0#0#255#0#0#255#0#0#255#0#0#0#255#255#255#0#0#0#255#255#0#255#255#0 + +#255#255#0#255#255#0#255#255#0#0#0#0#255#255#255#0#0#0 +]); +LazarusResources.Add('ORBLUEDOT','BMP',[ + 'BM>'#1#0#0#0#0#0#0'6'#0#0#0'('#0#0#0#7#0#0#0#11#0#0#0#1#0#24#0#0#0#0#0#8#1#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#0#0#0#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0#0#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#0#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#0#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#0#0#0#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#0#0#0#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0#0#255 + +#255#0#0#0#0#0#0#0#0#0#0#255#255#255#255#255#255#255#255#255#0#0#0#255#255#0 + +#128#128#0#128#128#0#0#0#0#255#255#255#255#255#255#255#255#255#0#0#0#255#255 + +#0#128#128#0#128#128#0#0#0#0#255#255#255#255#255#255#255#255#255#0#0#0#255 + +#255#0#255#255#0#255#255#0#0#0#0#255#255#255#255#255#255#255#255#255#0#0#0 +]); diff --git a/components/orpheus/ovcrlbl.pas b/components/orpheus/ovcrlbl.pas new file mode 100644 index 000000000..f82473d37 --- /dev/null +++ b/components/orpheus/ovcrlbl.pas @@ -0,0 +1,514 @@ +{*********************************************************} +{* OVCRLBL.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovcrlbl; + {-Rotated label component} + +interface + +uses + {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, LclType, MyMisc, {$ENDIF} + Classes, Controls, Graphics, SysUtils, + OvcBase, OvcMisc; + +type + TOvcCustomRotatedLabel = class(TOvcGraphicControl) + {.Z+} + protected {private} + {property instance variables} + FAlignment : TAlignment; + FAutoSize : Boolean; + FCaption : string; + FFontAngle : Integer; + FOriginX : Integer; + FOriginY : Integer; + FShadowColor : TColor; {color for text shadowing} + FShadowedText : Boolean; {true to draw shadowed text} + + {internal variables} + rlBusy : Boolean; + + {property methods} + function GetTransparent : Boolean; + procedure SetAlignment(Value : TAlignment); + procedure SetAutoSize(Value : Boolean); {$IFDEF VERSION6}{$IFNDEF LCL} override;{$ENDIF}{$ENDIF} + procedure SetCaption(const Value : string); + procedure SetOriginX(Value : Integer); + procedure SetOriginY(Value : Integer); + procedure SetShadowColor(const Value : TColor); + procedure SetShadowedText(Value : Boolean); + procedure SetTransparent(Value : Boolean); + procedure SetFontAngle(Value : Integer); + + {internal methods} + procedure lblAdjustSize; + {-adjust horizontal and/or vertical size of control} + procedure lblDrawText(var R : TRect; Flags : Word); + {-draw the label text} + + {VCL message handling methods} + procedure CMFontChanged(var Msg : TMessage); + message CM_FONTCHANGED; + procedure CMTextChanged(var Mes : TMessage); + message CM_TEXTCHANGED; + + protected + procedure Loaded; + override; + procedure Paint; + override; + procedure SetName(const NewName : TComponentName); + override; + {.Z-} + + property Alignment : TAlignment + read FAlignment write SetAlignment; + property AutoSize : Boolean + read FAutoSize write SetAutoSize; + property Caption : string + read FCaption write SetCaption; + property FontAngle : Integer + read FFontAngle write SetFontAngle; + property OriginX : Integer + read FOriginX write SetOriginX; + property OriginY : Integer + read FOriginY write SetOriginY; + property ShadowColor : TColor + read FShadowColor write SetShadowColor; + property ShadowedText : Boolean + read FShadowedText write SetShadowedText; + property Transparent : Boolean + read GetTransparent write SetTransparent; + + public + {.Z+} + constructor Create(AOwner: TComponent); + override; + {.Z-} + + {public properties} + property Canvas; + end; + + TOvcRotatedLabel = class(TOvcCustomRotatedLabel) + published + {$IFDEF VERSION4} + property Anchors; + property Constraints; + property DragKind; + {$ENDIF} + property Align; + property Alignment default taLeftJustify; + property AutoSize; + property Caption; + property Color; + property DragCursor; + property DragMode; + property Enabled; + property Font; + property FontAngle default 0; + property Height default 20; + property OriginX default 0; + property OriginY default 0; + property ParentColor; + {property ParentFont;} + property ParentShowHint; + property PopupMenu; + property ShadowColor default clBtnShadow; + property ShadowedText; + property ShowHint; + property Transparent default False; + property Visible; + + {events} + property OnClick; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEndDrag; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnStartDrag; + end; + +implementation + +{*** TOvcCustomRotatedLabel ***} + +procedure TOvcCustomRotatedLabel.CMFontChanged(var Msg : TMessage); +var + TM : TTextMetric; +begin + inherited; + + if csLoading in ComponentState then + Exit; + + if FFontAngle <> 0 then begin + {check if the current font can be rotated} + Canvas.Font := Self.Font; + GetTextMetrics(Canvas.Handle, TM); + if (TM.tmPitchAndFamily and TMPF_TRUETYPE) = 0 then + {force zero font angle} + FontAngle := 0; + end; + lblAdjustSize; +end; + +procedure TOvcCustomRotatedLabel.CMTextChanged(var Mes : TMessage); +begin + lblAdjustSize; +end; + +constructor TOvcCustomRotatedLabel.Create(AOwner : TComponent); +begin + inherited Create(AOwner); + + ControlStyle := ControlStyle + [csReplicatable, csOpaque]; + + {default property values} + FAlignment := taLeftJustify; + FFontAngle := 0; + FOriginX := 0; + FOriginY := 0; + FShadowColor := clBtnShadow; + FShadowedText := False; + + Font.Name := 'Arial'; + Height := 20; + Width := 130; + + if csDesigning in ComponentState then + lblAdjustSize; +end; + +function TOvcCustomRotatedLabel.GetTransparent : Boolean; +begin + Result := not (csOpaque in ControlStyle); +end; + +procedure TOvcCustomRotatedLabel.lblAdjustSize; + {-adjust horizontal and/or vertical size of control} +var + R : TRect; + W, H, X, Y : Integer; +begin + if rlBusy then {avoid reentrance} + Exit; + + rlBusy := True; + try + if not (csLoading in ComponentState) and AutoSize then begin + R := ClientRect; + Canvas.Font := Font; + W := Canvas.TextWidth(Caption); + H := Canvas.TextHeight(Caption); + if FFontAngle <> 0 then begin + {adjust height and width as necessary} + {width (X) of text at new angle} + X := Round(W * Cos(FFontAngle*Pi/180)); + {height (y) of text at new angle} + Y := Round(W * Sin(FFontAngle*Pi/180)); + R.Bottom := Abs(Y) + 2*H; + R.Right := Abs(X) + 2*H; + if X < 0 then + FOriginX := R.Right-H + else + FOriginX := H; + if Y < 0 then + FOriginY := H + else begin + if X < 0 then + FOriginY := R.Bottom - H + else + FOriginY := R.Bottom - H - H div 2; + end; + end else begin + FOriginX := 0; + FOriginY := 0; + R.Right := W; + R.Bottom := H; + end; + + SetBounds(Left, Top, R.Right, R.Bottom); + end; + finally + rlBusy := False; + end; +end; + +procedure TOvcCustomRotatedLabel.lblDrawText(var R : TRect; Flags : Word); + {-paint the controls display or calculate a TRect to fit text} +var + HoldColor : TColor; + T : string; + XO, YO : Integer; + A : Integer; + Buf : array[0..255] of Char; +{$IFDEF LCL} + FontHand : hFont; +{$ENDIF} +begin + T := Caption; + if (Flags and DT_CALCRECT <> 0) and (T = '') then + T := ' '; + + Flags := Flags or DT_NOPREFIX; + + {use our font} + Canvas.Font := Font; + + {create the rotated font} + if FFontAngle <> 0 then +{$IFNDEF LCL} + Canvas.Font.Handle := CreateRotatedFont(Font, FFontAngle); +{$ELSE} //Workaround for now - Qt widgetset not setting Handle? + FontHand := CreateRotatedFont(Font, FFontAngle); +{$ENDIF} + + {force disabled text color, if not enabled} + if not Enabled then + Canvas.Font.Color := clGrayText; + + {draw the text} + StrPLCopy(Buf, T, 255); + if FFontAngle = 0 then begin + {draw shadow first, if selected} + if FShadowedText then begin + HoldColor := Canvas.Font.Color; + Canvas.Font.Color := FShadowColor; + if not Transparent then begin + SetBkMode(Canvas.Handle, OPAQUE); + Canvas.Brush.Color := Color; + end; + OffsetRect(R, +2, +1); + DrawText(Canvas.Handle, @Buf, -1, R, Flags); + Canvas.Font.Color := HoldColor; +{$IFNDEF LCL} + SetBkMode(Canvas.Handle, Windows.TRANSPARENT); +{$ELSE} + SetBkMode(Canvas.Handle, LclType.TRANSPARENT); +{$ENDIF} + OffsetRect(R, -2, -1); + DrawText(Canvas.Handle, @Buf, -1, R, Flags); + end else begin + DrawText(Canvas.Handle, @Buf, -1, R, Flags) + end; + end else begin + if FShadowedText then begin + HoldColor := Canvas.Font.Color; + Canvas.Font.Color := FShadowColor; + if not Transparent then begin +{$IFNDEF LCL} + SetBkMode(Canvas.Handle, Windows.OPAQUE); +{$ELSE} + SetBkMode(Canvas.Handle, LclType.OPAQUE); +{$ENDIF} + Canvas.Brush.Color := Color; + end; + {calculate the shadow offset based on the quadrant the text is in} + { | } { 1 -- X+2, Y+1} + { 2 | 1 } { 2 -- X-1, Y-2} + { -------+--------- } { 3 -- X+2, Y+1} + { 3 | 4 } { 4 -- X-1, Y-2} + { | } + A := FFontAngle; + if A < 0 then A := 360 + A; + if A >= 270 then begin + XO := 2; YO := 1; {Quad=4} + end else if A >= 180 then begin + XO := 2; YO := 1; {Quad=3} + end else if A >= 90 then begin + XO := 2; YO := 1; {Quad=2} + end else begin + XO := 2; YO := 1; {Quad=1} + end; +{$IFDEF LCL} + SelectObject(Canvas.Handle, FontHand); +{$ENDIF} + ExtTextOut(Canvas.Handle, OriginX+XO, OriginY+YO, ETO_CLIPPED, + @R, Buf, StrLen(Buf), nil); + Canvas.Font.Color := HoldColor; +{$IFNDEF LCL} + SetBkMode(Canvas.Handle, Windows.TRANSPARENT); +{$ELSE} + SetBkMode(Canvas.Handle, LclType.TRANSPARENT); +{$ENDIF} +{$IFDEF LCL} + SelectObject(Canvas.Handle, FontHand); +{$ENDIF} + ExtTextOut(Canvas.Handle, OriginX, OriginY, ETO_CLIPPED, + @R, Buf, StrLen(Buf), nil); + end else begin +{$IFDEF LCL} + SelectObject(Canvas.Handle, FontHand); +{$ENDIF} + ExtTextOut(Canvas.Handle, OriginX, OriginY, ETO_CLIPPED, + @R, Buf, StrLen(Buf), nil); + end; + end; +end; + +procedure TOvcCustomRotatedLabel.Loaded; +begin + inherited Loaded; + + lblAdjustSize; +end; + +procedure TOvcCustomRotatedLabel.Paint; +const + Alignments: array[TAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER); +var + R : TRect; +begin + R := ClientRect; + with Canvas do begin + if not Transparent then begin + Brush.Color := Self.Color; + Brush.Style := bsSolid; + FillRect(R); + end; + Brush.Style := bsClear; + lblDrawText(R, Alignments[FAlignment]) + end; +end; + +procedure TOvcCustomRotatedLabel.SetAlignment(Value : TAlignment); +begin + if FAlignment <> Value then begin + FAlignment := Value; + Invalidate; + end; +end; + +procedure TOvcCustomRotatedLabel.SetAutoSize(Value : Boolean); +begin + if Value <> FAutoSize then begin + FAutoSize := Value; + lblAdjustSize; + end; +end; + +procedure TOvcCustomRotatedLabel.SetCaption(const Value : string); +begin + if Value <> FCaption then begin + FCaption := Value; + lblAdjustSize; + Repaint; + end; +end; + +procedure TOvcCustomRotatedLabel.SetOriginX(Value : Integer); +begin + if Value <> FOriginX then begin + FOriginX := Value; + Invalidate; + end; +end; + +procedure TOvcCustomRotatedLabel.SetOriginY(Value : Integer); +begin + if Value <> FOriginY then begin + FOriginY := Value; + Invalidate; + end; +end; + +procedure TOvcCustomRotatedLabel.SetShadowColor(const Value : TColor); +begin + if Value <> FShadowColor then begin + FShadowColor := Value; + invalidate; + end; +end; + +procedure TOvcCustomRotatedLabel.SetShadowedText(Value : Boolean); +begin + if Value <> FShadowedText then begin + FShadowedText := Value; + Invalidate; + end; +end; + +procedure TOvcCustomRotatedLabel.SetTransparent(Value : Boolean); +begin + if Transparent <> Value then begin + if Value then + ControlStyle := ControlStyle - [csOpaque] + else + ControlStyle := ControlStyle + [csOpaque]; + Invalidate; + end; +end; + +procedure TOvcCustomRotatedLabel.SetFontAngle(Value : Integer); +var + Neg : Integer; + TM : TTextMetric; +begin + if Value <> FFontAngle then begin + {check if the current font can be rotated} + if not (csLoading in ComponentState) then begin + if Value <> 0 then begin + Canvas.Font := Font; + GetTextMetrics(Canvas.Handle, TM); + if (TM.tmPitchAndFamily and TMPF_TRUETYPE) = 0 then + {force true-type font} + Font.Name := 'Arial'; + end; + end; + if Value < 0 then Neg := -1 else Neg := 1; + FFontAngle := (Abs(Value) mod 360) * Neg; + + lblAdjustSize; + + {repaint with new font} + Invalidate; + end; +end; + +procedure TOvcCustomRotatedLabel.SetName(const NewName : TComponentName); +begin + inherited SetName(NewName); + if (csDesigning in ComponentState) and (FCaption = '') then + FCaption := Self.Name; +end; + + +end. diff --git a/components/orpheus/ovcsc.pas b/components/orpheus/ovcsc.pas new file mode 100644 index 000000000..e5bdb00e5 --- /dev/null +++ b/components/orpheus/ovcsc.pas @@ -0,0 +1,1717 @@ +{*********************************************************} +{* OVCSC.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +(*Changes) + + 01/15/02 - Set AutoRepeat modified to prevent deadlocks at runtime. +*) + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovcsc; + {-Spin control} + +interface + +uses + {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, LclType, MyMisc, {$ENDIF} + Buttons, Classes, Controls, Forms, Graphics, StdCtrls, + SysUtils, OvcBase, OvcData, OvcEF, OvcMisc, OvcExcpt; + +type + TOvcSpinnerStyle = (stNormalVertical, stNormalHorizontal, stFourWay, stStar, + stDiagonalVertical, stDiagonalHorizontal, stDiagonalFourWay, + stPlainStar); + + TOvcDirection = (dUp, dDown, dRight, dLeft); + + TOvcSpinState = (ssNone, ssNormal, ssUpBtn, ssDownBtn, ssLeftBtn, + ssRightBtn, ssCenterBtn); + + TOvcSpinnerLineType = (ltSingle, + ltTopBevel, ltBottomBevel, ltTopSlice, ltBottomSlice, + ltTopSliceSquare, ltBottomSliceSquare, + ltDiagTopBevel,ltDiagBottomBevel, + ltStarLine0, ltStarLine1, ltStarLine2, ltStarLine3, ltStarLine4, ltStarLine5 + ); + + TSpinClickEvent = + procedure(Sender : TObject; State : TOvcSpinState; Delta : Double; Wrap : Boolean) + of object; + +type + TOvcSpinner = class(TOvcCustomControl) + protected {private} + {property variables} + FAcceleration : Integer; {value used to determine acceleration} + FAutoRepeat : Boolean; {repeat if button held} + FDelayTime : LongInt; + FDelta : Double; {amount to change by} + FRepeatCount : LongInt; + FFocusedControl : TWinControl; {the control to give the focus to} + FShowArrows : Boolean; + FStyle : TOvcSpinnerStyle; + FWrapMode : Boolean; {wrap at field bounderies} + + {events} + FOnClick : TSpinClickEvent; + + {private instance variables} + scNextMsgTime : LongInt; + + {regions for the five spin button sections} + scUpRgn : hRgn; + scDownRgn : hRgn; + scLeftRgn : hRgn; + scRightRgn : hRgn; + scCenterRgn : hRgn; + + scCurrentState : TOvcSpinState; + scLButton : Byte; + scMouseOverBtn : Boolean; + scPrevState : TOvcSpinState; + scSizing : Boolean; + scTopLeft, scTopRight, scBottomLeft, scBottomRight, scCenter : TPoint; + scTopLeftCenter, scBottomLeftCenter, scTopRightCenter, scBottomRightCenter : TPoint; + scTopMiddle, scBottomMiddle, scLeftMiddle, scRightMiddle : TPoint; + scTopLeft4, scBottomLeft4, scTopRight4, scBottomRight4 : TPoint; + + {property methods} + procedure SetAcceleration(const Value : Integer); + procedure SetAutoRepeat(Value: Boolean); + procedure SetShowArrows(const Value : Boolean); + procedure SetStyle(Value : TOvcSpinnerStyle); + + {internal methods} + function scCheckMousePos : TOvcSpinState; + procedure scDeleteRegions; + procedure scDoAutoRepeat; + procedure scDrawArrow(const R: TRect; const Pressed: Boolean; const Direction: TOvcDirection); + procedure scDrawLine(P1, P2 : TPoint; const Up : Boolean; LineType : TOvcSpinnerLineType); + procedure scDrawNormalButton(const Redraw : Boolean); + procedure scDrawFourWayButton(const Redraw : Boolean); + procedure scDrawStarButton(const Redraw : Boolean); + procedure scDrawDiagonalVertical(const Redraw : Boolean); + procedure scDrawDiagonalHorizontal(const Redraw : Boolean); + procedure scDrawDiagonalFourWay(const Redraw : Boolean); + procedure scDrawPlainStar(const Redraw : Boolean); + procedure scDrawButton(const Redraw : Boolean); + procedure scInvalidateButton(const State : TOvcSpinState); + procedure scPolyline(const Points: array of TPoint); + + {private message response methods} + procedure OMRecreateWnd(var Msg : TMessage); + message om_RecreateWnd; + + {windows message handling methods} + procedure WMGetDlgCode(var Msg : TWMGetDlgCode); + message WM_GETDLGCODE; + procedure WMLButtonDown(var Msg : TWMLButtonDown); + message WM_LBUTTONDOWN; + procedure WMLButtonUp(var Msg : TWMLButtonUp); + message WM_LBUTTONUP; + + protected + procedure CreateParams(var Params : TCreateParams); + override; + procedure Loaded; + override; + procedure Notification(AComponent : TComponent; Operation : TOperation); + override; + procedure Paint; + override; + + {dynamic event wrappers} + procedure DoOnClick(State : TOvcSpinState); + dynamic; + + procedure scDoMouseDown(const XPos, YPos: Integer); + virtual; + procedure scDoMouseUp; + virtual; + procedure scUpdateNormalSizes; + procedure scUpdateFourWaySizes; + procedure scUpdateStarSizes; + procedure scUpdateDiagonalVerticalSizes; + procedure scUpdateDiagonalHorizontalSizes; + procedure scUpdateDiagonalFourWaySizes; + procedure scUpdatePlainStarSizes; + procedure scUpdateSizes; + virtual; + + public + constructor Create(AOwner : TComponent); + override; + destructor Destroy; + override; + procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); + override; + + property RepeatCount : LongInt + read FRepeatCount; + + published + {properties} + property Acceleration : Integer + read FAcceleration write SetAcceleration + default 5; + property AutoRepeat : Boolean + read FAutoRepeat write SetAutoRepeat; + property Delta : Double + read FDelta write FDelta; + property DelayTime : LongInt + read FDelayTime write FDelayTime + default 500; + property FocusedControl : TWinControl + read FFocusedControl write FFocusedControl; + property ShowArrows : Boolean + read FShowArrows write SetShowArrows + default True; + property Style : TOvcSpinnerStyle + read FStyle write SetStyle + default stNormalVertical; + property WrapMode : Boolean + read FWrapMode write FWrapMode + default True; + + {inherited properties} + {$IFDEF VERSION4} + property Anchors; + property Constraints; + {$ENDIF} + property Enabled; + property ParentShowHint; + property ShowHint; + property Visible; + + {events} + property OnClick : TSpinClickEvent + read FOnClick write FOnClick; + + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + end; + + +implementation + +uses + OvcEdCal, OvcEdTim; + +const + scDefMinSize = 13; + + +{$IFDEF NoAsm} +function GetArrowWidth(Width, Height : Integer) : Integer; +begin + Result := Height; + if Width < Height then + Result := Width; + Result := (Result SHR 1) OR 1; +end; +{$ELSE} +function GetArrowWidth(Width, Height : Integer) : Integer; register; +asm + cmp eax, edx + jle @@1 + mov eax, edx +@@1: + shr eax, 1 + or eax, 1 +end; +{$ENDIF} + +{*** TOvcSpinner ***} + +constructor TOvcSpinner.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + ControlStyle := ControlStyle + [csFramed, csOpaque]; + ControlStyle := ControlStyle + [csReplicatable]; + + {initialize property variables} + FAcceleration := 5; + FAutoRepeat := True; + FDelayTime := 500; + FDelta := 1; + FRepeatCount := 0; + FShowArrows := True; + FStyle := stNormalVertical; + FWrapMode := True; + + Width := 16; + Height := 25; + TabStop := False; + + scCurrentState := ssNormal; + scPrevState := ssNone; + scMouseOverBtn := False; +end; + +procedure TOvcSpinner.CreateParams(var Params : TCreateParams); +begin + inherited CreateParams(Params); + ControlStyle := ControlStyle + [csOpaque] - [csFramed]; + + if not (csDesigning in ComponentState) then + ControlStyle := ControlStyle - [csDoubleClicks]; +end; + +destructor TOvcSpinner.Destroy; +begin + scDeleteRegions; + + inherited Destroy; +end; + +procedure TOvcSpinner.DoOnClick(State : TOvcSpinState); +var + D : Double; +begin + if Assigned(FOnClick) or + (Assigned(FFocusedControl) and + ((FFocusedControl is TOvcBaseEntryField) or + (FFocusedControl is TCustomEdit))) then begin + if scMouseOverBtn then begin + if LongInt(GetTickCount) > scNextMsgTime then begin + + {auto link with Orpheus entry fields} + if Assigned(FFocusedControl) and (FFocusedControl is TOvcBaseEntryField) then begin + case State of + ssUpBtn : TOvcBaseEntryField(FFocusedControl).IncreaseValue(FWrapMode, Delta); + ssDownBtn : TOvcBaseEntryField(FFocusedControl).DecreaseValue(FWrapMode, Delta); + ssLeftBtn : TOvcBaseEntryField(FFocusedControl).MoveCaret(-1); + ssRightBtn : TOvcBaseEntryField(FFocusedControl).MoveCaret(+1); + end; + end; + + {auto link with TCustomEdit controls} + if Assigned(FFocusedControl) and (FFocusedControl is TCustomEdit) then begin + try + if (FFocusedControl is TOvcCustomDateEdit) then + D := TOvcCustomDateEdit(FFocusedControl).Date + else if (FFocusedControl is TOvcCustomTimeEdit) then + D := TOvcCustomTimeEdit(FFocusedControl).AsMinutes + else + D := StrToFloat(TCustomEdit(FFocusedControl).Text); + + case State of + ssUpBtn : D := D + Delta; + ssDownBtn : D := D - Delta; + end; + + if (FFocusedControl is TOvcCustomDateEdit) then + TOvcCustomDateEdit(FFocusedControl).Date := D + else if (FFocusedControl is TOvcCustomTimeEdit) then + TOvcCustomTimeEdit(FFocusedControl).AsMinutes := trunc(D) + else + TCustomEdit(FFocusedControl).Text := FloatToStr(D); + except + end; + end; + + {call OnClick event handler, if assigned} + if Assigned(FOnClick) then + FOnClick(Self, State, Delta, FWrapMode); + + {setup for next time} + scNextMsgTime := LongInt(GetTickCount) + DelayTime - Acceleration*10*FRepeatCount; + Inc(FRepeatCount); + end; + end; + end; +end; + +procedure TOvcSpinner.Loaded; +begin + inherited Loaded; + + scUpdateSizes; +end; + +procedure TOvcSpinner.Notification(AComponent : TComponent; Operation : TOperation); +begin + inherited Notification(AComponent, Operation); + + if (AComponent = FFocusedControl) and (Operation = opRemove) then + FocusedControl := nil; +end; + +procedure TOvcSpinner.OMRecreateWnd(var Msg : TMessage); +begin +{$IFNDEF LCL} + RecreateWnd; +{$ELSE} + MyMisc.RecreateWnd(Self); +{$ENDIF} +end; + +function TOvcSpinner.scCheckMousePos : TOvcSpinState; +var + P : TPoint; +begin + GetCursorPos(P); + P := ScreenToClient(P); + + {see which button the mouse is over} + Result := ssNone; + if PtInRect(ClientRect, P) then begin +{$IFDEF MSWINDOWS} + if not (csClicked in ControlState) then +{$ELSE} //csClicked not getting set with GTK + if not (csLButtonDown in ControlState) then +{$ENDIF} + Result := ssNormal + + {mouse is over one of the buttons, which one?} + else if (scUpRgn <> 0) and PtInRegion(scUpRgn, P.X, P.Y) then + if (Style = stNormalHorizontal) then + Result := ssRightBtn + else + Result := ssUpBtn + else if (scDownRgn <> 0) and PtInRegion(scDownRgn, P.X, P.Y) then + if (Style = stNormalHorizontal) then + Result := ssLeftBtn + else + Result := ssDownBtn + else if (scLeftRgn <> 0) and PtInRegion(scLeftRgn, P.X, P.Y) then + Result := ssLeftBtn + else if (scRightRgn <> 0) and PtInRegion(scRightRgn, P.X, P.Y) then + Result := ssRightBtn + else if (scCenterRgn <> 0) and PtInRegion(scCenterRgn, P.X, P.Y) then + Result := ssCenterBtn + else + Result := ssNormal; + end; +end; + +procedure TOvcSpinner.scDeleteRegions; +begin + if scUpRgn <> 0 then begin + DeleteObject(scUpRgn); + scUpRgn := 0; + end; + if scDownRgn <> 0 then begin + DeleteObject(scDownRgn); + scDownRgn := 0; + end; + if scLeftRgn <> 0 then begin + DeleteObject(scLeftRgn); + scLeftRgn := 0; + end; + if scRightRgn <> 0 then begin + DeleteObject(scRightRgn); + scRightRgn := 0; + end; + if scCenterRgn <> 0 then begin + DeleteObject(scCenterRgn); + scCenterRgn := 0; + end; +end; + +procedure TOvcSpinner.scDoAutoRepeat; +var + NewState : TOvcSpinState; +begin + DoOnClick(scCurrentState); + + {don't auto-repeat for center button} + if (scCurrentState = ssCenterBtn) or (not AutoRepeat) then begin + repeat + {allow other messages} + Application.ProcessMessages; + + {until the mouse button is released} +{$IFDEF MSWINDOWS} + until ({$IFNDEF LCL} GetAsyncKeyState(scLButton) {$ELSE} GetKeyState(scLButton) {$ENDIF} and $8000) = 0; +{$ELSE} //GTK GetKeyState returns 0 + until not (csLButtonDown in ControlState); +{$ENDIF} + scDoMouseUp; + Exit; + end; + + {repeat until left button released} + repeat + if AutoRepeat then + DoOnClick(scCurrentState); + + {allow other messages} + Application.ProcessMessages; + + {get new button/mouse state} + NewState := scCheckMousePos; + + {has anything changed} + if NewState <> scCurrentState then begin + {the mouse is not over a button or its over a new one} + scPrevState := scCurrentState; + scCurrentState := NewState; + + {don't depress the center button if the mouse moves over it} + if NewState = ssCenterBtn then + scCurrentState := ssNormal; + + scMouseOverBtn := not (scCurrentState in [ssNone, ssNormal]); + + scInvalidateButton(scPrevState); + scInvalidateButton(scCurrentState); + end; + + {until the mouse button is released} +{$IFDEF MSWINDOWS} + until ({$IFNDEF LCL} GetAsyncKeyState(scLButton) {$ELSE} GetKeyState(scLButton) {$ENDIF} and $8000) = 0; +{$ELSE} //GTK GetKeyState returns 0 + until not (csLButtonDown in ControlState); +{$ENDIF} + scDoMouseUp; +end; + +procedure TOvcSpinner.scDoMouseDown(const XPos, YPos: Integer); +begin + scPrevState := scCurrentState; + + {find which button was clicked} + scCurrentState := scCheckMousePos; + scMouseOverBtn := True; + + scInvalidateButton(scPrevState); + scInvalidateButton(scCurrentState); + + {initialize and start repeating} + FRepeatCount := 0; + scLButton := GetLeftButton; + scNextMsgTime := GetTickCount-1; + scDoAutoRepeat; +end; + +procedure TOvcSpinner.scDoMouseUp; +begin + {save last state and redraw} + scPrevState := scCurrentState; + scCurrentState := ssNormal; + scMouseOverBtn := False; + + scInvalidateButton(scPrevState); + scInvalidateButton(scCurrentState); + scDrawButton(False); +end; + +procedure TOvcSpinner.scDrawArrow(const R: TRect; const Pressed: Boolean; + const Direction: TOvcDirection); +var + ArrowWidth, ArrowHeight : Integer; + X, Y : Integer; + LeftPoint, RightPoint, PointPoint : TPoint; + PLeftPoint, PRightPoint, PPointPoint : TPoint; +begin + if not FShowArrows then + Exit; + + with Canvas do begin + ArrowWidth := GetArrowWidth(R.Right-R.Left, R.Bottom-R.Top); + ArrowHeight := (ArrowWidth + 1) div 2; + if Direction in [dUp, dDown] then begin + X := (R.Right-R.Left-ArrowWidth) div 2; + Y := (R.Bottom-R.Top-ArrowHeight) div 2; + end else begin + X := (R.Right-R.Left-ArrowHeight) div 2; + Y := (R.Bottom-R.Top-ArrowWidth) div 2; + end; + case Direction of + dUp : + begin + LeftPoint := Point(R.Left + X, Y + ArrowHeight + R.Top - 1); + RightPoint := Point(R.Left + X + ArrowWidth - 1, Y + ArrowHeight + R.Top -1 ); + PointPoint := Point(R.Left + X + (ArrowWidth div 2), Y + R.Top); + end; + dDown : + begin + LeftPoint := Point(R.Left + X, Y + R.Top); + RightPoint := Point(R.Left + X + ArrowWidth - 1 , Y + R.Top); + PointPoint := Point(R.Left + X + (ArrowWidth div 2), Y + ArrowHeight + R.Top - 1); + end; + dRight : + begin + LeftPoint := Point(R.Left + X, Y + R.Top); + RightPoint := Point(R.Left + X, Y + ArrowWidth + R.Top - 1); + PointPoint := Point(R.Left + X + ArrowHeight - 1, Y + (ArrowWidth div 2) + R.Top); + end; + dLeft : + begin + LeftPoint := Point(R.Left + X + ArrowHeight - 1, Y + R.Top); + RightPoint := Point(R.Left + X + ArrowHeight - 1, Y + ArrowWidth - 1 + R.Top); + PointPoint := Point(R.Left + X, Y + (ArrowWidth div 2) + R.Top); + end; + end; + PLeftPoint.X := LeftPoint.X + 1; + PLeftPoint.Y := LeftPoint.Y + 1; + PRightPoint.X := RightPoint.X + 1; + PRightPoint.Y := RightPoint.Y + 1; + PPointPoint.X := PointPoint.X + 1; + PPointPoint.Y := PointPoint.Y + 1; + if Pressed then begin + Pen.Color := clBtnFace; + Brush.Color := clBtnFace; + Polygon([LeftPoint, RightPoint, PointPoint]); + Pen.Color := clBtnText; + Brush.Color := clBtnText; + Polygon([PLeftPoint, PRightPoint, PPointPoint]); + end else begin + Pen.Color := clBtnFace; + Brush.Color := clBtnFace; + Polygon([PLeftPoint, PRightPoint, PPointPoint]); + Pen.Color := clBtnText; + Brush.Color := clBtnText; + Polygon([LeftPoint, RightPoint, PointPoint]); + end; + end; +end; + +procedure TOvcSpinner.scDrawButton(const Redraw : Boolean); +begin + case FStyle of + stDiagonalFourWay : scDrawDiagonalFourWay(Redraw); + stDiagonalHorizontal : scDrawDiagonalHorizontal(Redraw); + stDiagonalVertical : scDrawDiagonalVertical(Redraw); + stFourWay : scDrawFourWayButton(Redraw); + stNormalHorizontal : scDrawNormalButton(Redraw); + stNormalVertical : scDrawNormalButton(Redraw); + stPlainStar : scDrawPlainStar(Redraw); + stStar : scDrawStarButton(Redraw); + end; +end; + +procedure TOvcSpinner.scDrawDiagonalFourWay(const Redraw : Boolean); + + procedure DrawBasicShape; + begin + with Canvas do begin + Brush.Color := clBtnFace; + Brush.Style := bsSolid; + Pen.Color := clBtnFace; + FillRect(Rect(scTopLeft.X, scTopLeft.Y, scBottomRight.X, scBottomRight.Y)); + scDrawLine(scBottomLeft4, scTopRight4, True, ltSingle); + scDrawLine(scBottomLeft, scTopLeft, True, ltTopBevel); + scDrawLine(scTopLeft, scTopRight, True, ltTopBevel); + scDrawLine(scBottomLeft, scBottomRight, True, ltBottomBevel); + scDrawLine(scBottomRight, scTopRight, True, ltBottomBevel); + end; + end; + + procedure DrawFace(State : TOvcSpinState; Up : Boolean); + begin + with Canvas do begin + case State of + ssUpBtn : begin + scDrawArrow(Rect(Width Div 4, 0, Width Div 2, Height div 2), not(Up), dUp); + scDrawLine(scTopLeft4, scTopRight4, Up, ltTopBevel); + scDrawLine(scTopLeft4, scBottomLeft4, Up, ltDiagTopBevel); + scDrawLine(scBottomLeft4, scTopRight4, Up, ltBottomSlice); + end; + ssDownBtn : begin + scDrawArrow(Rect(Width Div 2, (Height+1) div 2, Width * 3 Div 4, Height), not(Up), dDown); + scDrawLine(scBottomRight4, scBottomLeft4, Up, ltBottomBevel); + scDrawLine(scTopRight4, scBottomRight4, Up, ltDiagBottomBevel); + scDrawLine(scBottomLeft4, scTopRight4, Up, ltTopSlice); + end; + ssLeftBtn : begin + scDrawArrow(Rect(0, 0, Width Div 4, Height), not(Up), dLeft); + scDrawLine(scTopLeft, scTopLeft4, Up, ltTopBevel); + scDrawLine(scTopLeft, scBottomLeft, Up, ltTopBevel); + scDrawLine(scTopLeft4, scBottomLeft4, Up, ltBottomBevel); + scDrawLine(scBottomLeft, scBottomLeft4, Up, ltBottomBevel); + end; + ssRightBtn : begin + scDrawArrow(Rect(Width * 3 Div 4, 0, Width, Height), not(Up), dRight); + scDrawLine(scTopRight4, scTopRight, Up, ltTopBevel); + scDrawLine(scTopRight4, scBottomRight4, Up, ltTopBevel); + scDrawLine(scTopRight, scBottomRight, Up, ltBottomBevel); + scDrawLine(scBottomRight4, scBottomRight, Up, ltBottomBevel); + end; + end; + end; + end; + +begin + with Canvas do begin + if Redraw then begin + DrawBasicShape; + DrawFace(ssUpBtn, True); + DrawFace(ssDownBtn, True); + DrawFace(ssLeftBtn, True); + DrawFace(ssRightBtn, True); + end; + + if scPrevState <> scCurrentState then + DrawFace(scPrevState, True); + if scMouseOverBtn then + DrawFace(scCurrentState, False); + end; +end; + +procedure TOvcSpinner.scDrawDiagonalHorizontal(const Redraw : Boolean); + + procedure DrawBasicShape; + begin + with Canvas do begin + Brush.Color := clBtnFace; + Brush.Style := bsSolid; + Pen.Color := clBtnFace; + FillRect(Rect(scTopLeft.X, scTopLeft.Y, scBottomRight.X, scBottomRight.Y)); + scDrawLine(scBottomLeft, scTopRight, True, ltSingle); + scDrawLine(scBottomLeft, scTopLeft, True, ltTopBevel); + scDrawLine(scTopLeft, scTopRight, True, ltTopBevel); + scDrawLine(scBottomLeft, scBottomRight, True, ltBottomBevel); + scDrawLine(scBottomRight, scTopRight, True, ltBottomBevel); + end; + end; + + procedure DrawFace(State : TOvcSpinState; Up : Boolean); + begin + with Canvas do begin + case State of + ssLeftBtn : begin + scDrawArrow(Rect(0, 0, Width div 2, (Height div 2)), not(Up), dLeft); + scDrawLine(scTopLeft, scTopRight, Up, ltTopBevel); + scDrawLine(scTopLeft, scBottomLeft, Up, ltTopBevel); + scDrawLine(scBottomLeft, scTopRight, Up, ltBottomSlice); + end; + ssRightBtn : begin + scDrawArrow(Rect((Width+1) div 2, (Height+1) div 2, Width, Height), not(Up), dRight); + scDrawLine(scBottomLeft, scBottomRight, Up, ltBottomBevel); + scDrawLine(scTopRight, scBottomRight, Up, ltBottomBevel); + scDrawLine(scBottomLeft, scTopRight, Up, ltTopSlice); + end; + end; + end; + end; + +begin + with Canvas do begin + if Redraw then begin + DrawBasicShape; + DrawFace(ssLeftBtn, True); + DrawFace(ssRightBtn, True); + end; + + if scPrevState <> scCurrentState then + DrawFace(scPrevState, True); + if scMouseOverBtn then + DrawFace(scCurrentState, False); + end; +end; + +procedure TOvcSpinner.scDrawDiagonalVertical(const Redraw : Boolean); + + procedure DrawBasicShape; + begin + with Canvas do begin + Brush.Color := clBtnFace; + Brush.Style := bsSolid; + Pen.Color := clBtnFace; + FillRect(Rect(scTopLeft.X, scTopLeft.Y, scBottomRight.X, scBottomRight.Y)); + scDrawLine(scBottomLeft, scTopRight, True, ltSingle); + scDrawLine(scBottomLeft, scTopLeft, True, ltTopBevel); + scDrawLine(scTopLeft, scTopRight, True, ltTopBevel); + scDrawLine(scBottomLeft, scBottomRight, True, ltBottomBevel); + scDrawLine(scBottomRight, scTopRight, True, ltBottomBevel); + end; + end; + + procedure DrawFace(State : TOvcSpinState; Up : Boolean); + begin + with Canvas do begin + case State of + ssUpBtn : begin + scDrawArrow(Rect(0, 0, Width div 2, (Height div 2)), not(Up), dUp); + scDrawLine(scTopLeft, scTopRight, Up, ltTopBevel); + scDrawLine(scTopLeft, scBottomLeft, Up, ltTopBevel); + scDrawLine(scBottomLeft, scTopRight, Up, ltBottomSlice); + end; + ssDownBtn : begin + scDrawArrow(Rect((Width+1) div 2, (Height+1) div 2, Width, Height), not(Up), dDown); + scDrawLine(scBottomLeft, scBottomRight, Up, ltBottomBevel); + scDrawLine(scTopRight, scBottomRight, Up, ltBottomBevel); + scDrawLine(scBottomLeft, scTopRight, Up, ltTopSlice); + end; + end; + end; + end; + +begin + with Canvas do begin + if Redraw then begin + DrawBasicShape; + DrawFace(ssUpBtn, True); + DrawFace(ssDownBtn, True); + end; + + if scPrevState <> scCurrentState then + DrawFace(scPrevState, True); + if scMouseOverBtn then + DrawFace(scCurrentState, False); + end; +end; + +procedure TOvcSpinner.scDrawFourWayButton(const Redraw : Boolean); + + procedure DrawBasicShape; + begin + with Canvas do begin + Brush.Color := clBtnFace; + Brush.Style := bsSolid; + Pen.Color := clBtnFace; + FillRect(Rect(scTopLeft.X, scTopLeft.Y, scBottomRight.X, scBottomRight.Y)); + scDrawLine(scTopLeft, scBottomRight, True, ltSingle); + scDrawLine(scBottomLeft, scTopRight, True, ltSingle); + scDrawLine(scBottomLeft, scTopLeft, True, ltTopBevel); + scDrawLine(scTopLeft, scTopRight, True, ltTopBevel); + scDrawLine(scBottomLeft, scBottomRight, True, ltBottomBevel); + scDrawLine(scBottomRight, scTopRight, True, ltBottomBevel); + end; + end; + + procedure DrawFace(State : TOvcSpinState; Up : Boolean); + begin + with Canvas do begin + case State of + ssUpBtn : begin + scDrawArrow(Rect(0, 0, Width, (Height div 3)), not(Up), dUp); + scDrawLine(scTopLeft, scTopRight, Up, ltTopBevel); + scDrawLine(scTopRight, scCenter, Up, ltBottomSliceSquare); + scDrawLine(scTopLeft, scCenter, Up, ltBottomSliceSquare); + end; + ssDownBtn : begin + scDrawArrow(Rect(0, Height - (Height div 3), Width, Height), not(Up), dDown); + scDrawLine(scBottomLeft, scBottomRight, Up, ltBottomBevel); + scDrawLine(scBottomLeft, scCenter, Up, ltTopSliceSquare); + scDrawLine(scBottomRight, scCenter, Up, ltTopSliceSquare); + end; + ssLeftBtn : begin + scDrawArrow(Rect(0, 0, (Width div 3), Height), not(Up), dLeft); + scDrawLine(scTopLeft, scBottomLeft, Up, ltTopBevel); + scDrawLine(scBottomLeft, scCenter, Up, ltBottomSliceSquare); + scDrawLine(scTopLeft, scCenter, Up, ltTopSliceSquare); + end; + ssRightBtn : begin + scDrawArrow(Rect(Width - (Width div 3), 0, Width, Height), not(Up), dRight); + scDrawLine(scTopRight, scBottomRight, Up, ltBottomBevel); + scDrawLine(scTopRight, scCenter, Up, ltTopSliceSquare); + scDrawLine(scBottomRight, scCenter, Up, ltBottomSliceSquare); + end; + end; + end; + end; + +begin + with Canvas do begin + if Redraw then begin + DrawBasicShape; + DrawFace(ssUpBtn, True); + DrawFace(ssDownBtn, True); + DrawFace(ssLeftBtn, True); + DrawFace(ssRightBtn, True); + end; + + if scPrevState <> scCurrentState then + DrawFace(scPrevState, True); + if scMouseOverBtn then + DrawFace(scCurrentState, False); + end; +end; + +procedure TOvcSpinner.scDrawLine(P1, P2 : TPoint; const Up : Boolean; LineType : TOvcSpinnerLineType); + {-this routine draws a parallel line} + {The Offset is required because of the nature of Bressenham's algorithm} + {Negative Offsets are above the line, and Positive Offsets are Below} + + function GetSlope(const P1, P2 : TPoint) : Extended; + var + dX, dY : Integer; + begin + dY := (P1.y - P2.y); + dX := (P1.x - P2.x); + + if (dX = 0) then + if dY > 0 then + Result := 999999.0 + else + Result := -999999.0 + else + Result := dY / dX; + end; + + procedure DrawLine(P1, P2 : TPoint; Offset : Integer; const Square : Boolean); + var + Slope : Extended; + P : TPoint; + P1Square, P2Square : Boolean; + begin + P2Square := Square; + P1Square := False; + if P1.x > P2.X then begin + P := P1; + P1 := P2; + P2 := P; + P2Square := False; + P1Square := Square; + end; + + Slope := GetSlope(P1, P2); + + if Slope >= 0 then begin + if P1.x > scTopMiddle.x then + Offset := -Offset; + end; + + if abs(Slope) <= 1 then begin + if Slope = 0 then begin + P1.y := P1.y + Offset; + P2.y := P2.y + Offset; + {these are to shorten the lines a little} + P1.X := P1.X - Abs(Offset); + P2.X := P2.X + Abs(Offset); + end else if (Slope = 1) and (Offset > 0) then begin + if P1Square then begin + P1.X := P1.X + 0 * Abs(Offset); + P1.y := P1.y + 1 * Abs(Offset); + end else begin + P1.X := P1.X + 2 * Abs(Offset); + P1.y := P1.y + 3 * Abs(Offset); + end; + if P2Square then begin + P2.X := P2.X - 1 * Abs(Offset); + P2.y := P2.y - 0 * Abs(Offset); + end else begin + P2.X := P2.X - 3 * Abs(Offset); + P2.y := P2.y - 2 * Abs(Offset); + end; + end else if (Slope = 1) and (Offset < 0) then begin + if P1Square then begin + P1.X := P1.X + 1 * Abs(Offset); + P1.y := P1.y + 0 * Abs(Offset); + end else begin + P1.X := P1.X + 3 * Abs(Offset); + P1.y := P1.y + 2 * Abs(Offset); + end; + if P2Square then begin + P2.X := P2.X - 0 * Abs(Offset); + P2.y := P2.y - 1 * Abs(Offset); + end else begin + P2.X := P2.X - 2 * Abs(Offset); + P2.y := P2.y - 3 * Abs(Offset); + end; + end else if (Slope = -1) and (Offset > 0) then begin + if P1Square then begin + P1.X := P1.X + 1 * Abs(Offset); + P1.y := P1.y - 0 * Abs(Offset); + end else begin + P1.X := P1.X + 3 * Abs(Offset); + P1.y := P1.y - 2 * Abs(Offset); + end; + if P2Square then begin + P2.X := P2.X - 0 * Abs(Offset); + P2.y := P2.y + 1 * Abs(Offset); + end else begin + P2.X := P2.X - 2 * Abs(Offset); + P2.y := P2.y + 3 * Abs(Offset); + end; + end else if (Slope = -1) and (Offset < 0) then begin + if P1Square then begin + P1.X := P1.X + 0 * Abs(Offset); + P1.y := P1.y - 1 * Abs(Offset); + end else begin + P1.X := P1.X + 2 * Abs(Offset); + P1.y := P1.y - 3 * Abs(Offset); + end; + if P2Square then begin + P2.X := P2.X - 1 * Abs(Offset); + P2.y := P2.y + 0 * Abs(Offset); + end else begin + P2.X := P2.X - 3 * Abs(Offset); + P2.y := P2.y + 2 * Abs(Offset); + end; + end else begin + P1.y := P1.y + Offset; + P2.y := P2.y + Offset; + end; + end else begin + P1.x := P1.x + Offset; + P2.x := P2.x + Offset; + if ((P1.x - P2.x) = 0) then begin + {These are to shorten the lines a little} + if (P1.y - P2.y) > 0 then begin + P1.Y := P1.Y - Abs(Offset); + P2.Y := P2.Y + Abs(Offset); + end else begin + P1.Y := P1.Y + Abs(Offset); + P2.Y := P2.Y - Abs(Offset); + end; + end; + end; + scPolyLine([P1, P2]); + end; + +const + BtnColor : array[Boolean, 0..7] of TColor = ( + (clBtnShadow, clBtnShadow, clBtnFace, + clBtnHighlight, clWindowFrame, clBtnHighLight, clRed, clWindowFrame), + (clBtnHighlight, clBtnFace, clBtnShadow, + clWindowFrame, clBtnHighlight, clBtnFace, clGreen, clWindowFrame)); + SpinnerLines : array[TOvcSpinnerLineType, 0..1] of -1..7 = ( + (7, -1), {ltSingle} + (4, 1), {ltTopBevel} + (3, 2), {ltBottomBevel} + (4, 7), {ltTopSlice} + (3, 7), {ltBottomSlice} + (4, 7), {ltTopSliceSquare} + (3, 7), {ltBottomSliceSquare} + (4, 1), {ltDiagTopBevel} + (3, 2), {ltDiagBottomBevel} + (0, -1), {ltStarLine0} + (3, -1), {ltStarLine1} + (4, 1), {ltStarLine2} + (3, 2), {ltStarLine3} + (4, 7), {ltStarLine4} + (2, 7) {ltStarLine5} + ); + +{ComplementLine is used for shading the Left/Right Lines} + ComplementLine : array[TOvcSpinnerLineType] of TOvcSpinnerLineType = ( + ltSingle, {ltSingle} + ltTopBevel, {ltTopBevel} + ltBottomBevel, {ltBottomBevel} + ltBottomSlice, {ltTopSlice} + ltTopSlice, {ltBottomSlice} + ltBottomSliceSquare, {ltTopSliceSquare} + ltTopSliceSquare, {ltBottomSliceSquare} + ltDiagBottomBevel, {ltDiagTopBevel} + ltDiagTopBevel, {ltDiagBottomBevel} + ltStarLine1, {ltStarLine0} + ltStarLine0, {ltStarLine1} + ltStarLine3, {ltStarLine2} + ltStarLine2, {ltStarLine3} + ltStarLine5, {ltStarLine4} + ltStarLine4 {ltStarLine5} + ); + +var + DrawSquare : Boolean; + Offset : Integer; + +begin + with Canvas do begin +{if the line is on the other side then ComplementLine} + if (GetSlope(P1, P2) > 1) then + linetype := ComplementLine[LineType]; + + Pen.Color := BtnColor[Up, SpinnerLines[LineType, 0]]; + DrawSquare := False; + Offset := 0; + + case LineType of + ltTopSlice : + begin + Offset := 1; + end; + ltBottomSlice : + begin + Offset := -1; + end; + ltTopSliceSquare : + begin + DrawSquare := True; + Offset := 1; + end; + ltBottomSliceSquare : + begin + DrawSquare := True; + Offset := -1; + end; + ltDiagTopBevel : + begin + Offset := 1; + end; + ltDiagBottomBevel : + begin + Offset := -1; + end; + ltStarLine2 : + begin + if P1.X = P2.X then begin + Inc(P1.X);Inc(P1.y);Inc(P2.X);Dec(P2.y); + end else begin + Inc(P1.X);Inc(P1.y);Dec(P2.X);Inc(P2.y); + end; + end; + ltStarLine3 : + begin + if P1.X = P2.X then begin + Dec(P1.X);Inc(P1.y);Dec(P2.X);Dec(P2.y); + end else begin + Inc(P1.X);Dec(P1.y);Dec(P2.X);Dec(P2.y); + end; + end; + ltStarLine4 : + begin + DrawSquare := True; + Offset := 1; + end; + ltStarLine5 : + begin + DrawSquare := True; + Offset := -1; + end; + end; + + DrawLine(P1, P2, Offset, DrawSquare); + + if SpinnerLines[LineType, 1] = -1 then + Exit; + + Pen.Color := BtnColor[Up, SpinnerLines[LineType, 1]]; + DrawSquare := False; + Offset := 0; + + case LineType of + ltTopBevel : + begin + Offset := 1; + end; + ltBottomBevel : + begin + Offset := -1; + end; + ltTopSliceSquare : + begin + DrawSquare := True; + end; + ltBottomSliceSquare : + begin + DrawSquare := True; + end; + ltDiagTopBevel : + begin + Offset := 2; + end; + ltDiagBottomBevel : + begin + Offset := -2; + end; + ltStarLine2 : + begin + if P1.X = P2.X then begin + Inc(P1.X);Inc(P1.y);Inc(P2.X);Dec(P2.y); + end else begin + Inc(P1.X);Inc(P1.y);Dec(P2.X);Inc(P2.y); + end; + end; + ltStarLine3 : + begin + if P1.X = P2.X then begin + Dec(P1.X);Inc(P1.y);Dec(P2.X);Dec(P2.y); + end else begin + Inc(P1.X);Dec(P1.y);Dec(P2.X);Dec(P2.y); + end; + end; + end; + + DrawLine(P1, P2, Offset, DrawSquare); + end; +end; + +procedure TOvcSpinner.scDrawNormalButton(const Redraw : Boolean); +var + TopPressed : Boolean; + BottomPressed : Boolean; + UpRect : TRect; + DownRect : TRect; + +begin +{$IFDEF MSWINDOWS} + if (csClicked in ControlState) and scMouseOverBtn then begin +{$ELSE} //csClicked not getting set with GTK + if (csLButtonDown in ControlState) and scMouseOverBtn then begin +{$ENDIF} + TopPressed := (scCurrentState in [ssUpBtn, ssRightBtn]); + BottomPressed := (scCurrentState in [ssDownBtn, ssLeftBtn]); + end else begin + TopPressed := False; + BottomPressed := False; + end; +{$IFNDEF LCL} + GetRgnBox(scUpRgn, UpRect); + GetRgnBox(scDownRgn, DownRect); +{$ELSE} + MyMisc.GetRgnBox(scUpRgn, @UpRect); + MyMisc.GetRgnBox(scDownRgn, @DownRect); +{$ENDIF} + if FStyle = stNormalVertical then begin + Inc(UpRect.Right); + Inc(UpRect.Bottom); + Inc(DownRect.Top); + end else begin + Inc(UpRect.Bottom); + Dec(DownRect.Right); + end; + Inc(DownRect.Bottom); + Inc(DownRect.Right); + DrawButtonFace(Canvas, UpRect, 1, bsNew, False, TopPressed, False); + DrawButtonFace(Canvas, DownRect, 1, bsNew, False, BottomPressed, False); + if FStyle = stNormalVertical then begin + scDrawArrow(UpRect, TopPressed, dUp); + scDrawArrow(DownRect, BottomPressed, dDown); + end else begin + scDrawArrow(UpRect, TopPressed, dRight); + scDrawArrow(DownRect, BottomPressed, dLeft); + end; +end; + +procedure TOvcSpinner.scDrawPlainStar(const Redraw : Boolean); +var + PC : TColor; + + procedure DrawBasicShape; + begin + with Canvas do begin + Pen.Color := clWindowFrame; + Brush.Color := PC; + Brush.Style := bsSolid; + FillRect(Rect(scTopLeft.X, scTopLeft.Y, scBottomRight.X, scBottomRight.Y)); + end; + end; + + procedure DrawFace(State : TOvcSpinState; Up : Boolean); + begin + with Canvas do begin + case State of + ssUpBtn : + begin + scDrawArrow(Rect(scTopLeftCenter.X, scTopMiddle.Y, scTopRightCenter.X, scCenter.Y), not(Up), dUp); + scDrawLine(scTopMiddle, scTopRightCenter, Up, ltStarLine0); + scDrawLine(scTopRightCenter, scCenter, Up, ltStarLine5); + scDrawLine(scCenter, scTopLeftCenter, Up, ltStarLine5); + scDrawLine(scTopMiddle, scTopLeftCenter, Up, ltStarLine0); + end; + ssDownBtn : + begin + scDrawArrow(Rect(scBottomLeftCenter.X, scCenter.Y, scBottomRightCenter.X, scBottomMiddle.Y), not(Up), dDown); + scDrawLine(scBottomMiddle, scBottomLeftCenter, Up, ltStarLine1); + scDrawLine(scCenter, scBottomLeftCenter, Up, ltStarLine4); + scDrawLine(scBottomRightCenter, scCenter, Up, ltStarLine4); + scDrawLine(scBottomMiddle, scBottomRightCenter, Up, ltStarLine1); + end; + ssLeftBtn : + begin + scDrawArrow(Rect(scLeftMiddle.X, scTopLeftCenter.Y, scCenter.X, scBottomLeftCenter.Y), not(Up), dLeft); + scDrawLine(scLeftMiddle, scTopLeftCenter, Up, ltStarLine0); + scDrawLine(scTopLeftCenter, scCenter, Up, ltStarLine4); + scDrawLine(scCenter, scBottomLeftCenter, Up, ltStarLine5); + scDrawLine(scBottomLeftCenter, scLeftMiddle, Up, ltStarLine1); + end; + ssRightBtn : + begin + scDrawArrow(Rect(scCenter.X, scTopRightCenter.Y, scRightMiddle.X, scBottomRightCenter.Y),not(Up), dRight); + scDrawLine(scCenter, scTopRightCenter, Up, ltStarLine4); + scDrawLine(scTopRightCenter, scRightMiddle, Up, ltStarLine0); + scDrawLine(scRightMiddle, scBottomRightCenter, Up, ltStarLine1); + scDrawLine(scBottomRightCenter, scCenter, Up, ltStarLine5); + end; + end; + end; + end; + +begin + {get current parent color} + {$IFDEF VERSION5} + if (Parent is TCustomForm) then + PC := TForm(Parent).Color + else if (Parent is TCustomFrame) then + PC := TFrame(Parent).Color + {$ELSE} + if Parent is TForm then + PC := TForm(Parent).Color + {$ENDIF} + else + PC := Color; + + with Canvas do begin + if Redraw then begin + DrawBasicShape; + DrawFace(ssUpBtn, True); + DrawFace(ssDownBtn, True); + DrawFace(ssLeftBtn, True); + DrawFace(ssRightBtn, True); + end; + + if scPrevState <> scCurrentState then + DrawFace(scPrevState, True); + if scMouseOverBtn then + DrawFace(scCurrentState, False); + end; +end; + +procedure TOvcSpinner.scDrawStarButton(const Redraw : Boolean); +var + PC : TColor; + + procedure DrawBasicShape; + begin + with Canvas do begin + Pen.Color := clWindowFrame; + Brush.Color := PC; + Brush.Style := bsSolid; + FillRect(Rect(scTopLeft.X, scTopLeft.Y, + scBottomRight.X, scBottomRight.Y)); + end; + end; + + procedure DrawFace(State : TOvcSpinState; Up : Boolean); + begin + with Canvas do begin + case State of + ssUpBtn : + begin + scDrawArrow(Rect(scTopLeftCenter.X, scTopMiddle.Y, + scTopRightCenter.X, scTopLeftCenter.Y), not(Up), dUp); + scDrawLine(scTopMiddle, scTopRightCenter, Up, ltStarLine0); + scDrawLine(scTopRightCenter, scTopLeftCenter, Up, ltStarLine1); + scDrawLine(scTopMiddle, scTopLeftCenter, Up, ltStarLine0); + end; + ssDownBtn : + begin + scDrawArrow(Rect(scBottomLeftCenter.X, scBottomLeftCenter.Y, + scBottomRightCenter.X, scBottomMiddle.Y),not(Up), dDown); + scDrawLine(scBottomMiddle, scBottomLeftCenter, Up, ltStarLine1); + scDrawLine(scBottomRightCenter, scBottomLeftCenter, Up, ltStarLine0); + scDrawLine(scBottomMiddle, scBottomRightCenter, Up, ltStarLine1); + end; + ssLeftBtn : + begin + scDrawArrow(Rect(scLeftMiddle.X, scTopLeftCenter.Y, + scTopLeftCenter.X, scBottomLeftCenter.Y), not(Up), dLeft); + scDrawLine(scLeftMiddle, scTopLeftCenter, Up, ltStarLine0); + scDrawLine(scTopLeftCenter, scBottomLeftCenter, Up, ltStarLine1); + scDrawLine(scBottomLeftCenter, scLeftMiddle, Up, ltStarLine1); + end; + ssRightBtn : + begin + scDrawArrow(Rect(scTopRightCenter.X, scTopRightCenter.Y, + scRightMiddle.X, scBottomRightCenter.Y), not(Up), dRight); + scDrawLine(scTopRightCenter, scBottomRightCenter, Up, ltStarLine0); + scDrawLine(scRightMiddle, scTopRightCenter, Up, ltStarLine0); + scDrawLine(scBottomRightCenter, scRightMiddle, Up, ltStarLine1); + end; + ssCenterBtn : + begin + scDrawLine(scTopLeftCenter, scTopRightCenter, Up, ltStarLine2); + scDrawLine(scTopLeftCenter, scBottomLeftCenter, Up, ltStarLine2); + scDrawLine(scTopRightCenter, scBottomRightCenter, Up, ltStarLine3); + scDrawLine(scBottomLeftCenter, scBottomRightCenter, Up, ltStarLine3); + end; + end; + end; + end; + +begin + {get current parent color} + {$IFDEF VERSION5} + if (Parent is TCustomForm) then + PC := TForm(Parent).Color + else if (Parent is TCustomFrame) then + PC := TFrame(Parent).Color + {$ELSE} + if Parent is TForm then + PC := TForm(Parent).Color + {$ENDIF} + else + PC := Color; + + with Canvas do begin + if Redraw then begin + DrawBasicShape; + DrawFace(ssUpBtn, True); + DrawFace(ssDownBtn, True); + DrawFace(ssLeftBtn, True); + DrawFace(ssRightBtn, True); + DrawFace(ssCenterBtn, True); + end; + + if scPrevState <> scCurrentState then + DrawFace(scPrevState, True); + if scMouseOverBtn then + DrawFace(scCurrentState, False); + end; +end; + +procedure TOvcSpinner.scInvalidateButton(const State : TOvcSpinState); +begin + case State of + ssUpBtn : InvalidateRgn(Handle, scUpRgn, False); + ssDownBtn : InvalidateRgn(Handle, scDownRgn, False); + ssLeftBtn : InvalidateRgn(Handle, scLeftRgn, False); + ssRightBtn : InvalidateRgn(Handle, scRightRgn, False); + ssCenterBtn : InvalidateRgn(Handle, scCenterRgn, False); + end; +end; + +procedure TOvcSpinner.scPolyline(const Points: array of TPoint); +begin + Canvas.Polyline(Points); + with Points[High(Points)] do + Canvas.Pixels[X,Y] := Canvas.Pen.Color; +end; + +procedure TOvcSpinner.scUpdateNormalSizes; +var + scHeight : Integer; {Height of client area} + scWidth : Integer; {Width of client area} +begin + {get size of client area} + scWidth := scBottomRight.X; + scHeight := scBottomRight.Y; + + {setup the TRect structures with new sizes} + if FStyle = stNormalVertical then begin + scUpRgn := CreateRectRgn(0, 0, scWidth, scHeight div 2); + scDownRgn := CreateRectRgn(0, scHeight div 2, scWidth, scHeight); + end else begin + scUpRgn := CreateRectRgn(scWidth div 2, 0, scWidth, scHeight); + scDownRgn := CreateRectRgn(0, 0, scWidth div 2, scHeight); + end; +end; + +procedure TOvcSpinner.scUpdateFourWaySizes; +var + Points : array[0..2] of TPoint; +begin + Points[0] := scTopLeft; + Points[1] := scTopRight; + Points[2] := scCenter; + scUpRgn := CreatePolygonRgn(Points, 3, ALTERNATE); + + Points[0] := scBottomLeft; + Points[1] := scCenter; + Points[2] := scBottomRight; + scDownRgn := CreatePolygonRgn(Points, 3, ALTERNATE); + + Points[0] := scTopLeft; + Points[1] := scCenter; + Points[2] := scBottomLeft; + scLeftRgn := CreatePolygonRgn(Points, 3, ALTERNATE); + + Points[0] := scTopRight; + Points[1] := scBottomRight; + Points[2] := scCenter; + scRightRgn := CreatePolygonRgn(Points, 3, ALTERNATE); +end; + +procedure TOvcSpinner.scUpdateStarSizes; +var + Points : array[0..3] of TPoint; +begin + {up} + Points[0] := scTopMiddle; + Points[1] := scTopRightCenter; + Points[2] := scTopLeftCenter; + scUpRgn := CreatePolygonRgn(Points, 3, ALTERNATE); + + {down} + Points[0] := scBottomMiddle; + Points[1] := scBottomLeftCenter; + Points[2] := scBottomRightCenter; + scDownRgn := CreatePolygonRgn(Points, 3, ALTERNATE); + + {left} + Points[0] := scLeftMiddle; + Points[1] := scTopLeftCenter; + Points[2] := scBottomLeftCenter; + scLeftRgn := CreatePolygonRgn(Points, 3, ALTERNATE); + + {right} + Points[0] := scRightMiddle; + Points[1] := scBottomRightCenter; + Points[2] := scTopRightCenter; + scRightRgn := CreatePolygonRgn(Points, 3, ALTERNATE); + + {center} + Points[0] := scTopLeftCenter; + Points[1] := scTopRightCenter; + Points[2] := scBottomRightCenter; + Points[3] := scBottomLeftCenter; + scCenterRgn := CreatePolygonRgn(Points, 4, ALTERNATE); +end; + +procedure TOvcSpinner.scUpdateDiagonalVerticalSizes; +var + Points : array[0..2] of TPoint; +begin + Points[0] := scTopLeft; + Points[1] := scTopRight; + Points[2] := scBottomLeft; + scUpRgn := CreatePolygonRgn(Points, 3, ALTERNATE); + + Points[0] := scBottomLeft; + Points[1] := scTopRight; + Points[2] := scBottomRight; + scDownRgn := CreatePolygonRgn(Points, 3, ALTERNATE); +end; + +procedure TOvcSpinner.scUpdateDiagonalHorizontalSizes; +var + Points : array[0..2] of TPoint; +begin + Points[0] := scTopLeft; + Points[1] := scTopRight; + Points[2] := scBottomLeft; + scLeftRgn := CreatePolygonRgn(Points, 3, ALTERNATE); + + Points[0] := scBottomLeft; + Points[1] := scTopRight; + Points[2] := scBottomRight; + scRightRgn := CreatePolygonRgn(Points, 3, ALTERNATE); +end; + +procedure TOvcSpinner.scUpdateDiagonalFourWaySizes; +var + Points : array[0..3] of TPoint; +begin + Points[0] := scTopLeft4; + Points[1] := scTopRight4; + Points[2] := scBottomLeft4; + scUpRgn := CreatePolygonRgn(Points, 3, ALTERNATE); + + Points[0] := scTopRight4; + Points[1] := scBottomRight4; + Points[2] := scBottomLeft4; + scDownRgn := CreatePolygonRgn(Points, 3, ALTERNATE); + + Points[0] := scTopLeft; + Points[1] := scTopLeft4; + Points[2] := scBottomLeft4; + Points[3] := scBottomLeft; + scLeftRgn := CreatePolygonRgn(Points, 4, ALTERNATE); + + Points[0] := scTopRight4; + Points[1] := scTopRight; + Points[2] := scBottomRight; + Points[3] := scBottomRight4; + scRightRgn := CreatePolygonRgn(Points, 4, ALTERNATE); +end; + +procedure TOvcSpinner.scUpdatePlainStarSizes; +var + Points : array[0..3] of TPoint; +begin + Points[0] := scTopMiddle; + Points[1] := scTopRightCenter; + Points[2] := scCenter; + Points[3] := scTopLeftCenter; + scUpRgn := CreatePolygonRgn(Points, 4, ALTERNATE); + + Points[0] := scBottomLeftCenter; + Points[1] := scCenter; + Points[2] := scBottomRightCenter; + Points[3] := scBottomMiddle; + scDownRgn := CreatePolygonRgn(Points, 4, ALTERNATE); + + Points[0] := scLeftMiddle; + Points[1] := scTopLeftCenter; + Points[2] := scCenter; + Points[3] := scBottomLeftCenter; + scLeftRgn := CreatePolygonRgn(Points, 4, ALTERNATE); + + Points[0] := scTopRightCenter; + Points[1] := scRightMiddle; + Points[2] := scBottomRightCenter; + Points[3] := scCenter; + scRightRgn := CreatePolygonRgn(Points, 4, ALTERNATE); +end; + +procedure TOvcSpinner.scUpdateSizes; +begin + {store info about button locations} + scDeleteRegions; + + case FStyle of + stNormalVertical : scUpdateNormalSizes; + stNormalHorizontal : scUpdateNormalSizes; + stFourWay : scUpdateFourWaySizes; + stStar : scUpdateStarSizes; + stDiagonalVertical : scUpdateDiagonalVerticalSizes; + stDiagonalHorizontal : scUpdateDiagonalHorizontalSizes; + stDiagonalFourWay : scUpdateDiagonalFourWaySizes; + stPlainStar : scUpdatePlainStarSizes; + end; +end; + +procedure TOvcSpinner.Paint; +begin + scDrawButton(True); +end; + +procedure TOvcSpinner.SetAcceleration(const Value : Integer); +begin + if Value <= 10 then + FAcceleration := Value; +end; + +{ - Added} +procedure TOvcSpinner.SetAutoRepeat(Value: Boolean); +begin + FAutoRepeat := Value; + if FAutoRepeat and not (csLoading in ComponentState) then + scDoAutoRepeat; +end; + +procedure TOvcSpinner.SetBounds(ALeft, ATop, AWidth, AHeight: Integer); +var + L, T, H, W : Integer; +begin + if (csDesigning in ComponentState) and not (csLoading in ComponentState) then begin + {limit smallest size} + if AWidth < scDefMinSize then + AWidth := scDefMinSize ; + if AHeight < scDefMinSize then + AHeight := scDefMinSize ; + end; + + L := Left; + T := Top; + H := Height; + W := Width; + + inherited SetBounds(ALeft, ATop, AWidth, AHeight); + + if (L <> Left) or (T <> Top) or (H <> Height) or (W <> Width) then begin + + scTopLeft := Point(0 , 0 ); + scTopRight := Point(Width-1 , 0 ); + scBottomLeft := Point(0 , Height-1); + scBottomRight := Point(Width-1 , Height-1); + scCenter := Point(Width div 2 , Height div 2 ); + + scTopLeftCenter := Point(Width * 1 div 3 , Height * 1 div 3 ); + scBottomLeftCenter := Point(Width * 1 div 3 , Height * 2 div 3 ); + scTopRightCenter := Point(Width * 2 div 3 , Height * 1 div 3 ); + scBottomRightCenter:= Point(Width * 2 div 3 , Height * 2 div 3 ); + + scTopMiddle := Point(Width div 2 , 0 ); + scBottomMiddle:= Point(Width div 2 , Height - 1 ); + scLeftMiddle := Point(0 , Height div 2 ); + scRightMiddle := Point(Width - 1 , Height div 2 ); + + scTopLeft4 := Point(Width div 4 , 0 ); + scBottomLeft4 := Point(Width div 4 , Height - 1 ); + scTopRight4 := Point(Width * 3 div 4, 0 ); + scBottomRight4:= Point(Width * 3 div 4, Height - 1 ); + end; + + {update sizes of control and button regions} + scUpdateSizes; + + if HandleAllocated then + Invalidate; +end; + +procedure TOvcSpinner.SetShowArrows(const Value : Boolean); +begin + if Value <> FShowArrows then begin + FShowArrows := Value; + Invalidate; + end; +end; + +procedure TOvcSpinner.SetStyle(Value : TOvcSpinnerStyle); +begin + if Value <> FStyle then begin + FStyle := Value; +{$IFNDEF LCL} + RecreateWnd; +{$ELSE} + MyMisc.RecreateWnd(Self); +{$ENDIF} + if not (csLoading in ComponentState) then + SetBounds(Left, Top, Width, Height); {force resize} + end; +end; + +procedure TOvcSpinner.WMGetDlgCode(var Msg : TWMGetDlgCode); +begin + {tell windows we are a static control to avoid receiving the focus} + Msg.Result := DLGC_STATIC; +end; + +procedure TOvcSpinner.WMLButtonDown(var Msg : TWMLButtonDown); +begin + inherited; + + if Assigned(FFocusedControl) then begin + if GetFocus <> FFocusedControl.Handle then begin + {set focus to ourself to force field validation} + SetFocus; + + {allow message processing} + Application.ProcessMessages; + + {if we didn't keep the focus, something must have happened--exit} + if (GetFocus <> Handle) then + Exit; + end; + + if GetFocus <> FFocusedControl.Handle then + if FFocusedControl.CanFocus then + FFocusedControl.SetFocus; + end; + + try + scDoMouseDown(Msg.XPos, Msg.YPos); + except + scDoMouseUp; + raise; + end; +end; + +procedure TOvcSpinner.WMLButtonUp(var Msg : TWMLButtonUp); +begin + inherited; + scDoMouseUp; +end; + + +end. diff --git a/components/orpheus/ovcsf.pas b/components/orpheus/ovcsf.pas new file mode 100644 index 000000000..4d2765042 --- /dev/null +++ b/components/orpheus/ovcsf.pas @@ -0,0 +1,2046 @@ +{*********************************************************} +{* OVCSF.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovcsf; + {-Simple field visual component} + +interface + +uses + {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, LclType, MyMisc, {$ENDIF} + Classes, Controls, Graphics, SysUtils, + OvcBase, OvcColor, OvcCaret, OvcConst, OvcData, OvcEF, OvcExcpt, + OvcIntl, OvcMisc, OvcStr; + +type + {simple field type names} + TSimpleDataType = ( + sftString, sftChar, sftBoolean, sftYesNo, + sftLongInt, sftWord, sftInteger, sftByte, sftShortInt, + sftReal, sftExtended, sftDouble, sftSingle, sftComp); + +type + TOvcCustomSimpleField = class(TOvcBaseEntryField) + {.Z+} + protected {private} + {property instance variables} + FSimpleDataType : TSimpleDataType; {data type for this field} + FPictureMask : AnsiChar; {picture mask name} + + function sfGetDataType(Value : TSimpleDataType) : Byte; + {-return a Byte value representing the type of this field} + procedure sfResetFieldProperties(FT : TSimpleDataType); + {-reset field properties} + procedure sfSetDefaultRanges; + {-set default range values based on the field type} + + protected + procedure CreateWnd; + override; + + procedure efEdit(var Msg : TMessage; Cmd : Word); + override; + {-process the specified editing command} + function efGetDisplayString(Dest : PAnsiChar; Size : Word) : PAnsiChar; + override; + {-return the display string in Dest and a pointer as the result} + procedure efIncDecValue(Wrap : Boolean; Delta : Double); + override; + {-increment field by Delta} + function efTransfer(DataPtr : Pointer; TransferFlag : Word) : Word; + override; + {-transfer data to/from the entry fields} + + {virtual property methods} + procedure sfSetDataType(Value : TSimpleDataType); + virtual; + {-set the data type for this field} + procedure sfSetPictureMask(Value: AnsiChar); + virtual; + {-set the picture mask} + + public + procedure Assign(Source : TPersistent); + override; + constructor Create(AOwner: TComponent); + override; + + function efValidateField : Word; + override; + {-validate contents of field; result is error code or 0} + {.Z-} + + {public properties} + property DataType : TSimpleDataType + read FSimpleDataType + write sfSetDataType; + + property PictureMask : AnsiChar + read FPictureMask + write sfSetPictureMask; + + end; + + TOvcSimpleField = class(TOvcCustomSimpleField) + published + {inherited properties} + property DataType; {needs to loaded before most other properties} + {$IFDEF VERSION4} + property Anchors; + property Constraints; + property DragKind; + {$ENDIF} + property AutoSize; + property BorderStyle; + property CaretIns; + property CaretOvr; + property Color; + property ControlCharColor; + property Controller; + property Ctl3D; + property Borders; + property DecimalPlaces; + property DragCursor; + property DragMode; + property EFColors; + property Enabled; + property Font; + property LabelInfo; + property MaxLength; + property Options; + property PadChar; + property ParentColor; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PasswordChar; + property PictureMask; + property PopupMenu; + property RangeHi stored False; + property RangeLo stored False; + property ShowHint; + property TabOrder; + property TabStop default True; + property Tag; + property TextMargin; + property Uninitialized; + property Visible; + property ZeroDisplay; + property ZeroDisplayValue; + + {inherited events} + property AfterEnter; + property AfterExit; + property OnChange; + property OnClick; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEndDrag; + property OnEnter; + property OnError; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnStartDrag; + property OnMouseWheel; + property OnUserCommand; + property OnUserValidation; + end; + +implementation + +{*** TOvcCustomSimpleField ***} + +procedure TOvcCustomSimpleField.Assign(Source : TPersistent); +var + SF : TOvcCustomSimpleField absolute Source; +begin + if (Source <> nil) and (Source is TOvcCustomSimpleField) then begin + DataType := SF.DataType; + AutoSize := SF.AutoSize; + BorderStyle := SF.BorderStyle; + Color := SF.Color; + ControlCharColor := SF.ControlCharColor; + DecimalPlaces := SF.DecimalPlaces; + EFColors.Error.Assign(SF.EFColors.Error); + EFColors.Highlight.Assign(SF.EFColors.Highlight); + MaxLength := SF.MaxLength; + Options := SF.Options; + PadChar := SF.PadChar; + PasswordChar := SF.PasswordChar; + PictureMask := SF.PictureMask; + RangeHi := SF.RangeHi; + RangeLo := SF.RangeLo; + TextMargin := SF.TextMargin; + Uninitialized := SF.Uninitialized; + ZeroDisplay := SF.ZeroDisplay; + ZeroDisplayValue := SF.ZeroDisplayValue; + end else + inherited Assign(Source); +end; + +constructor TOvcCustomSimpleField.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + + FSimpleDataType := sftString; + FPictureMask := pmAnyChar; + + efFieldClass := fcSimple; + efDataType := sfGetDataType(FSimpleDataType); + efPicture[0] := pmAnyChar; + efPicture[1] := #0; +end; + +procedure TOvcCustomSimpleField.CreateWnd; +var + P : array[0..MaxEditLen+1] of Byte; +begin + {save field data} + if efSaveData then + efTransfer(@P, otf_GetData); + + inherited CreateWnd; + + sfSetDefaultRanges; + efSetInitialValue; + + {if we saved the field data, restore it} + if efSaveData then + efTransfer(@P, otf_SetData); + + {set save data flag} + efSaveData := True; +end; + +procedure TOvcCustomSimpleField.efEdit(var Msg : TMessage; Cmd : Word); + {-process the specified editing command} + + procedure EditSimple(var Msg : TMessage; Cmd : Word); + {-process the specified editing command for String and PChar fields} + label + ExitPoint; + var + SaveHPos : Word; + DelEnd : Word; + Len : Word; + Ch : AnsiChar; + PrevCh : AnsiChar; + MF : ShortInt; + HaveSel : Boolean; + SelExtended : Boolean; + + function CharIsOK : Boolean; + {-return true if Ch can be added to the string} + var + PrevCh : AnsiChar; + begin + if efIsNumericType then + if Ch = IntlSupport.DecimalChar then + Ch := pmDecimalPt + else if Ch = pmDecimalPt then + Ch := #0; + if (Ch < ' ') and not (sefLiteral in sefOptions) then begin + CharIsOK := False; + Exit; + end; + if efHPos = 0 then + PrevCh := ' ' + else + PrevCh := efEditSt[efHPos-1]; + CharIsOK := efCharOK(efPicture[0], Ch, PrevCh, True); + if efIsNumericType and (Ch = pmDecimalPt) then + Ch := IntlSupport.DecimalChar; + end; + + function CheckAutoAdvance(SP : Integer) : Boolean; + {-see if we need to auto-advance to next/previous field} + begin + CheckAutoAdvance := False; + if (SP < 0) and + (efoAutoAdvanceLeftRight in Controller.EntryOptions) then begin + efMoveFocusToPrevField; + CheckAutoAdvance := True; + end else if (SP >= MaxLength) then + if (Cmd = ccChar) and + (efoAutoAdvanceChar in Controller.EntryOptions) then begin + efMoveFocusToNextField; + CheckAutoAdvance := True; + end else if (Cmd <> ccChar) and + (efoAutoAdvanceLeftRight in Controller.EntryOptions) then begin + efMoveFocusToNextField; + CheckAutoAdvance := True; + end; + end; + + procedure FixSelValues; + var + I : Integer; + begin + if efSelStart > efSelEnd then begin + I := efSelStart; + efSelStart := efSelEnd; + efSelEnd := I; + end; + end; + + procedure UpdateSel; + begin + if efSelStart = SaveHPos then + efSelStart := efHPos + else + efSelEnd := efHPos; + FixSelValues; + end; + + procedure WordLeftPrim; + begin + Dec(efHPos); + while (efHPos >= 0) and ((efHPos >= Len) or (efEditSt[efHPos] = ' ')) do + Dec(efHPos); + while (efHPos >= 0) and (efEditSt[efHPos] <> ' ') do + Dec(efHPos); + Inc(efHPos); + end; + + procedure WordRightPrim; + begin + if efEditSt[efHPos] <> ' ' then + Inc(efHPos); + while (efHPos < Len) and (efEditSt[efHPos] <> ' ') do + Inc(efHPos); + while (efHPos < Len) and (efEditSt[efHPos] = ' ') do + Inc(efHPos); + end; + + procedure DeleteSel; + begin + StrStDeletePrim(efEditSt, efSelStart, efSelEnd-efSelStart); + Len := StrLen(efEditSt); + efHPos := efSelStart; + efSelEnd := efHPos; + MF := 10; + end; + + procedure PastePrim(P : PAnsiChar); + var + Ch : AnsiChar; + IsNum : Boolean; + begin + if HaveSel then + DeleteSel; + IsNum := efIsNumericType; + while P^ <> #0 do begin + Ch := P^; + if IsNum then + if Ch = IntlSupport.DecimalChar then + Ch := pmDecimalPt + else if (Ch = pmDecimalPt) or (Ch = ' ') then + Ch := #0; + if efCharOK(efPicture[0], Ch, #255, True) then begin + if (Len = MaxLength) and (efHPos < Len) and + (efoInsertPushes in Controller.EntryOptions) then begin + Dec(Len); + efEditSt[Len] := #0; + end; + if (Len < MaxLength) then begin + if efIsNumericType and (Ch = pmDecimalPt) then + Ch := IntlSupport.DecimalChar; + StrChInsertPrim(efEditSt, Ch, efHPos); + Inc(efHPos); + Inc(Len); + end; + MF := 10; + end; + Inc(P); + end; + end; + + begin + HaveSel := efSelStart <> efSelEnd; + MF := Ord(HaveSel); + SaveHPos := efHPos; + SelExtended := False; + + case Cmd of + ccAccept : {}; + ccCtrlChar : Include(sefOptions, sefLiteral); + else + if Cmd <> ccChar then + Exclude(sefOptions, sefLiteral); + end; + + Len := StrLen(efEditSt); + Exclude(sefOptions, sefCharOK); + + case Cmd of + ccChar : + begin + Ch := AnsiChar(Lo(Msg.wParam)); + if (sefAcceptChar in sefOptions) and CharIsOk then begin + Exclude(sefOptions, sefAcceptChar); + Exclude(sefOptions, sefLiteral); + if HaveSel then begin + DeleteSel; + if efHPos = 0 then + PrevCh := ' ' + else + PrevCh := efEditSt[efHPos-1]; + efCharOK(efPicture[0], Ch, PrevCh, True); + end; + if (sefInsert in sefOptions) then begin + if (Len = MaxLength) and (efHPos < Len) and + (efoInsertPushes in Controller.EntryOptions) then begin + Dec(Len); + efEditSt[Len] := #0; + end; + if (Len < MaxLength) then begin + StrChInsertPrim(efEditSt, Ch, efHPos); + Inc(efHPos); + CheckAutoAdvance(efHPos); + end else if not CheckAutoAdvance(efHPos) then + efConditionalBeep; + end else if (efHPos+1) <= MaxLength then begin + efEditSt[efHPos] := Ch; + if efHPos >= Len then + efEditSt[efHPos+1] := #0; + Inc(efHPos); + CheckAutoAdvance(efHPos); + end else begin + if not CheckAutoAdvance(efHPos) then + efConditionalBeep; + Dec(MF, 10); + end; + Inc(MF, 10); + end else begin + Exclude(sefOptions, sefLiteral); + if sefAcceptChar in sefOptions then + efConditionalBeep + else + goto ExitPoint; + end; + end; + ccMouse : + if Len > 0 then begin + efHPos := efGetMousePos(SmallInt(Msg.lParamLo)); + {drag highlight initially if shift key is being pressed} + if (GetKeyState(vk_Shift) < 0) then begin + SelExtended := True; + if HaveSel then begin + if efHPos > efSelStart then + efSelEnd := efHPos + else + efSelStart := efHPos; + end else begin + efSelStart := SaveHPos; + efSelEnd := efHPos; + end; + FixSelValues; + end else begin + SetSelection(efHPos, efHPos); + efPositionCaret(False); + end; + end; + ccMouseMove : + if Len > 0 then begin + efHPos := efGetMousePos(SmallInt(Msg.lParamLo)); + UpdateSel; + end; + ccDblClk : + if Len > 0 then begin + efHPos := efGetMousePos(SmallInt(Msg.lParamLo)); + WordLeftPrim; + SaveHPos := efHPos; + efSelStart := SaveHPos; + efSelEnd := SaveHPos; + WordRightPrim; + UpdateSel; + end; +{$IFDEF LCL} //LCL form not seeing tab (?), so handle tab command here} + ccTab : efMoveFocusToNextField; +{$ENDIF} + ccLeft : + if efHPos > 0 then + Dec(efHPos) + else + CheckAutoAdvance(-1); + ccRight : + if efHPos < Len then + Inc(efHPos) + else + CheckAutoAdvance(MaxLength); + ccUp : + if (efoAutoAdvanceUpDown in Controller.EntryOptions) then + efMoveFocusToPrevField + else if (efoArrowIncDec in Options) and not (efoReadOnly in Options) then + IncreaseValue(True, 1) + else if efHPos > 0 then + Dec(efHPos) + else + CheckAutoAdvance(-1); + ccDown : + if (efoAutoAdvanceUpDown in Controller.EntryOptions) then + efMoveFocusToNextField + else if (efoArrowIncDec in Options) and not (efoReadOnly in Options) then + DecreaseValue(True, 1) + else if efHPos < Len then + Inc(efHPos) + else + CheckAutoAdvance(MaxLength); + ccWordLeft : + if efHPos > 0 then + WordLeftPrim + else + CheckAutoAdvance(-1); + ccWordRight : + if efHPos < Len then + WordRightPrim + else + CheckAutoAdvance(MaxLength); + ccHome : + efHPos := 0; + ccEnd : + efHPos := Len; + ccExtendLeft : + if efHPos > 0 then begin + Dec(efHPos); + UpdateSel; + end else + MF := -1; + ccExtendRight : + if efHPos < Len then begin + Inc(efHPos); + UpdateSel; + end else + MF := -1; + ccExtendHome : + begin + efHPos := 0; + UpdateSel; + end; + ccExtendEnd : + begin + efHPos := Len; + UpdateSel; + end; + ccExtWordLeft : + if efHPos > 0 then begin + WordLeftPrim; + UpdateSel; + end else + MF := -1; + ccExtWordRight : + if efHPos < Len then begin + WordRightPrim; + UpdateSel; + end else + MF := -1; + ccCut : + if HaveSel then + DeleteSel; + ccCopy : efCopyPrim; + ccPaste : + {for some reason, a paste action within the IDE} + {gets passed to the control. filter it out} + if not (csDesigning in ComponentState) then + PastePrim(PAnsiChar(Msg.lParam)); + ccBack : + if HaveSel then + DeleteSel + else if efHPos > 0 then begin + Dec(efHPos); + StrStDeletePrim(efEditSt, efHPos, 1); + MF := 10; + end; + ccDel : + if HaveSel then + DeleteSel + else if efHPos < Len then begin + StrStDeletePrim(efEditSt, efHPos, 1); + MF := 10; + end; + ccDelWord : + if HaveSel then + DeleteSel + else if efHPos < Len then begin + {start deleting at the caret} + DelEnd := efHPos; + + {delete all of the current word, if any} + if efEditSt[efHPos] <> ' ' then + while (efEditSt[DelEnd] <> ' ') and (DelEnd < Len) do + Inc(DelEnd); + + {delete any spaces prior to the next word, if any} + while (efEditSt[DelEnd] = ' ') and (DelEnd < Len) do + Inc(DelEnd); + + StrStDeletePrim(efEditSt, efHPos, DelEnd-efHPos); + MF := 10; + end; + ccDelLine : + if Len > 0 then begin + efEditSt[0] := #0; + efHPos := 0; + MF := 10; + end; + ccDelEol : + if efHPos < Len then begin + efEditSt[efHPos] := #0; + MF := 10; + end; + ccDelBol : + if Len > 0 then begin + StrStDeletePrim(efEditSt, 0, efHPos); + efHPos := 0; + MF := 10; + end; + ccIns : + begin + if sefInsert in sefOptions then + Exclude(sefOptions, sefInsert) + else + Include(sefOptions, sefInsert); + efCaret.InsertMode := (sefInsert in sefOptions); + end; + ccRestore : Restore; + ccAccept : + begin + Include(sefOptions, sefCharOK); + Include(sefOptions, sefAcceptChar); + Exit; + end; + ccDec : + DecreaseValue(True, 1); + ccInc : + IncreaseValue(True, 1); + ccCtrlChar, ccSuppress, ccPartial : + goto ExitPoint; + else + Include(sefOptions, sefCharOK); + goto ExitPoint; + end; + Exclude(sefOptions, sefAcceptChar); + + case Cmd of + ccRestore, ccMouseMove, ccDblClk, + ccExtendLeft, ccExtendRight, + ccExtendHome, ccExtendEnd, + ccExtWordLeft, ccExtWordRight : + Inc(MF); + ccMouse : + if SelExtended then + Inc(MF); + ccCut, ccCopy, ccPaste : {}; + else + efSelStart := efHPos; + efSelEnd := efHPos; + end; + + ExitPoint: + if efPositionCaret(True) then + Inc(MF); + if MF >= 10 then + efFieldModified; + if MF > 0 then + Invalidate; + end; + + procedure EditChar(var Msg : TMessage; Cmd : Word); + {-process the specified editing command for Char fields} + label + ExitPoint; + var + MF : Byte; + Ch : AnsiChar; + + function CharIsOK : Boolean; + {-return true if Ch can be added to the string} + begin + if (Ch < ' ') and not (sefLiteral in sefOptions) then + CharIsOK := False + else + CharIsOK := efCharOK(efPicture[0], Ch, ' ', True); + end; + + function CheckAutoAdvance(SP : Integer) : Boolean; + {-see if we need to auto-advance to next/previous field} + begin + CheckAutoAdvance := False; + if (SP < 0) and + (efoAutoAdvanceLeftRight in Controller.EntryOptions) then begin + efMoveFocusToPrevField; + Result := True; + end else if (SP > 0) then + if (Cmd = ccChar) and + (efoAutoAdvanceChar in Controller.EntryOptions) then begin + efMoveFocusToNextField; + Result := True; + end else if (Cmd <> ccChar) and + (efoAutoAdvanceLeftRight in Controller.EntryOptions) then begin + efMoveFocusToNextField; + Result := True; + end; + end; + + procedure PastePrim(P : PAnsiChar); + begin + while P^ <> #0 do begin + Ch := P^; + if efCharOK(efPicture[0], Ch, #255, True) then begin + efEditSt[0] := Ch; + MF := 10; + Exit; + end; + Inc(P); + end; + end; + + begin + MF := Ord(efSelStart <> efSelEnd); + case Cmd of + ccAccept : ; + ccCtrlChar : + Include(sefOptions, sefLiteral); + else + efHPos := 0; + if Cmd <> ccChar then + Exclude(sefOptions, sefLiteral); + end; + + Exclude(sefOptions, sefCharOK); + case Cmd of + ccChar : + begin + Ch := AnsiChar(Lo(Msg.wParam)); + if sefAcceptChar in sefOptions then + if CharIsOk then begin + efEditSt[0] := Ch; + efEditSt[1] := #0; + CheckAutoAdvance(1); + MF := 10; + end else + efConditionalBeep; + {end;} + sefOptions := sefOptions - [sefAcceptChar, sefLiteral]; + end; + ccLeft, ccWordLeft : + CheckAutoAdvance(-1); + ccRight, ccWordRight : + CheckAutoAdvance(MaxLength); + ccUp : + if (efoAutoAdvanceUpDown in Controller.EntryOptions) then + efMoveFocusToPrevField + else + CheckAutoAdvance(-1); + ccDown : + if (efoAutoAdvanceUpDown in Controller.EntryOptions) then + efMoveFocusToNextField + else + CheckAutoAdvance(MaxLength); + ccRestore : + Restore; + ccExtendRight, ccExtendEnd, ccExtWordRight : + efSelEnd := 1; + ccMouseMove : + if efGetMousePos(SmallInt(Msg.lParamLo)) > 0 then + efSelEnd := 1 + else + efSelEnd := 0; + ccDblClk : + efSelEnd := 1; + ccCopy : efCopyPrim; + ccPaste : + {for some reason, a paste action within the IDE} + {gets passed to the control. filter it out} + if not (csDesigning in ComponentState) then + PastePrim(PAnsiChar(Msg.lParam)); + ccAccept : + begin + sefOptions := sefOptions + [sefCharOK, sefAcceptChar]; + Exit; + end; + ccMouse, ccExtendLeft, ccExtendHome, ccExtWordLeft : ; + ccDec : + DecreaseValue(True, 1); + ccInc : + IncreaseValue(True, 1); + ccCtrlChar, ccSuppress, ccPartial : + goto ExitPoint; + else + Include(sefOptions, sefCharOK); + goto ExitPoint; + end; + Exclude(sefOptions, sefAcceptChar); + + case Cmd of + ccRestore, ccMouseMove, ccDblClk, ccExtendRight, + ccExtendEnd, ccExtWordRight : + Inc(MF); + else + efSelStart := 0; + efSelEnd := 0; + end; + + ExitPoint: + if efPositionCaret(True) then + Inc(MF); + if MF >= 10 then + efFieldModified; + if MF > 0 then + Invalidate; + end; + +begin {edit} + case FSimpleDataType of + sftString, + sftLongInt, sftWord, sftInteger, sftByte, sftShortInt, + sftReal, sftExtended, sftDouble, sftSingle, sftComp : + EditSimple(Msg, Cmd); + sftChar, sftBoolean, sftYesNo : + EditChar(Msg, Cmd); + end; +end; + +function TOvcCustomSimpleField.efGetDisplayString(Dest : PAnsiChar; Size : Word) : PAnsiChar; + {-return the display string in Dest and a pointer as the result} +var + Len : Word; +begin + Result := inherited efGetDisplayString(Dest, Size); + + Len := StrLen(Dest); + if Len = 0 then + Exit; + + if Uninitialized and not (sefHaveFocus in sefOptions) then begin + FillChar(Dest[0], Len, ' '); + Exit; + end; + + if (efoPasswordMode in Options) then + FillChar(Dest[0], Len, PasswordChar); + + if PadChar <> ' ' then begin + FillChar(Dest[Len], MaxLength-Len, PadChar); + Dest[MaxLength] := #0; + end; +end; + +procedure TOvcCustomSimpleField.efIncDecValue(Wrap : Boolean; Delta : Double); + {-increment field by Delta} +var + S : TEditString; + + procedure IncDecValueChar; + {-increment Char field by Delta} + var + C, CC, CL, CH, MC : AnsiChar; + OK : Boolean; + begin + {get valid range} + CL := efRangeLo.rtChar; + CH := efRangeHi.rtChar; + if CL = CH then begin + CL := #1; + CH := #255; + end; + + {get current character} + C := efEditSt[0]; + + {get mask character} + MC := efPicture[0]; + + {exit if we're at the range limit and not allowed to wrap} + if (Delta < 0) and (C = CL) then begin + if not Wrap then + Exit; + end else if (Delta > 0) and (C = CH) then + if not Wrap then + Exit; + + {find the next/prev allowable character} + OK := False; + repeat + repeat + if Delta = 1 then + Inc(C) + else + Dec(C); + CC := C; + efFixCase(MC, CC, ' '); + until efCharOK(MC, C, ' ', False) and (C = CC); + + {check result to see if it's in valid range} + if (C >= CL) and (C <= CH) then + OK := True + else if Wrap then + OK := False + else + Exit; + until OK; + + efTransfer(@C, otf_SetData); + efPerformRepaint(True); + end; + + procedure IncDecValueBoolean; + var + Ch : AnsiChar; + B : Boolean; + begin + Ch := UpCaseChar(efEditSt[0]); + if Ch = IntlSupport.TrueChar then + Ch := IntlSupport.FalseChar + else + Ch := IntlSupport.TrueChar; + B := Ch = IntlSupport.TrueChar; + + efTransfer(@B, otf_SetData); + efPerformRepaint(True); + end; + + procedure IncDecValueYesNo; + var + Ch : AnsiChar; + B : Boolean; + begin + Ch := UpCaseChar(efEditSt[0]); + if Ch = IntlSupport.YesChar then + Ch := IntlSupport.NoChar + else + Ch := IntlSupport.YesChar; + B := Ch = IntlSupport.YesChar; + + efTransfer(@B, otf_SetData); + efPerformRepaint(True); + end; + + procedure IncDecValueLongInt; + var + L : LongInt; + begin + if efStr2Long(efEditSt, L) then begin + if (Delta < 0) and (L <= efRangeLo.rtLong) then + if Wrap then + L := efRangeHi.rtLong + else Exit + else if (Delta > 0) and (L >= efRangeHi.rtLong) then + if Wrap then + L := efRangeLo.rtLong + else Exit + else + Inc(L, Trunc(Delta)); + + {insure valid value} + if L < efRangeLo.rtLong then + L := efRangeLo.rtLong; + if L > efRangeHi.rtLong then + L := efRangeHi.rtLong; + + efTransfer(@L, otf_SetData); + efPerformRepaint(True); + end; + end; + + procedure IncDecValueReal; + var + Re : Real; + Code : Integer; + begin + {convert efEditSt to a real} + StrLCopy(S, efEditSt, 80); + FixRealPrim(S, IntlSupport.DecimalChar); +{$IFNDEF FPC} + Val(S, Re, Code); +{$ELSE} + Val(String(S), Re, Code); +{$ENDIF} + if Code = 0 then begin + if (Delta < 0) and (Re <= efRangeLo.rtReal) then + if Wrap then + Re := efRangeHi.rtReal + else Exit + else if (Delta > 0) and (Re >= efRangeHi.rtReal) then + if Wrap then + Re := efRangeLo.rtReal + else Exit + else + Re := Re + Delta; + + {insure valid value} + if Re < efRangeLo.rtReal then + Re := efRangeLo.rtReal; + if Re > efRangeHi.rtReal then + Re := efRangeHi.rtReal; + + efTransfer(@Re, otf_SetData); + efPerformRepaint(True); + end; + end; + + procedure IncDecValueExtended; + var + Ex : Extended; + Code : Integer; + begin + {convert efEditSt to an real} + StrLCopy(S, efEditSt, 80); + FixRealPrim(S, IntlSupport.DecimalChar); +{$IFNDEF FPC} + Val(S, Ex, Code); +{$ELSE} + Val(String(S), Ex, Code); +{$ENDIF} + if Code = 0 then begin + if (Delta < 0) and (Ex <= efRangeLo.rtExt) then + if Wrap then + Ex := efRangeHi.rtExt + else Exit + else if (Delta > 0) and (Ex >= efRangeHi.rtExt) then + if Wrap then + Ex := efRangeLo.rtExt + else Exit + else + Ex := Ex + Delta; + + {insure valid value} + if Ex < efRangeLo.rtExt then + Ex := efRangeLo.rtExt; + if Ex > efRangeHi.rtExt then + Ex := efRangeHi.rtExt; + + efTransfer(@Ex, otf_SetData); + efPerformRepaint(True); + end; + end; + + procedure IncDecValueDouble; + var + Db : Double; + Code : Integer; + begin + {convert efEditSt to an real} + StrLCopy(S, efEditSt, 80); + FixRealPrim(S, IntlSupport.DecimalChar); +{$IFNDEF FPC} + Val(S, Db, Code); +{$ELSE} + Val(String(S), Db, Code); +{$ENDIF} + if Code = 0 then begin + if (Delta < 0) and (Db <= efRangeLo.rtExt) then + if Wrap then + Db := efRangeHi.rtExt + else Exit + else if (Delta > 0) and (Db >= efRangeHi.rtExt) then + if Wrap then + Db := efRangeLo.rtExt + else Exit + else + Db := Db + Delta; + + {insure valid value} + if Db < efRangeLo.rtExt then + Db := efRangeLo.rtExt; + if Db > efRangeHi.rtExt then + Db := efRangeHi.rtExt; + + efTransfer(@Db, otf_SetData); + efPerformRepaint(True); + end; + end; + + procedure IncDecValueSingle; + var + Si : Single; + Code : Integer; + begin + {convert efEditSt to an real} + StrLCopy(S, efEditSt, 80); + FixRealPrim(S, IntlSupport.DecimalChar); +{$IFNDEF FPC} + Val(S, Si, Code); +{$ELSE} + Val(String(S), Si, Code); +{$ENDIF} + if Code = 0 then begin + if (Delta < 0) and (Si <= efRangeLo.rtExt) then + if Wrap then + Si := efRangeHi.rtExt + else Exit + else if (Delta > 0) and (Si >= efRangeHi.rtExt) then + if Wrap then + Si := efRangeLo.rtExt + else Exit + else + Si := Si + Delta; + + {insure valid value} + if Si < efRangeLo.rtExt then + Si := efRangeLo.rtExt; + if Si > efRangeHi.rtExt then + Si := efRangeHi.rtExt; + + efTransfer(@Si, otf_SetData); + efPerformRepaint(True); + end; + end; + + procedure IncDecValueComp; + var +{$IFNDEF FPC} + Co : Comp; +{$ELSE} + {$IFDEF CPU86} + Co : Comp; + {$ELSE} + Co : Double; + {$ENDIF} +{$ENDIF} + Code : Integer; + begin + {convert efEditSt to an real} + StrLCopy(S, efEditSt, 80); + FixRealPrim(S, IntlSupport.DecimalChar); +{$IFNDEF FPC} + Val(S, Co, Code); +{$ELSE} + Val(String(S), Co, Code); +{$ENDIF} + if Code = 0 then begin + if (Delta < 0) and (Co <= efRangeLo.rtExt) then + if Wrap then + Co := efRangeHi.rtExt + else Exit + else if (Delta > 0) and (Co >= efRangeHi.rtExt) then + if Wrap then + Co := efRangeLo.rtExt + else Exit + else + Co := Co + Delta; + + {insure valid value} + if Co < efRangeLo.rtExt then + Co := efRangeLo.rtExt; + if Co > efRangeHi.rtExt then + Co := efRangeHi.rtExt; + + efTransfer(@Co, otf_SetData); + efPerformRepaint(True); + end; + end; + +begin + if not (sefHaveFocus in sefOptions) then + Exit; + case FSimpleDataType of + sftString : {not supported for this field type}; + sftChar : IncDecValueChar; + sftBoolean : IncDecValueBoolean; + sftYesNo : IncDecValueYesNo; + sftLongInt, + sftWord, + sftInteger, + sftByte, + sftShortInt : IncDecValueLongInt; + sftReal : IncDecValueReal; + sftExtended : IncDecValueExtended; + sftDouble : IncDecValueDouble; + sftSingle : IncDecValueSingle; + sftComp : IncDecValueComp; + else + raise EOvcException.Create(GetOrphStr(SCInvalidParamValue)); + end; + efPositionCaret(False); +end; + +function TOvcCustomSimpleField.efTransfer(DataPtr : Pointer; TransferFlag : Word) : Word; + {-transfer data to/from the entry fields} +var + S : TEditString; + + procedure TransferString; + var + I : Integer; + begin + if TransferFlag = otf_GetData then + ShortString(DataPtr^) := StrPas(efEditSt) + else begin + if ShortString(DataPtr^) = '' then + efEditSt[0] := #0 + else begin + StrPLCopy(efEditSt, ShortString(DataPtr^), MaxLength); + for I := 0 to Integer(StrLen(efEditSt))-1 do + efFixCase(efNthMaskChar(I), efEditSt[I], #255); + end; + end; + end; + + procedure TransferChar; + begin + if TransferFlag = otf_GetData then + AnsiChar(DataPtr^) := efEditSt[0] + else begin + efEditSt[0] := AnsiChar(DataPtr^); + efEditSt[1] := #0; + end; + end; + + procedure TransferBoolean; + begin + if TransferFlag = otf_GetData then + Boolean(DataPtr^) := (UpCaseChar(efEditSt[0]) = IntlSupport.TrueChar) + else begin + if Boolean(DataPtr^) then + efEditSt[0] := IntlSupport.TrueChar + else + efEditSt[0] := IntlSupport.FalseChar; + efEditSt[1] := #0; + end; + end; + + procedure TransferYesNo; + begin + if TransferFlag = otf_GetData then + Boolean(DataPtr^) := (UpCaseChar(efEditSt[0]) = IntlSupport.YesChar) + else begin + if Boolean(DataPtr^) then + efEditSt[0] := IntlSupport.YesChar + else + efEditSt[0] := IntlSupport.NoChar; + efEditSt[1] := #0; + end; + end; + + procedure TransferLongInt; + begin + if TransferFlag = otf_GetData then begin + if not efStr2Long(efEditSt, LongInt(DataPtr^)) then + LongInt(DataPtr^) := 0; + end else + efLong2Str(efEditSt, LongInt(DataPtr^)); + end; + + procedure TransferWord; + var + L : LongInt; + begin + if TransferFlag = otf_GetData then begin + if efStr2Long(efEditSt, L) then + Word(DataPtr^) := Word(L) + else + Word(DataPtr^) := 0; + end else + efLong2Str(efEditSt, Word(DataPtr^)); + end; + + procedure TransferInteger; + var + L : LongInt; + begin + if TransferFlag = otf_GetData then begin + if efStr2Long(efEditSt, L) then + SmallInt(DataPtr^) := SmallInt(L) + else + SmallInt(DataPtr^) := 0; + end else + efLong2Str(efEditSt, SmallInt(DataPtr^)); + end; + + procedure TransferByte; + var + L : LongInt; + begin + if TransferFlag = otf_GetData then begin + if efStr2Long(efEditSt, L) then + Byte(DataPtr^) := Byte(L) + else + Byte(DataPtr^) := 0; + end else + efLong2Str(efEditSt, Byte(DataPtr^)); + end; + + procedure TransferShortInt; + var + L : LongInt; + begin + if TransferFlag = otf_GetData then begin + if efStr2Long(efEditSt, L) then + ShortInt(DataPtr^) := ShortInt(L) + else + ShortInt(DataPtr^) := 0; + end else + efLong2Str(efEditSt, ShortInt(DataPtr^)); + end; + + procedure TransferReal; + label + UseExp; + var + Code : Integer; + I : Cardinal; + R : Real; + begin + if TransferFlag = otf_GetData then begin + StrCopy(S, efEditSt); + FixRealPrim(S, IntlSupport.DecimalChar); +{$IFNDEF FPC} + Val(PAnsiChar(@S[0]), R, Code); +{$ELSE} + Val(String(PAnsiChar(@S[0])), R, Code); +{$ENDIF} + if Code <> 0 then + R := 0; + Real(DataPtr^) := R; + end else begin + {try to use regular notation} + R := Real(DataPtr^); + if StrScan(efPicture, pmScientific) <> nil then + goto UseExp; + Str(R:0:DecimalPlaces, S); + + {trim trailing 0's if appropriate} + if StrScan(S, pmDecimalPt) <> nil then + TrimTrailingZerosPChar(S); + + {does it fit?} + if StrLen(S) > MaxLength then begin + {won't fit--use scientific notation} + UseExp: + if (DecimalPlaces <> 0) and (9+DecimalPlaces < MaxLength) then + Str(R:9+DecimalPlaces, S) + else + Str(R:MaxLength, S); + TrimAllSpacesPChar(S); + TrimEmbeddedZerosPChar(S); + end; + + {convert decimal point} + if StrChPos(S, pmDecimalPt, I) then + S[I] := IntlSupport.DecimalChar; + + StrLCopy(efEditSt, S, MaxLength); + end; + end; + + procedure TransferExtended; + label + UseExp; + var + Code : Integer; + I : Cardinal; + E : Extended; + begin + if TransferFlag = otf_GetData then begin + StrCopy(S, efEditSt); + FixRealPrim(S, IntlSupport.DecimalChar); +{$IFNDEF FPC} + Val(S, E, Code); +{$ELSE} + Val(String(S), E, Code); +{$ENDIF} + if Code <> 0 then + E := 0; + Extended(DataPtr^) := E; + end else begin + {try to use regular notation} + E := Extended(DataPtr^); + if StrScan(efPicture, pmScientific) <> nil then + goto UseExp; + Str(E:0:DecimalPlaces, S); + + {trim trailing 0's if appropriate} + if StrScan(S, pmDecimalPt) <> nil then + TrimTrailingZerosPChar(S); + + {does it fit?} + if StrLen(S) > MaxLength then begin + {won't fit--use scientific notation} + UseExp: + if (DecimalPlaces <> 0) and (9+DecimalPlaces < MaxLength) then + Str(E:9+DecimalPlaces, S) + else + Str(E:MaxLength, S); + TrimAllSpacesPChar(S); + TrimEmbeddedZerosPChar(S); + end; + + {convert decimal point} + if StrChPos(S, pmDecimalPt, I) then + S[I] := IntlSupport.DecimalChar; + + StrLCopy(efEditSt, S, MaxLength); + end; + end; + + procedure TransferDouble; + label + UseExp; + var + Code : Integer; + I : Cardinal; + D : Double; + begin + if TransferFlag = otf_GetData then begin + StrCopy(S, efEditSt); + FixRealPrim(S, IntlSupport.DecimalChar); +{$IFNDEF FPC} + Val(PAnsiChar(@S[0]), D, Code); +{$ELSE} + Val(String(PAnsiChar(@S[0])), D, Code); +{$ENDIF} + if Code <> 0 then + D := 0; + Double(DataPtr^) := D; + end else begin + {try to use regular notation} + D := Double(DataPtr^); + if StrScan(efPicture, pmScientific) <> nil then + goto UseExp; + Str(D:0:DecimalPlaces, S); + + {trim trailing 0's if appropriate} + if StrScan(S, pmDecimalPt) <> nil then + TrimTrailingZerosPChar(S); + + {does it fit?} + if StrLen(S) > MaxLength then begin + {won't fit--use scientific notation} + UseExp: + if (DecimalPlaces <> 0) and (9+DecimalPlaces < MaxLength) then + Str(D:9+DecimalPlaces, S) + else + Str(D:MaxLength, S); + TrimAllSpacesPChar(S); + TrimEmbeddedZerosPChar(S); + end; + + {convert decimal point} + if StrChPos(S, pmDecimalPt, I) then + S[I] := IntlSupport.DecimalChar; + + StrLCopy(efEditSt, S, MaxLength); + end; + end; + + procedure TransferSingle; + label + UseExp; + var + Code : Integer; + I : Cardinal; + G : Single; + begin + if TransferFlag = otf_GetData then begin + StrCopy(S, efEditSt); + FixRealPrim(S, IntlSupport.DecimalChar); +{$IFNDEF FPC} + Val(S, G, Code); +{$ELSE} + Val(String(S), G, Code); +{$ENDIF} + if Code <> 0 then + G := 0; + Single(DataPtr^) := G; + end else begin + {try to use regular notation} + G := Single(DataPtr^); + if StrScan(efPicture, pmScientific) <> nil then + goto UseExp; + Str(G:0:DecimalPlaces, S); + + {trim trailing 0's if appropriate} + if StrScan(S, pmDecimalPt) <> nil then + TrimTrailingZerosPChar(S); + + {does it fit?} + if StrLen(S) > MaxLength then begin + {won't fit--use scientific notation} + UseExp: + if (DecimalPlaces <> 0) and (9+DecimalPlaces < MaxLength) then + Str(G:9+DecimalPlaces, S) + else + Str(G:MaxLength, S); + TrimAllSpacesPChar(S); + TrimEmbeddedZerosPChar(S); + end; + + {convert decimal point} + if StrChPos(S, pmDecimalPt, I) then + S[I] := IntlSupport.DecimalChar; + + StrLCopy(efEditSt, S, MaxLength); + end; + end; + + procedure TransferComp; + {-transfer data to or from Comp fields} + label + UseExp; + var + Code : Integer; +{$IFNDEF FPC} + C : Comp; +{$ELSE} + {$IFDEF CPU86} + C : Comp; + {$ELSE} + C : Double; + {$ENDIF} +{$ENDIF} + begin + if TransferFlag = otf_GetData then begin + StrCopy(S, efEditSt); + FixRealPrim(S, IntlSupport.DecimalChar); +{$IFNDEF FPC} + Val(PAnsiChar(@S[0]), C, Code); +{$ELSE} + Val(String(PAnsiChar(@S[0])), C, Code); +{$ENDIF} + if Code <> 0 then + C := 0; +{$IFNDEF FPC} + Comp(DataPtr^) := C; +{$ELSE} + {$IFDEF CPU86} + Comp(DataPtr^) := C; + {$ELSE} + Double(DataPtr^) := C; + {$ENDIF} +{$ENDIF} + end else begin + {try to use regular notation} +{$IFNDEF FPC} + C := Comp(DataPtr^); +{$ELSE} + {$IFDEF CPU86} + C := Comp(DataPtr^); + {$ELSE} + C := Double(DataPtr^); + {$ENDIF} +{$ENDIF} + if StrScan(efPicture, pmScientific) <> nil then + goto UseExp; + Str(C:0:DecimalPlaces, S); + + {trim trailing 0's if appropriate} + if StrScan(S, pmDecimalPt) <> nil then + TrimTrailingZerosPChar(S); + + {does it fit?} + if StrLen(S) > MaxLength then begin + {won't fit--use scientific notation} + UseExp: + Str(C:MaxLength, S); + TrimAllSpacesPChar(S); + TrimEmbeddedZerosPChar(S); + end; + StrLCopy(efEditSt, S, MaxLength); + end; + end; + +begin {transfer} + if DataPtr = nil then begin + Result := 0; + Exit; + end; + + case FSimpleDataType of + sftString : TransferString; + sftChar : TransferChar; + sftBoolean : TransferBoolean; + sftYesNo : TransferYesNo; + sftLongInt : TransferLongInt; + sftWord : TransferWord; + sftInteger : TransferInteger; + sftByte : TransferByte; + sftShortInt : TransferShortInt; + sftReal : TransferReal; + sftExtended : TransferExtended; + sftDouble : TransferDouble; + sftSingle : TransferSingle; + sftComp : TransferComp; + else + raise EOvcException.Create(GetOrphStr(SCInvalidParamValue)); + end; + + Result := inherited efTransfer(DataPtr, TransferFlag); +end; + +function TOvcCustomSimpleField.efValidateField : Word; + {-validate contents of field; result is error code or 0} +var + S : TEditString; + + procedure ValidateString; + var + L : Word; + begin + if sefGettingValue in sefOptions then + Exit; + + if efoTrimBlanks in Options then + if sefHaveFocus in sefOptions then begin + L := StrLen(efEditSt); + TrimAllSpacesPChar(efEditSt); + if StrLen(efEditSt) <> L then + Invalidate; + end; + end; + + procedure ValidateChar; + begin + if (efRangeLo.rtChar <> efRangeHi.rtChar) and + ((efEditSt[0] < efRangeLo.rtChar) or (efEditSt[0] > efRangeHi.rtChar)) then + Result := oeRangeError; + end; + + procedure ValidateBoolean; + begin + if (UpCaseChar(efEditSt[0]) <> IntlSupport.TrueChar) and + (UpCaseChar(efEditSt[0]) <> IntlSupport.FalseChar) then + Result := oeRangeError; + end; + + procedure ValidateYesNo; + begin + if (UpCaseChar(efEditSt[0]) <> IntlSupport.YesChar) and + (UpCaseChar(efEditSt[0]) <> IntlSupport.NoChar) then + Result := oeRangeError; + end; + + procedure ValidateLongInt; + var + L : LongInt; + begin + if not efStr2Long(efEditSt, L) then + Result := oeInvalidNumber + else if (L < efRangeLo.rtLong) or (L > efRangeHi.rtLong) then + Result := oeRangeError + else begin + if sefHaveFocus in sefOptions then + if not (sefGettingValue in sefOptions) then begin + efTransfer(@L, otf_SetData); + Invalidate; + end; + end; + end; + + procedure ValidateWord; + var + L : LongInt; + begin + if not efStr2Long(efEditSt, L) then + Result := oeInvalidNumber + else if (L < efRangeLo.rtLong) or (L > efRangeHi.rtLong) then + Result := oeRangeError + else begin + if sefHaveFocus in sefOptions then + if not (sefGettingValue in sefOptions) then begin + efTransfer(@L, otf_SetData); + Invalidate; + end; + end; + end; + + procedure ValidateInteger; + var + L : LongInt; + I : Integer; + begin + if not efStr2Long(efEditSt, L) then + Result := oeInvalidNumber + else if (L < efRangeLo.rtLong) or (L > efRangeHi.rtLong) then + Result := oeRangeError + else begin + if sefHaveFocus in sefOptions then + if not (sefGettingValue in sefOptions) then begin + I := L; + efTransfer(@I, otf_SetData); + Invalidate; + end; + end; + end; + + procedure ValidateByte; + var + L : LongInt; + B : Byte; + begin + if not efStr2Long(efEditSt, L) then + Result := oeInvalidNumber + else if (L < efRangeLo.rtLong) or (L > efRangeHi.rtLong) then + Result := oeRangeError + else begin + if sefHaveFocus in sefOptions then + if not (sefGettingValue in sefOptions) then begin + B := L; + efTransfer(@B, otf_SetData); + Invalidate; + end; + end; + end; + + procedure ValidateShortInt; + var + L : LongInt; + Si : ShortInt; + begin + if not efStr2Long(efEditSt, L) then + Result := oeInvalidNumber + else if (L < efRangeLo.rtLong) or (L > efRangeHi.rtLong) then + Result := oeRangeError + else begin + if sefHaveFocus in sefOptions then + if not (sefGettingValue in sefOptions) then begin + Si := L; + efTransfer(@Si, otf_SetData); + Invalidate; + end; + end; + end; + + procedure ValidateReal; + var + R : Real; + Code : Integer; + begin + {convert efEditSt to a real} + StrLCopy(S, efEditSt, 80); + FixRealPrim(S, IntlSupport.DecimalChar); +{$IFNDEF FPC} + Val(S, R, Code); +{$ELSE} + Val(String(S), R, Code); +{$ENDIF} + + {format OK?} + if Code <> 0 then + Result := oeInvalidNumber + else if (R < efRangeLo.rtReal) or (R > efRangeHi.rtReal) then + Result := oeRangeError + else begin + if sefHaveFocus in sefOptions then + if not (sefGettingValue in sefOptions) then begin + efTransfer(@R, otf_SetData); + Invalidate; + end; + end; + end; + + procedure ValidateExtended; + var + E : Extended; + Code : Integer; + begin + {convert efEditSt to an extended} + StrLCopy(S, efEditSt, 80); + FixRealPrim(S, IntlSupport.DecimalChar); +{$IFNDEF FPC} + Val(S, E, Code); +{$ELSE} + Val(String(S), E, Code); +{$ENDIF} + if Code <> 0 then + Result := oeInvalidNumber + else if (E < efRangeLo.rtExt) or (E > efRangeHi.rtExt) then + Result := oeRangeError + else begin + if sefHaveFocus in sefOptions then + if not (sefGettingValue in sefOptions) then begin + efTransfer(@E, otf_SetData); + Invalidate; + end; + end; + end; + + procedure ValidateDouble; + var + E : Extended; + D : Double; + Code : Integer; + begin + {convert efEditSt to an extended} + StrLCopy(S, efEditSt, 80); + FixRealPrim(S, IntlSupport.DecimalChar); +{$IFNDEF FPC} + Val(S, E, Code); +{$ELSE} + Val(String(S), E, Code); +{$ENDIF} + if Code <> 0 then + Result := oeInvalidNumber + else if (E < efRangeLo.rtExt) or (E > efRangeHi.rtExt) then + Result := oeRangeError + else begin + if sefHaveFocus in sefOptions then + if not (sefGettingValue in sefOptions) then begin + D := E; + efTransfer(@D, otf_SetData); + Invalidate; + end; + end; + end; + + procedure ValidateSingle; + var + E : Extended; + Si : Single; + Code : Integer; + begin + {convert efEditSt to an extended} + StrLCopy(S, efEditSt, 80); + FixRealPrim(S, IntlSupport.DecimalChar); +{$IFNDEF FPC} + Val(S, E, Code); +{$ELSE} + Val(String(S), E, Code); +{$ENDIF} + if Code <> 0 then + Result := oeInvalidNumber + else if (E < efRangeLo.rtExt) or (E > efRangeHi.rtExt) then + Result := oeRangeError + else begin + if sefHaveFocus in sefOptions then + if not (sefGettingValue in sefOptions) then begin + Si := E; + efTransfer(@Si, otf_SetData); + Invalidate; + end; + end; + end; + + procedure ValidateComp; + var + E : Extended; +{$IFNDEF FPC} + C : Comp; +{$ELSE} + {$IFDEF CPU86} + C : Comp; + {$ELSE} + C : Double; + {$ENDIF} +{$ENDIF} + Code : Integer; + begin + {convert efEditSt to an extended} + StrLCopy(S, efEditSt, 80); + FixRealPrim(S, IntlSupport.DecimalChar); +{$IFNDEF FPC} + Val(S, C, Code); +{$ELSE} + Val(String(S), C, Code); +{$ENDIF} + E := C; + if Code <> 0 then + Result := oeInvalidNumber + else if (E < efRangeLo.rtExt) or (E > efRangeHi.rtExt) then + Result := oeRangeError + else begin + if sefHaveFocus in sefOptions then + if not (sefGettingValue in sefOptions) then begin + efTransfer(@C, otf_SetData); + Invalidate; + end; + end; + end; + +begin + Result := 0; + case FSimpleDataType of + sftString : ValidateString; + sftChar : ValidateChar; + sftBoolean : ValidateBoolean; + sftYesNo : ValidateYesNo; + sftLongInt : ValidateLongInt; + sftWord : ValidateWord; + sftInteger : ValidateInteger; + sftByte : ValidateByte; + sftShortInt : ValidateShortInt; + sftReal : ValidateReal; + sftExtended : ValidateExtended; + sftDouble : ValidateDouble; + sftSingle : ValidateSingle; + sftComp : ValidateComp; + end; + + if not (sefUserValidating in sefOptions) then begin + {user may retrieve data from field. flag that we are doing} + {user validation to avoid calling this routine recursively} + Include(sefOptions, sefUserValidating); + DoOnUserValidation(Result); + Exclude(sefOptions, sefUserValidating); + end; +end; + +procedure TOvcCustomSimpleField.sfSetDataType(Value : TSimpleDataType); + {-set the data type for this field} +begin + if FSimpleDataType <> Value then begin + FSimpleDataType := Value; + efDataType := sfGetDataType(FSimpleDataType); + Options := Options + [efoCaretToEnd]; + efSetDefaultRange(efDataType); + + {set defaults for this field type} + sfResetFieldProperties(FSimpleDataType); + if HandleAllocated then begin + {don't save data through create window} + efSaveData := False; +{$IFNDEF LCL} + RecreateWnd; +{$ELSE} + MyMisc.RecreateWnd(Self); +{$ENDIF} + end; + end; +end; + +procedure TOvcCustomSimpleField.sfSetPictureMask(Value: AnsiChar); + {-set the picture mask} +var + Buf : array[0..1] of AnsiChar; +begin + if FPictureMask <> Value then begin + if Value in SimplePictureChars then begin + FPictureMask := Value; + if csDesigning in ComponentState then begin + efPicture[0] := Value; + efPicture[1] := #0; + Repaint; + end else begin + Buf[0] := Value; + Buf[1] := #0; + efChangeMask(Buf); +{$IFNDEF LCL} + RecreateWnd; +{$ELSE} + MyMisc.RecreateWnd(Self); +{$ENDIF} + end; + end else + raise EInvalidPictureMask.Create(Value); + end; +end; + +function TOvcCustomSimpleField.sfGetDataType(Value : TSimpleDataType) : Byte; + {-return a Byte value representing the type of this field} +begin + case Value of + sftString : Result := fidSimpleString; + sftChar : Result := fidSimpleChar; + sftBoolean : Result := fidSimpleBoolean; + sftYesNo : Result := fidSimpleYesNo; + sftLongInt : Result := fidSimpleLongInt; + sftWord : Result := fidSimpleWord; + sftInteger : Result := fidSimpleInteger; + sftByte : Result := fidSimpleByte; + sftShortInt : Result := fidSimpleShortInt; + sftReal : Result := fidSimpleReal; + sftExtended : Result := fidSimpleExtended; + sftDouble : Result := fidSimpleDouble; + sftSingle : Result := fidSimpleSingle; + sftComp : Result := fidSimpleComp; + else + raise EOvcException.Create(GetOrphStr(SCInvalidParamValue)); + end; +end; + +procedure TOvcCustomSimpleField.sfResetFieldProperties(FT : TSimpleDataType); + {-reset field properties based on current setings} + + procedure Update(Len: Word; Mask: AnsiChar); + begin + MaxLength := Len; + FPictureMask := Mask; + efPicture[0] := Mask; + efPicture[1] := #0; + DecimalPlaces := 0; + end; + +begin + case FT of + sftString : Update(15, pmAnyChar); + sftBoolean : Update(1, pmTrueFalse); + sftYesNo : Update(1, pmYesNo); + sftChar : Update(1, pmAnyChar); + sftLongInt : Update(11, pmWhole); + sftWord : Update(5, pmPositive); + sftInteger : Update(6, pmWhole); + sftByte : Update(3, pmPositive); + sftShortInt : Update(4, pmWhole); + sftReal : Update(14, pmDecimal); + sftExtended : Update(14, pmDecimal); + sftDouble : Update(14, pmDecimal); + sftSingle : Update(14, pmDecimal); + sftComp : Update(14, pmWhole); + else + raise EOvcException.Create(GetOrphStr(SCInvalidParamValue)); + end; +end; + +procedure TOvcCustomSimpleField.sfSetDefaultRanges; + {-set default range values based on the field type} +begin + case FSimpleDataType of + sftChar, sftBoolean, sftYesNo : + if efRangeLo.rtChar = efRangeHi.rtChar then + efSetDefaultRange(efDataType); + sftLongInt, sftWord, sftInteger, sftByte, sftShortInt : + if efRangeLo.rtLong = efRangeHi.rtLong then + efSetDefaultRange(efDataType); + sftReal : + if efRangeLo.rtReal = efRangeHi.rtReal then + efSetDefaultRange(efDataType); + sftExtended, sftDouble, sftSingle, sftComp : + if efRangeLo.rtExt = efRangeHi.rtExt then + efSetDefaultRange(efDataType); + else + efSetDefaultRange(efDataType); + end; +end; + + +end. diff --git a/components/orpheus/ovcspary.pas b/components/orpheus/ovcspary.pas new file mode 100644 index 000000000..52b121617 --- /dev/null +++ b/components/orpheus/ovcspary.pas @@ -0,0 +1,698 @@ +{*********************************************************} +{* OVCSPARY.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovcspary; + {-Orpheus - sparse array implementation} + +interface + +uses + {$IFNDEF LCL} Windows, {$ELSE} LclIntf, {$ENDIF} + SysUtils, OvcExcpt, OvcConst, OvcData; + +const + MaxSparseArrayItems = 320000; {maximum items in a sparse array} + +type + TSparseArrayFunc = function (Index : longint; Item : pointer; + ExtraData : pointer) : boolean; + {-Sparse array's iterator type. Should return true to continue iterating, + false otherwise.} + + {The sparse array class} + TOvcSparseArray = class + protected {private} + FCount : longint; {Fake count of the items} + FArray : pointer; {Sparse array} + + ChunkCount : word; {Number of chunks} + ChunkArraySize : word; {Size of FArray} + + procedure RecalcCount; + + protected + function GetActiveCount : longint; + function GetItem(Index : longint) : pointer; + procedure PutItem(Index : longint; Item : pointer); + + public + constructor Create; + destructor Destroy; override; + + function Add(Item : pointer) : longint; + {-Add Item to end of array} + procedure Clear; + {-Clear array} + procedure Delete(Index : longint); + {-Delete item at Index, all items below move up one} + procedure Exchange(Index1, Index2 : longint); + {-Swap the items at Index1 and Index2} + function First : pointer; + {-Return First item} + function ForAll(Action : TSparseArrayFunc; + Backwards : boolean; + ExtraData : pointer) : longint; + {-Iterate through all active items, maybe backwards} + function IndexOf(Item : pointer) : longint; + {-Get the index of Item} + procedure Insert(Index : longint; Item : pointer); + {-Insert Item at Index, it and all items below move down one} + function Last : pointer; + {-Return Last item} + procedure Squeeze; + {-Pack the sparse array} + + property Count : longint + {-Logical count of the number of items (=IndexOf(Last)+1)} + read FCount; + property ActiveCount : longint + {-Count of non-nil items} + read GetActiveCount; + property Items[Index : longint] : pointer + {-Items array} + read GetItem write PutItem; + default; + end; + + +implementation + + +{Notes: the sparse array is implemented as an array of chunks, each + chunk contains 32 items (2^5). The array of chunks consists + of a set of elements, each with chunk index and a pointer to + the chunk. To find the item for a given index you do two + things: calculate the chunk index (divide by 32) and the + index into the chunk (the remainder once divided by 32). + For example: where is item 100? 100 = 3*32 + 4, so you try + and find chunk index 3 in the chunk array (the array is sorted + by chunk index, hence you do a binary search), and if found + return the 5th element (zero based arrays). If not found then + the item does not exist. + Thus setting item 10000 in a sparse array will allocate only + one chunk, the 9999 previous items are all assumed nil. + The sparse array can only accomodate pointers. An unused item + will be nil. A nil pointer will indicate an unused item. Hence + you cannot really use a sparse array for longints say, unless + you can guarantee that all your values will be non-nil. + + Sizing stuff: maximum number of pointers that can be stored is + just less than 350,000. For various reasons the maximum index + that is allowed for the sparse array is 319,999 meaning that a + sparse array could hold up to 320,000 pointers. To increase this + you could hold 64 or 128 pointers per chunk instead. + The minimum heap the sparse array will take is 896 bytes. + + Sparse arrays cannot really be used for keeping sorted items: + obviously all the items will appear at the start of the array, + there can be no holes. +} + +const + ShiftValue = 5; + ChunkElements = 1 shl ShiftValue; {Number of elements in a chunk: 32} + ChunkMask = pred(ChunkElements); {Mask used for the item in a chunk: $1F} + +type + PChunk = ^TChunk; {Definition of a chunk} + TChunk = array [0..pred(ChunkElements)] of pointer; + + TChunkArrayElement = packed record {Definition of a chunk array element} + ChunkIndex : word; {..index of the chunk} + Chunk : PChunk; {..the chunk itself} + end; + +const + DefChunkArrayElements = 4; {Initial size of the chunk array} + MaxChunkArrayElements = ($10000 div sizeof(TChunkArrayElement)) - 1; + {Absolute maximum of chunk array elements} + +type + PChunkArray = ^TChunkArray; {Definition of a chunk array} + TChunkArray = array [0..pred(MaxChunkArrayElements)] of TChunkArrayElement; + +{===Helper routines==================================================} +procedure RaiseException(ClassType : integer); + begin + case ClassType of + 1 : raise ESAEAtMaxSize.Create(GetOrphStr(SCSAEAtMaxSize)); + 2 : raise ESAEOutOfBounds.Create(GetOrphStr(SCSAEOutOfBounds)); + else + raise ESparseArrayError.Create(GetOrphStr(SCSAEGeneral)); + end;{case} + end; +{--------} +function GrowChunkArray(A : PChunkArray; var CurSize : word) : PChunkArray; + {-Grow the chunk array, return the new size and the new pointer} + var + NewSize : longint; + NewSizeAdj : word; + begin + NewSize := longint(CurSize) + + (DefChunkArrayElements * sizeof(TChunkArrayElement)); + NewSizeAdj := MaxChunkArrayElements * sizeof(TChunkArrayElement); + if (NewSize < NewSizeAdj) then + NewSizeAdj := NewSize; + GetMem(Result, NewSizeAdj); + {$IFOPT D+} + FillChar(Result^, NewSizeAdj, $CC); + {$ENDIF} + if (CurSize <> 0) then + begin + Move(A^, Result^, CurSize); + FreeMem(A, CurSize); + end; + CurSize := NewSizeAdj; + end; +{--------} +function GetChunk(A : PChunkArray; + CI : word; NumChunks : word) : integer; + {-Find a chunk array element given the chunk index CI and the number of + chunks. Return the index into the chunk array, or -1 if not found.} + var + L, R : integer; + MsInx : word; + begin + L := 0; + R := pred(NumChunks); + repeat + Result := (L + R) div 2; + MsInx := A^[Result].ChunkIndex; + if (CI = MsInx) then + Exit + else if (CI < MsInx) then + R := pred(Result) + else + L := succ(Result); + until (L > R); + Result := -1; + end; +{--------} +function EnsureChunk(var A : PChunkArray; CI : word; + var NumChunks, Size : word; + DontCreate : boolean) : integer; + {-Makes sure that chunk CI is available for use. If it does not yet + exist and DontCreate is false, creates a new chunk, inserts it into + the chunk array (possibly growing the array). Return the index of + the chunk in the array.} + var + NumElements : word; + L, R, M : integer; + MsInx : word; + begin + L := 0; + if (NumChunks > 0) then + begin + R := pred(NumChunks); + repeat + M := (L + R) div 2; + MsInx := A^[M].ChunkIndex; + if (CI = MsInx) then + begin + Result := M; + Exit; + end + else if (CI < MsInx) then + R := pred(M) + else + L := succ(M); + until (L > R); + end; + + if DontCreate then + begin + Result := -1; + Exit; + end; + + Result := L; + + NumElements := Size div sizeof(TChunkArrayElement); + if (NumChunks = NumElements) then + A := GrowChunkArray(A, Size); + + if (Result < NumChunks) then + Move(A^[Result], A^[succ(Result)], + (NumChunks - Result) * sizeof(TChunkArrayElement)); + + with A^[Result] do + begin + ChunkIndex := CI; + Chunk := New(PChunk); + FillChar(Chunk^, sizeof(TChunk), 0); + end; + + inc(NumChunks); + end; +{--------} +function ChunkIsBlank(A : PChunkArray; ArrayInx : word) : boolean; + {-Return true if the chunk has no items (all pointers are nil).} + const + ChunkSizeInWords = sizeof(TChunk) div 2; + ChunkSizeInDWords = sizeof(TChunk) div 4; + var + Chunk : PChunk; +{$IFDEF NoAsm} + ItemNum : Integer; +{$ENDIF} + begin + Chunk := A^[ArrayInx].Chunk; +{$IFDEF NoAsm} + for ItemNum := 0 to Pred(ChunkElements) do + begin + if Chunk^[ItemNum] <> nil then + begin + Result := False; + Exit; + end; + end; + Result := True; +{$ELSE} + asm + push edi +{$IFDEF VERSION6} { Delphi 6 codegen bug } + push ecx +{$ENDIF} + lea eax, Chunk + mov edi, [eax] + xor eax, eax + mov edx, eax + mov ecx, ChunkSizeInDWords + repe scasd + jne @@Exit + inc edx + @@Exit: +{$IFDEF VERSION6} { Delphi 6 codegen bug } + pop ecx +{$ENDIF} + mov @Result, dl + pop edi + end; +{$ENDIF} + end; +{--------} +procedure DeleteChunk(A : PChunkArray; ArrayInx : word; var NumChunks : word); + {-Delete a chunk, moving chunks below up one.} + begin + Dispose(A^[ArrayInx].Chunk); + if ArrayInx < pred(NumChunks) then + Move(A^[succ(ArrayInx)], A^[ArrayInx], + (NumChunks - ArrayInx) * sizeof(TChunkArrayElement)); + dec(NumChunks); + {$IFOPT D+} + FillChar(A^[NumChunks], sizeof(TChunkArrayElement), $CC); + {$ENDIF} + end; + +{===TOvcSparseArray ForAll routines=====================================} +function CountActiveElements(Index : longint; + Item : pointer; + ExtraData : pointer) : boolean; far; + var + ED : ^longint absolute ExtraData; + begin + Result := True; + inc(ED^); + end; +{=====} + +function Find1stOrLastElement(Index : longint; + Item : pointer; + ExtraData : pointer) : boolean; far; + var + ED : ^pointer absolute ExtraData; + begin + Find1stOrLastElement := false; + ED^ := Item; + end; +{=====} + +function FindSpecificElement(Index : longint; + Item : pointer; + ExtraData : pointer) : boolean; far; + begin + {continue looking if this Item is NOT the one we want} + FindSpecificElement := Item <> ExtraData; + end; +{=====} + +constructor TOvcSparseArray.Create; + begin + FArray := GrowChunkArray(FArray, ChunkArraySize); + end; +{=====} + +destructor TOvcSparseArray.Destroy; + begin + if Assigned(FArray) then + begin + Clear; + FreeMem(FArray, ChunkArraySize); + end; + end; +{=====} + +procedure TOvcSparseArray.RecalcCount; + var + Dummy : pointer; + begin + FCount := succ(ForAll(Find1stOrLastElement, true, @Dummy)); + end; +{--------} +procedure TOvcSparseArray.Squeeze; + var + ArrayInx : word; + begin + ArrayInx := 0; + while ArrayInx <> ChunkCount do + if ChunkIsBlank(FArray, ArrayInx) then + DeleteChunk(FArray, ArrayInx, ChunkCount) + else + inc(ArrayInx); + end; +{=======================================================================} + + +{===TOvcSparseArray property access=====================================} +function TOvcSparseArray.GetActiveCount : longint; + begin + Result := 0; + ForAll(CountActiveElements, true, @Result); + end; +{--------} +function TOvcSparseArray.GetItem(Index : longint) : pointer; + var + ChunkIndex : word; + ChunkNum : integer; + begin + if (Index < 0) or (Index >= MaxSparseArrayItems) then + begin + RaiseException(2); + end; + + Result := nil; + if (ChunkCount > 0) then + begin + ChunkIndex := Index shr ShiftValue; + ChunkNum := GetChunk(FArray, ChunkIndex, ChunkCount); + if (ChunkNum <> -1) then + Result := PChunkArray(FArray)^[ChunkNum].Chunk^[Index and ChunkMask]; + end; + end; +{--------} +procedure TOvcSparseArray.PutItem(Index : longint; Item : pointer); + var + ChunkIndex : word; + ChunkNum : integer; + begin + if (Index < 0) or (Index >= MaxSparseArrayItems) then + begin + RaiseException(2); + end; + + ChunkIndex := Index shr ShiftValue; + ChunkNum := EnsureChunk(PChunkArray(FArray), + ChunkIndex, ChunkCount, ChunkArraySize, + (Item = nil)); + + if (ChunkNum <> -1) then + begin + PChunkArray(FArray)^[ChunkNum].Chunk^[Index and ChunkMask] := Item; + if (Item = nil) then + Squeeze; + RecalcCount; + end; + end; +{====================================================================} + + +{===TOvcSparseArray item maintenance====================================} +function TOvcSparseArray.Add(Item : pointer) : longint; + begin + if (FCount = MaxSparseArrayItems) then + RaiseException(1); + + Result := FCount; + PutItem(Result, Item); + end; +{--------} +procedure TOvcSparseArray.Clear; + var + i : integer; + begin + if (ChunkCount > 0) then + begin + for i := 0 to pred(ChunkCount) do + Dispose(PChunkArray(FArray)^[i].Chunk); + {$IFOPT D+} + FillChar(FArray^, ChunkArraySize, $CC); + {$ENDIF} + end; + ChunkCount := 0; + FCount := 0; + end; +{--------} +procedure TOvcSparseArray.Delete(Index : longint); + const + LastPos = pred(ChunkElements); + var + MajorInx : word; + ChunkNum, Dummy : integer; + StartPos : word; + OurChunk : PChunk; + Transferred : boolean; + begin + if (Index < 0) or (Index >= MaxSparseArrayItems) then + begin + RaiseException(2); + end; + + if (Index >= FCount) then + Exit; + + MajorInx := Index shr ShiftValue; + ChunkNum := EnsureChunk(PChunkArray(FArray), + MajorInx, ChunkCount, ChunkArraySize, + false); + + StartPos := Index and ChunkMask; + OurChunk := PChunkArray(FArray)^[ChunkNum].Chunk; + if (StartPos <> LastPos) then + Move(OurChunk^[succ(StartPos)], OurChunk^[StartPos], + (LastPos-StartPos)*sizeof(Pointer)); + + inc(ChunkNum); + while (ChunkNum <> ChunkCount) do + begin + with PChunkArray(FArray)^[ChunkNum] do + begin + if (ChunkIndex = MajorInx+1) then + begin + Transferred := true; + OurChunk^[LastPos] := Chunk^[0]; + end + else + begin + Transferred := false; + OurChunk^[LastPos] := nil; + end; + MajorInx := ChunkIndex; + OurChunk := Chunk; + end; + if (OurChunk^[0] <> nil) and (not Transferred) then + begin + Dummy := EnsureChunk(PChunkArray(FArray), + MajorInx-1, ChunkCount, ChunkArraySize, + true); + PChunkArray(FArray)^[Dummy].Chunk^[LastPos] := + OurChunk^[0]; + end; + Move(OurChunk^[1], OurChunk^[0], LastPos*sizeof(Pointer)); + inc(ChunkNum); + end; + + OurChunk^[LastPos] := nil; + Squeeze; + RecalcCount; + end; +{--------} +procedure TOvcSparseArray.Exchange(Index1, Index2 : longint); + var + Item1, Item2 : pointer; + begin + if (Index1 = Index2) then + Exit; + + if (Index1 < 0) or (Index1 >= MaxSparseArrayItems) then + begin + RaiseException(2); + end; + if (Index2 < 0) or (Index2 >= MaxSparseArrayItems) then + begin + RaiseException(2); + end; + + Item1 := GetItem(Index1); + Item2 := GetItem(Index2); + PutItem(Index2, Item1); + PutItem(Index1, Item2); + end; +{--------} +function TOvcSparseArray.First : pointer; + begin + Result := nil; + ForAll(Find1stOrLastElement, false, @Result); + end; +{--------} +function TOvcSparseArray.ForAll(Action : TSparseArrayFunc; + Backwards : boolean; + ExtraData : pointer) : longint; + var + MajorInx : word; + MinorInx : word; + MajorStub : longint; + label + ExitLoopsReverse, ExitLoopsForwards; + begin + if (ChunkCount = 0) then + Result := -1 + else if Backwards then + begin + for MajorInx := pred(ChunkCount) downto 0 do + with PChunkArray(FArray)^[MajorInx] do + begin + MajorStub := longint(ChunkIndex) shl ShiftValue; + for MinorInx := pred(ChunkElements) downto 0 do + if (Chunk^[MinorInx] <> nil) then + begin + Result := MajorStub + MinorInx; + if not Action(Result, + Chunk^[MinorInx], + ExtraData) then + Goto ExitLoopsReverse; + end; + end; + Result := -1; + ExitLoopsReverse: + end + else + begin + for MajorInx := 0 to pred(ChunkCount) do + with PChunkArray(FArray)^[MajorInx] do + begin + MajorStub := longint(ChunkIndex) shl ShiftValue; + for MinorInx := 0 to pred(ChunkElements) do + if (Chunk^[MinorInx] <> nil) then + begin + Result := MajorStub + MinorInx; + if not Action(Result, + Chunk^[MinorInx], + ExtraData) then + Goto ExitLoopsForwards; + end; + end; + Result := -1; + ExitLoopsForwards: + end; + end; +{--------} +function TOvcSparseArray.IndexOf(Item : pointer) : longint; + begin + Result := ForAll(FindSpecificElement, true, Item); + end; +{--------} +procedure TOvcSparseArray.Insert(Index : longint; Item : pointer); + const + LastPos = pred(ChunkElements); + var + MajorInx : word; + ChunkNum : integer; + CarryItem, NewCarryItem : pointer; + StartPos : word; + begin + if (Index < 0) or (Index >= MaxSparseArrayItems) then + begin + RaiseException(2); + end; + + if (FCount = MaxSparseArrayItems) then + RaiseException(1); + + if (Index >= FCount) then + begin + PutItem(Index, Item); + Exit; + end; + + MajorInx := Index shr ShiftValue; + ChunkNum := EnsureChunk(PChunkArray(FArray), + MajorInx, ChunkCount, ChunkArraySize, + false); + + CarryItem := Item; + StartPos := Index and ChunkMask; + repeat + with PChunkArray(FArray)^[ChunkNum] do + begin + MajorInx := ChunkIndex; + NewCarryItem := Chunk^[LastPos]; + if (StartPos <> LastPos) then + Move(Chunk^[StartPos], Chunk^[succ(StartPos)], + (LastPos-StartPos)*sizeof(Pointer)); + Chunk^[StartPos] := CarryItem; + CarryItem := NewCarryItem; + StartPos := 0; + end; + inc(ChunkNum); + if (CarryItem <> nil) then + if (ChunkNum = ChunkCount) or + (PChunkArray(FArray)^[ChunkNum].ChunkIndex <> MajorInx+1) then + ChunkNum := EnsureChunk(PChunkArray(FArray), + MajorInx+1, ChunkCount, ChunkArraySize, + false); + until (ChunkNum = ChunkCount); + inc(FCount); + end; +{--------} +function TOvcSparseArray.Last : pointer; + begin + Result := nil; + ForAll(Find1stOrLastElement, true, @Result); + end; +{====================================================================} + +end. diff --git a/components/orpheus/ovcstr.pas b/components/orpheus/ovcstr.pas new file mode 100644 index 000000000..09a9a76e1 --- /dev/null +++ b/components/orpheus/ovcstr.pas @@ -0,0 +1,1262 @@ +{*********************************************************} +{* OVCSTR.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovcstr; + {-General string handling routines} + +interface + +type + BTable = array[0..255] of Byte; + {table used by the Boyer-Moore search routines} + +function BinaryBPChar(Dest : PAnsiChar; B : Byte) : PAnsiChar; + {-Return a binary PAnsiChar string for a byte} +function BinaryLPChar(Dest : PAnsiChar; L : LongInt) : PAnsiChar; + {-Return the binary PAnsiChar string for a long integer} +function BinaryWPChar(Dest : PAnsiChar; W : Word) : PAnsiChar; + {-Return the binary PAnsiChar string for a word} +procedure BMMakeTable(MatchString : PAnsiChar; var BT : BTable); + {-Build a Boyer-Moore link table} +function BMSearch(var Buffer; BufLength : Cardinal; var BT : BTable; + MatchString : PAnsiChar ; var Pos : Cardinal) : Boolean; + {-Use the Boyer-Moore search method to search a buffer for a string} +function BMSearchUC(var Buffer; BufLength : Cardinal; var BT : BTable; + MatchString : PAnsiChar ; var Pos : Cardinal) : Boolean; + {-Use the Boyer-Moore search method to search a buffer for a string. This + search is not case sensitive} +function CharStrPChar(Dest : PAnsiChar; C : AnsiChar; Len : Cardinal) : PAnsiChar; + {-Return a PAnsiChar string filled with the specified character} +function DetabPChar(Dest : PAnsiChar; Src : PAnsiChar; TabSize : Byte) : PAnsiChar; + {-Expand tabs in a PAnsiChar string to blanks} +function HexBPChar(Dest : PAnsiChar; B : Byte) : PAnsiChar; + {-Return hex PAnsiChar string for byte} +function HexLPChar(Dest : PAnsiChar; L : LongInt) : PAnsiChar; + {-Return the hex PAnsiChar string for a long integer} +function HexPtrPChar(Dest : PAnsiChar; P : Pointer) : PAnsiChar; + {-Return hex PAnsiChar string for pointer} +function HexWPChar(Dest : PAnsiChar; W : Word) : PAnsiChar; + {-Return the hex PAnsiChar string for a word} +function LoCaseChar(C : AnsiChar) : AnsiChar; + {-Convert C to lower case} +function OctalLPChar(Dest : PAnsiChar; L : LongInt) : PAnsiChar; + {-Return the octal PAnsiChar string for a long integer} +function StrChDeletePrim(P : PAnsiChar; Pos : Cardinal) : PAnsiChar; + {-Primitive routine to delete a character from a PAnsiChar string} +function StrChInsertPrim(Dest : PAnsiChar; C : AnsiChar; Pos : Cardinal) : PAnsiChar; + {-Primitive routine to insert a character into a PAnsiChar string} +function StrChPos(P : PAnsiChar; C : AnsiChar; var Pos : Cardinal) : Boolean; + {-Sets Pos to location of C in P, return is True if found} +procedure StrInsertChars(Dest : PAnsiChar; Ch : AnsiChar; Pos, Count : Word); + {-Insert count instances of Ch into S at Pos} +function StrStCopy(Dest, S : PAnsiChar; Pos, Count : Cardinal) : PAnsiChar; + {-Copy characters at a specified position in a PAnsiChar string} +function StrStDeletePrim(P : PAnsiChar; Pos, Count : Cardinal) : PAnsiChar; + {-Primitive routine to delete a sub-string from a PAnsiChar string} +function StrStInsert(Dest, S1, S2 : PAnsiChar; Pos : Cardinal) : PAnsiChar; + {-Insert a PAnsiChar string into another at a specified position} +function StrStInsertPrim(Dest, S : PAnsiChar; Pos : Cardinal) : PAnsiChar; + {-Insert a PAnsiChar string into another at a specified position. This + primitive version modifies the source directly} +function StrStPos(P, S : PAnsiChar; var Pos : Cardinal) : Boolean; + {-Sets Pos to position of the S in P, returns True if found} +function StrToLongPChar(S : PAnsiChar; var I : LongInt) : Boolean; + {-Convert a PAnsiChar string to a long integer} +procedure TrimAllSpacesPChar(P : PAnsiChar); + {-Trim leading and trailing blanks from P} +function TrimEmbeddedZeros(const S : string) : string; + {-Trim embedded zeros from a numeric string in exponential format} +procedure TrimEmbeddedZerosPChar(P : PAnsiChar); + {-Trim embedded zeros from a numeric PAnsiChar string in exponential format} +function TrimTrailPrimPChar(S : PAnsiChar) : PAnsiChar; + {-Return a PAnsiChar string with trailing white space removed} +function TrimTrailPChar(Dest, S : PAnsiChar) : PAnsiChar; + {-Return a PAnsiChar string with trailing white space removed} +function TrimTrailingZeros(const S : string) : string; + {-Trim trailing zeros from a numeric string. It is assumed that there is + a decimal point prior to the zeros. Also strips leading spaces.} +procedure TrimTrailingZerosPChar(P : PAnsiChar); + {-Trim trailing zeros from a numeric PAnsiChar string. It is assumed that + there is a decimal point prior to the zeros. Also strips leading spaces.} +function UpCaseChar(C : AnsiChar) : AnsiChar; + {-Convert a character to uppercase using the AnsiUpper API} + + +implementation + +uses + {$IFNDEF LCL} Windows, {$ELSE} LclIntf, LclType, {$ENDIF} SysUtils; + +const + Digits : array[0..$F] of AnsiChar = '0123456789ABCDEF'; + +function BinaryBPChar(Dest : PAnsiChar; B : Byte) : PAnsiChar; + {-Return binary string for byte} +var + I : Word; +begin + Result := Dest; + for I := 7 downto 0 do begin + Dest^ := Digits[Ord(B and (1 shl I) <> 0)]; {0 or 1} + Inc(Dest); + end; + Dest^ := #0; +end; + +function BinaryLPChar(Dest : PAnsiChar; L : LongInt) : PAnsiChar; + {-Return binary string for LongInt} +var + I : LongInt; +begin + Result := Dest; + for I := 31 downto 0 do begin + Dest^ := Digits[Ord(L and LongInt(1 shl I) <> 0)]; {0 or 1} + Inc(Dest); + end; + Dest^ := #0; +end; + +function BinaryWPChar(Dest : PAnsiChar; W : Word) : PAnsiChar; + {-Return binary string for word} +var + I : Word; +begin + Result := Dest; + for I := 15 downto 0 do begin + Dest^ := Digits[Ord(W and (1 shl I) <> 0)]; {0 or 1} + Inc(Dest); + end; + Dest^ := #0; +end; + +{$IFDEF NoAsm} +// These 3 routines not used by TOvcTable, etc. so don't Pascal-ize for now. +procedure BMMakeTable(MatchString : PAnsiChar; var BT : BTable); +begin + Assert(False, 'BMMakeTable not yet supported on non-Intel processors.'); +end; + +function BMSearch(var Buffer; BufLength : Cardinal; var BT : BTable; + MatchString : PAnsiChar; var Pos : Cardinal) : Boolean; +begin + Assert(False, 'BMSearch not yet supported on non-Intel processors.'); +end; + +function BMSearchUC(var Buffer; BufLength : Cardinal; var BT : BTable; + MatchString : PAnsiChar; var Pos : Cardinal) : Boolean; +begin + Assert(False, 'BMSearchUC not yet supported on non-Intel processors.'); +end; + +{$ELSE} +procedure BMMakeTable(MatchString : PAnsiChar; var BT : BTable); register; + {Build Boyer-Moore link table} +asm + push esi { Save registers because they will be changed } + push edi + push ebx + + cld { Ensure forward string ops } + mov edi, eax { Move EAX to ESI & EDI } + mov esi, eax + xor eax, eax { Zero EAX } + or ecx, -1 + repne scasb { Search for null terminator } + not ecx + dec ecx { ECX is length of search string } + cmp ecx, 0FFh { If ECX > 255, force to 255 } + jbe @@1 + mov ecx, 0FFh + +@@1: + mov ch, cl { Duplicate CL in CH } + mov eax, ecx { Fill each byte in EAX with length } + shl eax, 16 + mov ax, cx + mov edi, edx { Point to the table } + mov ecx, 64 { Fill table bytes with length } + rep stosd + cmp al, 1 { If length >= 1, we're done } + jbe @@MTDone + mov edi, edx { Reset EDI to beginning of table } + xor ebx, ebx { Zero EBX } + mov cl, al { Restore CL to length of string } + dec ecx + +@@MTNext: + lodsb { Load table with positions of letters } + mov bl, al { That exist in the search string } + mov [edi+ebx], cl + loop @@MTNext + +@@MTDone: + pop ebx { Restore registers } + pop edi + pop esi +end; + +function BMSearch(var Buffer; BufLength : Cardinal; var BT : BTable; + MatchString : PAnsiChar; var Pos : Cardinal) : Boolean; register; +var + BufPtr : Pointer; +asm + push edi { Save registers since we will be changing } + push esi + push ebx + push edx + + mov BufPtr, eax { Copy Buffer to local variable and ESI } + mov esi, eax + mov ebx, ecx { Copy BufLength to EBX } + + cld { Ensure forward string ops } + xor eax, eax { Zero out EAX so we can search for null } + mov edi, MatchString { Set EDI to beginning of MatchString } + or ecx, -1 { We will be counting down } + repne scasb { Find null } + not ecx { ECX = length of MatchString + null } + dec ecx { ECX = length of MatchString } + mov edx, ecx { Copy length of MatchString to EDX } + + pop ecx { Pop length of buffer into ECX } + mov edi, esi { Set EDI to beginning of search buffer } + mov esi, MatchString { Set ESI to beginning of MatchString } + + cmp dl, 1 { Check to see if we have a trivial case } + ja @@BMSInit { If Length(MatchString) > 1 do BM search } + jb @@BMSNotFound { If Length(MatchString) = 0 we're done } + + mov al,[esi] { If Length(MatchString) = 1 do a REPNE SCASB } + mov ebx, edi + repne scasb + jne @@BMSNotFound { No match during REP SCASB } + dec edi { Found, calculate position } + sub edi, ebx + mov esi, Pos { Set position in Pos } + mov [esi], edi + mov eax, 1 { Set result to True } + jmp @@BMSDone { We're done } + +@@BMSInit: + dec edx { Set up for BM Search } + add esi, edx { Set ESI to end of MatchString } + add ecx, edi { Set ECX to end of buffer } + add edi, edx { Set EDI to first check point } + mov dh, [esi] { Set DH to character we'll be looking for } + dec esi { Dec ESI in prep for BMSFound loop } + std { Backward string ops } + jmp @@BMSComp { Jump to first comparison } + +@@BMSNext: + mov al, [ebx+eax] { Look up skip distance from table } + add edi, eax { Skip EDI ahead to next check point } + +@@BMSComp: + cmp edi, ecx { Have we reached end of buffer? } + jae @@BMSNotFound { If so, we're done } + mov al, [edi] { Move character from buffer into AL for comparison } + cmp dh, al { Compare } + jne @@BMSNext { If not equal, go to next checkpoint } + + push ecx { Save ECX } + dec edi + xor ecx, ecx { Zero ECX } + mov cl, dl { Move Length(MatchString) to ECX } + repe cmpsb { Compare MatchString to buffer } + je @@BMSFound { If equal, string is found } + + mov al, dl { Move Length(MatchString) to AL } + sub al, cl { Calculate offset that string didn't match } + add esi, eax { Move ESI back to end of MatchString } + add edi, eax { Move EDI to pre-string compare location } + inc edi + mov al, dh { Move character back to AL } + pop ecx { Restore ECX } + jmp @@BMSNext { Do another compare } + +@@BMSFound: { EDI points to start of match } + mov edx, BufPtr { Move pointer to buffer into EDX } + sub edi, edx { Calculate position of match } + mov eax, edi + inc eax + mov esi, Pos + mov [esi], eax { Set Pos to position of match } + mov eax, 1 { Set result to True } + pop ecx { Restore ESP } + jmp @@BMSDone + +@@BMSNotFound: + xor eax, eax { Set result to False } + +@@BMSDone: + cld { Restore direction flag } + pop ebx { Restore registers } + pop esi + pop edi +end; + +function BMSearchUC(var Buffer; BufLength : Cardinal; var BT : BTable; + MatchString : PAnsiChar; var Pos : Cardinal) : Boolean; register; + {- Case-insensitive search of Buffer for MatchString. Return indicates + success or failure. Assumes MatchString is already raised to + uppercase (PRIOR to creating the table) -} +var + BufPtr : Pointer; +asm + push edi { Save registers since we will be changing } + push esi + push ebx + push edx + + mov BufPtr, eax { Copy Buffer to local variable and ESI } + mov esi, eax + mov ebx, ecx { Copy BufLength to EBX } + + cld { Ensure forward string ops } + xor eax, eax { Zero out EAX so we can search for null } + mov edi, MatchString { Set EDI to beginning of MatchString } + or ecx, -1 { We will be counting down } + repne scasb { Find null } + not ecx { ECX = length of MatchString + null } + dec ecx { ECX = length of MatchString } + mov edx, ecx { Copy length of MatchString to EDX } + + pop ecx { Pop length of buffer into ECX } + mov edi, esi { Set EDI to beginning of search buffer } + mov esi, MatchString { Set ESI to beginning of MatchString } + + or dl, dl { Check to see if we have a trivial case } + jz @@BMSNotFound { If Length(MatchString) = 0 we're done } + +@@BMSInit: + dec edx { Set up for BM Search } + add esi, edx { Set ESI to end of MatchString } + add ecx, edi { Set ECX to end of buffer } + add edi, edx { Set EDI to first check point } + mov dh, [esi] { Set DH to character we'll be looking for } + dec esi { Dec ESI in prep for BMSFound loop } + std { Backward string ops } + jmp @@BMSComp { Jump to first comparison } + +@@BMSNext: + mov al, [ebx+eax] { Look up skip distance from table } + add edi, eax { Skip EDI ahead to next check point } + +@@BMSComp: + cmp edi, ecx { Have we reached end of buffer? } + jae @@BMSNotFound { If so, we're done } + mov al, [edi] { Move character from buffer into AL for comparison } + + push ebx { Save registers } + push ecx + push edx + push eax { Push Char onto stack for CharUpper } + cld + call CharUpper + std + pop edx { Restore registers } + pop ecx + pop ebx + + cmp dh, al { Compare } + jne @@BMSNext { If not equal, go to next checkpoint } + + push ecx { Save ECX } + dec edi + xor ecx, ecx { Zero ECX } + mov cl, dl { Move Length(MatchString) to ECX } + jecxz @@BMSFound { If ECX is zero, string is found } + +@@StringComp: + mov al, [edi] { Get char from buffer } + dec edi { Dec buffer index } + + push ebx { Save registers } + push ecx + push edx + push eax { Push Char onto stack for CharUpper } + cld + call CharUpper + std + pop edx { Restore registers } + pop ecx + pop ebx + + mov ah, al { Move buffer char to AH } + lodsb { Get MatchString char } + cmp ah, al { Compare } + loope @@StringComp { OK? Get next character } + je @@BMSFound { Matched! } + + xor ah, ah { Zero AH } + mov al, dl { Move Length(MatchString) to AL } + sub al, cl { Calculate offset that string didn't match } + add esi, eax { Move ESI back to end of MatchString } + add edi, eax { Move EDI to pre-string compare location } + inc edi + mov al, dh { Move character back to AL } + pop ecx { Restore ECX } + jmp @@BMSNext { Do another compare } + +@@BMSFound: { EDI points to start of match } + mov edx, BufPtr { Move pointer to buffer into EDX } + sub edi, edx { Calculate position of match } + mov eax, edi + inc eax + mov esi, Pos + mov [esi], eax { Set Pos to position of match } + mov eax, 1 { Set result to True } + pop ecx { Restore ESP } + jmp @@BMSDone + +@@BMSNotFound: + xor eax, eax { Set result to False } + +@@BMSDone: + cld { Restore direction flag } + pop ebx { Restore registers } + pop esi + pop edi +end; +{$ENDIF} + +{$IFDEF NoAsm} +function CharStrPChar(Dest : PAnsiChar; C : AnsiChar; + Len : Cardinal) : PAnsiChar; +begin + Result := StrPCopy(Dest, StringOfChar(C, Len)); +end; + +{$ELSE} +function CharStrPChar(Dest : PAnsiChar; C : AnsiChar; + Len : Cardinal) : PAnsiChar; register; +asm + push edi { Save EDI-about to change it } + push eax { Save Dest pointer for return } + mov edi, eax { Point EDI to Dest } + + mov dh, dl { Dup character 4 times } + mov eax, edx + shl eax, $10 + mov ax, dx + + mov edx, ecx { Save Len } + + cld { Forward! } + shr ecx, 2 { Store dword char chunks first } + rep stosd + mov ecx, edx { Store remaining characters } + and ecx, 3 + rep stosb + + xor al,al { Add null terminator } + stosb + + pop eax { Return Dest pointer } + pop edi { Restore orig value of EDI } +end; +{$ENDIF} + +{$IFDEF NoAsm} +// This routine not used by TOvcTable, etc. so don't Pascal-ize for now. +function DetabPChar(Dest : PAnsiChar; Src : PAnsiChar; + TabSize : Byte) : PAnsiChar; +begin + Assert(False, 'DetabPChar not yet supported on non-Intel processors.'); +end; + +{$ELSE} +function DetabPChar(Dest : PAnsiChar; Src : PAnsiChar; + TabSize : Byte) : PAnsiChar; register; + { -Expand tabs in a string to blanks on spacing TabSize- } +asm + push eax { Save Dest for return value } + push edi { Save EDI, ESI and EBX, we'll be changing them } + push esi + push ebx + + mov esi, edx { ESI -> Src } + mov edi, eax { EDI -> Dest } + xor ebx, ebx { Get TabSize in EBX } + add bl, cl + jz @@Done { Exit if TabSize is zero } + + cld { Forward! } + xor edx, edx { Set output length to zero } + +@@Next: + lodsb { Get next input character } + or al, al { Is it a null? } + jz @@Done { Yes-all done } + cmp al, 09 { Is it a tab? } + je @@Tab { Yes, compute next tab stop } + stosb { No, store to output } + inc edx { Increment output length } + jmp @@Next { Next character } + +@@Tab: + push edx { Save output length } + mov eax, edx { Get current output length in DX:AX } + xor edx, edx + div ebx { Output length MOD TabSize in DX } + mov ecx, ebx { Calc number of spaces to insert... } + sub ecx, edx { = TabSize - Mod value } + pop edx + add edx, ecx { Add count of spaces into current output length } + + mov eax,$2020 { Blank in AH, Blank in AL } + shr ecx, 1 { Store blanks } + rep stosw + adc ecx, ecx + rep stosb + jmp @@Next { Back for next input } + +@@Done: + xor al,al { Store final null terminator } + stosb + + pop ebx { Restore caller's EBX, ESI and EDI } + pop esi + pop edi + pop eax { Return Dest } +end; +{$ENDIF} + +function HexBPChar(Dest : PAnsiChar; B : Byte) : PAnsiChar; + {-Return hex string for byte} +begin + Result := Dest; + Dest^ := Digits[B shr 4]; + Inc(Dest); + Dest^ := Digits[B and $F]; + Inc(Dest); + Dest^ := #0; +end; + +function HexLPChar(Dest : PAnsiChar; L : LongInt) : PAnsiChar; + {-Return the hex string for a long integer} +var + T2 : Array[0..4] of AnsiChar; +begin + Result := StrCat(HexWPChar(Dest, HIWORD(L)), HexWPChar(T2, LOWORD(L))); +end; + +function HexPtrPChar(Dest : PAnsiChar; P : Pointer) : PAnsiChar; + {-Return hex string for pointer} +var + T2 : Array[0..4] of AnsiChar; +begin + StrCat(HexWPChar(Dest, HIWORD(LongInt(P))), ':'); + Result := StrCat(Dest, HexWPChar(T2, LOWORD(LongInt(P)))); +end; + +function HexWPChar(Dest : PAnsiChar; W : Word) : PAnsiChar; +begin + Result := Dest; + Dest^ := Digits[Hi(W) shr 4]; + Inc(Dest); + Dest^ := Digits[Hi(W) and $F]; + Inc(Dest); + Dest^ := Digits[Lo(W) shr 4]; + Inc(Dest); + Dest^ := Digits[Lo(W) and $F]; + Inc(Dest); + Dest^ := #0; +end; + +{$IFDEF NoAsm} +function LoCaseChar(C: AnsiChar) : AnsiChar; +var + AStr : string; +begin + AStr := AnsiLowerCase(C); + Result := AStr[1]; +end; + +{$ELSE} +function LoCaseChar(C: AnsiChar) : AnsiChar; register; +asm + mov edx, eax + xor eax, eax + mov al, dl + push eax + call CharLower +end; +{$ENDIF} + +function OctalLPChar(Dest : PAnsiChar; L : LongInt) : PAnsiChar; + {-Return the octal PAnsiChar string for a long integer} +var + I : LongInt; +begin + Result := Dest; + FillChar(Dest^, 12, '0'); + Dest[12] := #0; + for I := 11 downto 0 do begin + if L = 0 then + Exit; + + Dest[I] := Digits[L and 7]; + L := L shr 3; + end; +end; + +{$IFDEF NoAsm} +function StrChDeletePrim(P : PAnsiChar; Pos : Cardinal) : PAnsiChar; +var + AStr : string; +begin + AStr := StrPas(P); + Delete(AStr, Succ(Pos), 1); + Result := StrPCopy(P, AStr); +end; + +function StrChInsertPrim(Dest : PAnsiChar; C : AnsiChar; + Pos : Cardinal) : PAnsiChar; +var + AStr : string; +begin + AStr := StrPas(Dest); + Insert(C, AStr, Succ(Pos)); + Result := StrPCopy(Dest, AStr); +end; + +function StrChPos(P : PAnsiChar; C : AnsiChar; + var Pos : Cardinal): Boolean; +var + AStr : string; + ChPos : Integer; +begin + AStr := StrPas(P); + ChPos := System.Pos(C, AStr); + Result := ChPos > 0; + if Result then + Pos := Pred(ChPos); +end; + +{$ELSE} +function StrChDeletePrim(P : PAnsiChar; Pos : Cardinal) : PAnsiChar; register; +asm + push edi { Save because we will be changing them } + push esi + push ebx + + mov ebx, eax { Save P to EDI & EBX } + mov edi, eax + + xor al, al { Zero } + or ecx, -1 { Set ECX to $FFFFFFFF } + cld + repne scasb { Find null terminator } + not ecx + jecxz @@ExitPoint + sub ecx, edx { Calc number to move } + jb @@ExitPoint { Exit if Pos > StrLen } + + mov edi, ebx + add edi, edx { Point to position to adjust } + mov esi, edi + inc esi { Offset for source string } + inc ecx { One more to include null terminator } + rep movsb { Adjust the string } +@@ExitPoint: + + mov eax, ebx + pop ebx { restore registers } + pop esi + pop edi +end; + +function StrChInsertPrim(Dest : PAnsiChar; C : AnsiChar; + Pos : Cardinal) : PAnsiChar; register; +asm + push eax {save because we will be changing them} + push edi + push esi + push ebx + + xor ebx, ebx {zero} + mov ebx, ecx {move POS to ebx} + + mov esi, eax {copy Dest to ESI and EDI} + mov edi, eax + + xor al, al {zero} + or ecx, -1 {set ECX to $FFFFFFFF} + cld {ensure forward} + repne scasb {find null terminator} + + not ecx {calc length (including null)} + std {backwards string ops} + add esi, ecx + dec esi {point to end of source string} + sub ecx, ebx {calculate number to do} + jae @@1 {append if Pos greater than strlen + 1} + mov ecx, 1 + +@@1: + rep movsb {adjust tail of string} + mov eax, edx + stosb {insert the new character} + +@@ExitPoint: + + cld {be a good neighbor} + pop ebx {restore registers} + pop esi + pop edi + pop eax +end; + +function StrChPos(P : PAnsiChar; C : AnsiChar; + var Pos : Cardinal): Boolean; register; + {-Sets Pos to position of character C within string P returns True if found} +asm + push esi {save since we'll be changing} + push edi + push ebx + mov esi, ecx {save Pos} + + cld {forward string ops} + mov edi, eax {copy P to EDI} + or ecx, -1 + xor eax, eax {zero} + mov ebx, edi {save EDI to EBX} + repne scasb {search for NULL terminator} + not ecx + dec ecx {ecx has len of string} + + test ecx, ecx + jz @@NotFound {if len of P = 0 then done} + + mov edi, ebx {reset EDI to beginning of string} + mov al, dl {copy C to AL} + repne scasb {find C in string} + jne @@NotFound + + mov ecx, edi {calculate position of C} + sub ecx, ebx + dec ecx {ecx holds found position} + + mov [esi], ecx {store location} + mov eax, 1 {return true} + jmp @@ExitCode + +@@NotFound: + xor eax, eax + +@@ExitCode: + + pop ebx {restore registers} + pop edi + pop esi +end; +{$ENDIF} + +procedure StrInsertChars(Dest : PAnsiChar; Ch : AnsiChar; Pos, Count : Word); + {-Insert count instances of Ch into S at Pos} +var + A : array[0..1024] of AnsiChar; +begin + FillChar(A, Count, Ch); + A[Count] := #0; + StrStInsertPrim(Dest, A, Pos); +end; + +function StrStCopy(Dest : PAnsiChar; S : PAnsiChar; Pos, Count : Cardinal) : PAnsiChar; +var + Len : Cardinal; +begin + Len := StrLen(S); + if Pos < Len then begin + if (Len-Pos) < Count then + Count := Len-Pos; + Move(S[Pos], Dest^, Count); + Dest[Count] := #0; + end else + Dest[0] := #0; + Result := Dest; +end; + +{$IFDEF NoAsm} +function StrStDeletePrim(P : PAnsiChar; Pos, Count : Cardinal) : PAnsiChar; +var + AStr : string; +begin + AStr := StrPas(P); + Delete(AStr, Succ(Pos), Count); + Result := StrPCopy(P, AStr); +end; + +{$ELSE} +function StrStDeletePrim(P : PAnsiChar; Pos, Count : Cardinal) : PAnsiChar; register; +asm + push eax {save because we will be changing them} + push edi + push esi + push ebx + + mov ebx, ecx {move Count to BX} + mov esi, eax {move P to ESI and EDI} + mov edi, eax + + xor eax, eax {null} + or ecx, -1 + cld + repne scasb {find null terminator} + not ecx {calc length} + jecxz @@ExitPoint + + sub ecx, ebx {subtract Count} + sub ecx, edx {subtract Pos} + jns @@L1 + + mov edi,esi {delete everything after Pos} + add edi,edx + stosb + jmp @@ExitPoint + +@@L1: + mov edi,esi + add edi,edx {point to position to adjust} + mov esi,edi + add esi,ebx {point past string to delete in src} + inc ecx {one more to include null terminator} + rep movsb {adjust the string} + +@@ExitPoint: + + pop ebx {restore registers} + pop esi + pop edi + pop eax +end; +{$ENDIF} + +function StrStInsert(Dest : PAnsiChar; S1, S2 : PAnsiChar; Pos : Cardinal) : PAnsiChar; +begin + StrCopy(Dest, S1); + Result := StrStInsertPrim(Dest, S2, Pos); +end; + +{$IFDEF NoAsm} +function StrStInsertPrim(Dest : PAnsiChar; S : PAnsiChar; + Pos : Cardinal) : PAnsiChar; +// Note source (S) not modified as in assembler version. +var + AStr : string; +begin + AStr := StrPas(Dest); + Insert(StrPas(S), AStr, Succ(Pos)); + Result := StrPCopy(Dest, AStr); +end; + +function StrStPos(P, S : PAnsiChar; var Pos : Cardinal) : boolean; +var + AStr : string; + ChPos : Integer; +begin + AStr := StrPas(P); + ChPos := System.Pos(StrPas(S), AStr); + Result := ChPos > 0; + if Result then + Pos := Pred(ChPos); +end; + +{$ELSE} +function StrStInsertPrim(Dest : PAnsiChar; S : PAnsiChar; + Pos : Cardinal) : PAnsiChar; register; +asm + push eax {save because we will be changing them} + push edi + push esi + push ebx + + mov ebx, ecx {move POS to ebx} + mov esi, eax {copy Dest to ESI, S to EDI} + mov edi, edx + + xor al, al {zero} + or ecx, -1 {set ECX to $FFFFFFFF} + cld {ensure forward} + repne scasb {find null terminator} + not ecx {calc length of source string (including null)} + dec ecx {length without null} + jecxz @@ExitPoint {if source length = 0, exit} + push ecx {save length for later} + + mov edi, esi {reset EDI to Dest} + or ecx, -1 + repne scasb {find null} + not ecx {length of dest string} + + cmp ebx, ecx + jb @@1 + mov ebx, ecx + dec ebx + +@@1: + std {backwards string ops} + pop eax {restore length of S from stack} + add edi, eax {set EDI S beyond end of Dest} + dec edi {back up one for null} + + add esi, ecx {set ESI to end of Dest} + dec esi {back up one for null} + sub ecx, ebx {# of chars in Dest that are past Pos} + rep movsb {adjust tail of string} + + mov esi, edx {set ESI to S} + add esi, eax {set ESI to end of S} + dec esi {back up one for null} + mov ecx, eax {# of chars in S} + rep movsb {copy S into Dest} + + cld {be a good neighbor} + +@@ExitPoint: + pop ebx {restore registers} + pop esi + pop edi + pop eax +end; + +function StrStPos(P, S : PAnsiChar; var Pos : Cardinal) : boolean; register; +asm + push edi { Save registers } + push esi + push ebx + push ecx + + mov ebx, eax { Move P to EBX } + mov edi, edx { Move S to EDI & ESI } + mov esi, edx + + xor eax, eax { Zero EAX } + or ecx, -1 { Set ECX to FFFFFFFF } + repne scasb { Find null at end of S } + not ecx + + mov edx, ecx { Save length to EDX } + dec edx { EDX has len of S } + test edx, edx + jz @@NotFound { If len of S = 0 then done } + + mov edi, ebx { Set EDI to beginning of P } + or ecx, -1 { Set ECX to FFFFFFFF } + repne scasb { Find null at end of P } + not ecx + dec ecx { ECX has len of P } + jcxz @@NotFound { If len of P = 0 then done } + + dec edx + sub ecx,edx { Max chars to search } + jbe @@NotFound { Done if len S > len P } + lodsb { Get first char of S in AL } + mov edi,ebx { Set EDI to beginning of EDI } + +@@Next: + repne scasb { Find first char of S in P } + jne @@NotFound { If not found then done } + test edx, edx { If length of S was one then found } + jz @@Found + push ecx + push edi + push esi + mov ecx,edx + repe cmpsb { See if remaining chars in S match } + pop esi + pop edi + pop ecx + je @@Found { Yes, so found } + jmp @@Next { Look for next first char occurrence } + +@@NotFound: + pop ecx + xor eax,eax { Set return to False } + jmp @@ExitPoint + +@@Found: + dec edi { Calc position of found string } + mov eax, edi + sub eax, ebx + pop ecx + mov [ecx], eax + mov eax, 1 { Set return to True } + +@@ExitPoint: + pop ebx { Restore registers } + pop esi + pop edi +end; +{$ENDIF} + +function StrToLongPChar(S : PAnsiChar; var I : LongInt) : Boolean; + {-Convert a string to a longint, returning true if successful} +var + Code : Cardinal; + P : array[0..255] of AnsiChar; +begin + if StrLen(S)+1 > SizeOf(P) then begin + Result := False; + I := -1; + Exit; + end; + StrCopy(P, S); + TrimTrailPrimPChar(P); + if StrStPos(P, '0x', Code) then begin + StrStDeletePrim(P, Code, 2); + StrChInsertPrim(P, '$', Code); + end; +{$IFNDEF FPC} + Val(P, I, Code); +{$ELSE} + Val(String(P), I, Integer(Code)); +{$ENDIF} + if Code <> 0 then begin + I := Code - 1; + Result := False; + end else + Result := True; +end; + +procedure TrimAllSpacesPChar(P : PAnsiChar); + {-Trim leading and trailing blanks from P} +var + I : Integer; + PT : PAnsiChar; +begin + I := StrLen(P); + if I = 0 then + Exit; + + {delete trailing spaces} + Dec(I); + while (I >= 0) and (P[I] = ' ') do begin + P[I] := #0; + Dec(I); + end; + + {delete leading spaces} + I := 0; + PT := P; + while PT^ = ' ' do begin + Inc(I); + Inc(PT); + end; + if I > 0 then + StrStDeletePrim(P, 0, I); +end; + +function TrimEmbeddedZeros(const S : string) : string; + {-trim embedded zeros from a numeric string in exponential format} +var + I, J : Integer; +begin + I := Pos('E', S); + if I = 0 then + Exit; {nothing to do} + + Result := S; + + {get rid of excess 0's after the decimal point} + J := I; + while (J > 1) and (Result[J-1] = '0') do + Dec(J); + if J <> I then begin + System.Delete(Result, J, I-J); + + {get rid of the decimal point if that's all that's left} + if (J > 1) and (Result[J-1] = '.') then + System.Delete(Result, J-1, 1); + end; + + {get rid of excess 0's in the exponent} + I := Pos('E', Result); + if I > 0 then begin + Inc(I); + J := I; + while Result[J+1] = '0' do + Inc(J); + if J > I then + System.Delete(Result, I+1, J-I); + end; +end; + +procedure TrimEmbeddedZerosPChar(P : PAnsiChar); + {-Trim embedded zeros from a numeric string in exponential format} +var + I, J : Cardinal; +begin + if not StrChPos(P, 'E', I) then + Exit; + + {get rid of excess 0's after the decimal point} + J := I; + while (J > 0) and (P[J-1] = '0') do + Dec(J); + if J <> I then begin + StrStDeletePrim(P, J, I-J); + + {get rid of the decimal point if that's all that's left} + if (J > 0) and (P[J-1] = '.') then + StrStDeletePrim(P, J-1, 1); + end; + + {Get rid of excess 0's in the exponent} + if StrChPos(P, 'E', I) then begin + Inc(I); + J := I; + while P[J+1] = '0' do + Inc(J); + if J > I then + if P[J+1] = #0 then + P[I-1] := #0 + else + StrStDeletePrim(P, I+1, J-I); + end; +end; + +function TrimTrailingZeros(const S : string) : string; + {-Trim trailing zeros from a numeric string. It is assumed that there is + a decimal point prior to the zeros. Also strips leading spaces.} +var + I : Integer; +begin + if S = '' then + Exit; + + Result := S; + I := Length(Result); + {delete trailing zeros} + while (Result[I] = '0') and (I > 1) do + Dec(I); + {delete decimal point, if any} + if Result[I] = '.' then + Dec(I); + Result := Trim(Copy(Result, 1, I)); +end; + +procedure TrimTrailingZerosPChar(P : PAnsiChar); + {-Trim trailing zeros from a numeric string. It is assumed that there is + a decimal point prior to the zeros. Also strips leading spaces.} +var + PT : PAnsiChar; +begin + PT := StrEnd(P); + if Pointer(PT) = Pointer(P) then + Exit; + + {back up to character prior to null} + Dec(PT); + + {delete trailing zeros} + while PT^ = '0' do begin + PT^ := #0; + Dec(PT); + end; + + {delete decimal point, if any} + if PT^ = '.' then + PT^ := #0; + + TrimAllSpacesPChar(P); +end; + +{$IFDEF NoAsm} +function TrimTrailPrimPChar(S : PAnsiChar) : PAnsiChar; +var + AStr : string; +begin + AStr := StrPas(S); + Result := StrPCopy(S, TrimRight(AStr)); +end; + +{$ELSE} +function TrimTrailPrimPChar(S : PAnsiChar) : PAnsiChar; register; +asm + cld + push edi + mov edx, eax + mov edi, eax + + or ecx, -1 + xor al, al + repne scasb + not ecx + dec ecx + jecxz @@ExitPoint + + dec edi + +@@1: + dec edi + cmp byte ptr [edi],' ' + jbe @@1 + mov byte ptr [edi+1],00h +@@ExitPoint: + mov eax, edx + pop edi +end; +{$ENDIF} + +function TrimTrailPChar(Dest, S : PAnsiChar) : PAnsiChar; + {-Return a string with trailing white space removed} +begin + StrCopy(Dest, S); + Result := TrimTrailPrimPChar(Dest); +end; + +{$IFDEF NoAsm} +function UpCaseChar(C : AnsiChar) : AnsiChar; +var + AStr : string; +begin + AStr := AnsiUpperCase(C); + Result := AStr[1]; +end; + +{$ELSE} +function UpCaseChar(C : AnsiChar) : AnsiChar; register; +asm + and eax, 0FFh + push eax + call CharUpper +end; +{$ENDIF} + +end. diff --git a/components/orpheus/ovctable.pas b/components/orpheus/ovctable.pas new file mode 100644 index 000000000..42d20ef60 --- /dev/null +++ b/components/orpheus/ovctable.pas @@ -0,0 +1,6316 @@ +{*********************************************************} +{* OVCTABLE.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +(*Changes) + + 10/20/01- Hdc changed to TOvcHdc for BCB Compatibility +*) + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovctable; + {Orpheus table definitions} + +interface + +uses + {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, LclType, MyMisc, {$ENDIF} + SysUtils, Graphics, Classes, Controls, Forms, StdCtrls, + Menus, Dialogs, OvcMisc, OvcData, OvcConst, OvcBase, OvcCmd, OvcTCmmn, + OvcTCAry, OvcTSelL, OvcTCell, OvcTCHdr, OvcTGPns, + OvcTbClr, OvcTbRws, OvcTbCls, OvcDrag; + +type + TOvcCustomTable = class(TOvcTableAncestor) + {-The custom class for tables} + protected {private} + {property fields - even size} + FActiveCol : TColNum; {column of active cell} + FActiveRow : TRowNum; {row of active cell} + FBlockColBegin : TColNum; {start column for settings} + FBlockColEnd : TColNum; {end column for settings} + FBlockRowBegin : TRowNum; {start row for settings} + FBlockRowEnd : TRowNum; {end row for settings} + FCells : TOvcTableCells; {independent cells} + FColors : TOvcTableColors; {table cell colors} + FCols : TOvcTableColumns; {table column definitions} + FGridPenSet : TOvcGridPenSet; {set of grid pens} + FLeftCol : TColNum; {leftmost column} + FLockedCols : TColNum; {number of locked columns} + FLockedRows : TRowNum; {number of locked rows} + FLockedRowsCell : TOvcBaseTableCell; {cell for column headings} + FRows : TOvcTableRows; {table row definitions} + FSelAnchorCol : TColNum; {selection: anchor column} + FSelAnchorRow : TRowNum; {selection: anchor row} + FTopRow : TRowNum; {topmost row} + FColorUnused : TColor; {color of unused area} + FOldRowColBehavior: Boolean; + + {property fields - odd size} + FAccess : TOvcTblAccess; {default access mode for the table} + FAdjust : TOvcTblAdjust; {default adjustment for the table} + FBorderStyle : TBorderStyle; {border type around table} + FOptions : TOvcTblOptionSet; {set of table options} + FScrollBars : TScrollStyle; {scroll bar presence} + Filler : byte; + + {property event fields} + FActiveCellChanged : TCellNotifyEvent; {active cell changed event} + FActiveCellMoving : TCellMoveNotifyEvent; {active cell moving event} + FBeginEdit : TCellBeginEditNotifyEvent;{active cell about to be edited} + FClipboardCopy : TNotifyEvent; {copy to clipboard requested} + FClipboardCut : TNotifyEvent; {cut to clipboard requested} + FClipboardPaste : TNotifyEvent; {paste from clipboard requested} + FColumnsChanged : TColChangeNotifyEvent; {column insert/delete/exchange} + FDoneEdit : TCellNotifyEvent; {active cell has been edited} + FEndEdit : TCellEndEditNotifyEvent;{active cell about to be stopped being edited} + FEnteringColumn : TColNotifyEvent; {entering column event} + FEnteringRow : TRowNotifyEvent; {entering row event} + FGetCellData : TCellDataNotifyEvent; {get cell data event} + FGetCellAttributes : TCellAttrNotifyEvent; {get cell attributes event} + FLeavingColumn : TColNotifyEvent; {leaving column event} + FLeavingRow : TRowNotifyEvent; {leaving row event} + FLockedCellClick : TCellNotifyEvent; {locked cell clicked event} + FPaintUnusedArea : TNotifyEvent; {unused bit needs painting event} + FRowsChanged : TRowChangeNotifyEvent; {row insert/delete/exchange} + FSizeCellEditor : TSizeCellEditorNotifyEvent;{sizing of cell editor} + FTopLeftCellChanged : TCellNotifyEvent; {top left cell change event} + FTopLeftCellChanging: TCellChangeNotifyEvent; {top left cell moving event} + FUserCommand : TUserCommandEvent; {user command event} + FOnResizeColumn : TColResizeEvent; + FOnResizeRow : TRowResizeEvent; + + {other fields - even size} + tbColNums : POvcTblDisplayArray; {displayed column numbers} + tbRowNums : POvcTblDisplayArray; {displayed row numbers} + tbRowsOnLastPage : TRowNum; {number of complete rows on last page} + tbLastTopRow : TRowNum; {the last row number that can be top} + tbColsOnLastPage : TColNum; {num of complete columns on rightmost page} + tbLastLeftCol : TColNum; {the last column number that can be leftmost} + tbLockCount : integer; {the lock display count} + tbCmdTable : PString; {the command table name for the grid} + tbState : TOvcTblStates; {the state of the table} + tbSizeOffset : integer; {the offset of the sizing line} + tbSizeIndex : integer; {the index of the sized row/col} + tbMoveIndex : integer; {the index of the column being moved} + tbMoveIndexTo : integer; {the index of the column being targeted by move} + tbLastEntRow : TRowNum; {last row that was entered} + tbLastEntCol : TColNum; {last column that was entered} + tbActCell : TOvcBaseTableCell; {the active cell object} + tbInvCells : TOvcCellArray; {cells that need repainting} + tbSelList : TOvcSelectionList; {list of selected cells} + tbCellAttrFont : TFont; {cached font for painting cells} + tbColMoveCursor : HCursor; {cursor for column moves} + tbRowMoveCursor : HCursor; {cursor for row moves} + tbHSBarPosCount : integer; {number of positions for horz scrollbar} + tbDrag : TOvcDragShow; + + {other fields - odd size} + tbHasHSBar : boolean; {true if horiz scroll bar present} + tbHasVSBar : boolean; {true if vert scroll bar present} + tbUpdateSBs : boolean; {true if the scroll bars must be updated} + tbIsSelecting : boolean; {is in mouse selection mode} + tbIsDeselecting : boolean; {is in mouse deselection mode} + tbIsKeySelecting : boolean; {is in key selection mode} + tbMustUpdate : boolean; {scrolling has left an invalid region} + tbMustFinishLoading : boolean; {finish loading data in CreateWnd} + ProcessingVScrollMessage: Boolean;{Internal flag} + + protected + {property read routines} + function GetAllowRedraw : boolean; + function GetColCount : TColNum; + function GetColOffset(ColNum : TColNum) : integer; + function GetRowLimit : TRowNum; + function GetRowOffset(RowNum : TRowNum) : integer; + + {property write routines} + procedure SetAccess(A : TOvcTblAccess); + procedure SetActiveCol(ColNum : TColNum); + procedure SetActiveRow(RowNum : TRowNum); + procedure SetAdjust(A : TOvcTblAdjust); + procedure SetAllowRedraw(AR : boolean); + procedure SetBorderStyle(const BS : TBorderStyle); + procedure SetBlockAccess(A : TOvcTblAccess); + procedure SetBlockAdjust(A : TOvcTblAdjust); + procedure SetBlockCell(C : TOvcBaseTableCell); + procedure SetBlockColBegin(ColNum : TColNum); + procedure SetBlockColEnd(ColNum : TColNum); + procedure SetBlockColor(C : TColor); + procedure SetBlockFont(F : TFont); + procedure SetBlockRowBegin(RowNum : TRowNum); + procedure SetBlockRowEnd(RowNum : TRowNum); + procedure SetColors(C : TOvcTableColors); + procedure SetColCount(CC : integer); + procedure SetCols(CS : TOvcTableColumns); + procedure SetLeftCol(ColNum : TColNum); + procedure SetLockedCols(ColNum : TColNum); + procedure SetLockedRows(RowNum : TRowNum); + procedure SetLockedRowsCell(C : TOvcBaseTableCell); + procedure SetOptions(O : TOvcTblOptionSet); + procedure SetPaintUnusedArea(PUA : TNotifyEvent); + procedure SetRowLimit(RowNum : TRowNum); + procedure SetRows(RS : TOvcTableRows); + procedure SetScrollBars(const SB : TScrollStyle); + procedure SetTopRow(RowNum : TRowNum); + procedure SetColorUnused(CU : TColor); + + {overridden Delphi VCL methods} + procedure ChangeScale(M, D : integer); override; + procedure Notification(AComponent: TComponent; Operation: TOperation); override; + + {general methods} + function tbCalcActiveCellRect(var ACR : TRect) : boolean; + function tbCalcCellsFromRect(const UR : TRect; var GR : TRect) : integer; + procedure tbCalcColData(var CD : POvcTblDisplayArray; NewLeftCol : TColNum); + procedure tbCalcColsOnLastPage; + procedure tbCalcHSBarPosCount; + function tbCalcRequiresVSBar : boolean; + procedure tbCalcRowData(var RD : POvcTblDisplayArray; NewTopRow : TRowNum); + procedure tbCalcRowsOnLastPage; + + procedure tbDrawActiveCell; + procedure tbDrawCells(RowInxStart, RowInxEnd : integer; + ColInxStart, ColInxEnd : integer); + procedure tbDrawInvalidCells(InvCells : TOvcCellArray); + procedure tbDrawMoveLine; + procedure tbDrawRow(RowInx : integer; ColInxStart, ColInxEnd : integer); + procedure tbDrawSizeLine; + procedure tbDrawUnusedBit; + +{ - HWnd changed to TOvcHWnd for BCB Compatibility } + function tbEditCellHasFocus(FocusHandle : TOvcHWnd{HWND}) : boolean; + + procedure tbEnsureColumnIsVisible(ColNum : TColNum); + procedure tbEnsureRowIsVisible(RowNum : TRowNum); + + function tbFindCell(RowNum : TRowNum; + ColNum : TColNum) : TOvcBaseTableCell; + function tbFindColInx(ColNum : TColNum) : integer; + function tbFindRowInx(RowNum : TRowNum) : integer; + + function tbIsOnGridLine(MouseX, MouseY : integer; + var VerticalGrid : boolean) : boolean; + function tbIsInMoveArea(MouseX, MouseY : integer; + var IsColMove : boolean) : boolean; + procedure tbSetActiveCellWithSel(RowNum : TRowNum; + ColNum : TColNum); + procedure tbSetActiveCellPrim(RowNum : TRowNum; ColNum : TColNum); + + {selection methods} + procedure tbDeselectAll(CA : TOvcCellArray); + function tbDeselectAllIterator(RowNum1 : TRowNum; ColNum1 : TColNum; + RowNum2 : TRowNum; ColNum2 : TColNum; + ExtraData : pointer) : boolean; + procedure tbSelectCol(ColNum : TColNum); + procedure tbSelectRow(RowNum : TRowNum); + procedure tbSelectTable; + procedure tbSetAnchorCell(RowNum : TRowNum; ColNum : TColNum; + Action : TOvcTblSelectionType); + procedure tbUpdateSelection(RowNum : TRowNum; ColNum : TColNum; + Action : TOvcTblSelectionType); + + {notification procedures} + procedure DoActiveCellChanged(RowNum : TRowNum; ColNum : TColNum); + virtual; + procedure DoActiveCellMoving(Command : word; var RowNum : TRowNum; + var ColNum : TColNum); virtual; + procedure DoBeginEdit(RowNum : TRowNum; ColNum : TColNum; + var AllowIt : boolean); virtual; + procedure DoClipboardCopy; virtual; + procedure DoClipboardCut; virtual; + procedure DoClipboardPaste; virtual; + procedure DoColumnsChanged(ColNum1, ColNum2 : TColNum; + Action : TOvcTblActions); virtual; + procedure DoDoneEdit(RowNum : TRowNum; ColNum : TColNum); virtual; + procedure DoEndEdit(Cell : TOvcBaseTableCell; + RowNum : TRowNum; ColNum : TColNum; + var AllowIt : boolean); virtual; + procedure DoEnteringColumn(ColNum : TColNum); virtual; + procedure DoEnteringRow(RowNum : TRowNum); virtual; + procedure DoGetCellAttributes(RowNum : TRowNum; ColNum : TColNum; + var CellAttr : TOvcCellAttributes); virtual; + procedure DoGetCellData(RowNum : TRowNum; ColNum : TColNum; + var Data : pointer; + Purpose : TOvcCellDataPurpose); virtual; + procedure DoLeavingColumn(ColNum : TColNum); virtual; + procedure DoLeavingRow(RowNum : TRowNum); virtual; + procedure DoLockedCellClick(RowNum : TRowNum; ColNum : TColNum); virtual; + procedure DoOnMouseWheel(Shift : TShiftState; Delta, XPos, YPos : SmallInt); + override; + procedure DoPaintUnusedArea; virtual; + procedure DoRowsChanged(RowNum1, RowNum2 : TRowNum; + Action : TOvcTblActions); virtual; + procedure DoSizeCellEditor(RowNum : TRowNum; + ColNum : TColNum; + var CellRect : TRect; + var CellStyle: TOvcTblEditorStyle); virtual; + procedure DoTopLeftCellChanged(RowNum : TRowNum; ColNum : TColNum); virtual; + procedure DoTopLeftCellChanging(var RowNum : TRowNum; + var ColNum : TColNum); virtual; + procedure DoUserCommand(Cmd : word); virtual; + + {row/col data retrieval} + function tbIsColHidden(ColNum : TColNum) : boolean; + function tbIsRowHidden(RowNum : TRowNum) : boolean; + procedure tbQueryColData(ColNum : TColNum; + var W : integer; + var A : TOvcTblAccess; + var H : boolean); + procedure tbQueryRowData(RowNum : TRowNum; + var Ht: integer; + var H : boolean); + + {invalidation} + procedure tbInvalidateColHdgPrim(ColNum : TColNum; InvCells : TOvcCellArray); + procedure tbInvalidateRowHdgPrim(RowNum : TRowNum; InvCells : TOvcCellArray); + + {scrollbar stuff} + procedure tbSetScrollPos(SB : TOvcScrollBar); + procedure tbSetScrollRange(SB : TOvcScrollBar); + + {active cell movement} + procedure tbMoveActCellBotOfPage; + procedure tbMoveActCellBotRight; + procedure tbMoveActCellDown; + procedure tbMoveActCellFirstCol; + procedure tbMoveActCellFirstRow; + procedure tbMoveActCellLastCol; + procedure tbMoveActCellLastRow; + procedure tbMoveActCellLeft; + procedure tbMoveActCellPageDown; + procedure tbMoveActCellPageLeft; + procedure tbMoveActCellPageRight; + procedure tbMoveActCellPageUp; + procedure tbMoveActCellRight; + procedure tbMoveActCellTopLeft; + procedure tbMoveActCellTopOfPage; + procedure tbMoveActCellUp; + + {scrollbar scrolling routine} + procedure tbScrollBarDown; + procedure tbScrollBarLeft; + procedure tbScrollBarPageDown; + procedure tbScrollBarPageLeft; + procedure tbScrollBarPageRight; + procedure tbScrollBarPageUp; + procedure tbScrollBarRight; + procedure tbScrollBarUp; + + {table scrolling routines} + procedure tbScrollTableLeft(NewLeftCol : TColNum); + procedure tbScrollTableRight(NewLeftCol : TColNum); + procedure tbScrollTableUp(NewTopRow : TRowNum); + procedure tbScrollTableDown(NewTopRow : TRowNum); + + {notifications} + procedure tbCellChanged(Sender : TObject); override; + procedure tbColChanged(Sender : TObject; ColNum1, ColNum2 : TColNum; + Action : TOvcTblActions); + procedure tbGridPenChanged(Sender : TObject); + procedure tbRowChanged(Sender : TObject; RowNum1, RowNum2 : TRowNum; + Action : TOvcTblActions); + procedure tbColorsChanged(Sender : TObject); + + {streaming routines} + procedure DefineProperties(Filer : TFiler); override; + procedure tbFinishLoadingDefaultCells; + procedure tbReadColData(Reader : TReader); + procedure tbReadRowData(Reader : TReader); + procedure tbWriteColData(Writer : TWriter); + procedure tbWriteRowData(Writer : TWriter); + + {Cell-Table interaction messages} + procedure ctimLoadDefaultCells(var Msg : TMessage); message ctim_LoadDefaultCells; + procedure ctimQueryOptions(var Msg : TMessage); message ctim_QueryOptions; + procedure ctimQueryColor(var Msg : TMessage); message ctim_QueryColor; + procedure ctimQueryFont(var Msg : TMessage); message ctim_QueryFont; + procedure ctimQueryLockedCols(var Msg : TMessage); message ctim_QueryLockedCols; + procedure ctimQueryLockedRows(var Msg : TMessage); message ctim_QueryLockedRows; + procedure ctimQueryActiveCol(var Msg : TMessage); message ctim_QueryActiveCol; + procedure ctimQueryActiveRow(var Msg : TMessage); message ctim_QueryActiveRow; + procedure ctimRemoveCell(var Msg : TMessage); message ctim_RemoveCell; + procedure ctimStartEdit(var Msg : TMessage); message ctim_StartEdit; + procedure ctimStartEditMouse(var Msg : TWMMouse); message ctim_StartEditMouse; + procedure ctimStartEditKey(var Msg : TWMKey); message ctim_StartEditKey; + + {Delphi component messages} + procedure CMColorChanged(var Msg : TMessage); message CM_COLORCHANGED; + procedure CMCtl3DChanged(var Msg : TMessage); message CM_CTL3DCHANGED; + procedure CMDesignHitTest(var Msg : TCMDesignHitTest); message CM_DESIGNHITTEST; + procedure CMFontChanged(var Msg : TMessage); message CM_FONTCHANGED; + + {Windows messages} + procedure WMCancelMode(var Msg : TMessage); message WM_CANCELMODE; + procedure WMEraseBkGnd(var Msg : TWMEraseBkGnd); message WM_ERASEBKGND; + procedure WMGetDlgCode(var Msg : TMessage); message WM_GETDLGCODE; + procedure WMHScroll(var Msg : TWMScroll); message WM_HSCROLL; + procedure WMKeyDown(var Msg : TWMKey); message WM_KEYDOWN; + procedure WMKillFocus(var Msg : TWMKillFocus); message WM_KILLFOCUS; + procedure WMLButtonDblClk(var Msg : TWMMouse); message WM_LBUTTONDBLCLK; + procedure WMLButtonDown(var Msg : TWMMouse); message WM_LBUTTONDOWN; + procedure WMLButtonUp(var Msg : TWMMouse); message WM_LBUTTONUP; + procedure WMMouseMove(var Msg : TWMMouse); message WM_MOUSEMOVE; + procedure WMNCHitTest(var Msg : TMessage); message WM_NCHITTEST; + procedure WMSetCursor(var Msg : TWMSetCursor); message WM_SETCURSOR; + procedure WMSetFocus(var Msg : TWMSetFocus); message WM_SETFOCUS; + procedure WMVScroll(var Msg : TWMScroll); message WM_VSCROLL; + + {unpublishable or should not be published properties} + property AllowRedraw : boolean + read GetAllowRedraw write SetAllowRedraw + stored false; + + property BlockAccess : TOvcTblAccess + write SetBlockAccess; + + property BlockAdjust : TOvcTblAdjust + write SetBlockAdjust; + + property BlockColBegin : TColNum + read FBlockColBegin write SetBlockColBegin; + + property BlockColEnd : TColNum + read FBlockColEnd write SetBlockColEnd; + + property BlockColor : TColor + write SetBlockColor; + + property BlockCell : TOvcBaseTableCell + write SetBlockCell; + + property BlockFont : TFont + write SetBlockFont; + + property BlockRowBegin : TRowNum + read FBlockRowBegin write SetBlockRowBegin; + + property BlockRowEnd : TRowNum + read FBlockRowEnd write SetBlockRowEnd; + + property ColOffset [ColNum : TColNum] : integer + read GetColOffset; + + property RowOffset [RowNum : TRowNum] : integer + read GetRowOffset; + + property TableState : TOvcTblStates + read tbState; + + {publishable properties} + property Access : TOvcTblAccess + read FAccess write SetAccess; + + property ActiveCol : TColNum + read FActiveCol write SetActiveCol; + + property ActiveRow : TRowNum + read FActiveRow write SetActiveRow; + + property Adjust : TOvcTblAdjust + read FAdjust write SetAdjust; + + property BorderStyle : TBorderStyle + read FBorderStyle write SetBorderStyle; + + property ColCount : TColNum + read GetColCount write SetColCount; + + property Colors : TOvcTableColors + read FColors write SetColors; + + property ColorUnused : TColor + read FColorUnused write SetColorUnused; + + property Columns : TOvcTableColumns + read FCols write SetCols; + + property GridPenSet : TOvcGridPenSet + read FGridPenSet write FGridPenSet; + + property LeftCol : TColNum + read FLeftCol write SetLeftCol; + + property LockedCols : TColNum + read FLockedCols write SetLockedCols; + + property LockedRows : TRowNum + read FLockedRows write SetLockedRows; + + property LockedRowsCell : TOvcBaseTableCell + read FLockedRowsCell write SetLockedRowsCell; + + property OldRowColBehavior : Boolean + read FOldRowColBehavior write FOldRowColBehavior; + + property Options : TOvcTblOptionSet + read FOptions write SetOptions; + + property RowLimit : TRowNum + read GetRowLimit write SetRowLimit; + + property Rows : TOvcTableRows + read FRows write SetRows; + + property ScrollBars : TScrollStyle + read FScrollBars write SetScrollBars; + + property TopRow : TRowNum + read FTopRow write SetTopRow; + + {New events} + property OnActiveCellChanged : TCellNotifyEvent + read FActiveCellChanged write FActiveCellChanged; + + property OnActiveCellMoving : TCellMoveNotifyEvent + read FActiveCellMoving write FActiveCellMoving; + + property OnBeginEdit : TCellBeginEditNotifyEvent + read FBeginEdit write FBeginEdit; + + property OnClipboardCopy : TNotifyEvent + read FClipboardCopy write FClipboardCopy; + + property OnClipboardCut : TNotifyEvent + read FClipboardCut write FClipboardCut; + + property OnClipboardPaste : TNotifyEvent + read FClipboardPaste write FClipboardPaste; + + property OnColumnsChanged : TColChangeNotifyEvent + read FColumnsChanged write FColumnsChanged; + + property OnDoneEdit : TCellNotifyEvent + read FDoneEdit write FDoneEdit; + + property OnEndEdit : TCellEndEditNotifyEvent + read FEndEdit write FEndEdit; + + property OnEnteringColumn : TColNotifyEvent + read FEnteringColumn write FEnteringColumn; + + property OnEnteringRow : TRowNotifyEvent + read FEnteringRow write FEnteringRow; + + property OnGetCellData : TCellDataNotifyEvent + read FGetCellData write FGetCellData; + + property OnGetCellAttributes : TCellAttrNotifyEvent + read FGetCellAttributes write FGetCellAttributes; + + property OnLeavingColumn : TColNotifyEvent + read FLeavingColumn write FLeavingColumn; + + property OnLeavingRow : TRowNotifyEvent + read FLeavingRow write FLeavingRow; + + property OnLockedCellClick : TCellNotifyEvent + read FLockedCellClick write FLockedCellClick; + + property OnPaintUnusedArea : TNotifyEvent + read FPaintUnusedArea write SetPaintUnusedArea; + + property OnResizeColumn : TColResizeEvent + read FOnResizeColumn write FOnResizeColumn; + + property OnResizeRow : TRowResizeEvent + read FOnResizeRow write FOnResizeRow; + + property OnRowsChanged : TRowChangeNotifyEvent + read FRowsChanged write FRowsChanged; + + property OnSizeCellEditor : TSizeCellEditorNotifyEvent + read FSizeCellEditor write FSizeCellEditor; + + property OnTopLeftCellChanged : TCellNotifyEvent + read FTopLeftCellChanged write FTopLeftCellChanged; + + property OnTopLeftCellChanging : TCellChangeNotifyEvent + read FTopLeftCellChanging write FTopLeftCellChanging; + + property OnUserCommand : TUserCommandEvent + read FUserCommand write FUserCommand; + + public + {overridden methods} + constructor Create(AOwner : TComponent); override; + destructor Destroy; override; + procedure CreateParams(var Params : TCreateParams); override; + procedure CreateWnd; override; + procedure Loaded; override; + procedure Paint; override; + procedure SetBounds(ALeft, ATop, AWidth, AHeight: integer); override; + + {new public methods} + function CalcRowColFromXY(X, Y : integer; + var RowNum : TRowNum; + var ColNum : TColNum) : TOvcTblRegion; + function FilterKey(var Msg : TWMKey) : TOvcTblKeyNeeds; override; + procedure GetDisplayedColNums(var NA : TOvcTableNumberArray); + procedure GetDisplayedRowNums(var NA : TOvcTableNumberArray); + procedure ResolveCellAttributes(RowNum : TRowNum; ColNum : TColNum; + var CellAttr : TOvcCellAttributes); override; + + {methods for setting cells, faster than setting row/col properties} + procedure SetActiveCell(RowNum : TRowNum; ColNum : TColNum); + procedure SetTopLeftCell(RowNum : TRowNum; ColNum : TColNum); + + {methods for calculating next/prev row/col numbers for main area} + function IncCol(ColNum : TColNum; Direction : integer) : TColNum; + function IncRow(RowNum : TRowNum; Direction : integer) : TRowNum; + + {methods for invalidating cells to force a redraw} + procedure InvalidateCell(RowNum : TRowNum; ColNum : TColNum); + procedure InvalidateColumn(ColNum : TColNum); + procedure InvalidateRow(RowNum : TRowNum); + procedure InvalidateTable; + procedure InvalidateCellsInRect(const R : TRect); + procedure InvalidateColumnHeading(ColNum : TColNum); + procedure InvalidateRowHeading(RowNum : TRowNum); + procedure InvalidateTableNotLockedCols; + procedure InvalidateTableNotLockedRows; + + {selection methods} + function HaveSelection : boolean; + function InSelection(RowNum : TRowNum; ColNum : TColNum) : boolean; + procedure IterateSelections(SI : TSelectionIterator; ExtraData : pointer); + + {editing state method} + function InEditingState : boolean; + function SaveEditedData : boolean; + function StartEditingState : boolean; + function StopEditingState(SaveValue : boolean) : boolean; + + {scrollbar scrolling routine} + procedure ProcessScrollBarClick(ScrollBar : TOvcScrollBar; + ScrollCode : TScrollCode); virtual; + + {active cell movement routine} + procedure MoveActiveCell(Command : word); virtual; + + {public property} + property Cells : TOvcTableCells + read FCells; + + + end; + + TOvcTable = class(TOvcCustomTable) + public + property AllowRedraw; + property BlockAccess; + property BlockAdjust; + property BlockColBegin; + property BlockColEnd; + property BlockColor; + property BlockCell; + property BlockFont; + property BlockRowBegin; + property BlockRowEnd; + property Canvas; + property ColOffset; + property RowOffset; + property TableState; + published + {Properties} + property LockedRows default 1; + property TopRow default 1; + property ActiveRow default 1; + property RowLimit default 10; + + property LockedCols default 1; + property LeftCol default 1; + property ActiveCol default 1; + + property OldRowColBehavior default false; + + {$IFDEF VERSION4} + property Anchors; + property Constraints; + property DragKind; + {$ENDIF} + property Access default otxNormal; + property Adjust default otaCenterLeft; + property Align; + property BorderStyle default bsSingle; + property ColCount stored False; + property Color default tbDefTableColor; + property ColorUnused default clWindow; + property Colors; + property Columns; + property Controller; + property Ctl3D; + property DragCursor; + property DragMode; + property Enabled; + property Font; + property GridPenSet; + property LockedRowsCell; + property Options default []; + property ParentColor default False; + property ParentCtl3D; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property Rows; + property ScrollBars default ssBoth; + property ShowHint; + property TabOrder; + property TabStop default True; + property Visible; + + {Events} + property OnActiveCellChanged; + property OnActiveCellMoving; + property OnBeginEdit; + property OnClipboardCopy; + property OnClipboardCut; + property OnClipboardPaste; + property OnColumnsChanged; + property OnDblClick; + property OnDoneEdit; + property OnDragDrop; + property OnDragOver; + property OnEndDrag; + property OnEndEdit; + property OnEnter; + property OnEnteringColumn; + property OnEnteringRow; + property OnExit; + property OnGetCellData; + property OnGetCellAttributes; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnLeavingColumn; + property OnLeavingRow; + property OnLockedCellClick; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnMouseWheel; + property OnPaintUnusedArea; + property OnResizeColumn; + property OnResizeRow; + property OnRowsChanged; + property OnSizeCellEditor; + property OnTopLeftCellChanged; + property OnTopLeftCellChanging; + property OnUserCommand; + end; + +implementation +{===== Local Routines ================================================} + +function NewString(const S: string): PString; +begin + New(Result); + Result^ := S; +end; + +procedure DisposeString(P: PString); +begin + if (P <> nil) + and (P^ <> '') then + Dispose(P); +end; + + +{===== TOvcTable creation and destruction ============================} + +constructor TOvcCustomTable.Create(AOwner : TComponent); + begin + inherited Create(AOwner); + + ProcessingVScrollMessage := false; + + tbState := [otsNormal]; + + if NewStyleControls then + ControlStyle := ControlStyle + [csOpaque, csCaptureMouse, csDoubleClicks] + else + ControlStyle := ControlStyle + [csOpaque, csCaptureMouse, csDoubleClicks, csFramed]; + + Height := tbDefHeight; + Width := tbDefWidth; + FColorUnused := clWindow; + + ParentColor := false; + Color := tbDefTableColor; + TabStop := true; + + + FGridPenSet := TOvcGridPenSet.Create; + FGridPenSet.OnCfgChanged := tbGridPenChanged; + + FColors := TOvcTableColors.Create; + FColors.OnCfgChanged := tbColorsChanged; + + FCols := TOvcTableColumns.Create(Self, tbDefColCount, TOvcTableColumn); + FCols.OnColumnChanged := tbColChanged; + FCols.Table := Self; + + FCells := TOvcTableCells.Create(Self); + FCells.OnCfgChanged := tbCellChanged; + FCells.Table := Self; + tbInvCells := TOvcCellArray.Create; + + FRows := TOvcTableRows.Create; + RowLimit := tbDefRowCount; + FRows.OnCfgChanged := tbRowChanged; + + FBorderStyle := tbDefBorderStyle; + FScrollBars := tbDefScrollBars; + FAccess := tbDefAccess; + FAdjust := tbDefAdjust; + tbCellAttrFont := TFont.Create; + + FActiveCol := tbDefLockedCols; + FLockedCols := tbDefLockedCols; + FLeftCol := tbDefLockedCols; + FSelAnchorCol := tbDefLockedCols; + + FActiveRow := tbDefLockedRows; + FLockedRows := tbDefLockedRows; + FTopRow := tbDefLockedRows; + FSelAnchorRow := tbDefLockedRows; + + tbColMoveCursor := LoadBaseCursor('ORCOLUMNMOVECURSOR'); + tbRowMoveCursor := LoadBaseCursor('ORROWMOVECURSOR'); + + tbSelList := TOvcSelectionList.Create(tbDefRowCount, tbDefColCount); + + tbLastEntRow := -1; + tbLastEntCol := -1; + + tbCmdTable := NewString(GetOrphStr(SCGridTableName)); + + AssignDisplayArray(tbColNums, succ(tbDefColCount)); + AssignDisplayArray(tbRowNums, succ(tbDefRowCount)); + + if csDesigning in ComponentState then + tbState := tbState + [otsDesigning] + else + tbState := tbState + [otsUnfocused]; + + tbMustFinishLoading := true; + end; +{--------} + +destructor TOvcCustomTable.Destroy; + begin + if not (csDestroying in ComponentState) then + Destroying; + FCols.Free; + FCells.Free; + FRows.Free; + tbInvCells.Free; + tbSelList.Free; + tbCellAttrFont.Free; + if Assigned(tbColNums) then + AssignDisplayArray(tbColNums, 0); + if Assigned(tbRowNums) then + AssignDisplayArray(tbRowNums, 0); + DisposeString(tbCmdTable); + GridPenSet.Free; + FColors.Free; + + inherited Destroy; + end; +{--------} + +procedure TOvcCustomTable.CreateParams(var Params: TCreateParams); + begin + inherited CreateParams(Params); + + with Params do + Style := LongInt(Style) or OvcData.ScrollBarStyles[FScrollBars] + or OvcData.BorderStyles[FBorderStyle]; + + if NewStyleControls and Ctl3D and (FBorderStyle = bsSingle) then begin + Params.Style := Params.Style and not WS_BORDER; + Params.ExStyle := Params.ExStyle or WS_EX_CLIENTEDGE; + end; + +{$IFDEF LCL} + inherited SetBorderStyle(FBorderStyle); +{$ENDIF} + end; +{--------} + +procedure TOvcCustomTable.CreateWnd; + begin + inherited CreateWnd; + {post a message to ourselves to finish loading the cells} + {--the reason for this is that cell components _may_ be } + { on a data module: we must wait until all data modules} + { have been created, otherwise we may not pick up some } + { cell references (Delphi 2 does not guarantee any } + { particular order for form/data module creation). } + + PostMessage(Handle, ctim_LoadDefaultCells, 0, 0); + + tbLockCount := 0; + + tbHasHSBar := false; + tbHasVSBar := false; + if (FScrollBars = ssBoth) or (FScrollBars = ssHorizontal) then + tbHasHSBar := true; + if (FScrollBars = ssBoth) or (FScrollBars = ssVertical) then + tbHasVSBar := true; + + tbCalcColData(tbColNums, LeftCol); + tbCalcRowData(tbRowNums, TopRow); + {make sure the column/row properties are valid} + LeftCol := LeftCol; + TopRow := TopRow; + ActiveCol := ActiveCol; + ActiveRow := ActiveRow; + FSelAnchorCol := ActiveCol; + FSelAnchorRow := ActiveRow; + + {Set up the scrollbars} + tbSetScrollRange(otsbHorizontal); + tbSetScrollPos(otsbHorizontal); + tbSetScrollRange(otsbVertical); + tbSetScrollPos(otsbVertical); + + {Must trigger the active cell and topleft cell change events} + DoTopLeftCellChanged(TopRow, LeftCol); + DoActiveCellChanged(ActiveRow, ActiveCol); + + if not (otsDesigning in tbState) and (otoAlwaysEditing in Options) then + PostMessage(Handle, ctim_StartEdit, 0, 0); + end; +{--------} + +procedure TOvcCustomTable.Loaded; + begin + inherited Loaded; + end; + +{==TOvcTable property streaming routines=============================} + +procedure TOvcCustomTable.DefineProperties(Filer : TFiler); + begin + inherited DefineProperties(Filer); + with Filer do + begin + DefineProperty('RowData', tbReadRowData, tbWriteRowData, true); + DefineProperty('ColData', tbReadColData, tbWriteColData, true); + end; + end; +{--------} + +procedure TOvcCustomTable.tbFinishLoadingDefaultCells; + var + i : integer; + begin + FCols.tcStopLoading; + {if our cell list is empty refresh it now} + if (taCellList.Count = 0) then + begin + if Assigned(FLockedRowsCell) then + tbIncludeCell(FLockedRowsCell); + for i := 0 to pred(FCols.Count) do + tbIncludeCell(FCols.DefaultCell[i]); + {we don't have to do the Cells matrix: no design time support} + end; + end; +{--------} + +procedure TOvcCustomTable.tbReadColData(Reader : TReader); + var + ColObj : TOvcTableColumn; + Fixups : TStringList; + begin + AllowRedraw := false; + with Reader do + begin + ReadListBegin; + FCols.Clear; + Fixups := FCols.tcStartLoading; + while not EndOfList do + begin + ColObj := TOvcTableColumn.Create(Self); + ColObj.Width := Readinteger; + ColObj.Hidden := ReadBoolean; + if ReadBoolean then + Fixups.AddObject(ReadString, ColObj); + FCols.Append(ColObj); + end; + ReadListEnd; + end; + AllowRedraw := true; + end; +{--------} + +procedure TOvcCustomTable.tbReadRowData(Reader : TReader); + var + RowNum : TRowNum; + RS : TRowStyle; + begin + with Reader do + begin + ReadListBegin; + FRows.Clear; + FRows.DefaultHeight := Readinteger; + while not EndOfList do + begin + RowNum := Readinteger; + RS.Hidden := ReadBoolean; + RS.Height := Readinteger; + FRows[RowNum] := RS; + end; + ReadListEnd; + end; + end; +{--------} + +procedure TOvcCustomTable.tbWriteColData(Writer : TWriter); + var + ColNum : TColNum; + S : string; + begin + if tbMustFinishLoading then begin + tbFinishLoadingCellList; + tbFinishLoadingDefaultCells; + tbMustFinishLoading := false; + end; + + with Writer do + begin + WriteListBegin; + for ColNum := 0 to pred(ColCount) do + with FCols[ColNum] do + begin + WriteInteger(Width); + WriteBoolean(Hidden); + if (DefaultCell <> nil) then + begin + WriteBoolean(true); + S := DefaultCell.Owner.Name; + if (S <> '') then + S := S + '.' + DefaultCell.Name + else + S := DefaultCell.Name; + WriteString(S); + end + else + WriteBoolean(false); + end; + WriteListEnd; + end; + end; +{--------} + +procedure TOvcCustomTable.tbWriteRowData(Writer : TWriter); + var + RowNum : TRowNum; + RS : TRowStyle; + begin + with Writer do + begin + WriteListBegin; + Writeinteger(FRows.DefaultHeight); + for RowNum := 0 to pred(FRows.Limit) do + if FRows.RowIsSpecial[RowNum] then + begin + Writeinteger(RowNum); + RS := FRows[RowNum]; + WriteBoolean(RS.Hidden); + Writeinteger(RS.Height); + end; + WriteListEnd; + end; + end; +{====================================================================} + + +{==TOvcTable property read routines==================================} +function TOvcCustomTable.GetAllowRedraw : boolean; + begin + Result := (tbLockCount = 0); + end; +{--------} +function TOvcCustomTable.GetColCount : TColNum; + begin + Result := FCols.Count; + end; +{--------} +function TOvcCustomTable.GetColOffset(ColNum : TColNum) : integer; + var + ColInx : integer; + begin + ColInx := tbFindColInx(ColNum); + if (ColInx <> -1) then + Result := tbColNums^.Ay[ColInx].Offset + else + Result := -1; + end; +{--------} +function TOvcCustomTable.GetRowLimit : TRowNum; + begin + Result := FRows.Limit; + end; +{--------} +function TOvcCustomTable.GetRowOffset(RowNum : TRowNum) : integer; + var + RowInx : integer; + begin + RowInx := tbFindRowInx(RowNum); + if (RowInx <> -1) then + Result := tbRowNums^.Ay[RowInx].Offset + else + Result := -1; + end; +{--------} +procedure TOvcCustomTable.ResolveCellAttributes(RowNum : TRowNum; ColNum : TColNum; + var CellAttr : TOvcCellAttributes); + var + TempAccess : TOvcTblAccess; + TempAdjust : TOvcTblAdjust; + TempColor : TColor; + TempFontColor : TColor; + TempSparseAttr: TOvcSparseAttr; + begin + FCells.ResolveFullAttr(RowNum, ColNum, TempSparseAttr); + with CellAttr do + begin + {calculate the access rights} + TempAccess := TempSparseAttr.scaAccess; + if (TempAccess = otxDefault) then + begin + TempAccess := caAccess; + if (TempAccess = otxDefault) then + TempAccess := Access; + end; + caAccess := TempAccess; + {calculate the adjustment} + TempAdjust := TempSparseAttr.scaAdjust; + if (TempAdjust = otaDefault) then + begin + TempAdjust := caAdjust; + if (TempAdjust = otaDefault) then + TempAdjust := Adjust; + end; + caAdjust := TempAdjust; + {calculate the font} + if Assigned(TempSparseAttr.scaFont) then + caFont.Assign(TempSparseAttr.scaFont); + {calculate the colors} + if (RowNum = ActiveRow) and (ColNum = ActiveCol) then + if (otsFocused in tbState) then + if InEditingState or + ((otoAlwaysEditing in Options) and (caAccess = otxNormal)) then + begin + TempColor := Colors.Editing; + TempFontColor := Colors.EditingText + end + else + begin + TempColor := Colors.ActiveFocused; + TempFontColor := Colors.ActiveFocusedText; + end + else + begin + TempColor := Colors.ActiveUnfocused; + TempFontColor := Colors.ActiveUnfocusedText; + end + else + begin + if (RowNum = ActiveRow) and (otoBrowseRow in FOptions) then + if (otsFocused in tbState) then + begin + TempColor := Colors.ActiveFocused; + TempFontColor := Colors.ActiveFocusedText; + end + else + begin + TempColor := Colors.ActiveUnfocused; + TempFontColor := Colors.ActiveUnfocusedText; + end + else if InSelection(RowNum, ColNum) then + begin + TempColor := Colors.Selected; + TempFontColor := Colors.SelectedText; + end + else + begin + TempColor := TempSparseAttr.scaColor; + if Assigned(TempSparseAttr.scaFont) then + TempFontColor := TempSparseAttr.scaFont.Color + else if (RowNum < LockedRows) or (ColNum < LockedCols) then + TempFontColor := Colors.LockedText + else + TempFontColor := caFontColor; + if (TempColor = clOvcTableDefault) then + if (RowNum < LockedRows) or (ColNum < LockedCols) then + TempColor := Colors.Locked + else + TempColor := caColor; + end; + end; + caColor := TempColor; + caFontColor := TempFontColor; + end; + DoGetCellAttributes(RowNum, ColNum, CellAttr); + end; +{====================================================================} + + +{==TOvcTable property write routines=================================} +procedure TOvcCustomTable.SetAccess(A : TOvcTblAccess); + var + TempAccess : TOvcTblAccess; + begin + if (A = otxDefault) then + TempAccess := tbDefAccess + else TempAccess := A; + if (TempAccess <> FAccess) then + begin + AllowRedraw := false; + try + if (TempAccess = otxInvisible) or (FAccess = otxInvisible) then + InvalidateTable; + FAccess := TempAccess; + finally + AllowRedraw := true; + end;{try..finally} + end; + end; +{--------} +procedure TOvcCustomTable.SetActiveCell(RowNum : TRowNum; ColNum : TColNum); + begin + DoActiveCellMoving(ccNone, RowNum, ColNum); + tbSetActiveCellWithSel(RowNum, ColNum); + end; +{--------} +procedure TOvcCustomTable.tbSetActiveCellWithSel(RowNum : TRowNum; + ColNum : TColNum); + begin + if tbIsKeySelecting then + tbUpdateSelection(RowNum, ColNum, tstDeselectAll) + else + tbSetAnchorCell(RowNum, ColNum, tstDeselectAll); + tbSetActiveCellPrim(RowNum, ColNum); + end; +{--------} + +procedure TOvcCustomTable.tbSetActiveCellPrim(RowNum : TRowNum; ColNum : TColNum); + var + TempInvCells : TOvcCellArray; + begin + {verify the row/column numbers to be visible} + RowNum := IncRow(RowNum, 0); + ColNum := IncCol(ColNum, 0); + {if nothing to do, get out} + if (RowNum = FActiveRow) and (ColNum = FActiveCol) then + Exit; + {if can't do anything visually, just set the internal fields and + then exit} + if (not HandleAllocated) or + (tbRowNums^.Count = 0) or (tbColNums^.Count = 0) then + begin + FActiveRow := RowNum; + FActiveCol := ColNum; + Exit; + end; + {set the new active cell} + TempInvCells := nil; + AllowRedraw := false; + try + TempInvCells := TOvcCellArray.Create; + if (RowNum <> FActiveRow) then + begin + tbInvalidateRowHdgPrim(FActiveRow, TempInvCells); + InvalidateRowHeading(RowNum); + DoLeavingRow(FActiveRow); + end; + if (ColNum <> FActiveCol) then + begin + tbInvalidateColHdgPrim(FActiveCol, TempInvCells); + InvalidateColumnHeading(ColNum); + DoLeavingColumn(FActiveCol); + end; + tbInvCells.DeleteCell(ActiveRow, ActiveCol); + TempInvCells.AddCell(ActiveRow, ActiveCol); + + if not OldRowColBehavior then + if FActiveRow <> RowNum then + DoEnteringRow(RowNum); + + FActiveRow := RowNum; + + if not OldRowColBehavior then + if FActiveCol <> ColNum then + DoEnteringColumn(ColNum); + + FActiveCol := ColNum; + tbDrawInvalidCells(TempInvCells); + tbEnsureRowIsVisible(RowNum); + tbEnsureColumnIsVisible(ColNum); + if not (otsDesigning in tbState) and (otoAlwaysEditing in Options) then + PostMessage(Handle, ctim_StartEdit, 0, 0) + else + InvalidateCell(ActiveRow, ActiveCol); + finally + AllowRedraw := true; + TempInvCells.Free; + end;{try..finally} + tbSetScrollPos(otsbHorizontal); + tbSetScrollPos(otsbVertical); + DoActiveCellChanged(RowNum, ColNum); + end; +{--------} +procedure TOvcCustomTable.SetActiveCol(ColNum : TColNum); + begin + SetActiveCell(FActiveRow, ColNum); + end; +{--------} +procedure TOvcCustomTable.SetActiveRow(RowNum : TRowNum); + begin + SetActiveCell(RowNum, FActiveCol); + end; +{--------} +procedure TOvcCustomTable.SetAdjust(A : TOvcTblAdjust); + var + TempAdjust : TOvcTblAdjust; + begin + if (A = otaDefault) then + TempAdjust := tbDefAdjust + else TempAdjust := A; + if (TempAdjust <> FAdjust) then + begin + AllowRedraw := false; + try + InvalidateTable; + FAdjust := TempAdjust; + finally + AllowRedraw := true; + end;{try..finally} + end; + end; +{--------} +procedure TOvcCustomTable.SetAllowRedraw(AR : boolean); + var + CellRect : TRect; + MustFocus: boolean; + R : TRect; + CellStyle: TOvcTblEditorStyle; + begin + if AR {AllowRedraw is true} then + begin + dec(tbLockCount); + if (tbLockCount <= 0) then + begin + {Setting the tbLockCount explicitly to zero is to catch + programmers who call AllowRedraw := true once to often} + tbLockCount := 0; + {Update the scroll bars} + if tbUpdateSBs then + begin + tbUpdateSBs := false; + tbSetScrollPos(otsbHorizontal); + tbSetScrollPos(otsbVertical); + end; + {if in row selection mode invalidate it} + if (otoBrowseRow in Options) then + InvalidateRow(ActiveRow); + {draw the invalid and active cells if we have a handle} + if HandleAllocated then + begin + {redraw invalid cells} + if not tbInvCells.Empty then + tbDrawInvalidCells(tbInvCells); + if (otsHiddenEdit in tbState) then + begin + if tbCalcActiveCellRect(CellRect) then + begin + {note: cell style is ignored here} + CellStyle := tesNormal; + DoSizeCellEditor(ActiveRow, ActiveCol, CellRect, CellStyle); + MustFocus := Focused; + tbActCell.EditMove(CellRect); + tbState := tbState - [otsHiddenEdit] + [otsEditing]; + if MustFocus then +{$IFNDEF LCL} + Windows.SetFocus(tbActCell.EditHandle); +{$ELSE} + LclIntf.SetFocus(tbActCell.EditHandle); +{$ENDIF} + end + end + else + tbDrawActiveCell; + end; + end; + end + else + begin + inc(tbLockCount); + if (tbLockCount = 1) and (HandleAllocated) then + begin + if (otoBrowseRow in Options) then + InvalidateRow(ActiveRow); + if (otsEditing in tbState) then + begin +{$IFNDEF LCL} + MustFocus := tbEditCellHasFocus(Windows.GetFocus); +{$ELSE} + MustFocus := tbEditCellHasFocus(LclIntf.GetFocus); +{$ENDIF} + GetWindowRect(tbActCell.EditHandle, R); + R.TopLeft := ScreenToClient(R.TopLeft); + R.BottomRight := ScreenToClient(R.BottomRight); + InvalidateCellsInRect(R); + tbActCell.EditHide; + tbState := tbState - [otsEditing] + [otsHiddenEdit]; + if MustFocus then + SetFocus; + end + else if not (otoBrowseRow in Options) then + InvalidateCell(ActiveRow, ActiveCol); + end; + end; + end; +{--------} +procedure TOvcCustomTable.SetBorderStyle(const BS : TBorderStyle); + begin + if (BS <> BorderStyle) then + begin + FBorderStyle := BS; +{$IFNDEF LCL} + RecreateWnd; +{$ELSE} + MyMisc.RecreateWnd(Self); +{$ENDIF} + end; + end; +{--------} +procedure TOvcCustomTable.SetBlockAccess(A : TOvcTblAccess); + var + R : TRowNum; + C : TColNum; + begin + for R := BlockRowBegin to BlockRowEnd do + for C := BlockColBegin to BlockColEnd do + FCells.Access[R, C] := A; + end; +{--------} +procedure TOvcCustomTable.SetBlockAdjust(A : TOvcTblAdjust); + var + R : TRowNum; + C : TColNum; + begin + for R := BlockRowBegin to BlockRowEnd do + for C := BlockColBegin to BlockColEnd do + FCells.Adjust[R, C] := A; + end; +{--------} +procedure TOvcCustomTable.SetBlockCell(C : TOvcBaseTableCell); + var + Rn : TRowNum; + Cn : TColNum; + begin + for Rn := BlockRowBegin to BlockRowEnd do + for Cn := BlockColBegin to BlockColEnd do + FCells.Cell[Rn, Cn] := C; + end; +{--------} +procedure TOvcCustomTable.SetBlockColBegin(ColNum : TColNum); + begin + if (ColNum <> FBlockColBegin) then + if (0 <= ColNum) and (ColNum < ColCount) then + begin + FBlockColBegin := ColNum; + if (FBlockColEnd < FBlockColBegin) then + FBlockColEnd := ColNum; + end; + end; +{--------} +procedure TOvcCustomTable.SetBlockColEnd(ColNum : TColNum); + begin + if (ColNum <> FBlockColEnd) then + if (0 <= ColNum) and (ColNum < ColCount) then + begin + FBlockColEnd := ColNum; + if (FBlockColEnd < FBlockColBegin) then + FBlockColBegin := ColNum; + end; + end; +{--------} +procedure TOvcCustomTable.SetBlockColor(C : TColor); + var + Rn : TRowNum; + Cn : TColNum; + begin + for Rn := BlockRowBegin to BlockRowEnd do + for Cn := BlockColBegin to BlockColEnd do + FCells.Color[Rn, Cn] := C; + end; +{--------} +procedure TOvcCustomTable.SetBlockFont(F : TFont); + var + R : TRowNum; + C : TColNum; + begin + for R := BlockRowBegin to BlockRowEnd do + for C := BlockColBegin to BlockColEnd do + FCells.Font[R, C] := F; + end; +{--------} +procedure TOvcCustomTable.SetBlockRowBegin(RowNum : TRowNum); + begin + if (RowNum <> FBlockRowBegin) then + if (0 <= RowNum) and (RowNum < RowLimit) then + begin + FBlockRowBegin := RowNum; + if (FBlockRowEnd < FBlockRowBegin) then + FBlockRowEnd := RowNum; + end; + end; +{--------} +procedure TOvcCustomTable.SetBlockRowEnd(RowNum : TRowNum); + begin + if (RowNum <> FBlockRowEnd) then + if (0 <= RowNum) and (RowNum < RowLimit) then + begin + FBlockRowEnd := RowNum; + if (FBlockRowEnd < FBlockRowBegin) then + FBlockRowBegin := RowNum; + end; + end; +{--------} +procedure TOvcCustomTable.SetColors(C : TOvcTableColors); + begin + FColors.Assign(C); + end; +{--------} +procedure TOvcCustomTable.SetColorUnused(CU : TColor); + begin + if (CU <> ColorUnused) then + begin + AllowRedraw := false; + FColorUnused := CU; + tbInvCells.AddUnusedBit; + AllowRedraw := true; + end; + end; +{--------} +procedure TOvcCustomTable.SetColCount(CC : integer); + begin + if (CC <> ColCount) and (CC > LockedCols) then + begin + AllowRedraw := false; + try + Columns.Count := CC; + tbSelList.SetColCount(CC); + tbSetScrollRange(otsbHorizontal); + if (CC <= ActiveCol) then + ActiveCol := pred(CC); + if (CC <= LeftCol) then + LeftCol := pred(CC); + if (CC <= FSelAnchorCol) then + FSelAnchorCol := pred(CC); + if (CC <= BlockColBegin) then + BlockColBegin := pred(CC); + if (CC <= BlockColEnd) then + BlockColEnd := pred(CC); + tbSetScrollPos(otsbHorizontal); + + finally + AllowRedraw := true; + end;{try..finally} + end; + end; +{--------} +procedure TOvcCustomTable.SetCols(CS : TOvcTableColumns); + begin + AllowRedraw := false; + try + FCols.Free; + FCols := CS; + FCols.Table := Self; + FCols.OnColumnChanged := tbColChanged; + tbColChanged(FCols, 0, 0, taGeneral); + finally + AllowRedraw := true; + end;{try..finally} + end; +{--------} +procedure TOvcCustomTable.SetLeftCol(ColNum : TColNum); + begin + SetTopLeftCell(TopRow, ColNum); + end; +{--------} +procedure TOvcCustomTable.SetLockedCols(ColNum : TColNum); + begin + if not HandleAllocated then + FLockedCols := ColNum + else + if (ColNum <> FLockedCols) then + if (0 <= ColNum) and (ColNum < ColCount) then + begin + AllowRedraw := false; + try + FLockedCols := ColNum; + if LeftCol < ColNum then + LeftCol := LeftCol; {this does do something!} + if (ActiveCol < ColNum) then + ActiveCol := LeftCol; {this does do something!} + tbCalcColData(tbColNums, LeftCol); + InvalidateTable; + finally + AllowRedraw := true; + end;{try..finally} + tbSetScrollRange(otsbHorizontal); + tbSetScrollPos(otsbHorizontal); + end; + end; +{--------} +procedure TOvcCustomTable.SetLockedRows(RowNum : TRowNum); + begin + if not HandleAllocated then + FLockedRows := RowNum + else + if (RowNum <> FLockedRows) then + if (0 <= RowNum) then + begin + AllowRedraw := false; + try + FLockedRows := RowNum; + if (TopRow < RowNum) then + TopRow := TopRow; {this does do something!} + if (ActiveRow < RowNum) then + ActiveRow := ActiveRow; {this does do something!} + tbCalcRowData(tbRowNums, TopRow); + InvalidateTable; + finally + AllowRedraw := true; + end;{try..finally} + tbSetScrollRange(otsbVertical); + tbSetScrollPos(otsbVertical); + end; + end; +{--------} +procedure TOvcCustomTable.SetLockedRowsCell(C : TOvcBaseTableCell); + var + DoIt : boolean; + begin + DoIt := false; + if (C <> FLockedRowsCell) then + if Assigned(C) then + begin + if (C.References = 0) or + ((C.References > 0) and (C.Table = Self)) then + DoIt := true; + end + else + DoIt := true; + + if DoIt then + begin + if Assigned(FLockedRowsCell) then + FLockedRowsCell.DecRefs; + FLockedRowsCell := C; + if Assigned(FLockedRowsCell) then + begin + if (FLockedRowsCell.References = 0) then + FLockedRowsCell.Table := Self; + FLockedRowsCell.IncRefs; + end; + tbCellChanged(Self); + end; + end; +{--------} +procedure TOvcCustomTable.SetOptions(O : TOvcTblOptionSet); + begin + AllowRedraw := false; + try + FOptions := O; + if HaveSelection then + begin + tbIsSelecting := false; + tbIsDeselecting := false; + tbSetAnchorCell(ActiveRow, ActiveCol, tstDeselectAll); + end; + {patch up the options set to exclude meaningless combinations} + if (otoBrowseRow in FOptions) then + begin + FOptions := FOptions + + [otoNoSelection, otoNoRowResizing{, otoNoColResizing}] - + [otoMouseDragSelect, otoRowSelection, otoColSelection]; + end; + if (otoAlwaysEditing in FOptions) then + begin + FOptions := FOptions + + [otoNoSelection, otoNoRowResizing, otoNoColResizing] - + [otoMouseDragSelect, otoRowSelection, otoColSelection]; + end + else if (otoNoSelection in FOptions) then + begin + FOptions := FOptions - + [otoMouseDragSelect, otoRowSelection, otoColSelection]; + end; + if (otoRowSelection in FOptions) then + FOptions := FOptions - [otoAllowRowMoves]; + if (otoColSelection in FOptions) then + FOptions := FOptions - [otoAllowColMoves]; + InvalidateTable; + finally + AllowRedraw := true; + end;{try..finally} + end; +{--------} +procedure TOvcCustomTable.SetPaintUnusedArea(PUA : TNotifyEvent); + begin + AllowRedraw := false; + FPaintUnusedArea := PUA; + tbInvCells.AddUnusedBit; + AllowRedraw := true; + end; +{--------} +procedure TOvcCustomTable.SetRowLimit(RowNum : TRowNum); + begin + if (RowNum <> FRows.Limit) and (RowNum > LockedRows) then + begin + AllowRedraw := false; + try + FRows.Limit := RowNum; + tbSelList.SetRowCount(RowLimit); + tbSetScrollRange(otsbVertical); + if (RowNum <= ActiveRow) then + ActiveRow := pred(RowNum); + if (RowNum <= TopRow) then + TopRow := pred(RowNum); + if (RowNum <= FSelAnchorRow) then + FSelAnchorRow := pred(RowNum); + if (RowNum <= BlockRowBegin) then + BlockRowBegin := pred(RowNum); + if (RowNum <= BlockRowEnd) then + BlockRowEnd := pred(RowNum); + tbSetScrollPos(otsbVertical); + finally + AllowRedraw := true; + end;{try..finally} + end; + end; +{--------} +procedure TOvcCustomTable.SetRows(RS : TOvcTableRows); + begin + AllowRedraw := false; + try + FRows.Free; + FRows := RS; + finally + AllowRedraw := true; + end;{try..finally} + end; +{--------} +procedure TOvcCustomTable.SetScrollBars(const SB : TScrollStyle); + begin + if (SB <> ScrollBars) then + begin + FScrollBars := SB; +{$IFNDEF LCL} + RecreateWnd; +{$ELSE} + MyMisc.RecreateWnd(Self); +{$ENDIF} + end; + end; +{--------} +procedure TOvcCustomTable.SetTopRow(RowNum : TRowNum); + begin + SetTopLeftCell(RowNum, LeftCol); + end; +{--------} +procedure TOvcCustomTable.SetTopLeftCell(RowNum : TRowNum; ColNum : TColNum); + begin + {ensure that the new top left cell minimises the unused space} + if (ColNum > tbLastLeftCol) then + ColNum := tbLastLeftCol; + if (RowNum > tbLastTopRow) then + RowNum := tbLastTopRow; + {ensure that RowNum and C are not hidden} + RowNum := IncRow(RowNum, 0); + ColNum := IncCol(ColNum, 0); + DoTopLeftCellChanging(RowNum, ColNum); + {change the topmost row and leftmost column if required} + if not HandleAllocated then + begin + FTopRow := RowNum; + FLeftCol := ColNum; + end + else + if (RowNum <> FTopRow) or (ColNum <> FLeftCol) then + begin + AllowRedraw := false; + {note: the tbScrollTableXxx routines set FTopRow and FLeftCol} + try + if (RowNum > FTopRow) then + tbScrollTableUp(RowNum) + else if (RowNum < FTopRow) then + tbScrollTableDown(RowNum); + if (ColNum > FLeftCol) then + tbScrollTableLeft(ColNum) + else if (ColNum < FLeftCol) then + tbScrollTableRight(ColNum); + finally + AllowRedraw := true; + end;{try..finally} + tbSetScrollPos(otsbVertical); + tbSetScrollPos(otsbHorizontal); + DoTopLeftCellChanged(RowNum, ColNum); + end; + end; +{====================================================================} + + +{==TOvcTable Scroller routines=======================================} +procedure TOvcCustomTable.tbSetScrollPos(SB : TOvcScrollBar); + var + ColNum : TColNum; + ColCnt : TColNum; + Divisor : LongInt; + begin + if (SB = otsbVertical) then + begin + if tbHasVSBar then + if HandleAllocated and (tbLockCount = 0) then + begin + if (tbLastTopRow < 16*1024) then + SetScrollPos(Handle, SB_VERT, TopRow, true) + else + begin + if (tbLastTopRow > (16 * 1024)) then + Divisor := RowLimit div $400 + else + Divisor := RowLimit div $40; + SetScrollPos(Handle, SB_VERT, + TopRow div Divisor, + True); + end + end + else + tbUpdateSBs := true; + end + else {SB = otsbHorizontal} + begin + if tbHasHSBar then + if HandleAllocated and (tbLockCount = 0) then + begin + ColCnt := 0; + for ColNum := LockedCols to pred(LeftCol) do + if not tbIsColHidden(ColNum) then + inc(ColCnt); + SetScrollPos(Handle, SB_HORZ, ColCnt, true) + end + else + tbUpdateSBs := true; + end; + end; +{--------} + +procedure TOvcCustomTable.tbSetScrollRange(SB : TOvcScrollBar); + var + Divisor : LongInt; + begin + if (SB = otsbVertical) then + begin + if HandleAllocated then + tbCalcRowsOnLastPage; + if tbHasVSBar and HandleAllocated then + begin +// tbCalcRowsOnLastPage; + if (tbLastTopRow < 16*1024) then + if tbCalcRequiresVSBar then + SetScrollRange(Handle, SB_Vert, LockedRows, tbLastTopRow, false) + else + SetScrollRange(Handle, SB_Vert, LockedRows, LockedRows, false) + else begin + if (tbLastTopRow > (16*1024)) then + Divisor := Succ(tbLastTopRow div $400) + else + Divisor := Succ(tbLastTopRow div $40); + SetScrollRange(Handle, SB_Vert, + LockedRows, + tbLastTopRow div Divisor, + False) + end; + end + end + else {SB = otsbHorizontal} + begin + tbCalcColsOnLastPage; + if tbHasHSBar and HandleAllocated then + begin + tbCalcHSBarPosCount; + SetScrollRange(Handle, SB_HORZ, 0, pred(tbHSBarPosCount), false); + end; + end; + end; +{====================================================================} + + +{==TOvcTable editing routines========================================} +function TOvcCustomTable.FilterKey(var Msg : TWMKey) : TOvcTblKeyNeeds; + var + Cmd : word; + begin + Result := otkDontCare; + Cmd := Controller.EntryCommands.TranslateUsing([tbCmdTable^], TMessage(Msg)); + {first the hard coded keys} + case Msg.CharCode of + VK_RETURN : + if (otoEnterToArrow in Options) then + Result := otkMustHave; + VK_TAB : + if (otoTabToArrow in Options) then + Result := otkMustHave; + VK_ESCAPE : + Result := otkMustHave; + end;{case} + {now the translated commands} + case Cmd of + ccTableEdit : + Result := otkMustHave; + ccBotOfPage, ccBotRightCell, ccDown, ccEnd, ccFirstPage, ccHome, + ccLastPage, ccLeft, ccNextPage, ccPageLeft, ccPageRight, ccPrevPage, + ccRight, ccTopLeftCell, ccTopOfPage, ccUp, ccWordLeft, ccWordRight : + Result := otkWouldLike; + end;{case} + end; +{--------} +function TOvcCustomTable.SaveEditedData : boolean; + var + Data : pointer; + begin + Result := true; + if InEditingState then + begin + Result := false; + if not tbActCell.CanSaveEditedData(true) then + Exit; + Result := true; + DoEnteringColumn(ActiveCol); + DoEnteringRow(ActiveRow); + DoGetCellData(ActiveRow, ActiveCol, Data, cdpForSave); + tbActCell.SaveEditedData(Data); + end; + end; +{--------} +function TOvcCustomTable.StartEditingState : boolean; + var + CellRect : TRect; + Data : pointer; + CellAttr : TOvcCellAttributes; + CellStyle: TOvcTblEditorStyle; + begin + Result := true; + if InEditingState then + Exit; + DoBeginEdit(ActiveRow, ActiveCol, Result); + if not Result then + Exit; + Result := false; + AllowRedraw := false; + try + tbEnsureRowIsVisible(ActiveRow); + tbEnsureColumnIsVisible(ActiveCol); + tbActCell := tbFindCell(ActiveRow, ActiveCol); + if Assigned(tbActCell) then + begin + FillChar(CellAttr, sizeof(CellAttr), 0); + CellAttr.caFont := tbCellAttrFont; + CellAttr.caFont.Assign(Font); + tbActCell.ResolveAttributes(ActiveRow, ActiveCol, CellAttr); + if (CellAttr.caAccess = otxNormal) then + begin + if not tbCalcActiveCellRect(CellRect) then + {we're in big trouble, lads}; + CellStyle := tesNormal; + DoSizeCellEditor(ActiveRow, ActiveCol, CellRect, CellStyle); + DoEnteringColumn(ActiveCol); + DoEnteringRow(ActiveRow); + DoGetCellData(ActiveRow, ActiveCol, Data, cdpForEdit); + tbState := tbState - [otsNormal] + [otsHiddenEdit]; + CellAttr.caColor := Colors.Editing; + CellAttr.caFontColor := Colors.EditingText; + tbActCell.StartEditing(ActiveRow, ActiveCol, CellRect, CellAttr, CellStyle, Data); + Result := (tbActCell.EditHandle <> 0); + if not Result then + begin + tbState := tbState + [otsNormal] - [otsHiddenEdit]; + tbActCell := nil; + end; + end + else + tbActCell := nil; + end; + finally + AllowRedraw := true; + end;{try..finally} + end; +{--------} +function TOvcCustomTable.StopEditingState(SaveValue : boolean) : boolean; + var + Data : pointer; + MustFocus : boolean; + + R : TRect; + + begin + Result := true; + if not InEditingState then + Exit; + Result := false; + if not tbActCell.CanSaveEditedData(SaveValue) then + Exit; + DoEndEdit(tbActCell, ActiveRow, ActiveCol, Result); + if not Result then + Exit; + Result := true; + GetWindowRect(tbActCell.EditHandle, R); + AllowRedraw := false; + try +{$IFNDEF LCL} + MustFocus := tbEditCellHasFocus(Windows.GetFocus); +{$ELSE} + MustFocus := tbEditCellHasFocus(LclIntf.GetFocus); +{$ENDIF} + if not MustFocus then + MustFocus := Focused; + DoEnteringColumn(ActiveCol); + DoEnteringRow(ActiveRow); + DoGetCellData(ActiveRow, ActiveCol, Data, cdpForSave); + + R.TopLeft := ScreenToClient(R.TopLeft); + R.BottomRight := ScreenToClient(R.BottomRight); + InvalidateCellsInRect(R); + + tbActCell.StopEditing(SaveValue, Data); + tbActCell := nil; + try + DoDoneEdit(ActiveRow, ActiveCol); + finally + if not (otoAlwaysEditing in Options) then + InvalidateCell(ActiveRow, ActiveCol); + tbState := tbState - [otsEditing, otsHiddenEdit] + [otsNormal]; + if MustFocus then + SetFocus + else + tbState := tbState - [otsFocused] + [otsUnfocused]; + end;{try..finally} + finally + AllowRedraw := true; + end;{try..finally} + end; +{====================================================================} + + +{==TOvcTable selection methods=======================================} +procedure TOvcCustomTable.tbDeselectAll(CA : TOvcCellArray); + begin + with tbSelList do + begin + Iterate(tbDeselectAllIterator, pointer(CA)); + DeselectAll; + end; + end; +{--------} +function TOvcCustomTable.tbDeselectAllIterator(RowNum1 : TRowNum; ColNum1 : TColNum; + RowNum2 : TRowNum; ColNum2 : TColNum; + ExtraData : pointer) : boolean; + var + RowNum : TRowNum; + ColNum : TColNum; + RowInx : integer; + CA : TOvcCellArray absolute ExtraData; + begin + {optimisations: 1. generally ColNum1 = ColNum2 + 2. take it from the viewpoint of what rows are visible + rather than what rows are selected} + Result := true; + for ColNum := ColNum1 to ColNum2 do + if (tbFindColInx(ColNum) <> -1) then + with tbRowNums^ do + for RowInx := 0 to pred(Count) do + begin + RowNum := Ay[RowInx].Number; + if (RowNum1 <= RowNum) and (RowNum <= RowNum2) then + CA.AddCell(RowNum, ColNum); + end; + end; +{--------} +function TOvcCustomTable.HaveSelection : boolean; + begin + Result := tbSelList.HaveSelection; + end; +{--------} +function TOvcCustomTable.InSelection(RowNum : TRowNum; ColNum : TColNum) : boolean; + begin + if HaveSelection then + Result := tbSelList.IsCellSelected(RowNum, ColNum) + else + Result := false; + end; +{--------} +procedure TOvcCustomTable.IterateSelections(SI : TSelectionIterator; ExtraData : pointer); + begin + with tbSelList do + Iterate(SI, ExtraData); + end; +{--------} +procedure TOvcCustomTable.tbSelectCol(ColNum : TColNum); + var + RowInx : integer; + ColInx : integer; + begin + tbSelList.SelectCellRange(LockedRows, ColNum, pred(RowLimit), ColNum); + ColInx := tbFindColInx(ColNum); + if (ColInx <> -1) then + with tbRowNums^ do + for RowInx := 0 to pred(Count) do + tbInvCells.AddCell(Ay[RowInx].Number, ColNum); + end; +{--------} +procedure TOvcCustomTable.tbSelectRow(RowNum : TRowNum); + var + RowInx : integer; + ColInx : integer; + begin + tbSelList.SelectCellRange(RowNum, LockedCols, RowNum, pred(ColCount)); + RowInx := tbFindRowInx(RowNum); + if (RowInx <> -1) then + with tbColNums^ do + for ColInx := 0 to pred(Count) do + tbInvCells.AddCell(RowNum, Ay[ColInx].Number); + end; +{--------} +procedure TOvcCustomTable.tbSelectTable; + begin + tbSelList.SelectAll; + InvalidateTable; + end; +{--------} +procedure TOvcCustomTable.tbSetAnchorCell(RowNum : TRowNum; ColNum : TColNum; + Action : TOvcTblSelectionType); + begin + {deselect the current selection(s) if required} + if (Action = tstDeselectAll) then + tbDeselectAll(tbInvCells); + {set the anchor point to a sensible value} + if (ColNum < LockedCols) then + FSelAnchorCol := LockedCols + else if (ColNum >= ColCount) then + FSelAnchorCol := pred(ColCount) + else + FSelAnchorCol := ColNum; + if (RowNum < LockedRows) then + FSelAnchorRow := LockedRows + else if (RowNum >= RowLimit) then + FSelAnchorRow := pred(RowLimit) + else + FSelAnchorRow := RowNum; + {tell the selection list object} + tbSelList.SetRangeAnchor(RowNum, ColNum, Action); + {try and work out whether we are selecting or deselecting} + tbIsSelecting := false; + tbIsDeselecting := false; + if (Action = tstAdditional) then + begin + if InSelection(RowNum, ColNum) then + tbIsDeselecting := true + else + tbIsSelecting := true; + end; + end; +{--------} +procedure TOvcCustomTable.tbUpdateSelection(RowNum : TRowNum; ColNum : TColNum; + Action : TOvcTblSelectionType); + var + R : TRowNum; + C : TColNum; + OldSelRow1 : TRowNum; + OldSelRow2 : TRowNum; + OldSelCol1 : TColNum; + OldSelCol2 : TColNum; + NewSelRow1 : TRowNum; + NewSelRow2 : TRowNum; + NewSelCol1 : TColNum; + NewSelCol2 : TColNum; + RowInx : integer; + ColInx : integer; + NewInvCells: TOvcCellArray; + DeselCells : TOvcCellArray; + begin + NewInvCells := nil; + DeselCells := nil; + try + {create temporary cell arrays: one for new invalid cells, + one for any deselected cells} + NewInvCells := TOvcCellArray.Create; + DeselCells := TOvcCellArray.Create; + {deselect currently selected cells if required} + if (Action = tstDeselectAll) then + tbDeselectAll(DeselCells); + {calculate the old and new selections (the parameters RowNum, + ColNum form the address of the new active cell)} + OldSelRow1 := MinL(ActiveRow, FSelAnchorRow); + OldSelRow2 := MaxL(ActiveRow, FSelAnchorRow); + NewSelRow1 := MinL(RowNum, FSelAnchorRow); + NewSelRow2 := MaxL(RowNum, FSelAnchorRow); + if (otoBrowseRow in Options) then + begin + OldSelCol1 := LockedCols; + OldSelCol2 := pred(ColCount); + NewSelCol1 := LockedCols; + NewSelCol2 := pred(ColCount); + end + else + begin + OldSelCol1 := MinI(ActiveCol, FSelAnchorCol); + OldSelCol2 := MaxI(ActiveCol, FSelAnchorCol); + NewSelCol1 := MinI(ColNum, FSelAnchorCol); + NewSelCol2 := MaxI(ColNum, FSelAnchorCol); + end; + {extend the range in the selection list} + tbSelList.ExtendRange(RowNum, ColNum, tbIsSelecting or tbIsKeySelecting); + {for the old selection, remove the cells from the deselected cell + array (if they are there) and add them to the new selected cell + array} + for RowInx := 0 to pred(tbRowNums^.Count) do + begin + R := tbRowNums^.Ay[RowInx].Number; + if (OldSelRow1 <= R) and (R <= OldSelRow2) then + for ColInx := 0 to pred(tbColNums^.Count) do + begin + C := tbColNums^.Ay[ColInx].Number; + if (OldSelCol1 <= C) and (C <= OldSelCol2) then + begin + DeselCells.DeleteCell(R, C); + NewInvCells.AddCell(R, C); + end; + end; + end; + {for the new selection, for each cell remove it from the new selected + cell array; if it wasn't there add it to the same array} + for RowInx := 0 to pred(tbRowNums^.Count) do + begin + R := tbRowNums^.Ay[RowInx].Number; + if (NewSelRow1 <= R) and (R <= NewSelRow2) then + for ColInx := 0 to pred(tbColNums^.Count) do + begin + C := tbColNums^.Ay[ColInx].Number; + if (NewSelCol1 <= C) and (C <= NewSelCol2) then + if not NewInvCells.DeleteCell(R, C) then + NewInvCells.AddCell(R, C); + end; + end; + {add the current active cell to the new selected cell array} + NewInvCells.AddCell(ActiveRow, ActiveCol); + {merge the cells from the temporary arrays into the main invalid + cell array} + tbInvCells.Merge(NewInvCells); + tbInvCells.Merge(DeselCells); + finally + NewInvCells.Free; + DeselCells.Free + end;{try..finally} + end; +{====================================================================} + + +{==TOvcTable notification methods====================================} +procedure TOvcCustomTable.tbCellChanged(Sender : TObject); + begin + {don't bother if we're being loaded or destroyed} + if ((ComponentState * [csLoading, csDestroying]) <> []) then + Exit; + {if we have a handle repaint the table} + if HandleAllocated then + begin + AllowRedraw := false; + try + InvalidateTable; + finally + AllowRedraw := true; + end;{try..finally} + end; + end; +{--------} +procedure TOvcCustomTable.tbColChanged(Sender : TObject; ColNum1, ColNum2 : TColNum; + Action : TOvcTblActions); + var + CC : TColNum; + DoIt : boolean; + begin + {don't bother if we're being loaded or destroyed} + if ((ComponentState * [csLoading, csDestroying]) <> []) then + Exit; + {similarly don't bother if we have no handle} + if not HandleAllocated then begin + tbSelList.SetColCount(ColCount); + Exit; + end; + {make sure there's no flicker} + AllowRedraw := false; + try + {decide whether there's anything to do to the visible display} + DoIt := false; + with tbColNums^ do +{$IFDEF LCL} //Apparent TurboPower bug revealed when checks on + if Count > 0 then +{$ENDIF} + case Action of + taGeneral : DoIt := true; + taSingle : begin + DoIt := (Ay[0].Number <= ColNum1) and + (ColNum1 <= Ay[pred(Count)].Number); + {check for unhiding a column after all others} + if not DoIt then + DoIt := (ColNum1 > Ay[pred(Count)].Number) and + (ClientWidth > Ay[Count].Offset); + DoColumnsChanged(ColNum1, -1, taSingle); + end; + taAll : DoIt := true; + taInsert : begin + DoIt := (Ay[0].Number <= ColNum1) and + (ColNum1 <= Ay[pred(Count)].Number); + {check for appending a column} + if not DoIt then + DoIt := (ColNum1 > Ay[pred(Count)].Number) and + (ClientWidth > Ay[Count].Offset); + FCells.InsertCol(ColNum1); + DoColumnsChanged(ColNum1, -1, taInsert); + end; + taDelete : begin + DoIt := (Ay[0].Number <= ColNum1) and + (ColNum1 <= Ay[pred(Count)].Number); + FCells.DeleteCol(ColNum1); + DoColumnsChanged(ColNum1, -1, taDelete); + end; + taExchange: begin + DoIt := (Ay[0].Number <= ColNum1) and + (ColNum1 <= Ay[pred(Count)].Number); + if not DoIt then + DoIt := (Ay[0].Number <= ColNum2) and + (ColNum2 <= Ay[pred(Count)].Number); + FCells.ExchangeCols(ColNum1, ColNum2); + DoColumnsChanged(ColNum1, ColNum2, taExchange); + end; + end;{case} + {if nothing to do to the visible columns, then do it!} + if not DoIt then + begin + {must still reset the horizontal scroll bar even so} + tbSelList.SetColCount(ColCount); + tbSetScrollRange(otsbHorizontal); + tbSetScrollPos(otsbHorizontal); + Exit; + end; + {redisplay the table} + tbCalcColData(tbColNums, LeftCol); + InvalidateTable; + {the column could have changed because it was hidden or deleted... + ...must make sure that LeftCol and ActiveCol haven't + been hidden as well.} + if (Action = taSingle) or (Action = taDelete) then + begin + if (ColNum1 = LeftCol) then + LeftCol := LeftCol; {this does do something!} + if (ColNum1 = ActiveCol) then + ActiveCol := ActiveCol; {this does do something!} + end; + {reset the block column values} + CC := ColCount; + if (CC <= BlockColBegin) then + BlockColBegin := pred(CC); + if (CC <= BlockColEnd) then + BlockColEnd := pred(CC); + tbSelList.SetColCount(ColCount); + tbSetScrollRange(otsbHorizontal); + tbSetScrollPos(otsbHorizontal); + if (LeftCol > tbLastLeftCol) then + LeftCol := tbLastLeftCol; + finally + AllowRedraw := true; + end;{try..finally} + end; +{--------} +procedure TOvcCustomTable.tbColorsChanged(Sender : TObject); + begin + {don't bother if we're being loaded or destroyed} + if ((ComponentState * [csLoading, csDestroying]) <> []) then + Exit; + {if we have a handle repaint the table} + if HandleAllocated then + begin + AllowRedraw := false; + try + InvalidateTable; + finally + AllowRedraw := true; + end;{try..finally} + end; + end; +{--------} +procedure TOvcCustomTable.tbGridPenChanged(Sender : TObject); + begin + {don't bother if we're being loaded or destroyed} + if ((ComponentState * [csLoading, csDestroying]) <> []) then + Exit; + {if we have a handle repaint the table} + if HandleAllocated then + begin + AllowRedraw := false; + try + InvalidateTable; + finally + AllowRedraw := true; + end;{try..finally} + end; + end; +{--------} +procedure TOvcCustomTable.tbRowChanged(Sender : TObject; RowNum1, RowNum2 : TRowNum; + Action : TOvcTblActions); + var + RL : TRowNum; + DoIt : boolean; + begin + {don't bother if we're being loaded or destroyed} + if ((ComponentState * [csLoading, csDestroying]) <> []) then + Exit; + {similarly don't bother if we have no handle} + if not HandleAllocated then begin + tbSelList.SetRowCount(RowLimit); + Exit; + end; + {make sure there's no flicker} + AllowRedraw := false; + try + {decide whether there's anything to do to the visible display} + DoIt := false; + with tbRowNums^ do + case Action of + taGeneral : DoIt := true; + taSingle : begin + DoIt := (Ay[0].Number <= RowNum1) and + (RowNum1 <= Ay[pred(Count)].Number); + {check for unhiding a row after all others} + if not DoIt then + DoIt := (RowNum1 > Ay[pred(Count)].Number) and + (ClientHeight > Ay[Count].Offset); + DoRowsChanged(RowNum1, -1, taSingle); + end; + taAll : DoIt := true; + taInsert : begin + DoIt := (Ay[0].Number <= RowNum1) and + (RowNum1 <= Ay[pred(Count)].Number); + {check for appending a row} + if not DoIt then + DoIt := (RowNum1 > Ay[pred(Count)].Number) and + (ClientHeight > Ay[Count].Offset); + FCells.InsertRow(RowNum1); + DoRowsChanged(RowNum1, -1, taInsert); + end; + taDelete : begin + DoIt := (Ay[0].Number <= RowNum1) and + (RowNum1 <= Ay[pred(Count)].Number); + FCells.DeleteRow(RowNum1); + DoRowsChanged(RowNum1, -1, taDelete); + end; + taExchange: begin + DoIt := (Ay[0].Number <= RowNum1) and + (RowNum1 <= Ay[pred(Count)].Number); + if not DoIt then + DoIt := (Ay[0].Number <= RowNum2) and + (RowNum2 <= Ay[pred(Count)].Number); + FCells.ExchangeRows(RowNum1, RowNum2); + DoRowsChanged(RowNum1, RowNum2, taExchange); + end; + end;{case} + {if nothing to do to the visible rows, then do it!} + if not DoIt then + begin + {must still reset the vertical scroll bar even so} + tbSelList.SetRowCount(RowLimit); + tbSetScrollRange(otsbVertical); + tbSetScrollPos(otsbVertical); + Exit; + end; + {redisplay the table} + tbCalcRowData(tbRowNums, TopRow); + InvalidateTable; + {the row could have changed because it was hidden or deleted... + ...must make sure that TopRow and ActiveRow haven't + been hidden as well.} + if (Action = taSingle) or (Action = taDelete) then + begin + if (RowNum1 = TopRow) then + TopRow := TopRow; {this does do something!} + if (RowNum1 = ActiveRow) then + ActiveRow := ActiveRow; {this does do something!} + end; + {reset the block row values} + RL := RowLimit; + if (RL <= BlockRowBegin) then + BlockRowBegin := pred(RL); + if (RL <= BlockRowEnd) then + BlockRowEnd := pred(RL); + tbSelList.SetRowCount(RowLimit); + tbSetScrollRange(otsbVertical); + tbSetScrollPos(otsbVertical); + finally + AllowRedraw := true; + end;{try..finally} + end; +{====================================================================} + + +{==TOvcTable invalidate cell methods=================================} +procedure TOvcCustomTable.InvalidateCell(RowNum : TRowNum; ColNum : TColNum); + var + CInx : integer; + RInx : integer; + begin + RInx := tbFindRowInx(RowNum); + if (RInx <> -1) then + begin + CInx := tbFindColInx(ColNum); + if (CInx <> -1) then + tbInvCells.AddCell(RowNum, ColNum); + end; + end; +{--------} +procedure TOvcCustomTable.InvalidateCellsInRect(const R : TRect); + var + GR : TRect; + WhatToPaint : integer; + RowInx : integer; + ColInx : integer; + begin + WhatToPaint := tbCalcCellsFromRect(R, GR); + + if (WhatToPaint <> 2) then + for RowInx := GR.Top to GR.Bottom do + for ColInx := GR.Left to GR.Right do + InvalidateCell(tbRowNums^.Ay[RowInx].Number, tbColNums^.Ay[ColInx].Number); + + if (WhatToPaint <> 0) then + tbInvCells.AddUnusedBit; + end; +{--------} +procedure TOvcCustomTable.InvalidateColumn(ColNum : TColNum); + var + RowInx : integer; + ColInx : integer; + begin + ColInx := tbFindColInx(ColNum); + if (ColInx <> -1) then + with tbRowNums^ do + for RowInx := 0 to pred(Count) do + tbInvCells.AddCell(Ay[RowInx].Number, ColNum); + end; +{--------} +procedure TOvcCustomTable.tbInvalidateColHdgPrim(ColNum : TColNum; InvCells : TOvcCellArray); + var + RowInx : integer; + ColInx : integer; + begin + ColInx := tbFindColInx(ColNum); + if (ColInx <> -1) then + with tbRowNums^ do + for RowInx := 0 to pred(LockedRows) do + InvCells.AddCell(Ay[RowInx].Number, ColNum); + end; +{--------} +procedure TOvcCustomTable.InvalidateColumnHeading(ColNum : TColNum); + begin + tbInvalidateColHdgPrim(ColNum, tbInvCells); + end; +{--------} +procedure TOvcCustomTable.InvalidateRow(RowNum : TRowNum); + var + RowInx : integer; + ColInx : integer; + begin + RowInx := tbFindRowInx(RowNum); + if (RowInx <> -1) then + with tbColNums^ do + for ColInx := 0 to pred(Count) do + tbInvCells.AddCell(RowNum, Ay[ColInx].Number); + end; +{--------} +procedure TOvcCustomTable.tbInvalidateRowHdgPrim(RowNum : TRowNum; InvCells : TOvcCellArray); + var + RowInx : integer; + ColInx : integer; + begin + RowInx := tbFindRowInx(RowNum); + if (RowInx <> -1) then + with tbColNums^ do + for ColInx := 0 to pred(LockedCols) do + InvCells.AddCell(RowNum, Ay[ColInx].Number); + end; +{--------} +procedure TOvcCustomTable.InvalidateRowHeading(RowNum : TRowNum); + begin + tbInvalidateRowHdgPrim(RowNum, tbInvCells); + end; +{--------} +procedure TOvcCustomTable.InvalidateTable; + var + RowInx : integer; + ColInx : integer; + PredColNumsCount : integer; + PredRowNumsCount : integer; + begin +{$IFDEF LCL} //Apparent TurboPower bug revealed when checks on + if (tbColNums^.Count > 0) and (tbRowNums^.Count > 0) then + begin +{$ENDIF} + PredColNumsCount := pred(tbColNums^.Count); + PredRowNumsCount := pred(tbRowNums^.Count); + for RowInx := 0 to PredRowNumsCount do + for ColInx := 0 to PredColNumsCount do + tbInvCells.AddCell(tbRowNums^.Ay[RowInx].Number, + tbColNums^.Ay[ColInx].Number); +{$IFDEF LCL} + end; +{$ENDIF} + tbInvCells.AddUnusedBit; + end; +{--------} +procedure TOvcCustomTable.InvalidateTableNotLockedCols; + var + RowInx : integer; + ColInx : integer; + StartColInx : integer; + PredColNumsCount : integer; + PredRowNumsCount : integer; + begin + StartColInx := 0; + PredColNumsCount := pred(tbColNums^.Count); + PredRowNumsCount := pred(tbRowNums^.Count); + while (StartColInx <= PredColNumsCount) and + (tbColNums^.Ay[StartColInx].Number < LockedCols) do + inc(StartColInx); + for RowInx := 0 to PredRowNumsCount do + for ColInx := StartColInx to PredColNumsCount do + tbInvCells.AddCell(tbRowNums^.Ay[RowInx].Number, + tbColNums^.Ay[ColInx].Number); + tbInvCells.AddUnusedBit; + end; +{--------} +procedure TOvcCustomTable.InvalidateTableNotLockedRows; + var + RowInx : integer; + ColInx : integer; + StartRowInx : integer; + PredColNumsCount : integer; + PredRowNumsCount : integer; + begin + StartRowInx := 0; + PredColNumsCount := pred(tbColNums^.Count); + PredRowNumsCount := pred(tbRowNums^.Count); + while (StartRowInx <= PredRowNumsCount) and + (tbRowNums^.Ay[StartRowInx].Number < LockedRows) do + inc(StartRowInx); + for RowInx := StartRowInx to PredRowNumsCount do + for ColInx := 0 to PredColNumsCount do + tbInvCells.AddCell(tbRowNums^.Ay[RowInx].Number, + tbColNums^.Ay[ColInx].Number); + tbInvCells.AddUnusedBit; + end; +{====================================================================} + + +{==TOvcTable miscellaneous===========================================} +function TOvcCustomTable.tbCalcActiveCellRect(var ACR : TRect) : boolean; + var + RInx : integer; + CInx : integer; + begin + Result := false; + RInx := tbFindRowInx(ActiveRow); + if (RInx = -1) then + Exit; + CInx := tbFindColInx(ActiveCol); + if (CInx = -1) then + Exit; + + Result := true; + with ACR do + begin + Top := tbRowNums^.Ay[RInx].Offset; + Bottom := tbRowNums^.Ay[succ(RInx)].Offset; + Left := tbColNums^.Ay[CInx].Offset; + Right := tbColNums^.Ay[succ(CInx)].Offset; + end; + with GridPenSet.NormalGrid do + case Effect of + geVertical : dec(ACR.Right); + geHorizontal : dec(ACR.Bottom); + geBoth : begin + dec(ACR.Right); + dec(ACR.Bottom); + end; + ge3D : InflateRect(ACR, -1, -1); + end;{case} + end; +{--------} +function TOvcCustomTable.tbCalcCellsFromRect(const UR : TRect; var GR : TRect) : integer; + {-Converts a paint rect into a 'grid' rect. A grid rect is a rectangle of + cells, defined by their display indexes rather than their row/column + numbers. + The function result is a definition of the type of rectangle produced: + 0--top left and bottom right corners of the original rect are + exclusively within the table; + 1--top left of the rect is in the displayed table, the bottom right is + in the 'unused' bit (the bit between the displayed cells and the + client area; + 2--the original rectangle is exclusively in the 'unused bit'. + } + var + Row : TRowNum; + Col : TColNum; + Region : TOvcTblRegion; + begin + Result := 0; + Region := CalcRowColFromXY(UR.Left, UR.Top, Row, Col); + if (Region = otrInUnused) then + begin + Result := 2; + FillChar(GR, sizeof(GR), $FF); {set 'em all to -1} + Exit; + end; + GR.Left := tbFindColInx(Col); + GR.Top := tbFindRowInx(Row); + Region := CalcRowColFromXY(UR.Right, UR.Bottom, Row, Col); + if (Region = otrInUnused) or (Region = otrOutside) then + Result := 1; + if (Col = CRCFXY_ColToRight) then + GR.Right := pred(tbColNums^.Count) + else + GR.Right := tbFindColInx(Col); + if (Row = CRCFXY_RowBelow) then + GR.Bottom := pred(tbRowNums^.Count) + else + GR.Bottom := tbFindRowInx(Row); + end; +{--------} +procedure TOvcCustomTable.tbCalcColData(var CD : POvcTblDisplayArray; + NewLeftCol : TColNum); + var + X : integer; + Width : integer; + Access : TOvcTblAccess; + Hidden : boolean; + ColNum : TColNum; + FullWidth : integer; + PredColCount : TColNum; + PredLocked : TColNum; + begin + {initialise} + X := 0; + ColNum := -1; + CD^.Count := 0; + FullWidth := ClientWidth; {save expense of function call in loop} + PredColCount := pred(ColCount); {save expense of function call in loop} + PredLocked := pred(LockedCols); {save expense of function call in loop} + + {deal with the locked columns first} + if (LockedCols <> 0) then + while (X < FullWidth) and (ColNum < PredLocked) do + begin + inc(ColNum); + tbQueryColData(ColNum, Width, Access, Hidden); + if not Hidden then + begin + with CD^ do + begin + with Ay[Count] do + begin + Number := ColNum; + Offset := X; + end; + inc(Count); + if (Count >= AllocNm) then + AssignDisplayArray(CD, AllocNm+16); + end; + inc(X, Width); + end; + end; + + {now deal with the rightmost columns} + ColNum := pred(NewLeftCol); + while (X < FullWidth) and (ColNum < PredColCount) do + begin + inc(ColNum); + tbQueryColData(ColNum, Width, Access, Hidden); + if not Hidden then + begin + with CD^ do + begin + with Ay[Count] do + begin + Number := ColNum; + Offset := X; + end; + inc(Count); + if (Count >= AllocNm) then + AssignDisplayArray(CD, AllocNm+16); + end; + inc(X, Width); + end; + end; + + {use the next spare element for storing the offset for the grid} + with CD^ do + Ay[Count].Offset := X; + end; +{--------} +function TOvcCustomTable.CalcRowColFromXY(X, Y : integer; + var RowNum : TRowNum; + var ColNum : TColNum) : TOvcTblRegion; + var + ColInx : integer; + RowInx : integer; + CW : integer; + CH : integer; + TW : integer; + TH : integer; + begin + RowNum := CRCFXY_RowBelow; + ColNum := CRCFXY_ColToRight; + CW := ClientWidth; + CH := ClientHeight; + + {calculate the table width and height} + with tbColNums^ do + TW := MinI(CW, Ay[Count].Offset); + with tbRowNums^ do + TH := MinI(CH, Ay[Count].Offset); + + {make a first pass at calculating the region} + if (X < 0) or (Y < 0) or (X >= CW) or (Y >= CH) then + Result := otrOutside {definitely} + else + Result := otrInMain; {possibly, could also be one of the other two} + + {calculate row first} + with tbRowNums^ do + if (0 <= Y) and (Y < TH) then + begin + RowInx := 0; + while (Ay[RowInx].Offset <= Y) do + inc(RowInx); + RowNum := Ay[pred(RowInx)].Number; + end; + + {now calculate column} + with tbColNums^ do + if (0 <= X) and (X < TW) then + begin + ColInx := 0; + while (Ay[ColInx].Offset <= X) do + inc(ColInx); + ColNum := Ay[pred(ColInx)].Number; + end; + + {now patch up the region} + if (Result = otrInMain) then + if (RowNum = CRCFXY_RowBelow) or (ColNum = CRCFXY_ColToRight) then + Result := otrInUnused + else if (RowNum < LockedRows) or (ColNum < LockedCols) then + Result := otrInLocked; + + {now patch up the row and column numbers} + if (Result = otrOutside) or (Result = otrInUnused) then + begin + if (RowNum = CRCFXY_RowBelow) and (Y < 0) then + RowNum := CRCFXY_RowAbove; + if (ColNum = CRCFXY_ColToRight) and (X < 0) then + ColNum := CRCFXY_ColToLeft; + end; + end; +{--------} +{$IFDEF SuppressWarnings} +{$Warnings OFF} +{$ENDIF} +procedure TOvcCustomTable.tbCalcColsOnLastPage; + var + CD : POvcTblDisplayArray; + OldLeftCol : TColNum; + NewLeftCol : TColNum; + StillGoing : boolean; + begin + OldLeftCol := 0; + if (ColCount <= LockedCols) then + begin + tbColsOnLastPage := 0; + Exit; + end; + + CD := nil; + AssignDisplayArray(CD, tbColNums^.AllocNm); + + try + NewLeftCol := IncCol(pred(ColCount), 0); + tbCalcColData(CD, NewLeftCol); + if (CD^.Ay[CD^.Count].Offset > ClientWidth) then + begin + tbLastLeftCol := NewLeftCol; + tbColsOnLastPage := 1; + Exit; + end; + + StillGoing := true; + while StillGoing do + begin + OldLeftCol := NewLeftCol; + NewLeftCol := IncCol(NewLeftCol, -1); + if (NewLeftCol = OldLeftCol) then + StillGoing := false + else + begin + tbCalcColData(CD, NewLeftCol); + StillGoing := (CD^.Ay[CD^.Count].Offset < ClientWidth); + end; + end; + tbColsOnLastPage := ColCount - NewLeftCol; + tbLastLeftCol := OldLeftCol; + if tbLastLeftCol < LeftCol then + LeftCol := tbLastLeftCol; + finally + AssignDisplayArray(CD, 0); + end;{try..finally} + end; +{$IFDEF SuppressWarnings} +{$Warnings ON} +{$ENDIF} +{--------} +procedure TOvcCustomTable.tbCalcRowData(var RD : POvcTblDisplayArray; + NewTopRow : TRowNum); + var + Y : integer; + Height : integer; + Hidden : boolean; + RowNum : TRowNum; + FullHeight : integer; + PredRowLimit : TRowNum; + PredLocked : TRowNum; + begin + {initialise} + Y := 0; + RowNum := -1; + RD^.Count := 0; + FullHeight := ClientHeight; {save expense of function call in loop} + PredRowLimit := pred(RowLimit); {save expense of function call in loop} + PredLocked := pred(LockedRows); {save expense of function call in loop} + + {deal with the locked rows first} + if (LockedRows <> 0) then + while (Y < FullHeight) and (RowNum < PredLocked) do + begin + inc(RowNum); + tbQueryRowData(RowNum, Height, Hidden); + if not Hidden then + begin + with RD^ do + begin + with Ay[Count] do + begin + Number := RowNum; + Offset := Y; + end; + inc(Count); + if (Count >= AllocNm) then + AssignDisplayArray(RD, AllocNm+16); + end; + inc(Y, Height); + end; + end; + + {now deal with the rows underneath the fixed rows} + RowNum := pred(NewTopRow); + while (Y < FullHeight) and (RowNum < PredRowLimit) do + begin + inc(RowNum); + tbQueryRowData(RowNum, Height, Hidden); + if not Hidden then + begin + with RD^ do + begin + with Ay[Count] do + begin + Number := RowNum; + Offset := Y; + end; + inc(Count); + if (Count >= AllocNm) then + AssignDisplayArray(RD, AllocNm+16); + end; + inc(Y, Height); + end; + end; + + {use the next spare element for storing the offset for the grid} + with RD^ do + Ay[Count].Offset := Y; + end; +{--------} +{$IFDEF SuppressWarnings} +{$Warnings OFF} +{$ENDIF} +procedure TOvcCustomTable.tbCalcRowsOnLastPage; + var + RD : POvcTblDisplayArray; + OldTopRow : TRowNum; + NewTopRow : TRowNum; + StillGoing : boolean; + begin + OldTopRow := 0; + if (RowLimit <= LockedRows) then + begin + tbRowsOnLastPage := 0; + Exit; + end; + + RD := nil; + AssignDisplayArray(RD, tbRowNums^.AllocNm); + + try + NewTopRow := IncRow(pred(RowLimit), 0); + tbCalcRowData(RD, NewTopRow); + if (RD^.Ay[RD^.Count].Offset >= ClientHeight) then + begin + tbLastTopRow := NewTopRow; + tbRowsOnLastPage := 1; + Exit; + end; + + StillGoing := true; + while StillGoing do + begin + OldTopRow := NewTopRow; + NewTopRow := IncRow(OldTopRow, -1); + if (NewTopRow = OldTopRow) then + StillGoing := false + else + begin + tbCalcRowData(RD, NewTopRow); + StillGoing := (RD^.Ay[RD^.Count].Offset < ClientHeight); + end; + end; + tbRowsOnLastPage := RowLimit - OldTopRow; + tbLastTopRow := OldTopRow; + if tbLastTopRow < TopRow then + TopRow := tbLastTopRow; + finally + AssignDisplayArray(RD, 0); + end;{try..finally} + end; +{$IFDEF SuppressWarnings} +{$Warnings ON} +{$ENDIF} +{--------} +procedure TOvcCustomTable.tbCalcHSBarPosCount; + var + Col : TColNum; + begin + tbHSBarPosCount := 0; + for Col := LockedCols to tbLastLeftCol do + if not tbIsColHidden(Col) then + inc(tbHSBarPosCount); + end; +{--------} +function TOvcCustomTable.tbCalcRequiresVSBar : boolean; + var + Row : TRowNum; + begin + {a fast check for possible hidden rows: if there are none and the + last page's top row is not equal to the number of locked rows + then obviously a vertical scrollbar is required.} + if (LockedRows < tbLastTopRow) and + (Rows.Count = 0) then + begin + Result := true; + Exit; + end; + {otherwise check to see whether all rows between the locked rows + and the last page's top row are hidden: if so no vertical scroll + bar is required.} + Result := false; + for Row := LockedRows to pred(tbLastTopRow) do + if not Rows.Hidden[Row] then + begin + Result := true; + Exit; + end; + end; +{--------} +procedure TOvcCustomTable.ChangeScale(M, D : integer); + var + i : TColNum; + begin + inherited ChangeScale(M, D); + if (M <> D) then + begin + Rows.rwScaleHeights(M, D); + for i := 0 to pred(ColCount) do + with Columns[i] do + Width := MulDiv(Width, M, D); + end; + end; +{--------} + +{ - HWnd changed to TOvcHWnd for BCB Compatibility } +function TOvcCustomTable.tbEditCellHasFocus( + FocusHandle : TOvcHWnd{HWND}) : boolean; + var + ChildHandle : HWND; + begin + Result := false; + if not InEditingState then + Exit; + if (tbActCell.EditHandle = 0) then + Exit; + Result := true; + if (FocusHandle = tbActCell.EditHandle) then + Exit; + ChildHandle := GetWindow(tbActCell.EditHandle, GW_CHILD); + while (ChildHandle <> 0) do + begin + if (FocusHandle = ChildHandle) then + Exit; + ChildHandle := GetWindow(ChildHandle, GW_CHILD); + end; + Result := false; + end; +{--------} +procedure TOvcCustomTable.tbEnsureColumnIsVisible(ColNum : TColNum); + var + ColInx : integer; + CW : integer; + FarRight : integer; + LeftInx : integer; + LColOfs : integer; + LColWd : integer; + begin + {get the index for the column} + ColInx := tbFindColInx(ColNum); + if (ColInx = -1) then + begin + {the column is not even visible} + {make this column the left column} + LeftCol := ColNum; + end + else + begin + CW := ClientWidth; + with tbColNums^ do + FarRight := Ay[succ(ColInx)].Offset; + if (FarRight > CW) then + begin + {the column is partially visible} + + {pretend that we're scrolling the table left + column by column, until either + (1) the column we want is fully visible, or + (2) the column we want is the leftmost column + then set the leftmost column} + LeftInx := tbFindColInx(LeftCol); + LColOfs := tbColNums^.Ay[LeftInx].Offset; + LColWd := tbColNums^.Ay[succ(LeftInx)].Offset - LColOfs; + dec(FarRight, LColWd); + inc(LColOfs, LColWd); + inc(LeftInx); + while (LeftInx < ColInx) and (FarRight > CW) do + begin + LColWd := tbColNums^.Ay[succ(LeftInx)].Offset - LColOfs; + dec(FarRight, LColWd); + inc(LColOfs, LColWd); + inc(LeftInx); + end; + if (LeftInx < tbColNums^.Count) then + LeftCol := tbColNums^.Ay[LeftInx].Number; + end; + end; + end; +{--------} +procedure TOvcCustomTable.tbEnsureRowIsVisible(RowNum : TRowNum); + var + RowInx : integer; + CH : integer; + FarBottom: integer; + TopInx : integer; + TpRowOfs : integer; + TpRowHt : integer; + begin + RowInx := tbFindRowInx(RowNum); + if (RowInx = -1) then + begin + {the row is not even visible} + {make this row the top row} + TopRow := RowNum; + end + else + begin + CH := ClientHeight; + with tbRowNums^ do + FarBottom := Ay[succ(RowInx)].Offset; + if (FarBottom > CH) then + begin + {the row is partially visible} + + {pretend that we're scrolling the table up + row by row, until either + (1) the row we want is fully visible, or + (2) the row we want is the topmost row + then set the topmost row} + TopInx := tbFindRowInx(TopRow); + TpRowOfs := tbRowNums^.Ay[TopInx].Offset; + TpRowHt := tbRowNums^.Ay[succ(TopInx)].Offset - TpRowOfs; + dec(FarBottom, TpRowHt); + inc(TpRowOfs, TpRowHt); + inc(TopInx); + while (TopInx < RowInx) and (FarBottom > CH) do + begin + TpRowHt := tbRowNums^.Ay[succ(TopInx)].Offset - TpRowOfs; + dec(FarBottom, TpRowHt); + inc(TpRowOfs, TpRowHt); + inc(TopInx); + end; + if (TopInx < tbRowNums^.Count) then + TopRow := tbRowNums^.Ay[TopInx].Number; + end; + end; + end; +{--------} +function TOvcCustomTable.tbFindCell(RowNum : TRowNum; + ColNum : TColNum) : TOvcBaseTableCell; + begin + Result := FCells[RowNum, ColNum]; + if not Assigned(Result) then + if (RowNum < LockedRows) then + Result := FLockedRowsCell + else + Result := FCols[ColNum].DefaultCell; + end; +{--------} +function TOvcCustomTable.tbFindColInx(ColNum : TColNum) : integer; + var + L, M, R : integer; + CurNumber : TColNum; + begin + Result := -1; + with tbColNums^ do + begin + if (Count = 0) then + Exit; + L := 0; + R := pred(Count); + repeat + M := (L + R) div 2; + CurNumber := Ay[M].Number; + if (ColNum = CurNumber) then + begin + Result := M; + Exit; + end + else if (ColNum < CurNumber) then + R := pred(M) + else + L := succ(M); + until (L > R); + end; + end; +{--------} +function TOvcCustomTable.tbFindRowInx(RowNum : TRowNum) : integer; + var + L, M, R : integer; + CurNumber : TRowNum; + begin + Result := -1; + with tbRowNums^ do + begin + if (Count = 0) then + Exit; + L := 0; + R := pred(Count); + repeat + M := (L + R) div 2; + CurNumber := Ay[M].Number; + if (RowNum = CurNumber) then + begin + Result := M; + Exit; + end + else if (RowNum < CurNumber) then + R := pred(M) + else + L := succ(M); + until (L > R); + end; + end; +{--------} +procedure TOvcCustomTable.GetDisplayedColNums(var NA : TOvcTableNumberArray); + var + i : integer; + WorkCount : integer; + begin + WorkCount := MinL(NA.NumElements, tbColNums^.Count); + for i := 0 to pred(WorkCount) do + NA.Number[i] := tbColNums^.Ay[i].Number; + NA.Count := tbColNums^.Count + end; +{--------} +procedure TOvcCustomTable.GetDisplayedRowNums(var NA : TOvcTableNumberArray); + var + i : integer; + WorkCount : integer; + begin + WorkCount := MinL(NA.NumElements, tbRowNums^.Count); + for i := 0 to pred(WorkCount) do + NA.Number[i] := tbRowNums^.Ay[i].Number; + NA.Count := tbRowNums^.Count + end; +{--------} +function TOvcCustomTable.IncCol(ColNum : TColNum; Direction : integer) : TColNum; + {-Return a valid unhidden column number. If Direction is: + -ve : start at C and find the previous unhidden column number, if there + is none previous to this one, return C. + +ve : start at R and find the next unhidden column number, if there is + none after this one, return C + 0 : verify that C is unhidden, if not find the next unhidden column + number, if none after this one, find the previous one. If still + none, return C.} + var + CL, CC : TColNum; + begin + {save the values of properties in local variables} + CL := LockedCols; + CC := ColCount; + {adjust ColNum to be in range} + if (ColNum < CL) or (ColNum >= CC) then + ColNum := CL; + {first direction=0, ie to see whether the column is visible} + Result := ColNum; + if (Direction = 0) then {check not hidden} + if not tbIsColHidden(Result) then + Exit; + {now direction>=0, ie to increment the column number} + if (Direction >= 0) then {go forwards} + begin + inc(Result); + while Result < CC do + begin + if not tbIsColHidden(Result) then + Exit; + inc(Result); + end; + Result := ColNum; + end; + {now direction<=0, ie to decrement the column number} + if (Direction <= 0) then {go backwards} + begin + dec(Result); + while (Result >= CL) do + begin + if not tbIsColHidden(Result) then + Exit; + dec(Result); + end; + Result := ColNum; + end; + end; +{--------} +function TOvcCustomTable.IncRow(RowNum : TRowNum; Direction : integer) : TRowNum; + {-Return a valid unhidden row number. If Direction is: + -ve : start at R and find the previous unhidden row number, if there + is none previous to this one, return R. + +ve : start at R and find the next unhidden row number, if there is + none after this one, return R + 0 : verify that R is unhidden, if not find the next unhidden row + number, if none after this one, find the previous one. If still + none, return R.} + var + RL, RC : TRowNum; + begin + {save the values of properties in local variables} + RL := LockedRows; + RC := RowLimit; + {adjust RowNum to be in range} + if (RowNum < RL) or (RowNum >= RC) then + RowNum := RL; + {first direction=0, ie to see whether the column is visible} + Result := RowNum; + if (Direction = 0) then {check not hidden} + if not tbIsRowHidden(Result) then + Exit; + {now direction>=0, ie to increment the column number} + if (Direction >= 0) then {go forwards} + begin + inc(Result); + while (Result < RC) do + begin + if not tbIsRowHidden(Result) then + Exit; + inc(Result); + end; + Result := RowNum; + end; + {now direction<=0, ie to decrement the column number} + if (Direction <= 0) then {go backwards} + begin + dec(Result); + while (Result >= RL) do + begin + if not tbIsRowHidden(Result) then + Exit; + dec(Result); + end; + Result := RowNum; + end; + end; +{--------} +function TOvcCustomTable.InEditingState : boolean; + begin + Result := (tbState * [otsEditing, otsHiddenEdit]) <> []; + end; +{--------} +function TOvcCustomTable.tbIsColHidden(ColNum : TColNum) : boolean; + begin + if (ColNum < 0) or (ColNum >= FCols.Count) then + Result := True + else + Result := FCols[ColNum].Hidden; + end; +{--------} +function TOvcCustomTable.tbIsOnGridLine(MouseX, MouseY : integer; + var VerticalGrid : boolean) : boolean; + var + GridLine : integer; + Inx : integer; + LockedColsOffset : integer; + LockedRowsOffset : integer; + begin + Result := false; + {calc the offsets of the column and row} + LockedColsOffset := -1; + Inx := 0; + with tbColNums^ do + while (Inx < Count) do + begin + if (Ay[Inx].Number >= LockedCols) then + Break; + inc(Inx); + LockedColsOffset := Ay[Inx].Offset; + end; + LockedRowsOffset := -1; + Inx := 0; + with tbRowNums^ do + while (Inx < Count) do + begin + if (Ay[Inx].Number >= LockedRows) then + Break; + inc(Inx); + LockedRowsOffset := Ay[Inx].Offset; + end; + {do the obvious test: cursor is not within the locked area} + if (MouseX >= LockedColsOffset) and (MouseY >= LockedRowsOffset) then + Exit; + {check rows first} + if (MouseX < LockedColsOffset) then + begin + Inx := 0; + with tbRowNums^ do + while (Inx < Count) do + begin + inc(Inx); + GridLine := Ay[Inx].Offset; + if (GridLine-2 <= MouseY) and (MouseY <= GridLine+2) then + begin + VerticalGrid := false; + Result := true; + tbSizeIndex := pred(Inx); + Exit; + end; + end; + end; + {check columns next} + if (MouseY < LockedRowsOffset) then + begin + Inx := 0; + with tbColNums^ do + while (Inx < Count) do + begin + inc(Inx); + GridLine := Ay[Inx].Offset; + if (GridLine-2 <= MouseX) and (MouseX <= GridLine+2) then + begin + VerticalGrid := true; + Result := true; + tbSizeIndex := pred(Inx); + Exit; + end; + end; + end; + end; +{--------} +function TOvcCustomTable.tbIsInMoveArea(MouseX, MouseY : integer; + var IsColMove : boolean) : boolean; + var + Inx : integer; + LockedColsOffset : integer; + LockedRowsOffset : integer; + begin + Result := false; + IsColMove := false; + {calc the offsets of the column and row} + LockedColsOffset := -1; + Inx := 0; + with tbColNums^ do + while (Inx < Count) do + begin + if (Ay[Inx].Number >= LockedCols) then + Break; + inc(Inx); + LockedColsOffset := Ay[Inx].Offset; + end; + LockedRowsOffset := -1; + Inx := 0; + with tbRowNums^ do + while (Inx < Count) do + begin + if (Ay[Inx].Number >= LockedRows) then + Break; + inc(Inx); + LockedRowsOffset := Ay[Inx].Offset; + end; + {do the obvious test: cursor is not within the locked area} + if (MouseX >= LockedColsOffset) and (MouseY >= LockedRowsOffset) then + Exit; + {the cursor is within the column move area if it's in a locked cell + above the main area of the table; otherwise the cursor is within the + row move area if it's in a locked cell to the left of the main area + of the table} + Result := (MouseX >= LockedColsOffset) and (MouseY < LockedRowsOffset) and + (MouseX < tbColNums^.Ay[tbColNums^.Count].Offset); + if Result then + IsColMove := true + else + Result := (MouseX < LockedColsOffset) and (MouseY >= LockedRowsOffset) and + (MouseY < tbRowNums^.Ay[tbRowNums^.Count].Offset); + end; +{--------} +function TOvcCustomTable.tbIsRowHidden(RowNum : TRowNum) : boolean; + begin + Result := Rows[RowNum].Hidden; + end; +{--------} +procedure TOvcCustomTable.Notification(AComponent: TComponent; Operation: TOperation); + begin + inherited Notification(AComponent, Operation); + if (AComponent is TOvcBaseTableCell) and (Operation = opRemove) then + begin + AllowRedraw := false; + try + if (FLockedRowsCell = TOvcBaseTableCell(AComponent)) then + begin + FLockedRowsCell.DecRefs; + FLockedRowsCell := nil; + tbCellChanged(Self); + end; + if Assigned(FCols) then + FCols.tcNotifyCellDeletion(TOvcBaseTableCell(AComponent)); + if Assigned(FCells) then + FCells.tcNotifyCellDeletion(TOvcBaseTableCell(AComponent)); + finally + AllowRedraw := true; + end;{try..finally} + end; + end; +{--------} +procedure TOvcCustomTable.tbQueryColData(ColNum : TColNum; + var W : integer; + var A : TOvcTblAccess; + var H : boolean); + var + ColData : TOvcTableColumn; + begin + ColData := FCols[ColNum]; + if Assigned(ColData) then with ColData do + begin + W := Width; + if (DefaultCell <> nil) then + A := DefaultCell.Access + else + A := otxReadOnly; + H := Hidden; + end; + end; +{--------} +procedure TOvcCustomTable.tbQueryRowData(RowNum : TRowNum; + var Ht: integer; + var H : boolean); + var + RowData : TRowStyle; + begin + RowData := FRows[RowNum]; + with RowData do + begin + Ht:= Height; + H := Hidden; + end; + end; +{--------} +procedure TOvcCustomTable.SetBounds(ALeft, ATop, AWidth, AHeight: integer); + var + WidthChanged : boolean; + HeightChanged : boolean; + begin + if (not HandleAllocated) then + begin + inherited SetBounds(ALeft, ATop, AWidth, AHeight); + Exit; + end; + + WidthChanged := (Width <> AWidth); + HeightChanged := (Height <> AHeight); + + if WidthChanged or HeightChanged then + begin + AllowRedraw := false; + try + inherited SetBounds(ALeft, ATop, AWidth, AHeight); + if WidthChanged then + tbCalcColData(tbColNums, LeftCol); + if HeightChanged then + tbCalcRowData(tbRowNums, TopRow); + tbSetScrollRange(otsbVertical); + tbSetScrollRange(otsbHorizontal); + if (TopRow > tbLastTopRow) then + TopRow := tbLastTopRow; + if (LeftCol > tbLastLeftCol) then + LeftCol := tbLastLeftCol; + InvalidateTable; + finally + AllowRedraw := true; + end;{try..finally} + end + else + inherited SetBounds(ALeft, ATop, AWidth, AHeight); + end; +{====================================================================} + + +{==TOvcTable active cell movement====================================} +procedure TOvcCustomTable.tbMoveActCellBotOfPage; + var + RowInx : integer; + NewActiveRow : TRowNum; + NewActiveCol : TColNum; + begin + with tbRowNums^ do + if (Ay[Count].Offset <= ClientHeight) then + NewActiveRow := IncRow(Ay[pred(Count)].Number, 0) + else + begin + RowInx := pred(Count); + if (RowInx > 0) then + dec(RowInx); + if (Ay[RowInx].Number < LockedRows) then + NewActiveRow := IncRow(TopRow, 0) + else + NewActiveRow := IncRow(Ay[RowInx].Number, 0); + end; + NewActiveCol := ActiveCol; + DoActiveCellMoving(ccBotOfPage, NewActiveRow, NewActiveCol); + if (ActiveRow <> NewActiveRow) or (ActiveCol <> NewActiveCol) then + begin + tbSetActiveCellWithSel(NewActiveRow, NewActiveCol); + end; + end; +{--------} +procedure TOvcCustomTable.tbMoveActCellBotRight; + var + NewActiveRow : TRowNum; + NewActiveCol : TColNum; + begin + NewActiveRow := IncRow(pred(RowLimit), 0); + NewActiveCol := IncCol(pred(ColCount), 0); + DoActiveCellMoving(ccBotRightCell, NewActiveRow, NewActiveCol); + if (ActiveRow <> NewActiveRow) or (ActiveCol <> NewActiveCol) then + begin + tbSetActiveCellWithSel(NewActiveRow, NewActiveCol); + end; + end; +{--------} +procedure TOvcCustomTable.tbMoveActCellDown; + var + NewTopRow : TRowNum; + NewActiveRow : TRowNum; + NewActiveCol : TColNum; + i : integer; + begin + NewTopRow := TopRow; + NewActiveRow := IncRow(ActiveRow, 1); + NewActiveCol := ActiveCol; + DoActiveCellMoving(ccDown, NewActiveRow, NewActiveCol); + if (ActiveRow <> NewActiveRow) or (ActiveCol <> NewActiveCol) then + begin + {we need to take care of a special case: if the current active + cell is *exactly* on the last row of the page, we need to + artificially move the top row down by one, before setting the + active cell, otherwise the top row is forced to the active cell + later on--a bit disconcerting.} + with tbRowNums^ do + if (Ay[Count].Offset = ClientHeight) and + (ActiveRow = Ay[pred(Count)].Number) and + (NewActiveRow > ActiveRow) then + begin + for i := 1 to NewActiveRow-ActiveRow do + NewTopRow := IncRow(TopRow, 1); + if (NewTopRow < NewActiveRow) then + begin + AllowRedraw := False; + try + TopRow := NewTopRow; + tbSetActiveCellWithSel(NewActiveRow, NewActiveCol); + finally + AllowRedraw := True; + end;{try..finally} + end + else + tbSetActiveCellWithSel(NewActiveRow, NewActiveCol); + end + else + begin + tbSetActiveCellWithSel(NewActiveRow, NewActiveCol); + end; + end; + end; +{--------} +procedure TOvcCustomTable.tbMoveActCellFirstCol; + var + NewActiveRow : TRowNum; + NewActiveCol : TColNum; + begin + NewActiveCol := IncCol(LockedCols, 0); + NewActiveRow := ActiveRow; + DoActiveCellMoving(ccHome, NewActiveRow, NewActiveCol); + if (ActiveCol <> NewActiveCol) or (ActiveRow <> NewActiveRow) then + begin + tbSetActiveCellWithSel(NewActiveRow, NewActiveCol); + end; + end; +{--------} +procedure TOvcCustomTable.tbMoveActCellFirstRow; + var + NewActiveRow : TRowNum; + NewActiveCol : TColNum; + begin + NewActiveRow := IncRow(LockedRows, 0); + NewActiveCol := ActiveCol; + DoActiveCellMoving(ccFirstPage, NewActiveRow, NewActiveCol); + if (ActiveRow <> NewActiveRow) then + begin + tbSetActiveCellWithSel(NewActiveRow, NewActiveCol); + end; + end; +{--------} +procedure TOvcCustomTable.tbMoveActCellLastCol; + var + NewActiveRow : TRowNum; + NewActiveCol : TColNum; + begin + NewActiveCol := IncCol(pred(ColCount), 0); + NewActiveRow := ActiveRow; + DoActiveCellMoving(ccEnd, NewActiveRow, NewActiveCol); + if (ActiveCol <> NewActiveCol) or (ActiveRow <> NewActiveRow) then + begin + tbSetActiveCellWithSel(NewActiveRow, NewActiveCol); + end; + end; +{--------} +procedure TOvcCustomTable.tbMoveActCellLastRow; + var + NewActiveRow : TRowNum; + NewActiveCol : TColNum; + begin +// Apparent TurboPower bug: not initializing NewActiveCol. +// But not sure what it should be set to. + NewActiveRow := IncRow(pred(RowLimit), 0); + if (ActiveRow <> NewActiveRow) or (ActiveCol <> NewActiveCol) then + begin + NewActiveCol := ActiveCol; + DoActiveCellMoving(ccLastPage, NewActiveRow, NewActiveCol); + tbSetActiveCellWithSel(NewActiveRow, NewActiveCol); + end; + end; +{--------} +procedure TOvcCustomTable.tbMoveActCellLeft; + var + NewActiveRow : TRowNum; + NewActiveCol : TColNum; + begin + NewActiveCol := IncCol(ActiveCol, -1); + NewActiveRow := ActiveRow; + DoActiveCellMoving(ccLeft, NewActiveRow, NewActiveCol); + if (ActiveCol <> NewActiveCol) or (ActiveRow <> NewActiveRow) then + begin + tbSetActiveCellWithSel(NewActiveRow, NewActiveCol); + end; + end; +{--------} +procedure TOvcCustomTable.tbMoveActCellPageDown; + var + NewTopRow, + CurRow, LastRow : TRowNum; + CurInx, LastInx : integer; + NewActiveRow : TRowNum; + NewActiveCol : TColNum; + begin + CurRow := ActiveRow; + CurInx := tbFindRowInx(CurRow); + with tbRowNums^ do + begin + LastInx := pred(Count); + LastRow := Ay[LastInx].Number; + end; + if (CurRow = LastRow) then + NewTopRow := IncRow(LastRow, 1) + else + NewTopRow := LastRow; + + AllowRedraw := false; + try + TopRow := NewTopRow; + + if (CurInx = -1) then + NewActiveRow := IncRow(TopRow, 0) + else if (CurInx < tbRowNums^.Count) then + NewActiveRow := IncRow(tbRowNums^.Ay[CurInx].Number, 0) + else + NewActiveRow := IncRow(tbRowNums^.Ay[pred(tbRowNums^.Count)].Number, 0); + NewActiveCol := ActiveCol; + DoActiveCellMoving(ccNextPage, NewActiveRow, NewActiveCol); + if (ActiveRow <> NewActiveRow) or (ActiveCol <> NewActiveCol) then + begin + tbSetActiveCellWithSel(NewActiveRow, NewActiveCol); + end; + finally + AllowRedraw := true; + end;{try..finally} + end; +{--------} +procedure TOvcCustomTable.tbMoveActCellPageLeft; + var + Walker, + CurLeftCol : TRowNum; + CurInx : integer; + NewActiveRow : TRowNum; + NewActiveCol : TColNum; + begin + CurLeftCol := LeftCol; + if (ActiveCol = LeftCol) then + begin + Walker := IncCol(CurLeftCol, -1); + if (Walker = CurLeftCol) then + Exit; + end; + CurInx := tbFindColInx(ActiveCol); + AllowRedraw := false; + try + tbScrollBarPageLeft; + if (CurInx = -1) or (CurLeftCol = LeftCol) then + NewActiveCol := IncCol(LeftCol, 0) + else if (CurInx < tbColNums^.Count) then + NewActiveCol := IncCol(tbColNums^.Ay[CurInx].Number, 0) + else + NewActiveCol := IncCol(tbColNums^.Ay[pred(tbColNums^.Count)].Number, 0); + NewActiveRow := ActiveRow; + DoActiveCellMoving(ccPageLeft, NewActiveRow, NewActiveCol); + if (ActiveCol <> NewActiveCol) or (ActiveRow <> NewActiveRow) then + begin + tbSetActiveCellWithSel(NewActiveRow, NewActiveCol); + end; + finally + AllowRedraw := true; + end;{try..finally} + end; +{--------} +procedure TOvcCustomTable.tbMoveActCellPageRight; + var + NewLeftCol, + CurCol, LastCol : TColNum; + CurInx, LastInx : integer; + NewActiveRow : TRowNum; + NewActiveCol : TColNum; + begin + CurCol := ActiveCol; + CurInx := tbFindColInx(CurCol); + with tbColNums^ do + begin + LastInx := pred(Count); + LastCol := Ay[LastInx].Number; + end; + if (CurCol = LastCol) then + NewLeftCol := IncCol(LastCol, 1) + else + NewLeftCol := LastCol; + + AllowRedraw := false; + try + LeftCol := NewLeftCol; + + if (CurInx = -1) then + NewActiveCol := IncCol(LeftCol, 0) + else if (CurInx < tbColNums^.Count) then + NewActiveCol := IncCol(tbColNums^.Ay[CurInx].Number, 0) + else + NewActiveCol := IncCol(tbColNums^.Ay[pred(tbColNums^.Count)].Number, 0); + NewActiveRow := ActiveRow; + DoActiveCellMoving(ccPageRight, NewActiveRow, NewActiveCol); + if (ActiveCol <> NewActiveCol) or (ActiveRow <> NewActiveRow) then + begin + tbSetActiveCellWithSel(NewActiveRow, NewActiveCol); + end; + finally + AllowRedraw := true; + end;{try..finally} + end; +{--------} +procedure TOvcCustomTable.tbMoveActCellPageUp; + var + Walker, + CurTopRow : TRowNum; + CurInx : integer; + NewActiveRow : TRowNum; + NewActiveCol : TColNum; + begin + CurTopRow := TopRow; + if (ActiveRow = TopRow) then + begin + Walker := IncRow(CurTopRow, -1); + if (Walker = CurTopRow) then + Exit; + end; + CurInx := tbFindRowInx(ActiveRow); + AllowRedraw := false; + try + tbScrollBarPageUp; + if (CurInx = -1) or (CurTopRow = TopRow) then + NewActiveRow := IncRow(TopRow, 0) + else if (CurInx < tbRowNums^.Count) then + NewActiveRow := IncRow(tbRowNums^.Ay[CurInx].Number, 0) + else + NewActiveRow := IncRow(tbRowNums^.Ay[pred(tbRowNums^.Count)].Number, 0); + NewActiveCol := ActiveCol; + DoActiveCellMoving(ccPrevPage, NewActiveRow, NewActiveCol); + if (ActiveRow <> NewActiveRow) or (ActiveCol <> NewActiveCol) then + begin + tbSetActiveCellWithSel(NewActiveRow, NewActiveCol); + end; + finally + AllowRedraw := true; + end;{try..finally} + end; +{--------} +procedure TOvcCustomTable.tbMoveActCellRight; + var + NewActiveRow : TRowNum; + NewLeftCol, + NewActiveCol : TColNum; + i : integer; + begin + NewLeftCol := LeftCol; + NewActiveCol := IncCol(ActiveCol, 1); + NewActiveRow := ActiveRow; + DoActiveCellMoving(ccRight, NewActiveRow, NewActiveCol); + if (ActiveCol <> NewActiveCol) or (ActiveRow <> NewActiveRow) then + begin + {we need to take care of a special case: if the current active + cell is *exactly* on the last column of the page, we need to + artificially move the leftmost column across by one, before + setting the active cell, otherwise the leftmost column is + forced to the active cell later on--a bit disconcerting.} + with tbColNums^ do + if (NewActiveCol > ActiveCol) and + (ActiveCol = Ay[pred(Count)].Number) and + (Ay[Count].Offset = ClientWidth) then + begin + for i := 1 to NewActiveCol-ActiveCol do + NewLeftCol := IncCol(LeftCol, 1); + if (NewLeftCol < NewActiveCol) then + begin + AllowRedraw := False; + try + LeftCol := NewLeftCol; + tbSetActiveCellWithSel(NewActiveRow, NewActiveCol); + finally + AllowRedraw := True; + end;{try..finally} + end + else + tbSetActiveCellWithSel(NewActiveRow, NewActiveCol) + end + else + tbSetActiveCellWithSel(NewActiveRow, NewActiveCol); + end; + end; +{--------} +procedure TOvcCustomTable.tbMoveActCellTopLeft; + var + NewActiveRow : TRowNum; + NewActiveCol : TColNum; + begin + NewActiveRow := IncRow(LockedRows, 0); + NewActiveCol := IncCol(LockedCols, 0); + DoActiveCellMoving(ccTopLeftCell, NewActiveRow, NewActiveCol); + if (ActiveRow <> NewActiveRow) or (ActiveCol <> NewActiveCol) then + begin + tbSetActiveCellWithSel(NewActiveRow, NewActiveCol); + end; + end; +{--------} +procedure TOvcCustomTable.tbMoveActCellTopOfPage; + var + NewActiveRow : TRowNum; + NewActiveCol : TColNum; + begin + NewActiveRow := IncRow(TopRow, 0); + NewActiveCol := ActiveCol; + DoActiveCellMoving(ccTopOfPage, NewActiveRow, NewActiveCol); + if (ActiveRow <> NewActiveRow) or (ActiveCol <> NewActiveCol) then + begin + tbSetActiveCellWithSel(NewActiveRow, NewActiveCol); + end; + end; +{--------} +procedure TOvcCustomTable.tbMoveActCellUp; + var + NewActiveRow : TRowNum; + NewActiveCol : TColNum; + begin + NewActiveRow := IncRow(ActiveRow, -1); + NewActiveCol := ActiveCol; + DoActiveCellMoving(ccUp, NewActiveRow, NewActiveCol); + if (ActiveRow <> NewActiveRow) or (ActiveCol <> NewActiveCol) then + begin + tbSetActiveCellWithSel(NewActiveRow, NewActiveCol); + end; + end; +{--------} +procedure TOvcCustomTable.MoveActiveCell(Command : word); + begin + if (otoNoSelection in Options) then + tbIsKeySelecting := false; + + case Command of + {NOTE: this case statement has been optimised, the ccXxx + constants are in ASCENDING order of value not name--it's + lucky that the former implies the latter.} + ccBotOfPage : tbMoveActCellBotOfPage; + ccBotRightCell : tbMoveActCellBotRight; + ccDown : tbMoveActCellDown; + ccEnd : tbMoveActCellLastCol; + ccFirstPage : tbMoveActCellFirstRow; + ccHome : tbMoveActCellFirstCol; + ccLastPage : tbMoveActCellLastRow; + ccLeft : tbMoveActCellLeft; + ccNextPage : tbMoveActCellPageDown; + ccPageLeft : tbMoveActCellPageLeft; + ccPageRight : tbMoveActCellPageRight; + ccPrevPage : tbMoveActCellPageUp; + ccRight : tbMoveActCellRight; + ccTopLeftCell : tbMoveActCellTopLeft; + ccTopOfPage : tbMoveActCellTopOfPage; + ccUp : tbMoveActCellUp; + end;{case} + end; +{====================================================================} + + +{==TOvcTable scrollbar event handlers================================} +procedure TOvcCustomTable.ProcessScrollBarClick(ScrollBar : TOvcScrollBar; + ScrollCode : TScrollCode); + var + Form : TCustomForm; + begin + {check to see whether the cell being edited is valid; + no scrolling allowed if it isn't (tough).} + if InEditingState then + begin + if not tbActCell.CanSaveEditedData(true) then + Exit; + end; + {perform the scroll} + if (ScrollBar = otsbVertical) then + case ScrollCode of + scLineUp : tbScrollBarUp; + scLineDown : tbScrollBarDown; + scPageUp : tbScrollBarPageUp; + scPageDown : tbScrollBarPageDown; + end{case} + else {it's otsbHorizontal} + case ScrollCode of + scLineUp : tbScrollBarLeft; + scLineDown : tbScrollBarRight; + scPageUp : tbScrollBarPageLeft; + scPageDown : tbScrollBarPageRight; + end;{case} + if (otsDesigning in tbState) then + begin + Form := TCustomForm(GetParentForm(Self)); + if (Form <> nil) and (Form.Designer <> nil) then + Form.Designer.Modified; + end; + end; +{--------} +procedure TOvcCustomTable.tbScrollBarDown; + begin + TopRow := IncRow(TopRow, 1); + end; +{--------} +procedure TOvcCustomTable.tbScrollBarPageDown; + var + LastInx : integer; + LastRow : TRowNum; + begin + with tbRowNums^ do + begin + LastInx := pred(Count); + LastRow := Ay[LastInx].Number; + end; + if (TopRow <> LastRow) then + TopRow := LastRow + else + TopRow := IncRow(TopRow, 1); + end; +{--------} +procedure TOvcCustomTable.tbScrollBarPageUp; + var + CurTopRow : TRowNum; + Walker : TRowNum; + CH : integer; + OurRowNums: POvcTblDisplayArray; + NewTopRow : TRowNum; + begin + {-Scroll the table so that the current top row appears at + the bottom of the table window (if possible).} + CurTopRow := TopRow; + Walker := IncRow(CurTopRow, -1); + if (Walker = CurTopRow) then + Exit; + + OurRowNums := nil; + AssignDisplayArray(OurRowNums, tbRowNums^.AllocNm); + try + CH := ClientHeight; + NewTopRow := Walker; + tbCalcRowData(OurRowNums, NewTopRow); + while (OurRowNums^.Ay[OurRowNums^.Count].Offset < CH) or + (OurRowNums^.Ay[pred(OurRowNums^.Count)].Number > CurTopRow) do + begin + Walker := IncRow(NewTopRow, -1); + if (Walker = NewTopRow) then + Break; + NewTopRow := Walker; + tbCalcRowData(OurRowNums, NewTopRow); + end; + finally + AssignDisplayArray(OurRowNums, 0); + end;{try..finally} + TopRow := NewTopRow; + end; +{--------} +procedure TOvcCustomTable.tbScrollBarUp; + begin + TopRow := IncRow(TopRow, -1); + end; +{--------} +procedure TOvcCustomTable.tbScrollBarLeft; + begin + LeftCol := IncCol(LeftCol, -1); + end; +{--------} +procedure TOvcCustomTable.tbScrollBarPageLeft; + var + CurLeftCol : TColNum; + Walker : TColNum; + CW : integer; + OurColNums : POvcTblDisplayArray; + NewLeftCol : TColNum; + begin + CurLeftCol := LeftCol; + Walker := IncCol(CurLeftCol, -1); + if (Walker = CurLeftCol) then + Exit; + + OurColNums := nil; + AssignDisplayArray(OurColNums, tbColNums^.AllocNm); + try + CW := ClientWidth; + NewLeftCol := Walker; + tbCalcColData(OurColNums, NewLeftCol); + while (OurColNums^.Ay[OurColNums^.Count].Offset < CW) or + (OurColNums^.Ay[pred(OurColNums^.Count)].Number > CurLeftCol) do + begin + Walker := IncCol(NewLeftCol, -1); + if (Walker = NewLeftCol) then + Break; + NewLeftCol := Walker; + tbCalcColData(OurColNums, NewLeftCol); + end; + finally + AssignDisplayArray(OurColNums, 0); + end;{try..finally} + LeftCol := NewLeftCol; + end; +{--------} +procedure TOvcCustomTable.tbScrollBarPageRight; + var + LastInx : integer; + LastCol : TColNum; + begin + with tbColNums^ do + begin + LastInx := pred(Count); + LastCol := Ay[LastInx].Number; + end; + if (LeftCol <> LastCol) then + LeftCol := LastCol + else + LeftCol := IncCol(LeftCol, 1); + end; +{--------} +procedure TOvcCustomTable.tbScrollBarRight; + begin + LeftCol := IncCol(LeftCol, 1); + end; +{====================================================================} + + +{==TOvcTable table scrolling routines================================} +procedure TOvcCustomTable.tbScrollTableLeft(NewLeftCol : TColNum); + var + NewColInx : integer; + NewCLOfs : integer; + OldColRight : TColNum; + OldColInx : integer; + OldCLOfs : integer; + ColNum : TColNum; + R : TRect; + CW : integer; + begin + {the window is scrolled left, ie the new leftmost column + is to the right of the current leftmost column} + AllowRedraw := false; + try + NewColInx := tbFindColInx(NewLeftCol); + CW := ClientWidth; + if (NewColInx = -1) or + (tbColNums^.Ay[succ(NewColInx)].Offset > CW) then + begin + {the new leftmost column is not (fully) visible} + FLeftCol := NewLeftCol; + tbCalcColData(tbColNums, LeftCol); + InvalidateTableNotLockedCols; + end + else + begin + {the new leftmost column is fully visible} + OldColInx := tbFindColInx(FLeftCol); + with tbColNums^ do + begin + OldColRight := Ay[pred(Count)].Number; + if (Ay[Count].Offset < CW) then + begin + inc(OldColRight); + tbInvCells.AddUnusedBit; + end; + NewCLOfs := Ay[NewColInx].Offset; + OldCLOfs := Ay[OldColInx].Offset; + end; + R := Rect(OldCLOfs, 0, CW, ClientHeight); + ScrollWindow(Handle, + (OldCLOfs-NewCLOfs), 0, + @R, @R); + FLeftCol := NewLeftCol; + tbCalcColData(tbColNums, LeftCol); +{$IFDEF MSWINDOWS} + if (OldColRight <= tbColNums^.Ay[pred(tbColNums^.Count)].Number) then + begin + tbInvCells.AddUnusedBit; + for ColNum := OldColRight to tbColNums^.Ay[pred(tbColNums^.Count)].Number do + InvalidateColumn(ColNum); + end; +{$ELSE} //With GTK, ScrollWindow (above) does nothing, so redraw all columns + InvalidateTableNotLockedCols; +{$ENDIF} + R.Left := OldCLOfs + (CW - NewCLOfs); + ValidateRect(Handle, @R); + tbMustUpdate := true; + UpdateWindow(Handle); + end; + finally + AllowRedraw := true; + end;{try..finally} + end; +{--------} +procedure TOvcCustomTable.tbScrollTableRight(NewLeftCol : TColNum); + var + OldLeftCol: TColNum; + OldColInx : integer; + OldCLOfs : integer; + OrigOfs : integer; + ColNum : TColNum; + R : TRect; + begin + {the window is scrolled right, ie the new leftmost column + is to the left of the current leftmost column} + AllowRedraw := false; + try + OldLeftCol := FLeftCol; + OldColInx := tbFindColInx(OldLeftCol); + OrigOfs := tbColNums^.Ay[OldColInx].Offset; + FLeftCol := NewLeftCol; + tbCalcColData(tbColNums, LeftCol); + OldColInx := tbFindColInx(OldLeftCol); + if (OldColInx = -1) then + begin + {the old leftmost column is no longer visible} + InvalidateTableNotLockedCols; + end + else + begin + {the old leftmost column is (partially) visible} + OldCLOfs := tbColNums^.Ay[OldColInx].Offset; + R := Rect(OrigOfs, 0, ClientWidth, ClientHeight); + ScrollWindow(Handle, + (OldClOfs-OrigOfs), 0, + @R, @R); +{$IFDEF MSWINDOWS} + for ColNum := FLeftCol to pred(OldLeftCol) do + InvalidateColumn(ColNum); +{$ELSE} //With GTK, ScrollWindow (above) does nothing, so redraw all columns + InvalidateTableNotLockedCols; +{$ENDIF} + R.Right := OldCLOfs; + ValidateRect(Handle, @R); + tbMustUpdate := true; + UpdateWindow(Handle); + end; + finally + AllowRedraw := true; + end;{try..finally} + end; +{--------} +procedure TOvcCustomTable.tbScrollTableUp(NewTopRow : TRowNum); + var + NewRowInx : integer; + NewRTOfs : integer; + OldRowBottom : TRowNum; + OldRowInx : integer; + OldRTOfs : integer; + RowNum : TRowNum; + R : TRect; + CH : integer; + begin + {the window is scrolled up, ie the new topmost row + is underneath the current topmost row} + AllowRedraw := false; + try + NewRowInx := tbFindRowInx(NewTopRow); + CH := ClientHeight; + if (NewRowInx = -1) or + (tbRowNums^.Ay[succ(NewRowInx)].Offset > CH) then + begin + {the new topmost row is not (fully) visible} + FTopRow := NewTopRow; + tbCalcRowData(tbRowNums, TopRow); + InvalidateTableNotLockedRows; + end + else + begin + {the new topmost row is fully visible} + OldRowInx := tbFindRowInx(FTopRow); + with tbRowNums^ do + begin + OldRowBottom := Ay[pred(Count)].Number; + if (Ay[Count].Offset < CH) then + begin + inc(OldRowBottom); + tbInvCells.AddUnusedBit; + end; + NewRTOfs := Ay[NewRowInx].Offset; + OldRTOfs := Ay[OldRowInx].Offset; + end; + R := Rect(0, OldRTOfs, ClientWidth, CH); + ScrollWindow(Handle, + 0, (OldRTOfs-NewRTOfs), + @R, @R); + FTopRow := NewTopRow; + tbCalcRowData(tbRowNums, TopRow); +{$IFDEF MSWINDOWS} + if (OldRowBottom <= tbRowNums^.Ay[pred(tbRowNums^.Count)].Number) then + begin + tbInvCells.AddUnusedBit; + for RowNum := OldRowBottom to tbRowNums^.Ay[pred(tbRowNums^.Count)].Number do + InvalidateRow(RowNum); + end; +{$ELSE} //With GTK, ScrollWindow (above) does nothing, so redraw all rows + InvalidateTableNotLockedRows; +{$ENDIF} + R.Top := OldRTOfs + (CH - NewRTOfs); + ValidateRect(Handle, @R); + tbMustUpdate := true; + UpdateWindow(Handle); + end; + finally + AllowRedraw := true; + end;{try..finally} + end; +{--------} +procedure TOvcCustomTable.tbScrollTableDown(NewTopRow : TRowNum); + var + OldTopRow : TRowNum; + OldRowInx : integer; + OldRTOfs : integer; + OrigOfs : integer; + RowNum : TRowNum; + R : TRect; + begin + {the window is scrolled down, ie the new topmost row + is above the current topmost row} + AllowRedraw := false; + try + OldTopRow := FTopRow; + OldRowInx := tbFindRowInx(OldTopRow); + OrigOfs := tbRowNums^.Ay[OldRowInx].Offset; + FTopRow := NewTopRow; + tbCalcRowData(tbRowNums, TopRow); + OldRowInx := tbFindRowInx(OldTopRow); + if (OldRowInx = -1) then + begin + {the old topmost row is no longer visible} + InvalidateTableNotLockedRows; + end + else + begin + {the old topmost row is (partially) visible} + OldRTOfs := tbRowNums^.Ay[OldRowInx].Offset; + R := Rect(0, OrigOfs, ClientWidth, ClientHeight); + ScrollWindow(Handle, + 0, (OldRTOfs-OrigOfs), + @R, @R); +{$IFDEF MSWINDOWS} + for RowNum := FTopRow to pred(OldTopRow) do + InvalidateRow(RowNum); +{$ELSE} //With GTK, ScrollWindow (above) does nothing, so redraw all rows + InvalidateTableNotLockedRows; +{$ENDIF} + R.Bottom := OldRTOfs; + ValidateRect(Handle, @R); + tbMustUpdate := true; + UpdateWindow(Handle); + end; + finally + AllowRedraw := true; + end;{try..finally} + end; +{====================================================================} + + +{==TOvcTable drawing routines========================================} +procedure TOvcCustomTable.tbDrawActiveCell; + var + RowOfs : integer; + ColOfs : integer; + RowInx : integer; + ColInx : integer; + Ht : integer; + Wd : integer; + ActRowOfs : integer; + ActRowBottom : integer; + ActColOfs : integer; + ActColRight : integer; + GridPen : TOvcGridPen; + BrushColor : TColor; + DrawItFocused: boolean; + begin + ActRowOfs := 0; + ActRowBottom := 0; + ActColOfs := 0; + ActColRight := 0; + + {Find the cell's row on the screen, exit if not present} + RowInx := tbFindRowInx(ActiveRow); + if (RowInx = -1) then Exit; + + {Find the cell's column on the screen, exit if not present} + ColInx := tbFindColInx(ActiveCol); + if (ColInx = -1) then Exit; + + {If we are in editing mode, display the editing control for the + cell, otherwise, draw the focus box around the cell contents} + if InEditingState then + begin + UpdateWindow(tbActCell.EditHandle); + end + else + begin + {draw the box round the cell} + with Canvas do + begin + {get the correct grid pen} + if (otsFocused in tbState) then + begin + GridPen := GridPenSet.CellWhenFocused; + DrawItFocused := true; + end + else + begin + GridPen := GridPenSet.CellWhenUnfocused; + DrawItFocused := false; + end; + if GridPen.Effect = geNone then + Exit; + + RowOfs := tbRowNums^.Ay[RowInx].Offset; + Ht := tbRowNums^.Ay[succ(RowInx)].Offset - RowOfs; + ColOfs := tbColNums^.Ay[ColInx].Offset; + Wd := tbColNums^.Ay[succ(ColInx)].Offset - ColOfs; + + {calculate where to draw the vertical/horizontal lines} + case GridPenSet.NormalGrid.Effect of + geNone : begin + ActRowOfs := RowOfs; + ActRowBottom := RowOfs+Ht-1; + ActColOfs := ColOfs; + ActColRight := ColOfs+Wd-1 + end; + geVertical : begin + ActRowOfs := RowOfs; + ActRowBottom := RowOfs+Ht-1; + ActColOfs := ColOfs; + ActColRight := ColOfs+Wd-2; + end; + geHorizontal: begin + ActRowOfs := RowOfs; + ActRowBottom := RowOfs+Ht-2; + ActColOfs := ColOfs; + ActColRight := ColOfs+Wd-1; + end; + geBoth : begin + ActRowOfs := RowOfs; + ActRowBottom := RowOfs+Ht-2; + ActColOfs := ColOfs; + ActColRight := ColOfs+Wd-2; + end; + ge3D : begin + ActRowOfs := RowOfs+1; + ActRowBottom := RowOfs+Ht-2; + ActColOfs := ColOfs+1; + ActColRight := ColOfs+Wd-2; + end; + end;{case} + + {get the correct background color for the pen} + if DrawItFocused then +{$IFNDEF LCL} + BrushColor := Colors.ActiveFocused + else BrushColor := Colors.ActiveUnfocused; +{$ELSE} + BrushColor := Self.Colors.ActiveFocused + else BrushColor := Self.Colors.ActiveUnfocused; +{$ENDIF} + Brush.Color := Color; + +{$IFNDEF LCL} + Windows.SetBkColor(Handle, ColorToRGB(BrushColor)); +{$ELSE} + LclIntf.SetBkColor(Handle, ColorToRGB(BrushColor)); +{$ENDIF} + + {set up the pen} + with Pen do + begin + Width := 1; + Style := GridPen.Style; + Color := GridPen.NormalColor; + end; + + {right line} + if GridPen.Effect in [geVertical, geBoth, ge3D] then + begin + MoveTo(ActColRight, ActRowOfs); + LineTo(ActColRight, ActRowBottom+1); + end; + {bottom line} + if GridPen.Effect in [geHorizontal, geBoth, ge3D] then + begin + MoveTo(ActColOfs, ActRowBottom); + LineTo(ActColRight+1, ActRowBottom); + end; + + {if in 3D, must change colors} + if (GridPen.Effect = ge3D) then + Pen.Color := GridPen.SecondColor; + + {left line} + if GridPen.Effect in [geVertical, geBoth, ge3D] then + begin + MoveTo(ActColOfs, ActRowOfs); + LineTo(ActColOfs, ActRowBottom+1); + end; + {top line} + if GridPen.Effect in [geHorizontal, geBoth, ge3D] then + begin + MoveTo(ActColOfs, ActRowOfs); + LineTo(ActColRight+1, ActRowOfs); + end; + end; + end; + end; +{--------} +procedure TOvcCustomTable.tbDrawCells(RowInxStart, RowInxEnd : integer; + ColInxStart, ColInxEnd : integer); + var + RowInx : integer; + begin + {Delphi bug fix - refresh the canvas handle to force brush to be recreated} + Canvas.Refresh; + {draw cells that need it} + + if (RowInxStart < 0) or (RowInxEnd < 0) or + (ColInxStart < 0) or (ColInxEnd < 0) then + Exit; + + with tbRowNums^ do + for RowInx := RowInxStart to RowInxEnd do + tbDrawRow(RowInx, ColInxStart, ColInxEnd); + end; +{--------} +procedure TOvcCustomTable.tbDrawInvalidCells(InvCells : TOvcCellArray); + var + RowInx : integer; + ColInx : integer; + EndColInx : integer; + CellInx : integer; + NextCellInx: integer; + OldRowNum : TRowNum; + CellAddr : TOvcCellAddress; + NewCellAddr: TOvcCellAddress; + EndCol : TColNum; + ContinueTrying : boolean; + begin + if (InvCells.Count > 0) then + begin + {Delphi bug fix - refresh the canvas handle to force brush to be recreated} + Canvas.Refresh; + {set up for while loop} + OldRowNum := -1; + CellInx := 0; + while (CellInx < InvCells.Count) do + begin + InvCells.GetCellAddr(CellInx, CellAddr); + RowInx := tbFindRowInx(CellAddr.Row); + if (RowInx <> -1) then + begin + ColInx := tbFindColInx(CellAddr.Col); + if (ColInx <> -1) then + begin + {have we switched rows?} + if (OldRowNum <> CellAddr.Row) then + OldRowNum := CellAddr.Row; + {try and get a block of columns} + EndCol := CellAddr.Col; + NextCellInx := succ(CellInx); + ContinueTrying := true; + while ContinueTrying do + begin + if (NextCellInx >= InvCells.Count) then + ContinueTrying := false + else + begin + InvCells.GetCellAddr(NextCellInx, NewCellAddr); + if (OldRowNum = NewCellAddr.Row) and + (NewCellAddr.Col = succ(EndCol)) then + begin + EndCol := NewCellAddr.Col; + inc(NextCellInx); + end + else + ContinueTrying := false; + end + end; + if (EndCol <> CellAddr.Col) then + begin + EndColInx := tbFindColInx(EndCol); + CellInx := pred(NextCellInx); + {just in case (hidden cols perhaps?)} + while (EndColInx = -1) do + begin + dec(EndCol); + EndColInx := tbFindColInx(EndCol); + end + end + else + EndColInx := ColInx; + tbDrawRow(RowInx, ColInx, EndColInx); + end; + end; + inc(CellInx); + end; + end; + if InvCells.MustDoUnusedBit then + DoPaintUnusedArea; + InvCells.Clear; + end; +{--------} +procedure TOvcCustomTable.tbDrawMoveLine; + var + OldPen : TPen; + MoveOffset : integer; + begin + if tbDrag <> nil then + tbDrag.HideDragImage; + if (otsMoving in tbState) then + with Canvas do + begin + OldPen := TPen.Create; + try + OldPen.Assign(Pen); + try + Pen.Mode := pmXor; + Pen.Style := psSolid; + Pen.Color := clWhite; + Pen.Width := 3; + if (otsDoingCol in tbState) then + begin + if (tbMoveIndex < tbMoveIndexTo) then + MoveOffset := tbColNums^.Ay[succ(tbMoveIndexTo)].Offset + else + MoveOffset := tbColNums^.Ay[tbMoveIndexTo].Offset; + MoveTo(MoveOffset, 0); + LineTo(MoveOffset, ClientHeight); + end + else {doing row} + begin + if (tbMoveIndex < tbMoveIndexTo) then + MoveOffset := tbRowNums^.Ay[succ(tbMoveIndexTo)].Offset + else + MoveOffset := tbRowNums^.Ay[tbMoveIndexTo].Offset; + MoveTo(0, MoveOffset); + LineTo(ClientWidth, MoveOffset); + end + finally + Canvas.Pen := OldPen; + end;{try..finally} + finally + OldPen.Free; + end;{try..finally} + end; + if tbDrag <> nil then + tbDrag.ShowDragImage; + end; +{--------} +procedure TOvcCustomTable.tbDrawRow(RowInx : integer; ColInxStart, ColInxEnd : integer); + var + RowOfs : integer; + RowHt : integer; + RowNum : TRowNum; + ColInx : integer; + ColNum : TColNum; + ColOfs : integer; + ColWd : integer; + Cell : TOvcBaseTableCell; + Data : pointer; + GridPen : TOvcGridPen; + BrushColor: TColor; + CellAttr : TOvcCellAttributes; + DestRect : TRect; + RowIsLocked : boolean; + ColIsLocked : boolean; + IsActiveRow : boolean; + begin + {calculate data about the row, tell the user we're entering the row} + with tbRowNums^ do + begin + RowNum := Ay[RowInx].Number; + RowOfs := Ay[RowInx].Offset; + RowHt := Ay[succ(RowInx)].Offset - RowOfs; + end; + IsActiveRow := ActiveRow = RowNum; + RowIsLocked := RowNum < LockedRows; + { Don't fire the OnEnteringRow when we are painting, unless } + { OldRowColBehavior is true } + if OldRowColBehavior then + DoEnteringRow(RowNum); + + {set up the cell attribute record} + FillChar(CellAttr, sizeof(CellAttr), 0); + CellAttr.caFont := tbCellAttrFont; + + {for all required cells} + for ColInx := ColInxEnd downto ColInxStart do + begin + {calculate data about the column, tell the user we're entering the column} + with tbColNums^ do + begin + ColNum := Ay[ColInx].Number; + ColOfs := Ay[ColInx].Offset; + ColWd := Ay[succ(ColInx)].Offset - ColOfs; + end; + ColIsLocked := (ColNum < LockedCols); + { Don't fire the OnEnteringCol when we are painting, unless } + { OldRowColBehavior is true } + if OldRowColBehavior then + DoEnteringColumn(ColNum); + + {get the gridpen for the cell} + if (RowIsLocked or ColIsLocked) then + GridPen := GridPenSet.LockedGrid + else + GridPen := GridPenSet.NormalGrid; + + {calculate row height/column width available to the cell} + DestRect := Rect(ColOfs, RowOfs, ColOfs+ColWd, RowOfs+RowHt); + case GridPen.Effect of + geVertical : dec(DestRect.Right); + geHorizontal: dec(DestRect.Bottom); + geBoth : begin + dec(DestRect.Right); + dec(DestRect.Bottom); + end; + ge3D : InflateRect(DestRect, -1, -1); + end;{case} + + {don't do painting for the cell being edited} + Cell := nil; + if not (IsActiveRow and (ColNum = ActiveCol) and + (InEditingState)) then + begin + {get the cell} + Cell := tbFindCell(RowNum, ColNum); + if Assigned(Cell) then begin + {paint it} + DoGetCellData(RowNum, ColNum, Data, cdpForPaint); + CellAttr.caFont.Assign(Font); + Cell.ResolveAttributes(RowNum, ColNum, CellAttr); + Cell.Paint(Canvas, DestRect, + RowNum, ColNum, + CellAttr, + Data); + end; + end; + + {if no cell found or it's the active cell in editing mode + clear the rectangle} + if not Assigned(Cell) or + (IsActiveRow and (ColNum = ActiveCol) and InEditingState) then + begin + with CellAttr do + begin + caAccess := otxDefault; + caAdjust := otaDefault; + caColor := Color; + caFont.Assign(Font); + caFontColor := Font.Color; + end; + ResolveCellAttributes(RowNum, ColNum, CellAttr); + Canvas.Brush.Color := CellAttr.caColor; + Canvas.FillRect(DestRect); + end; + + {Check to see if there is a grid to display} + if (GridPen.Effect <> geNone) then + with Canvas do + begin + {Get ready to draw the cell's grid} + BrushColor := Color; + Brush.Color := BrushColor; + Pen.Style := GridPen.Style; + Pen.Width := 1; + +{$IFNDEF LCL} + Windows.SetBkColor(Handle, ColorToRGB(BrushColor)); +{$ELSE} + LclIntf.SetBkColor(Handle, ColorToRGB(BrushColor)); +{$ENDIF} + + {draw the top and left lines, only if required of course} + if (GridPen.Effect = ge3D) then + begin + {set the pen color for the top & left} + Pen.Color := GridPen.SecondColor; + {draw the lines} + MoveTo(ColOfs, pred(RowOfs+RowHt)); + LineTo(ColOfs, RowOfs); + LineTo(ColOfs+ColWd, RowOfs); + end; + + {set the pen color for the bottom & right} + Pen.Color := GridPen.NormalColor; + + {draw right line} + if (GridPen.Effect <> geHorizontal) then + begin + MoveTo(ColOfs+ColWd-1, RowOfs); + LineTo(ColOfs+ColWd-1, RowOfs+RowHt); + end; + + {draw bottom line} + if (GridPen.Effect <> geVertical) then + begin + MoveTo(ColOfs, pred(RowOfs+RowHt)); + LineTo(ColOfs+ColWd, pred(RowOfs+RowHt)); + end; + end; + end; + end; +{--------} +procedure TOvcCustomTable.tbDrawSizeLine; + var + OldPen : TPen; + begin + if (otsSizing in tbState) then + with Canvas do + begin + OldPen := TPen.Create; + try + OldPen.Assign(Pen); + Pen.Color := clBlack; + Pen.Mode := pmXor; + Pen.Style := psDot; + Pen.Width := 1; + if (otsDoingRow in tbState) then + begin + MoveTo(0, tbSizeOffset); + LineTo(ClientWidth, tbSizeOffset); + end + else + begin + MoveTo(tbSizeOffset, 0); + LineTo(tbSizeOffset, ClientHeight); + end; + finally + Canvas.Pen := OldPen; + OldPen.Free; + end;{try..finally} + end; + end; +{--------} +procedure TOvcCustomTable.tbDrawUnusedBit; + var + R : TRect; + CR : TRect; + ChangedBrush : boolean; + begin + ChangedBrush := false; +{$IFNDEF LCL} + Windows.GetClientRect(Handle, CR); +{$ELSE} + LclIntf.GetClientRect(Handle, CR); +{$ENDIF} + with R, tbColNums^ do + begin + Left := Ay[Count].Offset; + Right := CR.Right; + Top := 0; + Bottom := CR.Bottom; + end; + if (R.Left < R.Right) then + with Canvas do + begin + Brush.Color := ColorUnused; + FillRect(R); + ChangedBrush := true; + end; + + with R, tbRowNums^ do + begin + Right := Left; + Left := 0; + Top := Ay[Count].Offset; + end; + if (R.Top < R.Bottom) then + with Canvas do + begin + if not ChangedBrush then + Brush.Color := ColorUnused; + FillRect(R); + end; + end; +{--------} +procedure TOvcCustomTable.Paint; + var + UR, GR : TRect; + WhatToPaint : integer; + RowInx : integer; + ColInx : integer; + begin + {don't do anything if the table is locked from drawing and + there is no scrolling going on (tbMustUpdate is *only* set in + the tbScrollTableXxx methods to force an update).} + if (tbLockCount > 0) and (not tbMustUpdate) then + begin + Exit; + end; + + if tbDrag <> nil then + tbDrag.HideDragImage; + +{$IFNDEF LCL} + Windows.GetClipBox(Canvas.Handle, UR); +{$ELSE} + LclIntf.GetClipBox(Canvas.Handle, @UR); +{$ENDIF} + WhatToPaint := tbCalcCellsFromRect(UR, GR); + + if (WhatToPaint = 0) and + (otsEditing in tbState) and + ((GR.Top = ActiveRow) and (GR.Bottom = ActiveRow) and + (GR.Left = ActiveCol) and (GR.Right = ActiveCol)) then + Exit; + + {if we are actually processing a WM_PAINT message, then paint the + invalid cells, etc} + if (tbLockCount = 0) then + begin + if (WhatToPaint <> 2) then + tbDrawCells(GR.Top, GR.Bottom, GR.Left, GR.Right); + + if (WhatToPaint <> 0) then + DoPaintUnusedArea; + + tbDrawActiveCell; + end + {otherwise we are in the middle of a scroll operation, so just invalidate + the cells that need it} + else {tbLockCount > 0, ie tbMustUpdate is true} + begin + if (WhatToPaint <> 2) then + for RowInx := GR.Top to GR.Bottom do + for ColInx := GR.Left to GR.Right do + InvalidateCell(tbRowNums^.Ay[RowInx].Number, tbColNums^.Ay[ColInx].Number); + if (WhatToPaint <> 0) then + tbInvCells.AddUnusedBit; + tbMustUpdate := false; + end; + + if tbDrag <> nil then + tbDrag.ShowDragImage; + + end; +{====================================================================} + + +{==TOvcTable event handlers==========================================} +procedure TOvcCustomTable.DoActiveCellChanged(RowNum : TRowNum; ColNum : TColNum); + begin + if ((ComponentState * [csLoading, csDestroying]) = []) and + Assigned(FActiveCellChanged) then + FActiveCellChanged(Self, RowNum, ColNum); + end; +{--------} +procedure TOvcCustomTable.DoActiveCellMoving(Command : word; + var RowNum : TRowNum; + var ColNum : TColNum); + begin + if ((ComponentState * [csLoading, csDestroying]) <> []) then + Exit; + if Assigned(FActiveCellMoving) then + FActiveCellMoving(Self, Command, RowNum, ColNum); + if InEditingState and ((RowNum <> ActiveRow) or (ColNum <> ActiveCol)) then + if not StopEditingState(true) then + begin + RowNum := ActiveRow; + ColNum := ActiveCol; + Exit; + end; + end; +{--------} +procedure TOvcCustomTable.DoBeginEdit(RowNum : TRowNum; ColNum : TColNum; + var AllowIt : boolean); + begin + if ((ComponentState * [csLoading, csDestroying]) <> []) then + AllowIt := false + else + begin + AllowIt := true; + if Assigned(FBeginEdit) then + FBeginEdit(Self, RowNum, ColNum, AllowIt); + end; + end; +{--------} +procedure TOvcCustomTable.DoClipboardCopy; + begin + if ((ComponentState * [csLoading, csDestroying]) = []) and + Assigned(FClipboardCopy) then + FClipboardCopy(Self); + end; +{--------} +procedure TOvcCustomTable.DoClipboardCut; + begin + if ((ComponentState * [csLoading, csDestroying]) = []) and + Assigned(FClipboardCut) then + FClipboardCut(Self); + end; +{--------} +procedure TOvcCustomTable.DoClipboardPaste; + begin + if ((ComponentState * [csLoading, csDestroying]) = []) and + Assigned(FClipboardPaste) then + FClipboardPaste(Self); + end; +{--------} +procedure TOvcCustomTable.DoColumnsChanged(ColNum1, ColNum2 : TColNum; + Action : TOvcTblActions); + var + i : integer; + begin + for i := 0 to pred(taCellList.Count) do + if (TOvcTableCellAncestor(taCellList[i]) is TOvcTCColHead) then + TOvcTCColHead(taCellList[i]).chColumnsChanged(ColNum1, ColNum2, Action); + + if ((ComponentState * [csLoading, csDestroying]) = []) and + Assigned(FColumnsChanged) then + FColumnsChanged(Self, ColNum1, ColNum2, Action); + end; +{--------} +procedure TOvcCustomTable.DoDoneEdit(RowNum : TRowNum; ColNum : TColNum); + begin + if ((ComponentState * [csLoading, csDestroying]) = []) and + Assigned(FDoneEdit) then + FDoneEdit(Self, RowNum, ColNum); + end; +{--------} +procedure TOvcCustomTable.DoEndEdit(Cell : TOvcBaseTableCell; + RowNum : TRowNum; ColNum : TColNum; + var AllowIt : boolean); + begin + if ((ComponentState * [csLoading, csDestroying]) <> []) then + AllowIt := false + else + begin + AllowIt := true; + if Assigned(FEndEdit) then + FEndEdit(Self, Cell, RowNum, ColNum, AllowIt); + end; + end; +{--------} +procedure TOvcCustomTable.DoEnteringColumn(ColNum : TColNum); + begin + if (ColNum <> tbLastEntCol) then + begin + tbLastEntCol := ColNum; + if ((ComponentState * [csLoading, csDestroying]) = []) and + Assigned(FEnteringColumn) then + FEnteringColumn(Self, ColNum); + end; + end; +{--------} +procedure TOvcCustomTable.DoEnteringRow(RowNum : TRowNum); + begin + if (RowNum <> tbLastEntRow) then + begin + tbLastEntRow := RowNum; + if ((ComponentState * [csLoading, csDestroying]) = []) and + Assigned(FEnteringRow) then + FEnteringRow(Self, RowNum); + end; + end; +{--------} +procedure TOvcCustomTable.DoGetCellAttributes(RowNum : TRowNum; ColNum : TColNum; + var CellAttr : TOvcCellAttributes); + begin + if ((ComponentState * [csLoading, csDestroying]) = []) and + Assigned(FGetCellAttributes) then + FGetCellAttributes(Self, RowNum, ColNum, CellAttr); + end; +{--------} +procedure TOvcCustomTable.DoGetCellData(RowNum : TRowNum; ColNum : TColNum; + var Data : pointer; + Purpose : TOvcCellDataPurpose); + begin + Data := nil; + if ((ComponentState * [csLoading, csDestroying]) = []) and + HandleAllocated and + Assigned(FGetCellData) then + FGetCellData(Self, RowNum, ColNum, Data, Purpose); + end; +{--------} +procedure TOvcCustomTable.DoLeavingColumn(ColNum : TColNum); + begin + if ((ComponentState * [csLoading, csDestroying]) = []) and + Assigned(FLeavingColumn) then + FLeavingColumn(Self, ColNum); + end; +{--------} +procedure TOvcCustomTable.DoLeavingRow(RowNum : TRowNum); + begin + if ((ComponentState * [csLoading, csDestroying]) = []) and + Assigned(FLeavingRow) then + FLeavingRow(Self, RowNum); + end; +{--------} +procedure TOvcCustomTable.DoLockedCellClick(RowNum : TRowNum; ColNum : TColNum); + begin + if ((ComponentState * [csLoading, csDestroying]) = []) and + Assigned(FLockedCellClick) then + FLockedCellClick(Self, RowNum, ColNum); + end; +{--------} + +procedure TOvcCustomTable.DoOnMouseWheel(Shift : TShiftState; Delta, XPos, YPos : SmallInt); +begin + inherited DoOnMouseWheel(Shift, Delta, XPos, YPos); + + if (ssCtrl in Shift) then begin + if (Delta > 0) then + tbMoveActCellPageUp + else + tbMoveActCellPageDown; + end else begin + if Delta < 0 then + MoveActiveCell(ccDown) + else + MoveActiveCell(ccUp); + end; +end; + +procedure TOvcCustomTable.DoPaintUnusedArea; + begin + if ((ComponentState * [csLoading, csDestroying]) <> []) then + Exit; + if Assigned(FPaintUnusedArea) then + FPaintUnusedArea(Self) + else + tbDrawUnusedBit; + end; +{--------} +procedure TOvcCustomTable.DoRowsChanged(RowNum1, RowNum2 : TRowNum; + Action : TOvcTblActions); + begin + if ((ComponentState * [csLoading, csDestroying]) = []) and + Assigned(FRowsChanged) then + FRowsChanged(Self, RowNum1, RowNum2, Action); + end; +{--------} +procedure TOvcCustomTable.DoSizeCellEditor(RowNum : TRowNum; + ColNum : TColNum; + var CellRect : TRect; + var CellStyle: TOvcTblEditorStyle); + begin + if Assigned(FSizeCellEditor) then + FSizeCellEditor(Self, RowNum, ColNum, CellRect, CellStyle); + end; +{--------} +procedure TOvcCustomTable.DoTopLeftCellChanged(RowNum : TRowNum; ColNum : TColNum); + begin + if ((ComponentState * [csLoading, csDestroying]) = []) and + Assigned(FTopLeftCellChanged) then + FTopLeftCellChanged(Self, RowNum, ColNum); + end; +{--------} +procedure TOvcCustomTable.DoTopLeftCellChanging(var RowNum : TRowNum; + var ColNum : TColNum); + begin + if ((ComponentState * [csLoading, csDestroying]) = []) and + Assigned(FTopLeftCellChanging) then + FTopLeftCellChanging(Self, RowNum, ColNum); + end; +{--------} +procedure TOvcCustomTable.DoUserCommand(Cmd : word); + begin + if ((ComponentState * [csLoading, csDestroying]) = []) and + Assigned(FUserCommand) then + FUserCommand(Self, Cmd); + end; +{====================================================================} + + +{==TOvcTable Windows Message handlers================================} +procedure TOvcCustomTable.CMColorChanged(var Msg : TMessage); + begin + inherited; + AllowRedraw := false; + tbNotifyCellsOfTableChange; + AllowRedraw := true; + end; +{--------} +procedure TOvcCustomTable.CMCtl3DChanged(var Msg : TMessage); + begin + if (csLoading in ComponentState) or not HandleAllocated then + Exit; + + if NewStyleControls and (FBorderStyle = bsSingle) then +{$IFNDEF LCL} + RecreateWnd; +{$ELSE} + MyMisc.RecreateWnd(Self); +{$ENDIF} + + inherited; + end; +{--------} +procedure TOvcCustomTable.CMDesignHitTest(var Msg : TCMDesignHitTest); + var + IsVert : boolean; + IsColMove : boolean; + OnGridLine : boolean; + begin + Msg.Result := 1; + if (otsDesigning in tbState) then + begin + if ((tbState * [otsSizing, otsMoving]) <> []) then + Exit; + Msg.Result := 0; + OnGridLine := tbIsOnGridLine(Msg.Pos.X, Msg.Pos.Y, IsVert); + if OnGridLine then + Msg.Result := 1 + else + Msg.Result := longint(tbIsInMoveArea(Msg.Pos.X, Msg.Pos.Y, IsColMove)); + end; + end; +{--------} +procedure TOvcCustomTable.CMFontChanged(var Msg : TMessage); + begin + inherited; + AllowRedraw := false; + tbNotifyCellsOfTableChange; + AllowRedraw := true; + end; +{--------} +procedure TOvcCustomTable.ctimQueryOptions(var Msg : TMessage); + begin +{$IFNDEF LCL} + Msg.Result := longint(word(FOptions)); +{$ELSE} + Msg.Result := longint(FOptions); +{$ENDIF} + end; +{--------} +procedure TOvcCustomTable.ctimQueryColor(var Msg : TMessage); + begin + Msg.Result := longint(Color); + end; +{--------} +procedure TOvcCustomTable.ctimQueryFont(var Msg : TMessage); + begin + Msg.Result := longint(Font); + end; +{--------} +procedure TOvcCustomTable.ctimQueryLockedCols(var Msg : TMessage); + begin + Msg.Result := longint(LockedCols); + end; +{--------} +procedure TOvcCustomTable.ctimQueryLockedRows(var Msg : TMessage); + begin + Msg.Result := longint(LockedRows); + end; +{--------} +procedure TOvcCustomTable.ctimQueryActiveCol(var Msg : TMessage); + begin + Msg.Result := longint(ActiveCol); + end; +{--------} +procedure TOvcCustomTable.ctimQueryActiveRow(var Msg : TMessage); + begin + Msg.Result := longint(ActiveRow); + end; +{--------} +procedure TOvcCustomTable.ctimRemoveCell(var Msg : TMessage); + begin + Notification(TComponent(Msg.LParam), opRemove); + Msg.Result := 0; + end; +{--------} +procedure TOvcCustomTable.ctimStartEdit(var Msg : TMessage); + begin + if not StartEditingState then + begin + AllowRedraw := false; + InvalidateCell(ActiveRow, ActiveCol); + AllowRedraw := true; + end; + Msg.Result := 1; + end; +{--------} +procedure TOvcCustomTable.ctimStartEditMouse(var Msg : TWMMouse); + begin + if Assigned(tbActCell) and InEditingState then + if tbActCell.AcceptActivationClick then + begin +{$IFNDEF LCL} + Windows.SetFocus(tbActCell.EditHandle); +{$ELSE} + LclIntf.SetFocus(tbActCell.EditHandle); +{$ENDIF} + PostMessage(tbActCell.EditHandle, + WM_LBUTTONDOWN, + Msg.Keys, longint(Msg.Pos)) + end; + Msg.Result := 1; + end; +{--------} +procedure TOvcCustomTable.ctimStartEditKey(var Msg : TWMKey); + begin + if Assigned(tbActCell) and InEditingState then + begin +{$IFNDEF LCL} + Windows.SetFocus(tbActCell.EditHandle); +{$ELSE} + LclIntf.SetFocus(tbActCell.EditHandle); +{$ENDIF} + PostMessage(tbActCell.EditHandle, WM_KEYDOWN, Msg.CharCode, Msg.KeyData); + end; + Msg.Result := 1; + end; +{--------} +procedure TOvcCustomTable.ctimLoadDefaultCells(var Msg : TMessage); + begin + AllowRedraw := false; + tbFinishLoadingCellList; + tbFinishLoadingDefaultCells; + Msg.Result := 0; + tbMustFinishLoading := false; + AllowRedraw := true; + end; +{--------} +procedure TOvcCustomTable.WMCancelMode(var Msg : TMessage); + begin + inherited; + tbIsKeySelecting := false; + if (otsMouseSelect in tbState) then + tbState := tbState - [otsMouseSelect] + [otsNormal]; + end; +{--------} +procedure TOvcCustomTable.WMEraseBkGnd(var Msg : TWMEraseBkGnd); + begin + Msg.Result := 1; {no erasing of the background, we'll do it all} + end; +{--------} +procedure TOvcCustomTable.WMGetDlgCode(var Msg : TMessage); + begin + Msg.Result := DLGC_WANTCHARS or DLGC_WANTARROWS; + if (otoTabToArrow in Options) then + Msg.Result := Msg.Result or DLGC_WANTTAB; + end; +{--------} +procedure TOvcCustomTable.WMHScroll(var Msg : TWMScroll); + {------} + procedure ProcessThumb; + var + i : integer; + NewLeftCol : TColNum; + begin + NewLeftCol := LockedCols; + for i := 0 to pred(Msg.Pos) do + NewLeftCol := IncCol(NewLeftCol, 1); + if (NewLeftCol <> LeftCol) then + LeftCol := NewLeftCol; + end; + {------} + begin + {ignore SB_ENDSCROLL and SB_THUMBTRACK messages (the latter + if required to by the Options property): this'll possibly + avoid multiple validations} + if (Msg.ScrollCode = SB_ENDSCROLL) or + ((Msg.ScrollCode = SB_THUMBTRACK) and + (not (otoThumbTrack in Options))) then + begin + inherited; + Exit; + end; + {if not focused then do so; if being designed update the + table view} + if (otsUnfocused in tbState) then +{$IFDEF MSWINDOWS} //Apparently can't focus scroll bar with GTK? + SetFocus +{$ENDIF} + else if (otsDesigning in tbState) then + Update; + {check to see whether the cell being edited is valid; + no scrolling allowed if it isn't (tough).} + if InEditingState then + begin + if not tbActCell.CanSaveEditedData(true) then + Exit; + end; + {process the scrollbar message} + case Msg.ScrollCode of + SB_LINELEFT : ProcessScrollBarClick(otsbHorizontal, scLineUp); + SB_LINERIGHT : ProcessScrollBarClick(otsbHorizontal, scLineDown); + SB_PAGELEFT : ProcessScrollBarClick(otsbHorizontal, scPageUp); + SB_PAGERIGHT : ProcessScrollBarClick(otsbHorizontal, scPageDown); + SB_THUMBPOSITION : ProcessThumb; + SB_THUMBTRACK : if (otoThumbTrack in Options) then ProcessThumb; + else + inherited; + Exit; + end; + Msg.Result := 0; + end; +{--------} +procedure TOvcCustomTable.WMKeyDown(var Msg : TWMKey); + var + Cmd : word; + ShiftFlags : byte; + begin + inherited; + + {If Tab key is being converted to arrow key, do it} + if (otoTabToArrow in Options) and (Msg.CharCode = VK_TAB) then + begin + {get shift value} + ShiftFlags := GetShiftFlags; + {convert Tab combination to command} + if (ShiftFlags = 0) then + Cmd := ccRight + else if (ShiftFlags = ss_Shift) then + Cmd := ccLeft + else + Cmd := ccNone; + end + {If Enter key is being converted to right arrow, do it.} + else if (otoEnterToArrow in Options) and (Msg.CharCode = VK_RETURN) then + begin + {get shift value} + ShiftFlags := GetShiftFlags; + {convert Enter combination to command} + if (ShiftFlags = 0) then + Cmd := ccRight + else + Cmd := ccNone; + end + {Otherwise just translate into a command} + else + Cmd := Controller.EntryCommands.TranslateUsing([tbCmdTable^], TMessage(Msg)); + + if InEditingState then + begin + if (not (otoAlwaysEditing in Options)) and + ((Cmd = ccTableEdit) or (Msg.CharCode = VK_ESCAPE)) then + begin + if not StopEditingState(Msg.CharCode <> VK_ESCAPE) then + begin + inherited; + Exit; + end; + end + end + else {not editing} + if (Cmd = ccTableEdit) or + ((Cmd > ccLastCmd) and (Cmd < ccUserFirst) and + ((Msg.CharCode = VK_SPACE) or + ((VK_0 <= Msg.CharCode) and (Msg.CharCode <= VK_DIVIDE)) or + (Msg.CharCode >= $BA))) then + begin + PostMessage(Handle, ctim_StartEdit, 0, 0); + if (Cmd <> ccTableEdit) then + PostMessage(Handle, ctim_StartEditKey, Msg.CharCode, Msg.KeyData); + end; + + tbIsKeySelecting := false; + case Cmd of + ccBotOfPage, ccBotRightCell, + ccDown, ccEnd, + ccFirstPage, ccHome, + ccLastPage, ccLeft, + ccNextPage, ccPageLeft, + ccPageRight, ccPrevPage, + ccRight, ccTopLeftCell, + ccTopOfPage, ccUp : MoveActiveCell(Cmd); + ccExtendDown : begin tbIsKeySelecting := true; MoveActiveCell(ccDown); end; + ccExtendEnd : begin tbIsKeySelecting := true; MoveActiveCell(ccEnd); end; + ccExtendHome : begin tbIsKeySelecting := true; MoveActiveCell(ccHome); end; + ccExtendLeft : begin tbIsKeySelecting := true; MoveActiveCell(ccLeft); end; + ccExtendPgDn : begin tbIsKeySelecting := true; MoveActiveCell(ccNextPage); end; + ccExtendPgUp : begin tbIsKeySelecting := true; MoveActiveCell(ccPrevPage); end; + ccExtendRight : begin tbIsKeySelecting := true; MoveActiveCell(ccRight); end; + ccExtendUp : begin tbIsKeySelecting := true; MoveActiveCell(ccUp); end; + ccExtBotOfPage : begin tbIsKeySelecting := true; MoveActiveCell(ccBotOfPage); end; + ccExtFirstPage : begin tbIsKeySelecting := true; MoveActiveCell(ccFirstPage); end; + ccExtLastPage : begin tbIsKeySelecting := true; MoveActiveCell(ccLastPage); end; + ccExtTopOfPage : begin tbIsKeySelecting := true; MoveActiveCell(ccTopOfPage); end; + ccExtWordLeft : begin tbIsKeySelecting := true; MoveActiveCell(ccWordLeft); end; + ccExtWordRight : begin tbIsKeySelecting := true; MoveActiveCell(ccWordRight); end; + ccCopy : DoClipboardCopy; + ccCut : DoClipboardCut; + ccPaste : DoClipboardPaste; + else + if (Cmd >= ccUserFirst) then + DoUserCommand(Cmd); + end; + end; +{--------} +procedure TOvcCustomTable.WMKillFocus(var Msg : TWMKillFocus); + begin + inherited; + + if (otsEditing in tbState) then + begin + Exit; + end; + + AllowRedraw := false; + try + InvalidateCell(ActiveRow, ActiveCol); + tbState := tbState - [otsFocused] + [otsUnfocused]; + finally + AllowRedraw := true; + end;{try..finally} + end; +{--------} +procedure TOvcCustomTable.WMLButtonDblClk(var Msg : TWMMouse); + var + Row : TRowNum; + Col : TColNum; + Region : TOvcTblRegion; + begin + inherited; + if not (otsDesigning in tbState) then + begin + Region := CalcRowColFromXY(Msg.XPos, Msg.YPos, Row, Col); + if Region = (otrInMain) then + begin + PostMessage(Handle, ctim_StartEdit, Msg.Keys, longint(Msg.Pos)); + PostMessage(Handle, ctim_StartEditMouse, Msg.Keys, longint(Msg.Pos)); + end; + end; + end; +{--------} +procedure TOvcCustomTable.WMLButtonDown(var Msg : TWMMouse); + var + Row : TRowNum; + Col : TColNum; + Action : TOvcTblSelectionType; + Region : TOvcTblRegion; + R : TRect; + P : TPoint; + ShiftKeyDown : boolean; + CtrlKeyDown : boolean; + AllowDrag : boolean; + WasUnfocused : boolean; + begin + inherited; + + {are we currently unfocused? if so focus the table} + WasUnfocused := false; + if (otsUnfocused in tbState) then + begin + WasUnfocused := true; + AllowRedraw := false; + try + {note: by the time SetFocus returns WMSetFocus will have been called} + SetFocus; + {..to get round an MDI bug..} + if not Focused then +{$IFNDEF LCL} + Windows.SetFocus(Handle); +{$ELSE} + LclIntf.SetFocus(Handle); +{$ENDIF} + finally + AllowRedraw := true; + end;{try..finally} + end; + + {are we currently showing a sizing cursor? if so the user wants to + resize a column/row} + if (otsShowSize in tbState) then + begin + tbState := tbState - [otsShowSize] + [otsSizing]; + if (otsDoingRow in tbState) then + begin + if (Msg.YPos >= tbRowNums^.Ay[tbSizeIndex].Offset+6) then + tbSizeOffset := Msg.YPos; + tbDrawSizeLine; + end + else {we're sizing a column} + begin + if (Msg.XPos >= tbColNums^.Ay[tbSizeIndex].Offset+6) then + tbSizeOffset := Msg.XPos; + tbDrawSizeLine; + end; + Exit; + end; + + {are we currently showing a row/col move cursor? if so the user wants + to move that row/col} + if (otsShowMove in tbState) then + begin + tbState := tbState - [otsShowMove] + [otsMoving]; + {work out the row/column we're in} + CalcRowColFromXY(Msg.XPos, Msg.YPos, Row, Col); + if (otsDoingCol in tbState) then begin + tbMoveIndex := tbFindColInx(Col); + R.Left := ColOffset[Col]; + R.Right := MinI(ClientWidth, R.Left + Columns[Col].Width); + R.Top := RowOffset[0]; + R.Bottom := RowOffset[1]; + end else begin{doing row} + tbMoveIndex := tbFindRowInx(Row); + R.Top := RowOffset[Row]; + R.Bottom := RowOffset[Row + 1]; + R.Bottom := MinI(ClientHeight, R.Top + Rows[Row].Height); + R.Left := ColOffset[0]; + R.Right := ColOffset[1]; + end; + + R.TopLeft := ClientToScreen(R.TopLeft); + R.BottomRight := ClientToScreen(R.BottomRight); + + P := ClientToScreen(Point(Msg.XPos, Msg.YPos)); + + tbDrag := TOvcDragShow.Create(P.x, P.y, R, clBtnFace); + + tbMoveIndexTo := tbMoveIndex; + tbDrawMoveLine; + Exit; + end; + + {are we focused and do we allow selections? if so be prepared to start or + extend the current selection (note that AlwaysEditing will be false)} + if (otsFocused in tbState) and (not (otoNoSelection in Options)) then + begin + {if we are editing a cell then stop editing it now (if possible)} + if InEditingState then + begin +{$IFNDEF LCL} + Windows.SetFocus(tbActCell.EditHandle); +{$ELSE} + LclIntf.SetFocus(tbActCell.EditHandle); +{$ENDIF} + end; + {get the state of the shift & ctrl keys} + ShiftKeyDown := (Msg.Keys and MK_SHIFT) <> 0; + CtrlKeyDown := (Msg.Keys and MK_CONTROL) <> 0; + {calculate where the mouse button was pressed} + Region := CalcRowColFromXY(Msg.XPos, Msg.YPos, Row, Col); + case Region of + otrInMain : + {the mouse was clicked in the main area} + begin + AllowRedraw := false; + try + AllowDrag := true; + {confirm the new active cell} + DoActiveCellMoving(ccMouse, Row, Col); + {if neither shift nor control are down, or control is + down on its own, we have to reset the anchor point} + if (not ShiftKeyDown) then + begin + if CtrlKeyDown then + Action := tstAdditional + else + begin + Action := tstDeselectAll; + {if the active cell hasn't changed (ie the user + clicked on the active cell, must start editing} + if (ActiveRow = Row) and (ActiveCol = Col) and + not WasUnfocused then + begin + PostMessage(Handle, ctim_StartEdit, 0, 0); + PostMessage(Handle, ctim_StartEditMouse, + Msg.Keys, longint(Msg.Pos)); + AllowDrag := false; + end; + end; + tbSetAnchorCell(Row, Col, Action); + end + {if the shift key is down then the user is either extending + the last selection only (control is up) or the last + selection in addition to the other selections (control is + down); extend the selection} + else {shift key is down} + begin + if CtrlKeyDown then + Action := tstAdditional + else + begin + Action := tstDeselectAll; + tbIsSelecting := true; + end; + tbUpdateSelection(Row, Col, Action); + end; + {now set the active cell} + tbSetActiveCellPrim(Row, Col); + finally + AllowRedraw := true; + end;{try..finally} + {until we get a mouse up message we are selecting with + the mouse (if we're allowed to, that is)} + if (otoMouseDragSelect in Options) and AllowDrag then + tbState := tbState - [otsNormal] + [otsMouseSelect]; + end; + otrInLocked : + begin + {the mouse was clicked on a locked cell} + if InEditingState then + if not StopEditingState(true) then + Exit; + AllowRedraw := false; + try + if (otoRowSelection in Options) and (Row >= LockedRows) then + tbSelectRow(Row); + if (otoColSelection in Options) and (Col >= LockedCols) then + tbSelectCol(Col); + if (otoRowSelection in Options) and (otoColSelection in Options) and + (Row < LockedRows) and (Col < LockedCols) then + tbSelectTable; + finally + AllowRedraw := true; + end;{try..finally} + if (otsNormal in tbState) then + DoLockedCellClick(Row, Col); + end; + otrInUnused : + begin + {clicking in the unused area deselects all selections} + if InEditingState then + if not StopEditingState(true) then + Exit; + + {move to new location} + if (Row = CRCFXY_RowBelow) then + Row := IncRow(pred(RowLimit), 0); + if (Col = CRCFXY_ColToRight) then + Col := IncCol(pred(ColCount), 0); + + {if row or col should changed, notify and doit} + if (Col <> ActiveCol) or (Row <> ActiveRow) then begin + DoActiveCellMoving(ccNone, Row, Col); + tbSetAnchorCell(Row, Col, tstDeselectAll); + tbSetActiveCellPrim(Row, Col); + end; + end; + end;{case} + Exit; + end; + + {are we focused? (and selections are not allowed)} + if (otsFocused in tbState) then + if ((tbState * [otsNormal, otsEditing, otsHiddenEdit]) <> []) then + begin + Region := CalcRowColFromXY(Msg.XPos, Msg.YPos, Row, Col); + case Region of + otrInMain : + begin + if InEditingState then +{$IFNDEF LCL} + Windows.SetFocus(tbActCell.EditHandle); +{$ELSE} + LclIntf.SetFocus(tbActCell.EditHandle); +{$ENDIF} + AllowRedraw := false; + try + DoActiveCellMoving(ccMouse, Row, Col); + if not (otoAlwaysEditing in Options) then + if (ActiveRow = Row) and (ActiveCol = Col) and + not WasUnfocused then + begin + PostMessage(Handle, ctim_StartEdit, 0, 0); + PostMessage(Handle, ctim_StartEditMouse, + Msg.Keys, longint(Msg.Pos)); + end; + tbSetActiveCellPrim(Row, Col); + finally + AllowRedraw := true; + end;{try..finally} + PostMessage(Handle, ctim_StartEditMouse, + Msg.Keys, longint(Msg.Pos)); + end; + otrInLocked : + if (otsNormal in tbState) then + DoLockedCellClick(Row, Col); + end;{case} + Exit; + end; + end; +{--------} +procedure TOvcCustomTable.WMLButtonUp(var Msg : TWMMouse); + var + Form : TForm; + ColNum : TColNum; + ColFrom : TColNum; + ColTo : TColNum; + RowNum : TRowNum; + RowFrom : TRowNum; + RowTo : TRowNum; + DoingCol: boolean; + begin + inherited; + + if tbDrag <> nil then begin + tbDrag.Free; + tbDrag := nil; + end; + + if (otsMouseSelect in tbState) then + begin + {tbIsSelecting := false;} + tbState := tbState - [otsMouseSelect] + [otsNormal]; + Exit; + end; + + if (otsSizing in tbState) then + begin + tbDrawSizeLine; + AllowRedraw := false; + try + if (otsDoingRow in tbState) then + begin + if (tbSizeOffset < tbRowNums^.Ay[tbSizeIndex].Offset+6) then + tbSizeOffset := tbRowNums^.Ay[tbSizeIndex].Offset+6; + FRows.Height[tbRowNums^.Ay[tbSizeIndex].Number] := + tbSizeOffset - tbRowNums^.Ay[tbSizeIndex].Offset; + if Assigned(OnResizeRow) then + OnResizeRow(Self, tbRowNums^.Ay[tbSizeIndex].Number, + FRows.Height[tbRowNums^.Ay[tbSizeIndex].Number]); + end + else + begin + if (tbSizeOffset < tbColNums^.Ay[tbSizeIndex].Offset+6) then + tbSizeOffset := tbColNums^.Ay[tbSizeIndex].Offset+6; + FCols[tbColNums^.Ay[tbSizeIndex].Number].Width := + tbSizeOffset - tbColNums^.Ay[tbSizeIndex].Offset; + if Assigned(OnResizeColumn) then + OnResizeColumn(Self, tbColNums^.Ay[tbSizeIndex].Number, + FCols[tbColNums^.Ay[tbSizeIndex].Number].Width); + end; +// Apparent TurboPower bug: otsDoingRow appears twice in set. Probably second +// otsDoingRow should be otsDoingCol (see otsMoving code below). +// tbState := tbState - [otsSizing, otsDoingRow, otsDoingRow] + [otsNormal]; + tbState := tbState - [otsSizing, otsDoingRow, otsDoingCol] + [otsNormal]; //Fixed + if (otsDesigning in tbState) then + begin + Form := TForm(GetParentForm(Self)); + if (Form <> nil) and (Form.Designer <> nil) then + Form.Designer.Modified; + end; + InvalidateTable; + finally + AllowRedraw := true; + end;{try..finally} + end; + + if (otsMoving in tbState) then + begin + tbDrawMoveLine; + DoingCol := otsDoingCol in tbState; + tbState := tbState - [otsMoving, otsDoingRow, otsDoingCol] + [otsNormal]; + if (tbMoveIndex <> tbMoveIndexTo) then + begin + AllowRedraw := false; + try + if DoingCol then + begin + ColFrom := tbColNums^.Ay[tbMoveIndex].Number; + ColTo := tbColNums^.Ay[tbMoveIndexTo].Number; + if (ColTo > ColFrom) then + for ColNum := ColFrom to pred(ColTo) do + Columns.Exchange(ColNum, succ(ColNum)) + else + for ColNum := pred(ColFrom) downto ColTo do + Columns.Exchange(ColNum, succ(ColNum)); + if ActiveCol = ColFrom then + ActiveCol := ColTo + else if (ColTo > ColFrom) then begin + if (ColFrom < ActiveCol) and (ActiveCol <= ColTo) then + ActiveCol := IncCol(ActiveCol, -1); + end + else begin + if (ColTo <= ActiveCol) and (ActiveCol < ColFrom) then + ActiveCol := IncCol(ActiveCol, +1); + end; + end + else {doing rows} + begin + RowFrom := tbRowNums^.Ay[tbMoveIndex].Number; + RowTo := tbRowNums^.Ay[tbMoveIndexTo].Number; + if (RowTo > RowFrom) then + for RowNum := RowFrom to pred(RowTo) do + Rows.Exchange(RowNum, succ(RowNum)) + else + for RowNum := pred(RowFrom) downto RowTo do + Rows.Exchange(RowNum, succ(RowNum)); + if ActiveRow = RowFrom then + ActiveRow := RowTo + else if (RowTo > RowFrom) then begin + if (RowFrom < ActiveRow) and (ActiveRow <= RowTo) then + ActiveRow := IncRow(ActiveRow, -1); + end + else begin + if (RowTo <= ActiveRow) and (ActiveRow < RowFrom) then + ActiveRow := IncRow(ActiveRow, +1); + end; + end; + finally + AllowRedraw := true; + end;{try..finally} + if (otsDesigning in tbState) then + begin + Form := TForm(GetParentForm(Self)); + if (Form <> nil) and (Form.Designer <> nil) then + Form.Designer.Modified; + end; + end; + end; + end; +{--------} +procedure TOvcCustomTable.WMMouseMove(var Msg : TWMMouse); + var + Row : TRowNum; + Col : TColNum; + NewMoveIndexTo : integer; + Region : TOvcTblRegion; + Action : TOvcTblSelectionType; + P : TPoint; + begin + inherited; + + if tbDrag <> nil then begin + P := ClientToScreen(Point(Msg.XPos, Msg.YPos)); + tbDrag.DragMove(P.x, P.y); + end; + + if (otsMouseSelect in tbState) then + begin + Region := CalcRowColFromXY(Msg.XPos, Msg.YPos, Row, Col); + if (Region = otrOutside) or (Region = otrInUnused) then + begin + if (Row = CRCFXY_RowAbove) then + Row := IncRow(ActiveRow, -1) + else if (Row = CRCFXY_RowBelow) then + with tbRowNums^ do + Row := MinL(pred(RowLimit), succ(Ay[pred(Count)].Number)); + if (Col = CRCFXY_ColToLeft) then + Col := IncCol(ActiveCol, -1) + else if (Col = CRCFXY_ColToRight) then + with tbColNums^ do + Col := MinI(pred(ColCount), succ(Ay[pred(Count)].Number)); + end + else if (Region = otrInLocked) then + begin + if (Row < LockedRows) then + Row := IncRow(ActiveRow, -1); + if (Col < LockedCols) then + Col := IncCol(ActiveCol, -1); + end; + DoActiveCellMoving(ccMouse, Row, Col); + if (Row = ActiveRow) and (Col = ActiveCol) then + Exit; {there's nothing to do, just moved within cell} + if ((Msg.Keys and MK_CONTROL) <> 0) then + Action := tstAdditional + else + begin + Action := tstDeselectAll; + tbIsSelecting := true; + end; + AllowRedraw := false; + try + tbUpdateSelection(Row, Col, Action); + tbSetActiveCellPrim(Row, Col); + finally + AllowRedraw := true; + end;{try..finally} + Exit; + end; + + if (otsSizing in tbState) then + begin + tbDrawSizeLine; + if (otsDoingRow in tbState) then + begin + if (Msg.YPos >= tbRowNums^.Ay[tbSizeIndex].Offset+6) then + tbSizeOffset := Msg.YPos; + end + else + begin + if (Msg.XPos >= tbColNums^.Ay[tbSizeIndex].Offset+6) then + tbSizeOffset := Msg.XPos; + end; + tbDrawSizeLine; + Exit; + end; + + if (otsMoving in tbState) then + begin + CalcRowColFromXY(Msg.XPos, Msg.YPos, Row, Col); + if (otsDoingCol in tbState) then + begin + if (Col >= LockedCols) then + begin + NewMoveIndexTo := tbFindColInx(Col); + if (NewMoveIndexTo <> tbMoveIndexTo) then + begin + tbDrawMoveLine; + tbMoveIndexTo := NewMoveIndexTo; + tbDrawMoveLine; + end; + end; + end + else {we're moving rows} + begin + if (Row >= LockedRows) then + begin + NewMoveIndexTo := tbFindRowInx(Row); + if (NewMoveIndexTo <> tbMoveIndexTo) then + begin + tbDrawMoveLine; + tbMoveIndexTo := NewMoveIndexTo; + tbDrawMoveLine; + end; + end; + end; + end; + end; +{--------} +procedure TOvcCustomTable.WMNCHitTest(var Msg : TMessage); + begin + if (otsDesigning in tbState) then + DefaultHandler(Msg) + else + inherited; + end; +{--------} +procedure TOvcCustomTable.WMSetCursor(var Msg : TWMSetCursor); + var + CurMousePos : TPoint; + NewCursor : HCursor; + IsVert : boolean; + IsColMove : boolean; + OnGridLine : boolean; + InMoveArea : boolean; + begin + {ignore non client hit tests, let our ancestor deal with it} + if (Msg.HitTest <> HTCLIENT) then + begin + inherited; + if ((tbState * [otsShowSize, otsShowMove]) <> []) then + tbState := tbState - [otsShowSize, otsShowMove, otsDoingRow, otsDoingCol] + + [otsNormal]; + Exit; + end; + + {if the table is unfocused or we are editing, let our ancestor deal with it} + if (otsUnfocused in tbState) or InEditingState then + begin + inherited; + Exit; + end; + + {get the mouse cursor position in terms of the table client area} + GetCursorPos(CurMousePos); + CurMousePos := ScreenToClient(CurMousePos); + {work out whether the cursor is over a grid line or on the column + move area; take into account whether such definitions are allowed} + OnGridLine := tbIsOnGridLine(CurMousePos.X, CurMousePos.Y, IsVert); + if OnGridLine then + if IsVert then + OnGridLine := (not (otoNoColResizing in Options)) or + (otsDesigning in tbState) + else + OnGridLine := (not (otoNoRowResizing in Options)) or + (otsDesigning in tbState); + InMoveArea := false; + if (not OnGridLine) and + ((otoAllowColMoves in Options) or (otoAllowRowMoves in Options) or + (otsDesigning in tbState)) then + begin + InMoveArea := tbIsInMoveArea(CurMousePos.X, CurMousePos.Y, IsColMove); + if InMoveArea then + if IsColMove then + InMoveArea := otoAllowColMoves in Options + else + InMoveArea := otoAllowRowMoves in Options; + end; + {now set the cursor} + if InMoveArea then + begin + if IsColMove then + begin + NewCursor := tbColMoveCursor; + tbState := tbState - [otsNormal, otsShowSize, otsDoingRow] + + [otsShowMove, otsDoingCol]; + end + else {row move} + begin + NewCursor := tbRowMoveCursor; + tbState := tbState - [otsNormal, otsShowSize, otsDoingCol] + + [otsShowMove, otsDoingRow]; + end; + end + else if OnGridLine then + if IsVert then + begin + NewCursor := Screen.Cursors[crHSplit]; + tbState := tbState - [otsNormal, otsShowMove, otsDoingRow] + + [otsShowSize, otsDoingCol]; + end + else + begin + NewCursor := Screen.Cursors[crVSplit]; + tbState := tbState - [otsNormal, otsShowMove, otsDoingCol] + + [otsShowSize, otsDoingRow]; + end + else + begin + NewCursor := Screen.Cursors[Cursor]; + tbState := tbState - [otsShowMove, otsShowSize, otsDoingRow, otsDoingCol] + + [otsNormal]; + end; + SetCursor(NewCursor); + + Msg.Result := 1; + end; +{--------} +procedure TOvcCustomTable.WMSetFocus(var Msg : TWMSetFocus); + begin + inherited; + + if (otsEditing in tbState) then + begin + if tbEditCellHasFocus(Msg.FocusedWnd) then + GetParentForm(Self).Perform(WM_NEXTDLGCTL, 1, 0) + else +{$IFNDEF LCL} + Windows.SetFocus(tbActCell.EditHandle); +{$ELSE} + LclIntf.SetFocus(tbActCell.EditHandle); +{$ENDIF} + Exit; + end; + + if (otsFocused in tbState) then + Exit; + + AllowRedraw := false; + try + InvalidateCell(ActiveRow, ActiveCol); + tbState := tbState - [otsUnfocused] + [otsFocused]; + finally + AllowRedraw := true; + end;{try..finally} + end; +{--------} + +procedure TOvcCustomTable.WMVScroll(var Msg : TWMScroll); + + procedure ProcessThumb; + var + Divisor : LongInt; + begin + if (Msg.Pos <> TopRow) then + begin + if RowLimit < (16*1024) then + TopRow := Msg.Pos + else if Msg.Pos = LockedRows then + TopRow := LockedRows + else begin + if (RowLimit > (16*1024)) then + Divisor := Succ(RowLimit div $400) + else + Divisor := Succ(RowLimit div $40); + if (Msg.Pos = RowLimit div Divisor) then + TopRow := pred(RowLimit) + else + TopRow := Msg.Pos * Divisor; + end; + end; + end; + +begin + if ProcessingVScrollMessage then + Exit; + ProcessingVScrollMessage := true; + try + {ignore SB_ENDSCROLL and SB_THUMBTRACK messages (the latter + if required to by the Options property): this'll possibly + avoid multiple validations} + if (Msg.ScrollCode = SB_ENDSCROLL) or + ((Msg.ScrollCode = SB_THUMBTRACK) and + (not (otoThumbTrack in Options))) then + begin + inherited; + Exit; + end; + {if we're not focused then do so; if we're being designed + update the table view} + if (otsUnFocused in tbState) then +{$IFDEF MSWINDOWS} + SetFocus //Apparently can't focus scroll bar with GTK? +{$ENDIF} + else if (otsDesigning in tbState) then + Update; + {check to see whether the cell being edited is valid; + no scrolling allowed if it isn't (tough).} + if InEditingState then + begin + if not tbActCell.CanSaveEditedData(true) then + Exit; + end; + {process the scrollbar message} + case Msg.ScrollCode of + SB_LINEUP : ProcessScrollBarClick(otsbVertical, scLineUp); + SB_LINEDOWN : ProcessScrollBarClick(otsbVertical, scLineDown); + SB_PAGEUP : ProcessScrollBarClick(otsbVertical, scPageUp); + SB_PAGEDOWN : ProcessScrollBarClick(otsbVertical, scPageDown); + SB_THUMBPOSITION : ProcessThumb; + SB_THUMBTRACK : if (otoThumbTrack in Options) then ProcessThumb; + else + inherited; + Exit; + end; + Msg.Result := 0; + finally + ProcessingVScrollMessage := false; + end; +end; +{====================================================================} + + +end. diff --git a/components/orpheus/ovctbclr.pas b/components/orpheus/ovctbclr.pas new file mode 100644 index 000000000..a000362dc --- /dev/null +++ b/components/orpheus/ovctbclr.pas @@ -0,0 +1,266 @@ +{*********************************************************} +{* OVCTBCLR.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovctbclr; + {-Orpheus table colors} + +interface + +uses + Graphics, Classes; + +type + TOvcTableColors = class(TPersistent) + protected {private} + {.Z+} + FLocked : TColor; + FLockedText : TColor; + FActiveFocused : TColor; + FActiveFocusedText : TColor; + FActiveUnfocused : TColor; + FActiveUnfocusedText : TColor; + FEditing : TColor; + FEditingText : TColor; + FSelected : TColor; + FSelectedText : TColor; + + FOnCfgChanged : TNotifyEvent; + {.Z-} + + protected + {.Z+} + procedure SetLocked(C : TColor); + procedure SetLockedText(C : TColor); + procedure SetActiveFocused(C : TColor); + procedure SetActiveFocusedText(C : TColor); + procedure SetActiveUnfocused(C : TColor); + procedure SetActiveUnfocusedText(C : TColor); + procedure SetEditing(C : TColor); + procedure SetEditingText(C : TColor); + procedure SetSelected(C : TColor); + procedure SetSelectedText(C : TColor); + + procedure DoCfgChanged; + {.Z-} + + public {protected} + {.Z+} + property OnCfgChanged : TNotifyEvent + read FOnCfgChanged write FOnCfgChanged; + {.Z-} + + public + constructor Create; + procedure Assign(Source : TPersistent); override; + + published + {properties} + property ActiveFocused : TColor + read FActiveFocused write SetActiveFocused + default clHighlight; + + property ActiveFocusedText : TColor + read FActiveFocusedText write SetActiveFocusedText + default clHighlightText; + + property ActiveUnfocused : TColor + read FActiveUnfocused write SetActiveUnfocused + default clHighlight; + + property ActiveUnfocusedText : TColor + read FActiveUnfocusedText write SetActiveUnfocusedText + default clHighlightText; + + property Locked : TColor + read FLocked write SetLocked + default clBtnFace; + + property LockedText : TColor + read FLockedText write SetLockedText + default clWindowText; + + property Editing : TColor + read FEditing write SetEditing + default clBtnFace; + + property EditingText : TColor + read FEditingText write SetEditingText + default clWindowText; + + property Selected : TColor + read FSelected write SetSelected + default clHighlight; + + property SelectedText : TColor + read FSelectedText write SetSelectedText + default clHighlightText; + end; + +implementation + + +{===TOvcTableColors==================================================} +constructor TOvcTableColors.Create; + begin + FLocked := clBtnFace; + FLockedText := clWindowText; + FActiveFocused := clHighlight; + FActiveFocusedText := clHighlightText; + FActiveUnfocused := clHighlight; + FActiveUnfocusedText := clHighlightText; + FEditing := clBtnFace; + FEditingText := clWindowText; + FSelected := clHighlight; + FSelectedText := clHighlightText; + end; +{--------} +procedure TOvcTableColors.Assign(Source : TPersistent); + begin + if (Source is TOvcTableColors) then + begin + FLocked := TOvcTableColors(Source).Locked; + FLockedText := TOvcTableColors(Source).LockedText; + FActiveFocused := TOvcTableColors(Source).ActiveFocused; + FActiveFocusedText := TOvcTableColors(Source).ActiveFocusedText; + FActiveUnfocused := TOvcTableColors(Source).ActiveUnfocused; + FActiveUnfocusedText := TOvcTableColors(Source).ActiveUnfocusedText; + FEditing := TOvcTableColors(Source).Editing; + FEditingText := TOvcTableColors(Source).EditingText; + FSelected := TOvcTableColors(Source).Selected; + FSelectedText := TOvcTableColors(Source).SelectedText; + DoCfgChanged; + end; + end; +{--------} +procedure TOvcTableColors.DoCfgChanged; + begin + if Assigned(FOnCfgChanged) then + FOnCfgChanged(Self); + end; +{--------} +procedure TOvcTableColors.SetActiveFocused(C : TColor); + begin + if (C <> FActiveFocused) then + begin + FActiveFocused := C; + DoCfgChanged; + end; + end; +{--------} +procedure TOvcTableColors.SetActiveFocusedText(C : TColor); + begin + if (C <> FActiveFocusedText) then + begin + FActiveFocusedText := C; + DoCfgChanged; + end; + end; +{--------} +procedure TOvcTableColors.SetActiveUnfocused(C : TColor); + begin + if (C <> FActiveUnfocused) then + begin + FActiveUnfocused := C; + DoCfgChanged; + end; + end; +{--------} +procedure TOvcTableColors.SetActiveUnfocusedText(C : TColor); + begin + if (C <> FActiveUnfocusedText) then + begin + FActiveUnfocusedText := C; + DoCfgChanged; + end; + end; +{--------} +procedure TOvcTableColors.SetEditing(C : TColor); + begin + if (C <> FEditing) then + begin + FEditing := C; + DoCfgChanged; + end; + end; +{--------} +procedure TOvcTableColors.SetEditingText(C : TColor); + begin + if (C <> FEditingText) then + begin + FEditingText := C; + DoCfgChanged; + end; + end; +{--------} +procedure TOvcTableColors.SetLocked(C : TColor); + begin + if (C <> FLocked) then + begin + FLocked := C; + DoCfgChanged; + end; + end; +{--------} +procedure TOvcTableColors.SetLockedText(C : TColor); + begin + if (C <> FLockedText) then + begin + FLockedText := C; + DoCfgChanged; + end; + end; +{--------} +procedure TOvcTableColors.SetSelected(C : TColor); + begin + if (C <> FSelected) then + begin + FSelected := C; + DoCfgChanged; + end; + end; +{--------} +procedure TOvcTableColors.SetSelectedText(C : TColor); + begin + if (C <> FSelectedText) then + begin + FSelectedText := C; + DoCfgChanged; + end; + end; +{====================================================================} + +end. diff --git a/components/orpheus/ovctbcls.pas b/components/orpheus/ovctbcls.pas new file mode 100644 index 000000000..88ff985be --- /dev/null +++ b/components/orpheus/ovctbcls.pas @@ -0,0 +1,608 @@ +{*********************************************************} +{* OVCTBCLS.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovctbcls; + {-Table column, column array classes} + +interface + +uses + {$IFNDEF LCL} Windows, {$ELSE} LclIntf, LclType, {$ENDIF} + SysUtils, Graphics, Classes, Controls, Forms, + OvcConst, OvcTCmmn, OvcTCell; + +type + TOvcTableColumnClass = class of TOvcTableColumn; + TOvcTableColumn = class(TPersistent) + protected {private} + {property fields-even size} + FDefCell : TOvcBaseTableCell; + FNumber : TColNum; + FOnColumnChanged : TColChangeNotifyEvent; + FTable : TOvcTableAncestor; + FWidth : Integer; + {property fields-odd size} + FHidden : boolean; + Filler : byte; + + protected + {property access} + procedure SetDefCell(BTC : TOvcBaseTableCell); + procedure SetHidden(H : boolean); + procedure SetWidth(W : Integer); + + {miscellaneous} + procedure tcDoColumnChanged; + procedure tcNotifyCellDeletion(Cell : TOvcBaseTableCell); + + public {protected} + {internal only usage} + property Number : TColNum + read FNumber write FNumber; + property OnColumnChanged : TColChangeNotifyEvent + write FOnColumnChanged; + + public + procedure Assign(Source : TPersistent); override; + constructor Create(ATable : TOvcTableAncestor); virtual; + destructor Destroy; override; + + {properties} + property Table : TOvcTableAncestor + read FTable; + + published + {properties for streaming} + property DefaultCell: TOvcBaseTableCell + read FDefCell write SetDefCell; + + property Hidden : boolean + read FHidden write SetHidden; + + property Width : Integer + read FWidth write SetWidth; + end; + + TOvcTableColumns = class(TPersistent) + protected {private} + {property fields} + FList : TList; + FOnColumnChanged: TColChangeNotifyEvent; + FFixups : TStringList; + FTable : TOvcTableAncestor; + + {other fields} + tcColumnClass : TOvcTableColumnClass; + + protected + {property access} + function GetCol(ColNum : TColNum) : TOvcTableColumn; + function GetCount : Integer; + function GetDefaultCell(ColNum : TColNum) : TOvcBaseTableCell; + function GetHidden(ColNum : TColNum) : boolean; + function GetWidth(ColNum : TColNum) : Integer; + + procedure SetCol(ColNum : TColNum; C : TOvcTableColumn); + procedure SetCount(C : Integer); + procedure SetDefaultCell(ColNum : TColNum; C : TOvcBaseTableCell); + procedure SetHidden(ColNum : TColNum; H : boolean); + procedure SetWidth(ColNum : TColNum; W : Integer); + + {event access} + procedure SetOnColumnChanged(OC : TColChangeNotifyEvent); + + {other} + procedure tcDoColumnChanged(ColNum1, ColNum2 : TColNum; + Action : TOvcTblActions); + + public + {internal only usage} + procedure tcNotifyCellDeletion(Cell : TOvcBaseTableCell); + function tcStartLoading : TStringList; + procedure tcStopLoading; + + property OnColumnChanged : TColChangeNotifyEvent + write SetOnColumnChanged; + + public + constructor Create(ATable : TOvcTableAncestor; ANumber : Integer; + AColumnClass : TOvcTableColumnClass); + destructor Destroy; override; + + procedure Append(C : TOvcTableColumn); + procedure Clear; + procedure Delete(ColNum : TColNum); + procedure Exchange(ColNum1, ColNum2 : TColNum); + procedure Insert(const ColNum : TColNum; C : TOvcTableColumn); + + property Count : Integer + read GetCount write SetCount; + + property DefaultCell [ColNum : TColNum] : TOvcBaseTableCell + read GetDefaultCell write SetDefaultCell; + + property Hidden [ColNum : TColNum] : boolean + read GetHidden write SetHidden; + + property List [ColNum : TColNum] : TOvcTableColumn + read GetCol write SetCol; + default; + + property Table : TOvcTableAncestor + read FTable write FTable; + + property Width [ColNum : TColNum] : Integer + read GetWidth write SetWidth; + end; + +implementation + + +{===TOvcTableColumn=====================================================} +constructor TOvcTableColumn.Create(ATable : TOvcTableAncestor); + begin + inherited Create; + FWidth := tbDefColWidth; + FDefCell := nil; + FTable := ATable; + end; +{--------} +destructor TOvcTableColumn.Destroy; + begin + DefaultCell := nil; + inherited Destroy; + end; +{--------} +procedure TOvcTableColumn.Assign(Source : TPersistent); + var + Src : TOvcTableColumn absolute Source; + begin + if not (Source is TOvcTableColumn) then + Exit; + FWidth := Src.Width; + FHidden := Src.Hidden; + DefaultCell := Src.DefaultCell; + end; +{--------} +procedure TOvcTableColumn.tcDoColumnChanged; + begin + if Assigned(FOnColumnChanged) then + FOnColumnChanged(Self, FNumber, 0, taSingle); + end; +{--------} +procedure TOvcTableColumn.tcNotifyCellDeletion(Cell : TOvcBaseTableCell); + begin + if (Cell = FDefCell) then + DefaultCell := nil; + end; +{--------} +procedure TOvcTableColumn.SetDefCell(BTC : TOvcBaseTableCell); + var + DoIt : boolean; + begin + DoIt := false; + if (BTC <> FDefCell) then + if Assigned(BTC) then + begin + if (BTC.References = 0) or + ((BTC.References > 0) and (BTC.Table = FTable)) then + DoIt := true; + end + else + DoIt := true; + + if DoIt then + begin + if Assigned(FDefCell) then + FDefCell.DecRefs; + FDefCell := BTC; + if Assigned(FDefCell) then + begin + if (FDefCell.References = 0) then + FDefCell.Table := FTable; + FDefCell.IncRefs; + end; + tcDoColumnChanged; + end; + end; +{--------} +procedure TOvcTableColumn.SetHidden(H : boolean); + begin + if (H <> FHidden) then + begin + FHidden := H; + tcDoColumnChanged; + end; + end; +{--------} +procedure TOvcTableColumn.SetWidth(W : Integer); + begin + if (W <> FWidth) then + begin + FWidth := W; + tcDoColumnChanged; + end; + end; +{====================================================================} + + + +{===TOvcTableColumns=======================================================} +constructor TOvcTableColumns.Create(ATable : TOvcTableAncestor; + ANumber : Integer; + AColumnClass : TOvcTableColumnClass); + var + i : Integer; + Col : TOvcTableColumn; + begin + inherited Create; + FTable := ATable; + FList := TList.Create; + tcColumnClass := AColumnClass; + for i := 0 to pred(ANumber) do + begin + Col := AColumnClass.Create(FTable); + Col.Number := i; + Append(Col); + end; + end; +{--------} +destructor TOvcTableColumns.Destroy; + begin + if Assigned(FList) then + begin + OnColumnChanged := nil; + Clear; + FList.Free; + end; + FFixups.Free; + end; +{--------} +procedure TOvcTableColumns.Append(C : TOvcTableColumn); + begin + if (FList.Count = Classes.MaxListSize) then + TableErrorRes(SCTableMaxColumns); + if (C.Table <> FTable) or (not (C is tcColumnClass)) then + Exit; + C.Number := FList.Count; + FList.Add(C); + C.OnColumnChanged := FOnColumnChanged; + tcDoColumnChanged(C.Number, 0, taInsert); + end; +{--------} +procedure TOvcTableColumns.Clear; + var + i : Integer; + begin + for i := 0 to pred(FList.Count) do + TOvcTableColumn(FList[i]).Free; + FList.Clear; + tcDoColumnChanged(0, 0, taAll); + end; +{--------} +procedure TOvcTableColumns.Delete(ColNum : TColNum); + var + i : integer; + begin + if (0 <= ColNum) and (ColNum < FList.Count) then + begin + TOvcTableColumn(FList[ColNum]).Free; + FList.Delete(ColNum); + for i := 0 to pred(FList.Count) do + TOvcTableColumn(FList[i]).Number := i; + tcDoColumnChanged(ColNum, 0, taDelete); + if Assigned(FFixups) then + if (ColNum < FFixups.Count) then + FFixups.Delete(ColNum); + end; + end; +{--------} +procedure TOvcTableColumns.Exchange(ColNum1, ColNum2 : TColNum); + var + Temp1, Temp2 : pointer; + begin + if (ColNum1 <> ColNum2) and + (0 <= ColNum1) and (ColNum1 < FList.Count) and + (0 <= ColNum2) and (ColNum2 < FList.Count) then + begin + Temp1 := FList[ColNum1]; + Temp2 := FList[ColNum2]; + TOvcTableColumn(Temp1).Number := ColNum2; + TOvcTableColumn(Temp2).Number := ColNum1; + FList[ColNum1] := Temp2; + FList[ColNum2] := Temp1; + tcDoColumnChanged(ColNum1, ColNum2, taExchange); + end; + end; +{--------} +function TOvcTableColumns.GetCol(ColNum : TColNum) : TOvcTableColumn; + begin + if (0 <= ColNum) and (ColNum < FList.Count) then + Result := TOvcTableColumn(FList[ColNum]) + else + Result := nil; + end; +{--------} +function TOvcTableColumns.GetCount : Integer; + begin + Result := FList.Count; + end; +{--------} +function TOvcTableColumns.GetDefaultCell(ColNum : TColNum) : TOvcBaseTableCell; + begin + Result := nil; + if (0 <= ColNum) and (ColNum < FList.Count) then + Result := TOvcTableColumn(FList[ColNum]).DefaultCell; + end; +{--------} +function TOvcTableColumns.GetHidden(ColNum : TColNum) : boolean; + begin + Result := True; + if (0 <= ColNum) and (ColNum < FList.Count) then + Result := TOvcTableColumn(FList[ColNum]).Hidden; + end; +{--------} +function TOvcTableColumns.GetWidth(ColNum : TColNum) : Integer; + begin + Result := 0; + if (0 <= ColNum) and (ColNum < FList.Count) then + Result := TOvcTableColumn(FList[ColNum]).Width; + end; +{--------} +procedure TOvcTableColumns.Insert(const ColNum : TColNum; + C : TOvcTableColumn); + var + i : integer; + begin + if (FList.Count = Classes.MaxListSize) then + TableErrorRes(SCTableMaxColumns); + if (C.Table <> FTable) or (not (C is tcColumnClass)) then + Exit; + if (0 <= ColNum) and (ColNum < FList.Count) then + begin + FList.Insert(ColNum, C); + for i := 0 to pred(FList.Count) do + TOvcTableColumn(FList[i]).Number := i; + C.OnColumnChanged := FOnColumnChanged; + tcDoColumnChanged(ColNum, 0, taInsert); + if Assigned(FFixups) then begin + FFixups.Insert(ColNum, 'unknown'); + FFixups.Objects[ColNum] := C; + end; + end; + end; +{--------} +procedure TOvcTableColumns.tcDoColumnChanged(ColNum1, ColNum2 : TColNum; + Action : TOvcTblActions); + begin + if Assigned(FOnColumnChanged) then + FOnColumnChanged(Self, ColNum1, ColNum2, Action); + end; +{--------} +procedure TOvcTableColumns.tcNotifyCellDeletion(Cell : TOvcBaseTableCell); + var + ColNum : TColNum; + begin + for ColNum := 0 to pred(FList.Count) do + TOvcTableColumn(FList[ColNum]).tcNotifyCellDeletion(Cell); + end; +{--------} +procedure TOvcTableColumns.SetCol(ColNum : TColNum; C : TOvcTableColumn); + var + PC : TOvcTableColumn; + begin + if (C.Table <> FTable) or (not (C is tcColumnClass)) then + Exit; + if (0 <= ColNum) and (ColNum < FList.Count) then + begin + PC := GetCol(ColNum); + PC.Assign(C); + end; + end; +{--------} +procedure TOvcTableColumns.SetCount(C : Integer); + var + ColNum : TColNum; + Col : TOvcTableColumn; + begin + if (C > 0) and (C <> Count) then + if (C < Count) then + begin + {must destroy the end set of columns} + for ColNum := pred(Count) downto C do + Delete(ColNum); + end + else {C > Count} + begin + {must add some new columns on the end} + for ColNum := Count to pred(C) do + begin + Col := tcColumnClass.Create(FTable); + Col.Number := ColNum; + Append(Col); + end; + end; + end; +{--------} +procedure TOvcTableColumns.SetDefaultCell(ColNum : TColNum; C : TOvcBaseTableCell); + begin + if (0 <= ColNum) and (ColNum < FList.Count) then + TOvcTableColumn(FList[ColNum]).DefaultCell := C; + end; +{--------} +procedure TOvcTableColumns.SetHidden(ColNum : TColNum; H : boolean); + begin + if (0 <= ColNum) and (ColNum < FList.Count) then + TOvcTableColumn(FList[ColNum]).Hidden := H; + end; +{--------} +procedure TOvcTableColumns.SetOnColumnChanged(OC : TColChangeNotifyEvent); + var + i : Integer; + begin + FOnColumnChanged := OC; + for i := 0 to pred(FList.Count) do + TOvcTableColumn(FList[i]).OnColumnChanged := OC; + end; +{--------} +procedure TOvcTableColumns.SetWidth(ColNum : TColNum; W : Integer); + begin + if (0 <= ColNum) and (ColNum < FList.Count) then + TOvcTableColumn(FList[ColNum]).Width := W; + end; +{--------} +function TOvcTableColumns.tcStartLoading : TStringList; + begin + if Assigned(FFixups) then + FFixups.Clear + else + FFixups := TStringList.Create; + Result := FFixups; + end; +{--------} +procedure TOvcTableColumns.tcStopLoading; + {------} + function GetImmediateParentForm(Control : TControl) : TWinControl; + var + ParentCtrl : TControl; + begin + ParentCtrl := Control.Parent; + while (Assigned(ParentCtrl)) and + (not (ParentCtrl is TCustomForm)) + {$IFDEF VERSION5} + and (not (ParentCtrl is TCustomFrame)) + {$ENDIF} + do + ParentCtrl := ParentCtrl.Parent; + Result := TForm(ParentCtrl); + end; + {------} + function GetFormName(const S, FormName : string) : string; + var + PosDot : integer; + begin + PosDot := Pos('.', S); + if (PosDot <> 0) then + Result := Copy(S, 1, pred(PosDot)) + else + Result := FormName; + end; + {------} + function FormNamesEqual(const CmptFormName, FormName : string) : boolean; + var + PosUL : integer; + begin + Result := true; + if (FormName = '') or (CmptFormName = FormName) then + Exit; + PosUL := length(FormName); + while (PosUL > 0) and (FormName[PosUL] <> '_') do + dec(PosUL); + if (PosUL > 0) then + if (CmptFormName = Copy(FormName, 1, pred(PosUL))) then + Exit; + Result := false; + end; + {------} + function GetComponentName(const S : string) : string; + var + PosDot : integer; + begin + PosDot := Pos('.', S); + if (PosDot <> 0) then + Result := Copy(S, succ(PosDot), length(S)) + else + Result := S; + end; + {------} + var + i : integer; + Form : TWinControl; + Compnt : TComponent; + DM : integer; + DataMod: TDataModule; + DMCount: integer; + begin + {if there's nothing to fix up, exit now} + if not Assigned(FFixups) then + Exit; + {fixup references to cell components on the table's form} + try + Form := GetImmediateParentForm(FTable); + for i := pred(FFixups.Count) downto 0 do + if FormNamesEqual(GetFormName(FFixups[i], Form.Name), + Form.Name) then + begin + Compnt := Form.FindComponent(GetComponentName(FFixups[i])); + if Assigned(Compnt) and (Compnt is TOvcBaseTableCell) then + begin + TOvcTableColumn(FFixups.Objects[i]).DefaultCell := TOvcBaseTableCell(Compnt); + FFixups.Delete(i); + end; + end; + {fixup references to cell components on any data modules} + if (FFixups.Count <> 0) then begin + DM := 0; +{$IFNDEF LCL} + DMCount := Screen.DataModuleCount; +{$ELSE} + DMCount := 0; +{$ENDIF} + while (FFixups.Count > 0) and (DM < DMCount) do begin +{$IFNDEF LCL} + DataMod := Screen.DataModules[DM]; +{$ENDIF} + for i := pred(FFixups.Count) downto 0 do + if (GetFormName(FFixups[i], Form.Name) = DataMod.Name) then begin + Compnt := DataMod.FindComponent(GetComponentName(FFixups[i])); + if Assigned(Compnt) and (Compnt is TOvcBaseTableCell) then begin + TOvcTableColumn(FFixups.Objects[i]).DefaultCell + := TOvcBaseTableCell(Compnt); + FFixups.Delete(i); + end; + end; + inc(DM); + end; + end; + finally + FFixups.Free; + FFixups := nil; + end; + end; +{====================================================================} + +end. diff --git a/components/orpheus/ovctbpe1.pas b/components/orpheus/ovctbpe1.pas new file mode 100644 index 000000000..bbae5243b --- /dev/null +++ b/components/orpheus/ovctbpe1.pas @@ -0,0 +1,315 @@ +{*********************************************************} +{* OVCTBPE1.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovctbpe1; + {-Property editor for the table component} + +interface + +uses + {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, LclType, LResources, {$ENDIF} + Classes, Graphics, Controls, + {$IFNDEF LCL} {$IFDEF VERSION6} DesignIntf, DesignEditors, {$ELSE} DsgnIntf, {$ENDIF} {$ELSE} PropEdits, {$ENDIF} + SysUtils, Forms, Dialogs, StdCtrls, OvcBase, OvcEf, OvcPb, OvcNf, + Buttons, ExtCtrls, OvcTCmmn, OvcTable, OvcTbRws, OvcSf, OvcSc; + +type + TOvcfrmRowEditor = class(TForm) + ctlHidden: TCheckBox; + ctlUseDefHeight: TRadioButton; + ctlUseCustHeight: TRadioButton; + DoneButton: TBitBtn; + Panel1: TPanel; + SpeedButton1: TSpeedButton; + SpeedButton2: TSpeedButton; + SpeedButton3: TSpeedButton; + SpeedButton4: TSpeedButton; + SpeedButton5: TSpeedButton; + SpeedButton6: TSpeedButton; + Label1: TLabel; + GroupBox1: TGroupBox; + GroupBox2: TGroupBox; + Label2: TLabel; + Label3: TLabel; + Reset: TBitBtn; + ctlHeight: TOvcSimpleField; + ctlDefaultHeight: TOvcSimpleField; + ctlRowLimit: TOvcSimpleField; + ctlRowNumber: TOvcSimpleField; + ApplyButton: TBitBtn; + DefaultController: TOvcController; + OvcSpinner1: TOvcSpinner; + OvcSpinner2: TOvcSpinner; + OvcSpinner3: TOvcSpinner; + OvcSpinner4: TOvcSpinner; + procedure ctlUseDefHeightClick(Sender: TObject); + procedure ctlUseCustHeightClick(Sender: TObject); + procedure SpeedButton1Click(Sender: TObject); + procedure SpeedButton2Click(Sender: TObject); + procedure SpeedButton3Click(Sender: TObject); + procedure SpeedButton4Click(Sender: TObject); + procedure SpeedButton5Click(Sender: TObject); + procedure SpeedButton6Click(Sender: TObject); + procedure ctlRowNumberExit(Sender: TObject); + procedure FormShow(Sender: TObject); + procedure ResetClick(Sender: TObject); + procedure ApplyButtonClick(Sender: TObject); + procedure DoneButtonClick(Sender: TObject); + procedure ctlRowNumberChange(Sender: TObject); + private + { Private declarations } + FRows : TOvcTableRows; + FRowNum : TRowNum; + CurDefHt : boolean; + + protected + procedure RefreshRowData; + procedure SetRowNum(R : TRowNum); + + public + { Public declarations } + procedure SetRows(RS : TOvcTableRows); + + property Rows : TOvcTableRows + read FRows + write SetRows; + + property RowNum : TRowNum + read FRowNum + write SetRowNum; + + end; + + {-A table row property editor} + TOvcTableRowProperty = class(TClassProperty) + public + procedure Edit; override; + function GetAttributes: TPropertyAttributes; override; + end; + + +implementation + +{$IFNDEF LCL} +{$R *.DFM} +{$ENDIF} + + + +{===TOvcTableRowProperty=============================================} +procedure TOvcTableRowProperty.Edit; + var + RowEditor : TOvcfrmRowEditor; + begin + RowEditor := TOvcfrmRowEditor.Create(Application); + try + RowEditor.SetRows(TOvcTableRows(GetOrdValue)); + RowEditor.ShowModal; +{$IFNDEF LCL} + Designer.Modified; +{$ELSE} + Modified; +{$ENDIF} + finally + RowEditor.Free; + end;{try..finally} + end; +{--------} +function TOvcTableRowProperty.GetAttributes: TPropertyAttributes; + begin + Result := [paMultiSelect, paDialog, paReadOnly]; + end; +{====================================================================} + + +{===TRowEditor=======================================================} +procedure TOvcfrmRowEditor.ApplyButtonClick(Sender: TObject); + var + RS : TRowStyle; + begin + FRows.Limit := ctlRowLimit.AsInteger; + if FRowNum >= FRows.Limit then + RowNum := pred(FRows.Limit); + FRows.DefaultHeight := ctlDefaultHeight.AsInteger; + with RS do + begin + if ctlUseDefHeight.Checked then + Height := ctlDefaultHeight.AsInteger + else + begin + Height := ctlHeight.AsInteger; + if (Height = FRows.DefaultHeight) then + ctlUseDefHeight.Checked := true; + end; + Hidden := ctlHidden.Checked; + FRows[RowNum] := RS; + end; + end; +{--------} +procedure TOvcfrmRowEditor.ctlRowNumberExit(Sender: TObject); + begin + RowNum := ctlRowNumber.AsInteger; + end; +{--------} +procedure TOvcfrmRowEditor.ctlUseCustHeightClick(Sender: TObject); + begin + CurDefHt := false; + ctlHeight.Enabled := true; + end; +{--------} +procedure TOvcfrmRowEditor.ctlUseDefHeightClick(Sender: TObject); + begin + CurDefHt := true; + ctlHeight.AsInteger := FRows.DefaultHeight; + ctlHeight.Enabled := false; + end; +{--------} +procedure TOvcfrmRowEditor.FormShow(Sender: TObject); + begin + ctlDefaultHeight.AsInteger := FRows.DefaultHeight; + ctlRowLimit.AsInteger := FRows.Limit; + RefreshRowData; + end; +{--------} +procedure TOvcfrmRowEditor.RefreshRowData; + begin + CurDefHt := FRows.Height[RowNum] = FRows.DefaultHeight; + + ctlRowNumber.RangeHi := IntToStr(pred(FRows.Limit)); + + ctlHidden.Checked := FRows.Hidden[RowNum]; + ctlHeight.AsInteger := FRows.Height[RowNum]; + if CurDefHt then + begin + ctlUseDefHeight.Checked := true; + ctlHeight.Enabled := false; + end + else + begin + ctlUseCustHeight.Checked := true; + ctlHeight.Enabled := true; + end; + + ctlRowLimit.AsInteger := FRows.Limit; + end; +{--------} +procedure TOvcfrmRowEditor.ResetClick(Sender: TObject); + begin + FRows.Clear; + ctlDefaultHeight.AsInteger := FRows.DefaultHeight; + RefreshRowData; + end; +{--------} +procedure TOvcfrmRowEditor.SetRowNum(R : TRowNum); + begin + if (FRowNum <> R) then + begin + FRowNum := R; + ctlRowNumber.AsInteger := R; + RefreshRowData; + end; + end; +{--------} +procedure TOvcfrmRowEditor.SetRows(RS : TOvcTableRows); + begin + if Assigned(FRows) then + FRows.Free; + FRows := RS; + FRowNum := 0; + CurDefHt := FRows.Height[RowNum] = FRows.DefaultHeight; + end; +{--------} +procedure TOvcfrmRowEditor.SpeedButton1Click(Sender: TObject); + begin + ApplyButtonClick(Self); + if (RowNum > 0) then + RowNum := RowNum - 1; + end; +{--------} +procedure TOvcfrmRowEditor.SpeedButton2Click(Sender: TObject); + begin + ApplyButtonClick(Self); + if (RowNum < pred(FRows.Limit)) then + RowNum := RowNum + 1; + end; +{--------} +procedure TOvcfrmRowEditor.SpeedButton3Click(Sender: TObject); + begin + ApplyButtonClick(Self); + RowNum := 0; + end; +{--------} +procedure TOvcfrmRowEditor.SpeedButton4Click(Sender: TObject); + begin + ApplyButtonClick(Self); + RowNum := pred(FRows.Limit); + end; +{--------} +procedure TOvcfrmRowEditor.SpeedButton5Click(Sender: TObject); + var + RS : TRowStyle; + begin + RS.Hidden := false; + RS.Height := FRows.DefaultHeight; + FRows.Insert(FRowNum, RS); + RefreshRowData; + end; +{--------} +procedure TOvcfrmRowEditor.SpeedButton6Click(Sender: TObject); + begin + FRows.Delete(FRowNum); + RefreshRowData; + end; +{====================================================================} + +procedure TOvcfrmRowEditor.DoneButtonClick(Sender: TObject); +begin + ApplyButtonClick(Self); +end; + +procedure TOvcfrmRowEditor.ctlRowNumberChange(Sender: TObject); +begin + ApplyButtonClick(Self); + RowNum := ctlRowNumber.AsInteger; +end; + +initialization +{$IFDEF LCL} +{$I ovctbpe1.lrs} {Include form's resource file} +{$ENDIF} + +end. diff --git a/components/orpheus/ovctbpe2.pas b/components/orpheus/ovctbpe2.pas new file mode 100644 index 000000000..67d92b140 --- /dev/null +++ b/components/orpheus/ovctbpe2.pas @@ -0,0 +1,332 @@ +{*********************************************************} +{* OVCTBPE2.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovctbpe2; + {-Property editor for the data-aware table component} + +interface + +uses + {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, LclType, LResources, {$ENDIF} + SysUtils, Classes, Graphics, Controls, + {$IFNDEF LCL} {$IFDEF VERSION6} DesignIntf, DesignEditors, {$ELSE} DsgnIntf, {$ENDIF} {$ELSE} PropEdits, ComponentEditors, {$ENDIF} + TypInfo, Forms, Dialogs, StdCtrls, OvcBase, OvcEf, OvcPb, OvcNf, Buttons, + ExtCtrls, OvcTCmmn, OvcTCell, OvcTbCls, OvcTable, OvcSf, OvcSc; + +type + TOvcfrmColEditor = class(TForm) + ctlColNumber: TOvcSimpleField; + ctlDefaultCell: TComboBox; + ctlHidden: TCheckBox; + ctlWidth: TOvcSimpleField; + Panel1: TPanel; + SpeedButton1: TSpeedButton; + SpeedButton2: TSpeedButton; + SpeedButton3: TSpeedButton; + SpeedButton4: TSpeedButton; + SpeedButton5: TSpeedButton; + SpeedButton6: TSpeedButton; + Label1: TLabel; + Label2: TLabel; + Label3: TLabel; + Label4: TLabel; + GroupBox1: TGroupBox; + DoneButton: TBitBtn; + ApplyButton: TBitBtn; + DefaultController: TOvcController; + OvcSpinner1: TOvcSpinner; + OvcSpinner2: TOvcSpinner; + procedure ctlColNumberExit(Sender: TObject); + procedure ApplyButtonClick(Sender: TObject); + procedure SpeedButton1Click(Sender: TObject); + procedure SpeedButton2Click(Sender: TObject); + procedure SpeedButton3Click(Sender: TObject); + procedure SpeedButton4Click(Sender: TObject); + procedure SpeedButton5Click(Sender: TObject); + procedure SpeedButton6Click(Sender: TObject); + procedure FormShow(Sender: TObject); + procedure DoneButtonClick(Sender: TObject); + procedure ctlColNumberChange(Sender: TObject); + private + { Private declarations } + FCols : TOvcTableColumns; + FColNum : TColNum; + CurCellIndex : integer; + Cells : TStringList; + + protected + procedure GetCells; + procedure RefreshColData; + procedure SetColNum(C : TColNum); + + procedure AddCellComponentName(const S : string); + + public + { Public declarations } + Editor : TObject; + procedure SetCols(CS : TOvcTableColumns); + + property Cols : TOvcTableColumns + read FCols + write SetCols; + + property ColNum : TColNum + read FColNum + write SetColNum; + + end; + + {-A table column property editor} + TOvcTableColumnProperty = class(TClassProperty) + public + procedure Edit; override; + function GetAttributes: TPropertyAttributes; override; + end; + + +implementation + +{$IFNDEF LCL} +{$R *.DFM} +{$ENDIF} + + + +{===TOvcTableColumnProperty==========================================} +procedure TOvcTableColumnProperty.Edit; + var + ColEditor : TOvcfrmColEditor; + begin + ColEditor := TOvcfrmColEditor.Create(Application); + try + ColEditor.Editor := Self; + ColEditor.SetCols(TOvcTableColumns(GetOrdValue)); + ColEditor.ShowModal; +{$IFNDEF LCL} + Designer.Modified; +{$ELSE} + Modified; +{$ENDIF} + finally + ColEditor.Free; + end;{try..finally} + end; +{--------} +function TOvcTableColumnProperty.GetAttributes: TPropertyAttributes; + begin + Result := [paMultiSelect, paDialog, paReadOnly]; + end; +{====================================================================} + + +{===TColEditor=======================================================} +procedure TOvcfrmColEditor.AddCellComponentName(const S : string); + begin + Cells.Add(S); + end; +{--------} +procedure TOvcfrmColEditor.ApplyButtonClick(Sender: TObject); + begin + with FCols[ColNum] do + begin + Hidden := ctlHidden.Checked; + FCols[ColNum].Width := ctlWidth.AsInteger; + if (ctlDefaultCell.ItemIndex <> CurCellIndex) then + begin + CurCellIndex := ctlDefaultCell.ItemIndex; + FCols[FColNum].DefaultCell := TOvcBaseTableCell(Cells.Objects[CurCellIndex]); + end; + end; + end; +{--------} +procedure TOvcfrmColEditor.ctlColNumberExit(Sender: TObject); + begin + ApplyButtonClick(Self); + ColNum := ctlColNumber.AsInteger; + end; +{--------} +procedure TOvcfrmColEditor.DoneButtonClick(Sender: TObject); + begin + ApplyButtonClick(Self); + Cells.Free; + end; +{--------} +procedure TOvcfrmColEditor.FormShow(Sender: TObject); + begin + if not Assigned(Cells) then + begin + Cells := TStringList.Create; + GetCells; + end; + RefreshColData; + end; +{--------} +procedure TOvcfrmColEditor.GetCells; + var + {$IFDEF VERSION4} + {$IFDEF VERSION6} +{$IFNDEF LCL} + Designer : IDesigner; +{$ENDIF} + {$ELSE} + Designer : IFormDesigner; + {$ENDIF} + {$ELSE} + Designer : TFormDesigner; + {$ENDIF} + TI : PTypeInfo; + Index: Integer; + C : TComponent; + Cell : TOvcBaseTableCell absolute C; + begin + Cells.Sorted := true; + Cells.AddObject('(None)', nil); + TI := TOvcBaseTableCell.ClassInfo; +{$IFNDEF LCL} + if (Editor is TClassProperty) then + Designer := TClassProperty(Editor).Designer + else {the editor is a TDefaultEditor} + Designer := TDefaultEditor(Editor).Designer; + Designer.GetComponentNames(GetTypeData(TI), AddCellComponentName); + for Index := 1 to pred(Cells.Count) do + Cells.Objects[Index] := Designer.GetComponent(Cells[Index]); +{$ELSE} + if (Editor is TClassProperty) then + begin + TClassProperty(Editor).PropertyHook.GetComponentNames(GetTypeData(TI), AddCellComponentName); + for Index := 1 to pred(Cells.Count) do + Cells.Objects[Index] := TClassProperty(Editor).PropertyHook.GetComponent(Cells[Index]); + end + else {the editor is a TDefaultComponentEditor} + begin + TDefaultComponentEditor(Editor).Designer.PropertyEditorHook.GetComponentNames(GetTypeData(TI), AddCellComponentName); + for Index := 1 to pred(Cells.Count) do + Cells.Objects[Index] := TDefaultComponentEditor(Editor).Designer.PropertyEditorHook.GetComponent(Cells[Index]); + end; +{$ENDIF} + ctlDefaultCell.Items := Cells; + end; +{--------} +procedure TOvcfrmColEditor.RefreshColData; + begin + CurCellIndex := Cells.IndexOfObject(FCols[ColNum].DefaultCell); + + ctlColNumber.RangeHi := IntToStr(pred(FCols.Count)); + + ctlHidden.Checked := FCols[ColNum].Hidden; + ctlWidth.AsInteger := FCols[ColNum].Width; + ctlDefaultCell.ItemIndex := CurCellIndex; + end; +{--------} +procedure TOvcfrmColEditor.SetColNum(C : TColNum); + begin + if (FColNum <> C) then + begin + FColNum := C; + ctlColNumber.AsInteger := C; + RefreshColData; + end; + end; +{--------} +procedure TOvcfrmColEditor.SetCols(CS : TOvcTableColumns); + begin + if Assigned(FCols) then + FCols.Free; + FCols := CS; + FColNum := 0; + end; +{--------} +procedure TOvcfrmColEditor.SpeedButton1Click(Sender: TObject); + begin + ApplyButtonClick(Self); + if (ColNum > 0) then + ColNum := ColNum - 1; + end; +{--------} +procedure TOvcfrmColEditor.SpeedButton2Click(Sender: TObject); + begin + ApplyButtonClick(Self); + if (ColNum < pred(FCols.Count)) then + ColNum := ColNum + 1; + end; +{--------} +procedure TOvcfrmColEditor.SpeedButton3Click(Sender: TObject); + begin + ApplyButtonClick(Self); + ColNum := 0; + end; +{--------} +procedure TOvcfrmColEditor.SpeedButton4Click(Sender: TObject); + begin + ApplyButtonClick(Self); + ColNum := pred(FCols.Count); + end; +{--------} +procedure TOvcfrmColEditor.SpeedButton5Click(Sender: TObject); + var + C : TOvcTableColumn; + begin + C := TOvcTableColumn.Create(FCols.Table); + FCols.Insert(FColNum, C); + RefreshColData; + end; +{--------} +procedure TOvcfrmColEditor.SpeedButton6Click(Sender: TObject); + begin + if (FCols.Count > 1) then + begin + FCols.Delete(FColNum); + if (FColNum = FCols.Count) then + ColNum := pred(FColNum) + else RefreshColData; + end; + end; +{====================================================================} + + +procedure TOvcfrmColEditor.ctlColNumberChange(Sender: TObject); +begin + ApplyButtonClick(Self); + ColNum := ctlColNumber.AsInteger; +end; + +initialization +{$IFDEF LCL} +{$I ovctbpe2.lrs} {Include form's resource file} +{$ENDIF} + +end. diff --git a/components/orpheus/ovctbrws.pas b/components/orpheus/ovctbrws.pas new file mode 100644 index 000000000..14aa2d7e6 --- /dev/null +++ b/components/orpheus/ovctbrws.pas @@ -0,0 +1,511 @@ +{*********************************************************} +{* OVCTBRWS.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovctbrws; + {-Orpheus Table Rows array} + +interface + +uses + {$IFNDEF LCL} Windows, {$ELSE} LclIntf, LclType, {$ENDIF} + SysUtils, Classes, OvcConst, OvcTCmmn, OvcSpAry; + +type + TOvcTableRows = class(TPersistent) + {-Sparse array for rows} + protected {private} + {property fields} + FActiveCount : TRowNum; + FList : TOvcSparseArray; + FDefHeight : integer; + FLimit : TRowNum; + {property event fields} + FOnCfgChanged : TRowChangeNotifyEvent; + + protected + {property read access} + function GetRow(RowNum : TRowNum) : TRowStyle; + function GetRowHeight(RowNum : TRowNum) : integer; + function GetRowHidden(RowNum : TRowNum) : boolean; + function GetRowIsSpecial(RowNum : TRowNum) : boolean; + {property write access} + procedure SetDefHeight(H : integer); + procedure SetRow(RowNum : TRowNum; const RS : TRowStyle); + procedure SetRowHeight(RowNum : TRowNum; H : integer); + procedure SetRowHidden(RowNum : TRowNum; H : boolean); + procedure SetLimit(RowNum : TRowNum); + + {general} + procedure trDoCfgChanged(RowNum1, RowNum2 : TRowNum; Action : TOvcTblActions); + + public {protected} + procedure rwScaleHeights(M, D : integer); + + property OnCfgChanged : TRowChangeNotifyEvent + write FOnCfgChanged; + + public + constructor Create; + {-Create an array of row styles} + destructor Destroy; override; + {-Destroy an array of row styles} + + procedure Append(const RS : TRowStyle); + {-Add row to end of current list, increment Limit} + procedure Clear; + {-Delete all row styles (reset all rows to the defaults)} + procedure Delete(RowNum : TRowNum); + {-Delete a row, move rows below it up one, decrement Limit} + procedure Exchange(const RowNum1, RowNum2 : TRowNum); + {-Exchange two rows} + procedure Insert(const RowNum : TRowNum; + const RS : TRowStyle); + {-Insert a row, move rows below it down one, increment Limit} + procedure Reset(const RowNum : TRowNum); + {-Reset a row to the defaults} + + property List [RowNum : TRowNum] : TRowStyle + {-Array of row styles} + read GetRow write SetRow; + default; + + {properties} + property Count : TRowNum + {-The current number of rows with explicit attributes} + read FActiveCount; + + property DefaultHeight : integer + {-The default row height} + read FDefHeight write SetDefHeight; + + property Height [RowNum : TRowNum] : integer + {-Array of row heights} + read GetRowHeight write SetRowHeight; + + property Hidden [RowNum : TRowNum] : boolean + {-Array of row hidden flags} + read GetRowHidden write SetRowHidden; + + property RowIsSpecial [RowNum : TRowNum] : boolean + read GetRowIsSpecial; + + property Limit : TRowNum + {-Maximum number of rows} + read FLimit write SetLimit; + end; + + +implementation + + +{===Extra RowStyle routines==========================================} +function NewRowStyle(AHeight : integer; AHidden : boolean) : PRowStyle; + {-Allocate a row style on the heap} + begin + Result := New(PRowStyle); + with Result^ do + begin + Height := AHeight; + Hidden := AHidden; + end; + end; +{--------} +function DelRow(Index : longint; Item : pointer; ExtraData : pointer) : boolean; far; + {-Iterator to delete a row style from the sparse list} + var + R : PRowStyle absolute Item; + begin + Dispose(R); + Result := true; + end; +{--------------------------------------------------------------------} + +{Note: the row numbers passed to this class have a minimum limit of + zero, and an upper limit that consists of two parts. Firstly + the real upper limit is the value of Limit: if a row number + is greater than this an out-of-bounds exception is generated. + Secondly the upper limit for rows with explicit styles is + MaxSparseArrayItems, since that is the limit for the under- + lying sparse array. Generally exceeding this limit causes the + action to be ignored, no exception is generated.} + + +{===TOvcTableRows==========================================================} +constructor TOvcTableRows.Create; + begin + FList := TOvcSparseArray.Create; + FDefHeight := tbDefRowHeight; + FLimit := tbDefRowCount; + end; +{--------} +destructor TOvcTableRows.Destroy; + begin + if Assigned(FList) then + begin + Clear; + FList.Free; + end; + end; +{--------} +procedure TOvcTableRows.Append(const RS : TRowStyle); + begin + Insert(Limit, RS); + end; +{--------} +procedure TOvcTableRows.Clear; + var + DummyPtr : pointer; + begin + DummyPtr := nil; + FList.ForAll(DelRow, false, DummyPtr); + FList.Clear; + FActiveCount := 0; + trDoCfgChanged(0, 0, taAll); + end; +{--------} +procedure TOvcTableRows.Delete(RowNum : TRowNum); + var + RS : PRowStyle; + begin + if (RowNum < 0) or (RowNum >= Limit) then + TableErrorRes(SCTableRowOutOfBounds); + if (RowNum < OvcSpAry.MaxSparseArrayItems) then + begin + RS := PRowStyle(FList[RowNum]); + if Assigned(RS) then + begin + Dispose(RS); + dec(FActiveCount); + end; + FList.Delete(RowNum); + Limit := Limit - 1; + trDoCfgChanged(RowNum, 0, taDelete); + end; + end; +{--------} +procedure TOvcTableRows.trDoCfgChanged(RowNum1, RowNum2 : TRowNum; Action : TOvcTblActions); + {-On a change, call the notify event handler} + begin + if Assigned(FOnCfgChanged) then + FOnCfgChanged(Self, RowNum1, RowNum2, Action); + end; +{--------} +procedure TOvcTableRows.Exchange(const RowNum1, RowNum2 : TRowNum); + begin + if (RowNum1 < 0) or (RowNum1 >= Limit) then + TableErrorRes(SCTableRowOutOfBounds); + if (RowNum2 < 0) or (RowNum2 >= Limit) then + TableErrorRes(SCTableRowOutOfBounds); + if (RowNum1 <> RowNum2) and + (RowNum1 < OvcSpAry.MaxSparseArrayItems) and + (RowNum2 < OvcSpAry.MaxSparseArrayItems) then + begin + FList.Exchange(RowNum1, RowNum2); + trDoCfgChanged(RowNum1, RowNum2, taExchange); + end; + end; +{--------} +function TOvcTableRows.GetRow(RowNum : TRowNum) : TRowStyle; + var + PRS : PRowStyle; + begin + if (RowNum < 0) or (RowNum >= Limit) then + TableErrorRes(SCTableRowOutOfBounds); + if (FActiveCount > 0) and (RowNum < OvcSpAry.MaxSparseArrayItems) then + PRS := PRowStyle(FList[RowNum]) + else + PRS := nil; + if Assigned(PRS) then + begin + Result := PRS^; + if (Result.Height = UseDefHt) then + Result.Height := DefaultHeight; + end + else + with Result do + begin + Height := DefaultHeight; + Hidden := false; + end; + end; +{--------} +function TOvcTableRows.GetRowHeight(RowNum : TRowNum) : integer; + var + PRS : PRowStyle; + begin + if (RowNum < 0) or (RowNum >= Limit) then + TableErrorRes(SCTableRowOutOfBounds); + Result := DefaultHeight; + if (FActiveCount > 0) and (RowNum < OvcSpAry.MaxSparseArrayItems) then + begin + PRS := PRowStyle(FList[RowNum]); + if Assigned(PRS) then + begin + Result := PRS^.Height; + if (Result = UseDefHt) then + Result := DefaultHeight; + end; + end; + end; +{--------} +function TOvcTableRows.GetRowHidden(RowNum : TRowNum) : boolean; + var + PRS : PRowStyle; + begin + if (RowNum < 0) or (RowNum >= Limit) then + TableErrorRes(SCTableRowOutOfBounds); + Result := false; + if (FActiveCount > 0) and (RowNum < OvcSpAry.MaxSparseArrayItems) then + begin + PRS := PRowStyle(FList[RowNum]); + if Assigned(PRS) then + Result := PRS^.Hidden; + end; + end; +{--------} +function TOvcTableRows.GetRowIsSpecial(RowNum : TRowNum) : boolean; + var + PRS : PRowStyle; + begin + if (RowNum < 0) or (RowNum >= Limit) then + TableErrorRes(SCTableRowOutOfBounds); + if (FActiveCount > 0) and (RowNum < OvcSpAry.MaxSparseArrayItems) then + begin + PRS := PRowStyle(FList[RowNum]); + Result := Assigned(PRS); + end + else + Result := false; + end; +{--------} +procedure TOvcTableRows.Insert(const RowNum : TRowNum; + const RS : TRowStyle); + var + Height : integer; + begin + {note: you can insert a style at row number Limit} + if (RowNum < 0) or (RowNum > Limit) then + TableErrorRes(SCTableRowOutOfBounds); + if (RowNum >= OvcSpAry.MaxSparseArrayItems) then + TableErrorRes(SCTableMaxRows); + Height := RS.Height; + if (Height < 1) or (Height = DefaultHeight) then + Height := UseDefHt; + if (RS.Hidden = false) and (Height = UseDefHt) then + FList.Insert(RowNum, nil) + else + begin + FList.Insert(RowNum, NewRowStyle(Height, RS.Hidden)); + inc(FActiveCount); + end; + Limit := Limit + 1; + trDoCfgChanged(RowNum, 0, taInsert); + end; +{--------} +procedure TOvcTableRows.Reset(const RowNum : TRowNum); + var + PRS : PRowStyle; + begin + if (RowNum < 0) or (RowNum >= Limit) then + TableErrorRes(SCTableRowOutOfBounds); + if (FActiveCount > 0) and (RowNum < OvcSpAry.MaxSparseArrayItems) then + begin + PRS := PRowStyle(FList[RowNum]); + if Assigned(PRS) then + begin + Dispose(PRS); + FList[RowNum] := nil; + dec(FActiveCount); + trDoCfgChanged(RowNum, 0, taSingle); + end; + end; + end; +{--------} +type + PScaleExtraData = ^TScaleExtraData; + TScaleExtraData = packed record + M, D : integer; + end; + {------} +function ScaleHeight(Index : longint; Item : pointer; + ExtraData : pointer) : boolean; far; + var + RS : PRowStyle absolute Item; + ED : PScaleExtraData absolute ExtraData; + begin + Result := true; + with RS^ do + if (Height <> UseDefHt) then + Height := MulDiv(Height, ED^.M, ED^.D); + end; + {------} +procedure TOvcTableRows.rwScaleHeights(M, D : integer); + var + ExtraData : TScaleExtraData; + begin + FDefHeight := MulDiv(FDefHeight, M, D); + if (FActiveCount > 0) then + begin + ExtraData.M := M; + ExtraData.D := D; + FList.ForAll(ScaleHeight, false, @ExtraData); + end; + end; +{--------} +procedure TOvcTableRows.SetDefHeight(H : integer); + begin + if (H <> FDefHeight) and (H >= 1) then + begin + FDefHeight := H; + trDoCfgChanged(0, 0, taAll); + end; + end; +{--------} +procedure TOvcTableRows.SetLimit(RowNum : TRowNum); + begin + if RowNum < 1 then + RowNum := 1; + if (RowNum <> FLimit) then + begin + FLimit := RowNum; + trDoCfgChanged(RowLimitChanged, 0, taGeneral); + end; + end; +{--------} +procedure TOvcTableRows.SetRow(RowNum : TRowNum; const RS : TRowStyle); + var + PRS : PRowStyle; + Height : integer; + begin + if (RowNum < 0) or (RowNum >= Limit) then + TableErrorRes(SCTableRowOutOfBounds); + if (RowNum < OvcSpAry.MaxSparseArrayItems) then + begin + Height := RS.Height; + if (Height < 1) or (Height = DefaultHeight) then + Height := UseDefHt; + if (RS.Hidden = false) and (Height = UseDefHt) then + Reset(RowNum) + else + begin + PRS := PRowStyle(FList[RowNum]); + if Assigned(PRS) then + PRS^ := RS + else + begin + FList[RowNum] := NewRowStyle(Height, RS.Hidden); + inc(FActiveCount); + end; + trDoCfgChanged(RowNum, 0, taSingle); + end; + end; + end; +{--------} +procedure TOvcTableRows.SetRowHeight(RowNum : TRowNum; H : integer); + var + PRS : PRowStyle; + begin + if (RowNum < 0) or (RowNum >= Limit) then + TableErrorRes(SCTableRowOutOfBounds); + if (RowNum < OvcSpAry.MaxSparseArrayItems) then + begin + if (H < 1) or (H = DefaultHeight) then + H := UseDefHt; + PRS := PRowStyle(FList[RowNum]); + if Assigned(PRS) then + begin + if (H <> PRS^.Height) then + begin + if (H = UseDefHt) then + if not PRS^.Hidden then + begin + Dispose(PRS); + FList[RowNum] := nil; + dec(FActiveCount); + end + else + PRS^.Height := UseDefHt + else + PRS^.Height := H; + trDoCfgChanged(RowNum, 0, taSingle); + end; + end + else if (H <> UseDefHt) then {only create new style if not default} + begin + FList[RowNum] := NewRowStyle(H, false); + inc(FActiveCount); + trDoCfgChanged(RowNum, 0, taSingle); + end; + end; + end; +{--------} +procedure TOvcTableRows.SetRowHidden(RowNum : TRowNum; H : boolean); + var + PRS : PRowStyle; + begin + if (RowNum < 0) or (RowNum >= Limit) then + TableErrorRes(SCTableRowOutOfBounds); + if (RowNum < OvcSpAry.MaxSparseArrayItems) then + begin + PRS := PRowStyle(FList[RowNum]); + if Assigned(PRS) then + begin + if (H <> PRS^.Hidden) then + begin + if (not H) and (PRS^.Height = UseDefHt) then + begin + Dispose(PRS); + FList[RowNum] := nil; + dec(FActiveCount); + end + else + PRS^.Hidden := H; + trDoCfgChanged(RowNum, 0, taSingle); + end; + end + else if H then {only create new style if hidden} + begin + FList[RowNum] := NewRowStyle(UseDefHt, H); + inc(FActiveCount); + trDoCfgChanged(RowNum, 0, taSingle); + end; + end; + end; +{====================================================================} + + +end. diff --git a/components/orpheus/ovctcary.pas b/components/orpheus/ovctcary.pas new file mode 100644 index 000000000..40cff0011 --- /dev/null +++ b/components/orpheus/ovctcary.pas @@ -0,0 +1,324 @@ +{*********************************************************} +{* OVCTCARY.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovctcary; + {-Orpheus Table - Cell Array class} + +interface + +{Note: this class exists for the *sole* purpose of providing a sorted + list of cell addresses that need repainting. It has no other + possible application. It also stores a flag that states that + the unused bit of the table window needs painting} + +uses + SysUtils, Classes, OvcTCmmn; + +type + TOvcCellAddress = packed record + Row : TRowNum; + Col : TColNum; + end; + + TOvcCellArray = class + protected {private} + {.Z+} + FArray : pointer; + FLimit : Integer; + FCount : Integer; + + DoUnusedBit : boolean; + {.Z-} + + protected + {.Z+} + function GetEmpty : boolean; + {.Z-} + + public + destructor Destroy; override; + + procedure AddCell(RowNum : TRowNum; ColNum : TColNum); + procedure AddUnusedBit; + procedure Clear; + function DeleteCell(RowNum : TRowNum; ColNum : TColNum) : boolean; + procedure GetCellAddr(Inx : Integer; var CellAddr : TOvcCellAddress); + procedure Merge(CA : TOvcCellArray); + function MustDoUnusedBit : boolean; + + property Count : Integer + read FCount; + + property Empty : boolean + read GetEmpty; + end; + +implementation + + +type + POvcCellArrayPrim = ^TOvcCellArrayPrim; + TOvcCellArrayPrim = array [0..9999] of TOvcCellAddress; + + +{===TOvcCellArray====================================================} +destructor TOvcCellArray.Destroy; + begin + if Assigned(FArray) then + FreeMem(FArray, sizeof(TOvcCellAddress) * FLimit); + end; +{--------} +procedure TOvcCellArray.AddCell(RowNum : TRowNum; ColNum : TColNum); + var + NewLimit : Integer; + L, R, M : Integer; + NewArray : pointer; + MCell : TOvcCellAddress; + begin + {grow array if required} + if (FCount = FLimit) then + begin + NewLimit := FLimit + 128; + GetMem(NewArray, sizeof(TOvcCellAddress) * NewLimit); + if Assigned(FArray) then + begin + Move(FArray^, NewArray^, sizeof(TOvcCellAddress) * FLimit); + FreeMem(FArray, sizeof(TOvcCellAddress) * FLimit); + end; + FLimit := NewLimit; + FArray := NewArray; + end; + {do special case, er, specially} + if (FCount = 0) then + begin + with POvcCellArrayPrim(FArray)^[0] do + begin + Row := RowNum; + Col := ColNum; + end; + FCount := 1; + Exit; + end; + {binary search through array, insert in order} + L := 0; + R := pred(FCount); + repeat + M := (L + R) div 2; + MCell := POvcCellArrayPrim(FArray)^[M]; + if (RowNum = MCell.Row) then + if (ColNum = MCell.Col) then + Exit {nothing to do-already present} + else if (ColNum < MCell.Col) then + R := M - 1 + else + L := M + 1 + else if (RowNum < MCell.Row) then + R := M - 1 + else + L := M + 1; + until (L > R); + {insert at L} + if (L < FCount) then + Move(POvcCellArrayPrim(FArray)^[L], + POvcCellArrayPrim(FArray)^[L+1], + sizeof(TOvcCellAddress)*(FCount-L)); + with POvcCellArrayPrim(FArray)^[L] do + begin + Row := RowNum; + Col := ColNum; + end; + inc(FCount); + end; +{--------} +procedure TOvcCellArray.AddUnusedBit; + begin + DoUnusedBit := true; + end; +{--------} +procedure TOvcCellArray.Clear; + begin + FCount := 0; + DoUnusedBit := false; + end; +{--------} +function TOvcCellArray.DeleteCell(RowNum : TRowNum; ColNum : TColNum) : boolean; + var + L, R, M : Integer; + MCell : TOvcCellAddress; + begin + Result := false; + {do special case, er, specially} + if (FCount = 0) then + Exit; + {binary search through array} + L := 0; + R := pred(FCount); + repeat + M := (L + R) div 2; + MCell := POvcCellArrayPrim(FArray)^[M]; + if (RowNum = MCell.Row) then + if (ColNum = MCell.Col) then + begin + {got it} + dec(FCount); + if (FCount > M) then + Move(POvcCellArrayPrim(FArray)^[M+1], + POvcCellArrayPrim(FArray)^[M], + sizeof(TOvcCellAddress)*(FCount-M)); + Result := true; + Exit; + end + else if (ColNum < MCell.Col) then + R := M - 1 + else + L := M + 1 + else if (RowNum < MCell.Row) then + R := M - 1 + else + L := M + 1; + until (L > R); + end; +{--------} +procedure TOvcCellArray.GetCellAddr(Inx : Integer; var CellAddr : TOvcCellAddress); + begin + if (0 <= Inx) and (Inx < FCount) then + CellAddr := POvcCellArrayPrim(FArray)^[Inx] + else + FillChar(CellAddr, sizeof(CellAddr), 0); + end; +{--------} +function TOvcCellArray.GetEmpty : boolean; + begin + Result := (Count = 0) and (not DoUnusedBit); + end; +{--------} +procedure TOvcCellArray.Merge(CA : TOvcCellArray); + var + NewA : POvcCellArrayPrim; + InxMerge : integer; + InxSelf : integer; + InxCA : integer; + CellSelf : TOvcCellAddress; + CellCA : TOvcCellAddress; + NewLimit : integer; + MergeNum : integer; + i : integer; + begin + {if both cell arrays are empty, there's nothing to do} + if (Count = 0) and (CA.Count = 0) then + Exit; + {make a new array at least as large as both arrays put together} + NewLimit := ((Count + CA.Count) + 127) and $7FFFFF80; + GetMem(NewA, sizeof(TOvcCellAddress) * NewLimit); + {prepare for the loop} + InxMerge := 0; + InxSelf := 0; + InxCA := 0; + if (Count > 0) then + CellSelf := POvcCellArrayPrim(FArray)^[0]; + if (CA.Count > 0) then + CellCA := POvcCellArrayPrim(CA.FArray)^[0]; + {loop until one (or both) of the arrays is exhausted} + while (InxSelf < Count) and (InxCA < CA.Count) do + begin + if (CellSelf.Row < CellCA.Row) then + MergeNum := 1 + else if (CellSelf.Row > CellCA.Row) then + MergeNum := 2 + else {CellSelf.Row = CellCA.Row} + if (CellSelf.Col < CellCA.Col) then + MergeNum := 1 + else if (CellSelf.Col > CellCA.Col) then + MergeNum := 2 + else {both rows & cols equal} + MergeNum := 0; + case MergeNum of + 0 : begin {equal} + NewA^[InxMerge] := CellSelf; + inc(InxMerge); + inc(InxSelf); + if (InxSelf < Count) then + CellSelf := POvcCellArrayPrim(FArray)^[InxSelf]; + inc(InxCA); + if (InxCA < CA.Count) then + CellCA := POvcCellArrayPrim(CA.FArray)^[InxCA]; + end; + 1 : begin + NewA^[InxMerge] := CellSelf; + inc(InxMerge); + inc(InxSelf); + if (InxSelf < Count) then + CellSelf := POvcCellArrayPrim(FArray)^[InxSelf]; + end; + 2 : begin + NewA^[InxMerge] := CellCA; + inc(InxMerge); + inc(InxCA); + if (InxCA < CA.Count) then + CellCA := POvcCellArrayPrim(CA.FArray)^[InxCA]; + end; + end;{case} + end; + {after this loop one (or both) of the input merge streams has been + exhausted; copy the remaining elements from the other} + if (InxSelf = Count) then {self array exhausted} + for i := InxCA to pred(CA.Count) do + begin + NewA^[InxMerge] := POvcCellArrayPrim(CA.FArray)^[i]; + inc(InxMerge); + end + else if (InxCA = CA.Count) then {CA array exhausted} + for i := InxSelf to pred(Count) do + begin + NewA^[InxMerge] := POvcCellArrayPrim(FArray)^[i]; + inc(InxMerge); + end; + {all merged, replace the current array with the merged array} + FreeMem(FArray, sizeof(TOvcCellAddress) * FLimit); + FArray := NewA; + FLimit := NewLimit; + FCount := InxMerge; + end; +{--------} +function TOvcCellArray.MustDoUnusedBit : boolean; + begin + Result := DoUnusedBit; + end; +{====================================================================} + + +end. diff --git a/components/orpheus/ovctcbef.pas b/components/orpheus/ovctcbef.pas new file mode 100644 index 000000000..afd2acd47 --- /dev/null +++ b/components/orpheus/ovctcbef.pas @@ -0,0 +1,584 @@ +{*********************************************************} +{* OVCTCBEF.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovctcbef; + {-Orpheus Table Cell - base entry field type} + +interface + +uses + {$IFNDEF LCL} Windows, {$ELSE} LclIntf, LclType, MyMisc, {$ENDIF} + SysUtils, Classes, Graphics, Controls, Forms, + OvcBase, OvcCmd, OvcEF, OvcCaret, OvcTCmmn, OvcTCell, OvcTable, OvcTCStr; + +type + TOvcTCBaseEntryField = class(TOvcTCBaseString) + protected {private} + FEdit : TOvcBaseEntryField; + FEditDisplay : TOvcBaseEntryField; + + FOnError : TValidationErrorEvent; + FOnUserCommand : TUserCommandEvent; + FOnUserValidation : TUserValidationEvent; + + CopyOfData : pointer; + CopyOfDataSize : Integer; + + protected + function GetCaretIns : TOvcCaret; + function GetCaretOvr : TOvcCaret; + function GetControlCharColor : TColor; + function GetDataSize : integer; + function GetDecimalPlaces : byte; + function GetOptions : TOvcEntryFieldOptions; + function GetEFColors : TOvcEFColors; + function GetMaxLength : word; + function GetModified : boolean; + function GetPadChar : AnsiChar; + function GetPasswordChar : AnsiChar; + function GetRangeHi : string; + function GetRangeLo : string; + function GetTextMargin : integer; + + procedure SetCaretIns(CI : TOvcCaret); + procedure SetCaretOvr(CO : TOvcCaret); + procedure SetControlCharColor(CCC : TColor); + procedure SetDecimalPlaces(DP : byte); + procedure SetEFColors(Value : TOvcEFColors); + procedure SetMaxLength(ML : word); + procedure SetOptions(Value : TOvcEntryFieldOptions); + procedure SetPadChar(PC : AnsiChar); + procedure SetPasswordChar(PC : AnsiChar); + procedure SetRangeHi(const RI : string); + procedure SetRangeLo(const RL : string); + procedure SetTextMargin(TM : integer); + + procedure DefineProperties(Filer: TFiler); override; + + procedure tcPaint(TableCanvas : TCanvas; + const CellRect : TRect; + RowNum : TRowNum; + ColNum : TColNum; + const CellAttr : TOvcCellAttributes; + Data : pointer); override; + + {properties for entry fields, to be exposed by descendants} + property CaretIns : TOvcCaret + read GetCaretIns write SetCaretIns; + + property CaretOvr : TOvcCaret + read GetCaretOvr write SetCaretOvr; + + property ControlCharColor : TColor + read GetControlCharColor write SetControlCharColor; + + property DecimalPlaces : byte + read GetDecimalPlaces write SetDecimalPlaces; + + property EFColors : TOvcEFColors + read GetEFColors write SetEFColors; + + property MaxLength : word + read GetMaxLength write SetMaxLength; + + property Options : TOvcEntryFieldOptions + read GetOptions write SetOptions; + + property PadChar : AnsiChar + read GetPadChar write SetPadChar; + + property PasswordChar : AnsiChar + read GetPasswordChar write SetPasswordChar; + + property RangeHi : string + read GetRangeHi write SetRangeHi + stored false; + + property RangeLo : string + read GetRangeLo write SetRangeLo + stored false; + + property TextMargin : integer + read GetTextMargin write SetTextMargin; + + {events} + property OnError : TValidationErrorEvent + read FOnError write FOnError; + + property OnUserCommand : TUserCommandEvent + read FOnUserCommand write FOnUserCommand; + + property OnUserValidation : TUserValidationEvent + read FOnUserValidation write FOnUserValidation; + + public + constructor Create(AOwner : TComponent); override; + destructor Destroy; + override; + function CreateEntryField(AOwner : TComponent) : TOvcBaseEntryField; virtual; abstract; + + function EditHandle : THandle; override; + procedure EditHide; override; + procedure EditMove(CellRect : TRect); override; + + function CanSaveEditedData(SaveValue : boolean) : boolean; override; + procedure SaveEditedData(Data : pointer); override; + procedure StartEditing(RowNum : TRowNum; ColNum : TColNum; + CellRect : TRect; + const CellAttr : TOvcCellAttributes; + CellStyle: TOvcTblEditorStyle; + Data : pointer); override; + procedure StopEditing(SaveValue : boolean; + Data : pointer); override; + + property DataSize : integer + read GetDataSize; + + property Modified : boolean + read GetModified; + + published + property About; + end; + +implementation + +uses + Dialogs; + +type {for typecast to get around protected clause} + TOvcBEF = class(TOvcBaseEntryField) + public + property CaretIns; + property CaretOvr; + property ControlCharColor; + property DecimalPlaces; + property EFColors; + property MaxLength; + property Options; + property PadChar; + property PasswordChar; + property RangeHi; + property RangeLo; + property ShowHint; + property TextMargin; + end; + +{===TOvcTCBaseEntryField=============================================} +constructor TOvcTCBaseEntryField.Create(AOwner : TComponent); + begin + inherited Create(AOwner); + + FEdit := CreateEntryField(Self); + FEdit.Visible := false; + + FEditDisplay := CreateEntryField(Self); + FEditDisplay.Visible := false; + end; + +destructor TOvcTCBaseEntryField.Destroy; +begin + if (CopyOfData <> nil) and (CopyOfDataSize > 0) then + FreeMem(CopyOfData, CopyOfDataSize); + + inherited Destroy; +end; + +{--------} +function TOvcTCBaseEntryField.CanSaveEditedData(SaveValue : boolean) : boolean; + begin + Result := true; + if Assigned(FEdit) then + if SaveValue then + with TOvcBEF(FEdit) do + if Controller.ErrorPending then + Result := false + else + Result := ValidateSelf + else + FEdit.Restore; + end; +{--------} +function TOvcTCBaseEntryField.EditHandle : THandle; + begin + if Assigned(FEdit) then + Result := FEdit.Handle + else + Result := 0; + end; +{--------} +procedure TOvcTCBaseEntryField.EditHide; + begin + if Assigned(FEdit) then + with FEdit do + begin + SetWindowPos(FEdit.Handle, HWND_TOP, + 0, 0, 0, 0, + SWP_HIDEWINDOW or SWP_NOREDRAW or SWP_NOZORDER); + end; + + end; +{--------} +procedure TOvcTCBaseEntryField.EditMove(CellRect : TRect); + var + EditHandle : HWND; + begin + if Assigned(FEdit) then + begin + EditHandle := FEdit.Handle; + with CellRect do + SetWindowPos(EditHandle, HWND_TOP, + Left, Top, Right-Left, Bottom-Top, + SWP_SHOWWINDOW or SWP_NOREDRAW or SWP_NOZORDER); + InvalidateRect(EditHandle, nil, false); + UpdateWindow(EditHandle); + + end; + end; +{--------} +procedure TOvcTCBaseEntryField.tcPaint(TableCanvas : TCanvas; + const CellRect : TRect; + RowNum : TRowNum; + ColNum : TColNum; + const CellAttr : TOvcCellAttributes; + Data : pointer); + var + S : ShortString; + I : integer; + begin + if (Data = nil) then + inherited tcPaint(TableCanvas, CellRect, RowNum, ColNum, CellAttr, Data) + else + begin + FEditDisplay.Controller := TOvcTable(FTable).Controller; + if (FEditDisplay.Controller = nil) then + ShowMessage('NIL in tcPaint'); + FEditDisplay.Parent := FTable; + SetWindowPos(FEditDisplay.Handle, HWND_TOP, 0, 0, 0, 0, + SWP_HIDEWINDOW or SWP_NOREDRAW or SWP_NOZORDER); + FEditDisplay.SetValue(Data^); + S := Trim(FEditDisplay.DisplayString); // Inserted Trim +(* TurboPower bug: this code trims string of white space, but in using I as + index into string S doesn't check if I is in range of 1..Length(S), + which can result in range-check error. + I := 1; + while (S[I] <= #32) do + Inc(I); + Delete(S, 1, I-1); + I := Length(S); + while (S[I] <= #32) do + Dec(I); + Delete(S, I+1, Length(S) - I); +*) + inherited tcPaint(TableCanvas, CellRect, RowNum, ColNum, CellAttr, @S); + end; + end; +{--------} +procedure TOvcTCBaseEntryField.SaveEditedData(Data : pointer); + begin + if Assigned(Data) then + begin + FEdit.GetValue(CopyOfData^); + Move(CopyOfData^, Data^, CopyOfDataSize); + end; + end; +{--------} +procedure TOvcTCBaseEntryField.StartEditing(RowNum : TRowNum; ColNum : TColNum; + CellRect : TRect; + const CellAttr : TOvcCellAttributes; + CellStyle: TOvcTblEditorStyle; + Data : pointer); + begin + CopyOfDataSize := FEdit.DataSize; + GetMem(CopyOfData, CopyOfDataSize); + if (Data = nil) then + FillChar(CopyOfData^, CopyOfDataSize, 0) + else + Move(Data^, CopyOfData^, CopyOfDataSize); + + with TOvcBEF(FEdit) do + begin + Parent := FTable; + Font := CellAttr.caFont; + Font.Color := CellAttr.caFontColor; + Color := CellAttr.caColor; + BorderStyle := bsNone; + Ctl3D := false; + case CellStyle of + tesBorder : BorderStyle := bsSingle; + tes3D : Ctl3D := true; + end;{case} + Left := CellRect.Left; + Top := CellRect.Top; + Width := CellRect.Right - CellRect.Left; + Height := CellRect.Bottom - CellRect.Top; + Hint := Self.Hint; + ShowHint := Self.ShowHint; + TabStop := false; + Controller := TOvcTable(FTable).Controller; + if (Controller = nil) then + ShowMessage('NIL in StartEditing'); + SetValue(CopyOfData^); + Visible := true; + + OnChange := Self.OnChange; + OnClick := Self.OnClick; + OnDblClick := Self.OnDblClick; + OnDragDrop := Self.OnDragDrop; + OnDragOver := Self.OnDragOver; + OnEndDrag := Self.OnEndDrag; + OnEnter := Self.OnEnter; + OnError := Self.OnError; + OnExit := Self.OnExit; + OnKeyDown := Self.OnKeyDown; + OnKeyPress := Self.OnKeyPress; + OnKeyUp := Self.OnKeyUp; + OnMouseDown := Self.OnMouseDown; + OnMouseMove := Self.OnMouseMove; + OnMouseUp := Self.OnMouseUp; + OnUserCommand := Self.OnUserCommand; + OnUserValidation := Self.OnUserValidation; + end; + end; +{--------} +procedure TOvcTCBaseEntryField.StopEditing(SaveValue : boolean; + Data : pointer); + begin + if SaveValue and Assigned(Data) then + begin + FEdit.GetValue(CopyOfData^); + Move(CopyOfData^, Data^, CopyOfDataSize); + end; + FreeMem(CopyOfData, CopyOfDataSize); + CopyOfData := nil; + CopyOfDataSize := 0; + EditHide; + end; +{====================================================================} + + +{===TOvcTCBaseEntryField property access=============================} +procedure TOvcTCBaseEntryField.DefineProperties(Filer: TFiler); + begin + inherited DefineProperties(Filer); + with Filer do + begin + DefineBinaryProperty('RangeHigh', + TOvcBEF(FEdit).efReadRangeHi, TOvcBEF(FEdit).efWriteRangeHi, true); + DefineBinaryProperty('RangeLow', + TOvcBEF(FEdit).efReadRangeLo, TOvcBEF(FEdit).efWriteRangeLo, true); + end; + end; +{--------} +function TOvcTCBaseEntryField.GetOptions : TOvcEntryFieldOptions; + begin + if Assigned(FEdit) then + Result := FEdit.Options + else + Result := []; + end; +function TOvcTCBaseEntryField.GetCaretIns : TOvcCaret; + begin + if Assigned(FEdit) then + Result := TOvcBEF(FEdit).CaretIns + else Result := nil; + end; +{--------} +function TOvcTCBaseEntryField.GetCaretOvr : TOvcCaret; + begin + if Assigned(FEdit) then + Result := TOvcBEF(FEdit).CaretOvr + else Result := nil; + end; +{--------} +function TOvcTCBaseEntryField.GetControlCharColor : TColor; + begin + if Assigned(FEdit) then + Result := TOvcBEF(FEdit).ControlCharColor + else Result := clRed; + end; +{--------} +function TOvcTCBaseEntryField.GetDataSize : integer; + begin + if Assigned(FEdit) then + Result := TOvcBEF(FEdit).DataSize + else Result := 0; + end ; +{--------} +function TOvcTCBaseEntryField.GetDecimalPlaces : byte; + begin + if Assigned(FEdit) then + Result := TOvcBEF(FEdit).DecimalPlaces + else Result := 0; + end ; +{--------} +function TOvcTCBaseEntryField.GetEFColors : TOvcEFColors; + begin + Result := nil; + if Assigned(FEdit) then + Result := TOvcBEF(FEdit).EFColors; + end; +{--------} +function TOvcTCBaseEntryField.GetModified : boolean; + begin + if Assigned(FEdit) then + Result := TOvcBEF(FEdit).Modified + else Result := false; + end ; +{--------} +function TOvcTCBaseEntryField.GetMaxLength : word; + begin + if Assigned(FEdit) then + Result := TOvcBEF(FEdit).MaxLength + else Result := 0; + end; +{--------} +function TOvcTCBaseEntryField.GetPadChar : AnsiChar; + begin + if Assigned(FEdit) then + Result := TOvcBEF(FEdit).PadChar + else Result := ' '; + end; +{--------} +function TOvcTCBaseEntryField.GetPasswordChar : AnsiChar; + begin + if Assigned(FEdit) then + Result := TOvcBEF(FEdit).PasswordChar + else Result := '*'; + end; +{--------} +function TOvcTCBaseEntryField.GetRangeHi : string; + begin + if Assigned(FEdit) then + Result := TOvcBEF(FEdit).RangeHi + else Result := ''; + end; +{--------} +function TOvcTCBaseEntryField.GetRangeLo : string; + begin + if Assigned(FEdit) then + Result := TOvcBEF(FEdit).RangeLo + else Result := ''; + end; +{--------} +function TOvcTCBaseEntryField.GetTextMargin : integer; + begin + if Assigned(FEdit) then + Result := TOvcBEF(FEdit).TextMargin + else Result := 0; + end; +{--------} +procedure TOvcTCBaseEntryField.SetCaretIns(CI : TOvcCaret); + begin + if Assigned(FEdit) then TOvcBEF(FEdit).CaretIns := CI; + end; +{--------} +procedure TOvcTCBaseEntryField.SetCaretOvr(CO : TOvcCaret); + begin + if Assigned(FEdit) then TOvcBEF(FEdit).CaretOvr := CO; + end; +{--------} +procedure TOvcTCBaseEntryField.SetControlCharColor(CCC : TColor); + begin + if Assigned(FEdit) then TOvcBEF(FEdit).ControlCharColor := CCC; + end; +{--------} +procedure TOvcTCBaseEntryField.SetDecimalPlaces(DP : byte); + begin + if Assigned(FEdit) then + begin + TOvcBEF(FEdit).DecimalPlaces := DP; + TOvcBEF(FEditDisplay).DecimalPlaces := DP; + end; + end; +{--------} +procedure TOvcTCBaseEntryField.SetEFColors(Value : TOvcEFColors); + begin + if Assigned(FEdit) then + TOvcBEF(FEdit).EFColors := Value; + end; +{--------} +procedure TOvcTCBaseEntryField.SetMaxLength(ML : word); + begin + if Assigned(FEdit) then begin + TOvcBEF(FEdit).MaxLength := ML; + TOvcBEF(FEditDisplay).MaxLength := ML; + end; + end; +{--------} +procedure TOvcTCBaseEntryField.SetOptions(Value : TOvcEntryFieldOptions); + begin + if Assigned(FEdit) then begin + TOvcBEF(FEdit).Options := Value; + TOvcBEF(FEditDisplay).Options := Value; + end; + end; +{--------} +procedure TOvcTCBaseEntryField.SetPadChar(PC : AnsiChar); + begin + if Assigned(FEdit) then + begin + TOvcBEF(FEdit).PadChar := PC; + TOvcBEF(FEditDisplay).PadChar := PC; + end; + end; +{--------} +procedure TOvcTCBaseEntryField.SetPasswordChar(PC : AnsiChar); + begin + if Assigned(FEdit) then + begin + TOvcBEF(FEdit).PasswordChar := PC; + TOvcBEF(FEditDisplay).PasswordChar := PC; + end; + end; +{--------} +procedure TOvcTCBaseEntryField.SetRangeHi(const RI : string); + begin + if Assigned(FEdit) then TOvcBEF(FEdit).RangeHi := RI; + end; +{--------} +procedure TOvcTCBaseEntryField.SetRangeLo(const RL : string); + begin + if Assigned(FEdit) then TOvcBEF(FEdit).RangeLo := RL; + end; +{--------} +procedure TOvcTCBaseEntryField.SetTextMargin(TM : integer); + begin + if Assigned(FEdit) then TOvcBEF(FEdit).TextMargin := TM; + end; + +end. diff --git a/components/orpheus/ovctcbmp.pas b/components/orpheus/ovctcbmp.pas new file mode 100644 index 000000000..7cd961db7 --- /dev/null +++ b/components/orpheus/ovctcbmp.pas @@ -0,0 +1,273 @@ +{*********************************************************} +{* OVCTCBMP.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovctcbmp; + {-Orpheus Table Cell - Bitmap type} + +interface + +uses + {$IFNDEF LCL} Windows, {$ELSE} LclIntf, MyMisc, {$ENDIF} + SysUtils, Graphics, Classes, OvcTCmmn, OvcTCell; + +type + TOvcTCBaseBitMap = class(TOvcBaseTableCell) + protected + {.Z+} + procedure tcPaint(TableCanvas : TCanvas; + const CellRect : TRect; + RowNum : TRowNum; + ColNum : TColNum; + const CellAttr : TOvcCellAttributes; + Data : pointer); override; + {.Z-} + public + function EditHandle : THandle; override; + procedure EditHide; override; + procedure EditMove(CellRect : TRect); override; + procedure SaveEditedData(Data : pointer); override; + procedure StartEditing(RowNum : TRowNum; ColNum : TColNum; + CellRect : TRect; + const CellAttr : TOvcCellAttributes; + CellStyle: TOvcTblEditorStyle; + Data : pointer); override; + procedure StopEditing(SaveValue : boolean; + Data : pointer); override; + end; + + TOvcTCCustomBitMap = class(TOvcTCBaseBitMap) + protected + {.Z+} + procedure tcPaint(TableCanvas : TCanvas; + const CellRect : TRect; + RowNum : TRowNum; + ColNum : TColNum; + const CellAttr : TOvcCellAttributes; + Data : pointer); override; + {.Z-} + public + {.Z+} + procedure ResolveAttributes(RowNum : TRowNum; ColNum : TColNum; + var CellAttr : TOvcCellAttributes); override; + {.Z-} + end; + + TOvcTCBitMap = class(TOvcTCCustomBitMap) + published + {properties inherited from custom ancestor} + property AcceptActivationClick default False; + property Access default otxDefault; + property Adjust default otaDefault; + property Color; + property Margin default 4; + property Table; + property TableColor default True; + + property OnOwnerDraw; + end; + + +implementation + + +{===TOvcTCBaseBitMap=================================================} +procedure TOvcTCBaseBitMap.tcPaint(TableCanvas : TCanvas; + const CellRect : TRect; + RowNum : TRowNum; + ColNum : TColNum; + const CellAttr : TOvcCellAttributes; + Data : pointer); + type + LH = packed record cX, cY : word; end; + var + BMInfo : PCellBitMapInfo absolute Data; + Wd, Ht : integer; + DisplayWd : integer; + DisplayHt : integer; + CellWidth : integer; + CellHeight : integer; + SrcRect, DestRect : TRect; + TransparentColor : TColor; + CellAdj : TOvcTblAdjust; + begin + {blank out the cell (also sets the brush color)} + inherited tcPaint(TableCanvas, CellRect, RowNum, ColNum, CellAttr, Data); + {if there's no data, the index to the sub-bitmap is zero or + the cell is invisible anyway, just exit} + if (Data = nil) or + (BMInfo^.Index = -1) or + (CellAttr.caAccess = otxInvisible) then + Exit; + {make a note of the adjustment, and calc the cell width and height} + CellAdj := CellAttr.caAdjust; + CellWidth := CellRect.Right - CellRect.Left; + CellHeight := CellRect.Bottom - CellRect.Top; + {calculate data about the bitmap, including the source rectangle} + with BMInfo^ do + begin + Wd := BM.Width; + if (Count <= 1) then + Index := 0 + else + begin + Wd := Wd div Count; + if (Index >= Count) then + Index := 0; + end; + Ht := BM.Height; + DisplayWd := MinI(Wd, (CellWidth - 2*Margin)); + DisplayHt := MinI(Ht, (CellHeight - 2*Margin)); + with SrcRect do + begin + Left := Index * Wd; + Right := Left + DisplayWd; + Top := 0; + Bottom := Top + DisplayHt; + end; + TransparentColor := BM.Canvas.Pixels[SrcRect.Left, Ht-1] + end; + {calculate the destination rectangle} + with DestRect do + begin + case CellAdj of + otaTopLeft, otaCenterLeft, otaBottomLeft : + Left := Margin; + otaTopRight, otaCenterRight, otaBottomRight : + Left := (CellWidth - DisplayWd - Margin); + else + Left := (CellWidth - DisplayWd) div 2; + end;{case} + inc(Left, CellRect.Left); + case CellAdj of + otaTopLeft, otaTopCenter, otaTopRight : + Top := Margin; + otaBottomLeft, otaBottomCenter, otaBottomRight : + Top := (CellHeight - DisplayHt - Margin); + else + Top := (CellHeight - DisplayHt) div 2; + end;{case} + inc(Top, CellRect.Top); + Right := Left + DisplayWd; + Bottom := Top + DisplayHt; + end; + {brush copy the bitmap onto the table} +{$IFNDEF LCL} + TableCanvas.BrushCopy(DestRect, BMInfo^.BM, SrcRect, TransparentColor); +{$ELSE} + BrushCopy(TableCanvas, DestRect, BMInfo^.BM, SrcRect, TransparentColor); +{$ENDIF} + end; + +function TOvcTCBaseBitMap.EditHandle : THandle; +begin + {stub out abstract method so BCB doesn't see this as an abstract class} + Result := 0; +end; + +procedure TOvcTCBaseBitMap.EditHide; +begin + {stub out abstract method so BCB doesn't see this as an abstract class} +end; + +procedure TOvcTCBaseBitMap.EditMove(CellRect : TRect); +begin + {stub out abstract method so BCB doesn't see this as an abstract class} +end; + +procedure TOvcTCBaseBitMap.SaveEditedData(Data : pointer); +begin + {stub out abstract method so BCB doesn't see this as an abstract class} +end; + +procedure TOvcTCBaseBitMap.StartEditing(RowNum : TRowNum; ColNum : TColNum; + CellRect : TRect; + const CellAttr : TOvcCellAttributes; + CellStyle: TOvcTblEditorStyle; + Data : pointer); +begin + {stub out abstract method so BCB doesn't see this as an abstract class} +end; + +procedure TOvcTCBaseBitMap.StopEditing(SaveValue : boolean; + Data : pointer); +begin + {stub out abstract method so BCB doesn't see this as an abstract class} +end; + + +{====================================================================} + +{===TOvcTCCustomBitMap===============================================} +procedure TOvcTCCustomBitMap.tcPaint(TableCanvas : TCanvas; + const CellRect : TRect; + RowNum : TRowNum; + ColNum : TColNum; + const CellAttr : TOvcCellAttributes; + Data : pointer); + var + BitMap : TBitmap absolute Data; + BMInfo : TCellBitMapInfo; + begin + {if there's no bitmap, just let our ancestor deal with it} + if (Data = nil) then + inherited tcPaint(TableCanvas, CellRect, RowNum, ColNum, CellAttr, nil) + {otherwise set up a bitmap info record, and let the ancestor paint it} + else + begin + with BMInfo do + begin + BM := BitMap; + Count := 1; + ActiveCount := 1; + Index := 0; + end; + inherited tcPaint(TableCanvas, CellRect, RowNum, ColNum, CellAttr, @BMInfo); + end; + end; +{--------} +procedure TOvcTCCustomBitMap.ResolveAttributes(RowNum : TRowNum; ColNum : TColNum; + var CellAttr : TOvcCellAttributes); + begin + inherited ResolveAttributes(RowNum, ColNum, CellAttr); + case CellAttr.caAccess of + otxDefault, otxNormal : CellAttr.caAccess := otxReadOnly; + end;{case} + end; +{====================================================================} + + +end. diff --git a/components/orpheus/ovctcbox.pas b/components/orpheus/ovctcbox.pas new file mode 100644 index 000000000..72b5529ab --- /dev/null +++ b/components/orpheus/ovctcbox.pas @@ -0,0 +1,224 @@ +{*********************************************************} +{* OVCTCBOX.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovctcbox; + {-Orpheus Table Cell - Check box type} + +interface + +uses + {$IFNDEF LCL} Windows, {$ELSE} LclIntf, {$ENDIF} + SysUtils, Graphics, Classes, Controls, StdCtrls, + OvcTCmmn, OvcTCell, OvcTGRes, OvcTCGly; + +type + TOvcTCCustomCheckBox = class(TOvcTCCustomGlyph) + protected {private} + {.Z+} + FAllowGrayed : boolean; + + FatherValue : Integer; + {.Z-} + + protected + {.Z+} + procedure SetAllowGrayed(AG : boolean); + + procedure GlyphsHaveChanged(Sender : TObject); + procedure tcPaint(TableCanvas : TCanvas; + const CellRect : TRect; + RowNum : TRowNum; + ColNum : TColNum; + const CellAttr : TOvcCellAttributes; + Data : pointer); override; + {.Z-} + + public + constructor Create(AOwner : TComponent); override; + + function CanAssignGlyphs(CBG : TOvcCellGlyphs) : boolean; override; + + procedure SaveEditedData(Data : pointer); override; + procedure StartEditing(RowNum : TRowNum; ColNum : TColNum; + CellRect : TRect; + const CellAttr : TOvcCellAttributes; + CellStyle: TOvcTblEditorStyle; + Data : pointer); override; + procedure StopEditing(SaveValue : boolean; + Data : pointer); override; + + property AllowGrayed : boolean + read FAllowGrayed write SetAllowGrayed; + + end; + + TOvcTCCheckBox = class(TOvcTCCustomCheckBox) + published + {properties inherited from custom ancestor} + property AcceptActivationClick default True; + property Access default otxDefault; + property Adjust default otaDefault; + property AllowGrayed default False; + property CellGlyphs; + property Color; + property Hint; + property Margin default 4; + property ShowHint default False; + property Table; + property TableColor default True; + + {events inherited from custom ancestor} + property OnClick; + property OnDragDrop; + property OnDragOver; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnOwnerDraw; + end; + +implementation + + +{===TOvcTCCustomCheckBox creation/destruction========================} +constructor TOvcTCCustomCheckBox.Create(AOwner : TComponent); + begin + inherited Create(AOwner); + CellGlyphs.OnCfgChanged := nil; + if (CellGlyphs.ActiveGlyphCount = 3) then + CellGlyphs.ActiveGlyphCount := 2; + CellGlyphs.OnCfgChanged := GlyphsHaveChanged; + FAcceptActivationClick := true; + end; +{--------} +procedure TOvcTCCustomCheckBox.SetAllowGrayed(AG : boolean); + begin + if AG <> FAllowGrayed then + begin + FAllowGrayed := AG; + if AG then + CellGlyphs.ActiveGlyphCount := 3 + else + CellGlyphs.ActiveGlyphCount := 2; + tcDoCfgChanged; + end; + end; +{--------} +function TOvcTCCustomCheckBox.CanAssignGlyphs(CBG : TOvcCellGlyphs) : boolean; + begin + Result := CBG.GlyphCount = 3; + end; +{--------} +procedure TOvcTCCustomCheckBox.GlyphsHaveChanged(Sender : TObject); + begin + CellGlyphs.OnCfgChanged := nil; + if FAllowGrayed then + CellGlyphs.ActiveGlyphCount := 3 + else + CellGlyphs.ActiveGlyphCount := 2; + CellGlyphs.OnCfgChanged := GlyphsHaveChanged; + tcDoCfgChanged; + end; +{====================================================================} + + +{===TOvcTCCustomCheckBox painting====================================} +procedure TOvcTCCustomCheckBox.tcPaint(TableCanvas : TCanvas; + const CellRect : TRect; + RowNum : TRowNum; + ColNum : TColNum; + const CellAttr : TOvcCellAttributes; + Data : pointer); + var + B : ^TCheckBoxState absolute Data; + Value : integer; + begin + if (Data = nil) then + inherited tcPaint(TableCanvas, CellRect, RowNum, ColNum, CellAttr, nil) + else + begin + Value := ord(B^); + inherited tcPaint(TableCanvas, CellRect, RowNum, ColNum, CellAttr, @Value); + end; + end; +{====================================================================} + + +{===TOvcTCCheckBox editing===========================================} +procedure TOvcTCCustomCheckBox.SaveEditedData(Data : pointer); + begin + if Assigned(Data) then + begin + inherited SaveEditedData(@FatherValue); + TCheckBoxState(Data^) := TCheckBoxState(FatherValue); + end; + end; +{--------} +procedure TOvcTCCustomCheckBox.StartEditing(RowNum : TRowNum; ColNum : TColNum; + CellRect : TRect; + const CellAttr : TOvcCellAttributes; + CellStyle: TOvcTblEditorStyle; + Data : pointer); + begin + if (Data = nil) then + inherited StartEditing(RowNum, ColNum, + CellRect, CellAttr, CellStyle, nil) + else + begin + FatherValue := Integer(TCheckBoxState(Data^)); + inherited StartEditing(RowNum, ColNum, + CellRect, CellAttr, CellStyle, @FatherValue); + end; + end; +{--------} +procedure TOvcTCCustomCheckBox.StopEditing(SaveValue : boolean; + Data : pointer); + begin + inherited StopEditing(SaveValue, @FatherValue); + if SaveValue and Assigned(Data) then + TCheckBoxState(Data^) := TCheckBoxState(FatherValue); + end; +{====================================================================} + + +end. diff --git a/components/orpheus/ovctccbx.pas b/components/orpheus/ovctccbx.pas new file mode 100644 index 000000000..7ad29cbee --- /dev/null +++ b/components/orpheus/ovctccbx.pas @@ -0,0 +1,959 @@ +{*********************************************************} +{* OVCTCCBX.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +{$IFDEF VERSION6} + {$IFNDEF LCL} + {$WARN SYMBOL_DEPRECATED OFF} + {$ENDIF} +{$ENDIF} + +unit ovctccbx; + {-Orpheus Table Cell - combo box type} + +interface + +uses + {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, LclType, MyMisc, {$ENDIF} + SysUtils, Graphics, Classes, Controls, Forms, StdCtrls, + OvcMisc, OvcTCmmn, OvcTCell, OvcTCStr; + +type + TOvcTCComboBoxState = (otlbsUp, otlbsDown); + +type + TOvcTCComboBoxEdit = class(TCustomComboBox) + protected {private} + {.Z+} + FCell : TOvcBaseTableCell; + + EditField : HWnd; + PrevEditWndProc : pointer; + NewEditWndProc : pointer; + {.Z-} + + protected + {.Z+} + procedure EditWindowProc(var Msg : TMessage); + function FilterWMKEYDOWN(var Msg : TWMKey) : boolean; + + procedure CMRelease(var Message: TMessage); message CM_RELEASE; + + procedure WMChar(var Msg : TWMKey); message WM_CHAR; + procedure WMGetDlgCode(var Msg : TMessage); message WM_GETDLGCODE; + procedure WMKeyDown(var Msg : TWMKey); message WM_KEYDOWN; + procedure WMKillFocus(var Msg : TWMKillFocus); message WM_KILLFOCUS; + procedure WMSetFocus(var Msg : TWMSetFocus); message WM_SETFOCUS; + {.Z-} + + public + constructor Create(AOwner : TComponent); override; + destructor Destroy; override; + procedure CreateWnd; override; + + property CellOwner : TOvcBaseTableCell + read FCell write FCell; + end; + + TOvcTCCustomComboBox = class(TOvcTCBaseString) + protected {private} + {.Z+} + {property fields - even size} + FDropDownCount : Integer; + FEdit : TOvcTCComboBoxEdit; + FItems : TStrings; + FMaxLength : Word; + + {property fields - odd size} + FStyle : TComboBoxStyle; + FAutoAdvanceChar : Boolean; + FAutoAdvanceLeftRight : Boolean; + FHideButton : Boolean; + FSaveStringValue : boolean; + FSorted : Boolean; + FShowArrow : Boolean; + FUseRunTimeItems : Boolean; + + {events} + FOnChange : TNotifyEvent; + FOnDropDown : TNotifyEvent; + FOnDrawItem : TDrawItemEvent; + FOnMeasureItem : TMeasureItemEvent; + {.Z-} + + protected + {.Z+} + function GetCellEditor : TControl; override; + + procedure SetShowArrow(Value : Boolean); + procedure SetItems(I : TStrings); + procedure SetSorted(S : boolean); + + procedure DrawArrow(Canvas : TCanvas; + const CellRect : TRect; + const CellAttr : TOvcCellAttributes); + procedure DrawButton(Canvas : TCanvas; + const CellRect : TRect); + + procedure tcPaint(TableCanvas : TCanvas; + const CellRect : TRect; + RowNum : TRowNum; + ColNum : TColNum; + const CellAttr : TOvcCellAttributes; + Data : pointer); override; + {.Z-} + + {properties} + property AutoAdvanceChar : boolean + read FAutoAdvanceChar write FAutoAdvanceChar; + property AutoAdvanceLeftRight : boolean + read FAutoAdvanceLeftRight write FAutoAdvanceLeftRight; + property DropDownCount : Integer + read FDropDownCount write FDropDownCount; + property HideButton : Boolean + read FHideButton write FHideButton; + property Items : TStrings + read FItems write SetItems; + property MaxLength : word + read FMaxLength write FMaxLength; + property SaveStringValue : boolean + read FSaveStringValue write FSaveStringValue; + property Sorted : boolean + read FSorted write SetSorted; + property ShowArrow : Boolean + read FShowArrow write SetShowArrow; + property Style : TComboBoxStyle + read FStyle write FStyle; + property UseRunTimeItems : boolean + read FUseRunTimeItems write FUseRunTimeItems; + + {events} + property OnChange : TNotifyEvent + read FOnChange write FOnChange; + property OnDropDown: TNotifyEvent + read FOnDropDown write FOnDropDown; + property OnDrawItem: TDrawItemEvent + read FOnDrawItem write FOnDrawItem; + property OnMeasureItem: TMeasureItemEvent + read FOnMeasureItem write FOnMeasureItem; + + public + constructor Create(AOwner : TComponent); override; + destructor Destroy; override; + function CreateEditControl : TOvcTCComboBoxEdit; virtual; + + function EditHandle : THandle; override; + procedure EditHide; override; + procedure EditMove(CellRect : TRect); override; + + procedure SaveEditedData(Data : pointer); override; + procedure StartEditing(RowNum : TRowNum; ColNum : TColNum; + CellRect : TRect; + const CellAttr : TOvcCellAttributes; + CellStyle: TOvcTblEditorStyle; + Data : pointer); override; + procedure StopEditing(SaveValue : boolean; + Data : pointer); override; + end; + + TOvcTCComboBox = class(TOvcTCCustomComboBox) + published + property AcceptActivationClick default True; + property Access default otxDefault; + property Adjust default otaDefault; + property AutoAdvanceChar default False; + property AutoAdvanceLeftRight default False; + property Color; + property DropDownCount default 8; + property Font; + property HideButton default False; + property Hint; + property Items; + property ShowHint default False; + property Margin default 4; + property MaxLength default 0; + property SaveStringValue default False; + property ShowArrow default False; + property Sorted default False; + property Style default csDropDown; + property Table; + property TableColor default True; + property TableFont default True; + property TextHiColor default clBtnHighlight; + property TextStyle default tsFlat; + property UseRunTimeItems default False; + + {events inherited from custom ancestor} + property OnChange; + property OnClick; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnDrawItem; + property OnDropDown; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMeasureItem; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnOwnerDraw; + end; + + +var + OvcComboBoxBitmap : TBitmap; + OvcComboBoxButtonWidth : Integer; + +implementation + +const + ComboBoxHeight = 24; + +var + ComboBoxResourceCount : longint = 0; + +// Workaround for lack of MakeObjectInstance in LCL for making +// WindowProc callback function from object method. +// Note: Not using: function appears to work with Win32, but +// crash when object destroyed. Doesn't work with GTK. +{$IFDEF LCL} +function LclEditWindowProc(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM) : LRESULT; stdcall; +var + CbEdit : TWinControl; + AMsg : TMessage; +begin + CbEdit := FindOwnerControl(hWnd); + AMsg.Msg := Msg; + AMsg.WParam := wParam; + AMsg.LParam := lParam; + TOvcTCComboBoxEdit(CbEdit).EditWindowProc(AMsg); +// Result := AMsg.Result; +end; +{$ENDIF} + +{===TOvcTCComboBoxEdit================================================} +constructor TOvcTCComboBoxEdit.Create(AOwner : TComponent); + begin + inherited Create(AOwner); +{$IFNDEF LCL} + NewEditWndProc := MakeObjectInstance(EditWindowProc); +{$ELSE} +// NewEditWndProc := @LclEditWindowProc; +{$ENDIF} + end; +{--------} +destructor TOvcTCComboBoxEdit.Destroy; + begin + if (Style = csDropDown) or (Style = csSimple) then + SetWindowLong(EditField, GWL_WNDPROC, longint(PrevEditWndProc)); +{$IFNDEF LCL} + FreeObjectInstance(NewEditWndProc); +{$ENDIF} + inherited Destroy; + end; +{--------} +procedure TOvcTCComboBoxEdit.CreateWnd; + begin + inherited CreateWnd; + + if (Style = csDropDown) or (Style = csSimple) then + begin + EditField := GetWindow(Handle, GW_CHILD); + if (Style = csSimple) then + EditField := GetWindow(EditField, GW_HWNDNEXT); + PrevEditWndProc := pointer(GetWindowLong(EditField, GWL_WNDPROC)); +{$IFNDEF LCL} + SetWindowLong(EditField, GWL_WNDPROC, longint(NewEditWndProc)); +{$ENDIF} + end; + end; +{--------} +procedure TOvcTCComboBoxEdit.EditWindowProc(var Msg : TMessage); + var + GridUsedIt : boolean; + KeyMsg : TWMKey absolute Msg; + begin + GridUsedIt := false; + if (Msg.Msg = WM_KEYDOWN) then + GridUsedIt := FilterWMKEYDOWN(KeyMsg) + else if (Msg.Msg = WM_CHAR) then + if (KeyMsg.CharCode = 9) or + (KeyMsg.CharCode = 13) or + (KeyMsg.CharCode = 27) then + GridUsedIt := true; + if not GridUsedIt then + with Msg do + Result := CallWindowProc(PrevEditWndProc, EditField, Msg, wParam, lParam); + end; +{--------} +function TOvcTCComboBoxEdit.FilterWMKEYDOWN(var Msg : TWMKey) : boolean; + procedure GetSelection(var S, E : word); + type + LH = packed record L, H : word; end; + var + GetSel : longint; + begin + GetSel := SendMessage(EditField, EM_GETSEL, 0, 0); + S := LH(GetSel).L; + E := LH(GetSel).H; + end; + var + GridReply : TOvcTblKeyNeeds; + SStart, SEnd : word; + GridUsedIt : boolean; + PassIton : boolean; + begin + GridUsedIt := false; + GridReply := otkDontCare; + if (CellOwner <> nil) then + GridReply := CellOwner.FilterTableKey(Msg); + case GridReply of + otkMustHave : + begin + CellOwner.SendKeyToTable(Msg); + GridUsedIt := true; + end; + otkWouldLike : + begin + PassItOn := false; + case Msg.CharCode of + VK_LEFT : + begin + case Style of + csDropDown, csSimple : + if TOvcTCCustomComboBox(CellOwner).AutoAdvanceLeftRight then + begin + GetSelection(SStart, SEnd); + if (SStart = SEnd) and (SStart = 0) then + PassItOn := true; + end; + else + PassItOn := true; + end;{case} + end; + VK_RIGHT : + begin + case Style of + csDropDown, csSimple : + if TOvcTCCustomComboBox(CellOwner).AutoAdvanceLeftRight then + begin + GetSelection(SStart, SEnd); + if ((SStart = SEnd) or (SStart = 0)) and + (SEnd = GetTextLen) then + PassItOn := true; + end; + else + PassItOn := true; + end;{case} + end; + end;{case} + if PassItOn then + begin + CellOwner.SendKeyToTable(Msg); + GridUsedIt := true; + end; + end; + end;{case} + Result := GridUsedIt; + end; +{--------} + + + procedure TOvcTCComboBoxEdit.CMRelease(var Message: TMessage); + begin + Free; + end; + + procedure TOvcTCComboBoxEdit.WMChar(var Msg : TWMKey); + var + CurText : string; + begin + inherited; + if TOvcTCCustomComboBox(CellOwner).AutoAdvanceChar then + begin + CurText := Text; + if (length(CurText) >= MaxLength) then + begin + FillChar(Msg, sizeof(Msg), 0); + with Msg do + begin + Msg := WM_KEYDOWN; + CharCode := VK_RIGHT; + end; + CellOwner.SendKeyToTable(Msg); + end; + end; + end; +{--------} +procedure TOvcTCComboBoxEdit.WMGetDlgCode(var Msg : TMessage); + begin + inherited; + if CellOwner.TableWantsTab then + Msg.Result := Msg.Result or DLGC_WANTTAB; + end; +{--------} +procedure TOvcTCComboBoxEdit.WMKeyDown(var Msg : TWMKey); + var + GridUsedIt : boolean; + begin + if (Style <> csDropDown) and (Style <> csSimple) then + begin + GridUsedIt := FilterWMKEYDOWN(Msg); + if not GridUsedIt then + inherited; + end + else + inherited; + end; +{--------} +procedure TOvcTCComboBoxEdit.WMKillFocus(var Msg : TWMKillFocus); + begin + inherited; + {ComboBox posts cbn_killfocus message to table} + end; +{--------} +procedure TOvcTCComboBoxEdit.WMSetFocus(var Msg : TWMSetFocus); + begin + inherited; + CellOwner.PostMessageToTable(ctim_SetFocus, Msg.FocusedWnd, 0); + end; +{====================================================================} + + +{===TOvcTCCustomComboBox=============================================} +constructor TOvcTCCustomComboBox.Create(AOwner : TComponent); + begin + inherited Create(AOwner); + FItems := TStringList.Create; + FDropDownCount := 8; + if (ComboBoxResourceCount = 0) then + begin + OvcComboBoxBitmap := TBitMap.Create; +{$IFNDEF LCL} + OvcComboBoxBitmap.Handle := LoadBaseBitMap('ORTCCOMBOARROW'); +{$ELSE} + OvcComboBoxBitmap.LoadFromLazarusResource('ORTCCOMBOARROW'); +{$ENDIF} + OvcComboBoxButtonWidth := OvcComboBoxBitmap.Width + 11; + end; + inc(ComboBoxResourceCount); + FAcceptActivationClick := true; + FShowArrow := False; + FHideButton := False; + end; +{--------} +destructor TOvcTCCustomComboBox.Destroy; + begin + FItems.Free; + dec(ComboBoxResourceCount); + if (ComboBoxResourceCount = 0) then + OvcComboBoxBitmap.Free; + inherited Destroy; + end; +{--------} +function TOvcTCCustomComboBox.CreateEditControl : TOvcTCComboBoxEdit; + begin + Result := TOvcTCComboBoxEdit.Create(FTable); + end; +{--------} +procedure TOvcTCCustomComboBox.DrawArrow(Canvas : TCanvas; + const CellRect : TRect; + const CellAttr : TOvcCellAttributes); + var + ArrowDim : Integer; + X, Y : Integer; + LeftPoint, RightPoint, BottomPoint : TPoint; +{$IFNDEF LCL} + Width : integer; + Height : integer; +{$ELSE} //LCL TCanvas has Width and Height properties + AWidth : integer; + AHeight : integer; +{$ENDIF} + R : TRect; + begin + R := CellRect; + R.Left := R.Right - OvcComboBoxButtonWidth; +{$IFNDEF LCL} + Width := R.Right - R.Left; + Height := R.Bottom - R.Top; +{$ELSE} + AWidth := R.Right - R.Left; + AHeight := R.Bottom - R.Top; +{$ENDIF} + with Canvas do + begin + Brush.Color := CellAttr.caColor; + FillRect(R); + Pen.Color := CellAttr.caFont.Color; + Brush.Color := Pen.Color; +{$IFNDEF LCL} + ArrowDim := MinI(Width, Height) div 3; + X := R.Left + (Width - ArrowDim) div 2; + Y := R.Top + (Height - ArrowDim) div 2; +{$ELSE} + ArrowDim := MinI(AWidth, AHeight) div 3; + X := R.Left + (AWidth - ArrowDim) div 2; + Y := R.Top + (AHeight - ArrowDim) div 2; +{$ENDIF} + LeftPoint := Point(X, Y); + RightPoint := Point(X+ArrowDim, Y); + BottomPoint := Point(X+(ArrowDim div 2), Y+ArrowDim); + Polygon([LeftPoint, RightPoint, BottomPoint]); + end; + end; +{--------} +procedure TOvcTCCustomComboBox.DrawButton(Canvas : TCanvas; + const CellRect : TRect); + var + EffCellWidth : Integer; + Wd, Ht : Integer; + TopPixel : Integer; + BotPixel : Integer; + LeftPixel : Integer; + RightPixel : Integer; + SrcRect : TRect; + DestRect : TRect; + begin + {Calculate the effective cell width (the cell width less the size + of the button)} + EffCellWidth := CellRect.Right - CellRect.Left - OvcComboBoxButtonWidth; + + {Calculate the black border's rectangle} + LeftPixel := CellRect.Left + EffCellWidth; + RightPixel := CellRect.Right - 1; + TopPixel := CellRect.Top + 1; + BotPixel := CellRect.Bottom - 1; + + {Paint the button} + with Canvas do + begin + {FIRST: paint the black border around the button} + Pen.Color := clBlack; + Pen.Width := 1; + Brush.Color := clBtnFace; + {Note: Rectangle excludes the Right and bottom pixels} + Rectangle(LeftPixel, TopPixel, RightPixel, BotPixel); + {SECOND: paint the highlight border on left/top sides} + {decrement drawing area} + inc(TopPixel); + dec(BotPixel); + inc(LeftPixel); + dec(RightPixel); + {Note: PolyLine excludes the end points of a line segment, + but since the end points are generally used as the + starting point of the next we must adjust for it.} + Pen.Color := clBtnHighlight; + PolyLine([Point(RightPixel-1, TopPixel), + Point(LeftPixel, TopPixel), + Point(LeftPixel, BotPixel)]); + {THIRD: paint the highlight border on bottom/right sides} + Pen.Color := clBtnShadow; + PolyLine([Point(LeftPixel, BotPixel-1), + Point(RightPixel-1, BotPixel-1), + Point(RightPixel-1, TopPixel-1)]); + inc(TopPixel); + dec(BotPixel); + inc(LeftPixel); + dec(RightPixel); + PolyLine([Point(LeftPixel, BotPixel-1), + Point(RightPixel-1, BotPixel-1), + Point(RightPixel-1, TopPixel-1)]); + {THIRD: paint the arrow bitmap} + Wd := OvcComboBoxBitmap.Width; + Ht := OvcComboBoxBitmap.Height; + SrcRect := Rect(0, 0, Wd, Ht); + with DestRect do + begin + Left := CellRect.Left + EffCellWidth + 5; + Top := CellRect.Top + + ((CellRect.Bottom - CellRect.Top - Ht) div 2); + Right := Left + Wd; + Bottom := Top + Ht; + end; +{$IFNDEF LCL} + BrushCopy(DestRect, OvcComboBoxBitmap, SrcRect, clSilver); +{$ELSE} + BrushCopy(Canvas, DestRect, OvcComboBoxBitmap, SrcRect, clSilver); +{$ENDIF} + end; + end; +{--------} +function TOvcTCCustomComboBox.EditHandle : THandle; + begin + if Assigned(FEdit) then + Result := FEdit.Handle + else + Result := 0; + end; +{--------} +procedure TOvcTCCustomComboBox.EditHide; + begin + if Assigned(FEdit) then + with FEdit do + begin + SetWindowPos(FEdit.Handle, HWND_TOP, + 0, 0, 0, 0, + SWP_HIDEWINDOW or SWP_NOREDRAW or SWP_NOZORDER); + end; + end; +{--------} +procedure TOvcTCCustomComboBox.EditMove(CellRect : TRect); + var + EditHandle : HWND; + NewTop : Integer; + begin + if Assigned(FEdit) then + begin + EditHandle := FEdit.Handle; + with CellRect do + begin + NewTop := Top; + if FEdit.Ctl3D then + InflateRect(CellRect, -1, -1); + SetWindowPos(EditHandle, HWND_TOP, + Left, NewTop, Right-Left, ComboBoxHeight, + SWP_SHOWWINDOW or SWP_NOREDRAW or SWP_NOZORDER); + end; + InvalidateRect(EditHandle, nil, false); + UpdateWindow(EditHandle); + end; + end; + +function TOvcTCCustomComboBox.GetCellEditor : TControl; +begin + Result := FEdit; +end; + +procedure TOvcTCCustomComboBox.tcPaint(TableCanvas : TCanvas; + const CellRect : TRect; + RowNum : TRowNum; + ColNum : TColNum; + const CellAttr : TOvcCellAttributes; + Data : pointer); +var + ItemRec : PCellComboBoxInfo absolute Data; + ActiveRow : TRowNum; + ActiveCol : TColNum; + R : TRect; + S : ShortString; + OurItems : TStrings; +begin + {Note: Data is a pointer to an integer, or to an integer and a + shortstring. The first is used for drop down ListBoxes + (only) and the latter with simple and drop down combo boxes} + + {If the cell is invisible let the ancestor to all the work} + if (CellAttr.caAccess = otxInvisible) then begin + inherited tcPaint(TableCanvas, CellRect, RowNum, ColNum, CellAttr, nil); + Exit; + end; + + {If we have valid data, get the string to display from the stringlist + or from the Data pointer. } + S := ''; + if (Data <> nil) then begin + if UseRunTimeItems then + OurItems := ItemRec^.RTItems + else + OurItems := Items; + if (0 <= ItemRec^.Index) and (ItemRec^.Index < OurItems.Count) then + S := OurItems[ItemRec^.Index] + else if (Style = csDropDown) or (Style = csSimple) then begin + if UseRunTimeItems then + {$IFDEF CBuilder} + S := StrPas(ItemRec^.RTSt) + {$ELSE} + S := ItemRec^.RTSt + {$ENDIF} + else + {$IFDEF CBuilder} + S := StrPas(ItemRec^.St); + {$ELSE} + S := ItemRec^.St; + {$ENDIF} + end; + end + {Otherwise, mock up a string in design mode.} + else if (csDesigning in ComponentState) and (Items.Count > 0) then + S := Items[RowNum mod Items.Count]; + + ActiveRow := tcRetrieveTableActiveRow; + ActiveCol := tcRetrieveTableActiveCol; + {Calculate the effective cell width (the cell width less the size of the button)} + R := CellRect; + dec(R.Right, OvcComboBoxButtonWidth); + if (ActiveRow = RowNum) and (ActiveCol = ColNum) then begin + if FHideButton then begin + {let ancestor paint the text} + inherited tcPaint(TableCanvas, CellRect, RowNum, ColNum, CellAttr, @S); + end else begin + {Paint the string in the restricted rectangle} + inherited tcPaint(TableCanvas, R, RowNum, ColNum, CellAttr, @S); + {Paint the button on the right side} + DrawButton(TableCanvas, CellRect); + end; + end else if FShowArrow then begin + {paint the string in the restricted rectangle} + inherited tcPaint(TableCanvas, R, RowNum, ColNum, CellAttr, @S); + {Paint the arrow on the right side} + DrawArrow(TableCanvas, CellRect, CellAttr); + end else + inherited tcPaint(TableCanvas, CellRect, RowNum, ColNum, CellAttr, @S); + +(* + {Are we just displaying a button on the active cell?} + if not FHideButton then begin + {If we are not the active cell, let the ancestor do the painting (we only + paint a button when the cell is the active one)} + if (ActiveRow <> RowNum) or (ActiveCol <> ColNum) then begin + inherited tcPaint(TableCanvas, CellRect, RowNum, ColNum, CellAttr, @S); + Exit; + end; + {Calculate the effective cell width (the cell width less the size + of the button)} + R := CellRect; + dec(R.Right, OvcComboBoxButtonWidth); + {Paint the string in this restricted rectangle} + inherited tcPaint(TableCanvas, R, RowNum, ColNum, CellAttr, @S); + {Paint the button on the right side} + DrawButton(TableCanvas, CellRect); + end else if FShowArrow then begin + {Calculate the effective cell width (the cell width less the size + of the button)} + R := CellRect; + dec(R.Right, OvcComboBoxButtonWidth); + {Paint the string in this restricted rectangle} + inherited tcPaint(TableCanvas, R, RowNum, ColNum, CellAttr, @S); + {Paint the arrow on the right side} + DrawArrow(TableCanvas, CellRect, CellAttr); + end else + inherited tcPaint(TableCanvas, CellRect, RowNum, ColNum, CellAttr, @S); +*) +end; + +procedure TOvcTCCustomComboBox.SaveEditedData(Data : pointer); + var + ItemRec : PCellComboBoxInfo absolute Data; + begin + if Assigned(Data) then + begin + ItemRec^.Index := FEdit.ItemIndex; + if (Style = csDropDown) or (Style = csSimple) or SaveStringValue then + begin + if (ItemRec^.Index = -1) then + if UseRunTimeItems then + {$IFDEF CBuilder} + StrPCopy(ItemRec^.RTSt, Copy(FEdit.Text, 1, MaxLength)) + {$ELSE} + ItemRec^.RTSt := Copy(FEdit.Text, 1, MaxLength) + {$ENDIF} + else + {$IFDEF CBuilder} + StrPCopy(ItemRec^.St, Copy(FEdit.Text, 1, MaxLength)) + {$ELSE} + ItemRec^.St := Copy(FEdit.Text, 1, MaxLength) + {$ENDIF} + else + if UseRunTimeItems then + {$IFDEF CBuilder} + StrPCopy(ItemRec^.RTSt, Copy(ItemRec^.RTItems[ItemRec^.Index], 1, MaxLength)) + {$ELSE} + ItemRec^.RTSt := Copy(ItemRec^.RTItems[ItemRec^.Index], 1, MaxLength) + {$ENDIF} + else + {$IFDEF CBuilder} + StrPCopy(ItemRec^.St, Copy(Items[ItemRec^.Index], 1, MaxLength)); + {$ELSE} + ItemRec^.St := Copy(Items[ItemRec^.Index], 1, MaxLength); + {$ENDIF} + end; + end; + end; +{--------} +procedure TOvcTCCustomComboBox.SetItems(I : TStrings); + begin + FItems.Assign(I); + if Sorted then + TStringList(FItems).Sorted := true; + tcDoCfgChanged; + end; + +procedure TOvcTCCustomComboBox.SetShowArrow(Value : Boolean); +begin + if (Value <> FShowArrow) then begin + FShowArrow := Value; + tcDoCfgChanged; + end; +end; + +procedure TOvcTCCustomComboBox.SetSorted(S : boolean); + begin + if (S <> Sorted) then + begin + FSorted := S; + if Sorted then + TStringList(Items).Sorted := True; + tcDoCfgChanged; + end; + end; +{--------} +procedure TOvcTCCustomComboBox.StartEditing(RowNum : TRowNum; ColNum : TColNum; + CellRect : TRect; + const CellAttr : TOvcCellAttributes; + CellStyle: TOvcTblEditorStyle; + Data : pointer); + var + ItemRec : PCellComboBoxInfo absolute Data; + begin + FEdit := CreateEditControl; + with FEdit do + begin + Color := CellAttr.caColor; + Ctl3D := false; + case CellStyle of + tes3D : Ctl3D := true; + end;{case} + Left := CellRect.Left; + Top := CellRect.Top; + Width := CellRect.Right - CellRect.Left; + Font := CellAttr.caFont; + Font.Color := CellAttr.caFontColor; + MaxLength := Self.MaxLength; + Hint := Self.Hint; + ShowHint := Self.ShowHint; + Visible := true; + CellOwner := Self; + TabStop := false; + Parent := FTable; + DropDownCount := Self.DropDownCount; + Sorted := Self.Sorted; + Style := Self.Style; + if UseRunTimeItems then + Items := ItemRec^.RTItems + else + Items := Self.Items; + if Data = nil then + ItemIndex := -1 + else + begin + ItemIndex := ItemRec^.Index; + if (ItemIndex = -1) and + ((Style = csDropDown) or (Style = csSimple)) then + if UseRunTimeItems then + {$IFDEF CBuilder} + Text := StrPas(ItemRec^.RTSt) + {$ELSE} + Text := ItemRec^.RTSt + {$ENDIF} + else + {$IFDEF CBuilder} + Text := StrPas(ItemRec^.St) + {$ELSE} + Text := ItemRec^.St; + {$ENDIF} + end; + + OnChange := Self.OnChange; + OnClick := Self.OnClick; + OnDblClick := Self.OnDblClick; + OnDragDrop := Self.OnDragDrop; + OnDragOver := Self.OnDragOver; + OnDrawItem := Self.OnDrawItem; + OnDropDown := Self.OnDropDown; + OnEndDrag := Self.OnEndDrag; + OnEnter := Self.OnEnter; + OnExit := Self.OnExit; + OnKeyDown := Self.OnKeyDown; + OnKeyPress := Self.OnKeyPress; + OnKeyUp := Self.OnKeyUp; + OnMeasureItem := Self.OnMeasureItem; + OnMouseDown := Self.OnMouseDown; + OnMouseMove := Self.OnMouseMove; + OnMouseUp := Self.OnMouseUp; + end; + end; +{--------} +procedure TOvcTCCustomComboBox.StopEditing(SaveValue : boolean; + Data : pointer); + var + ItemRec : PCellComboBoxInfo absolute Data; + begin + if SaveValue and Assigned(Data) then + begin + ItemRec^.Index := FEdit.ItemIndex; + if (Style = csDropDown) or (Style = csSimple) or SaveStringValue then + begin + if (ItemRec^.Index = -1) then + if UseRunTimeItems then + {$IFDEF CBuilder} + StrPCopy(ItemRec^.RTSt, Copy(FEdit.Text, 1, MaxLength)) + {$ELSE} + ItemRec^.RTSt := Copy(FEdit.Text, 1, MaxLength) + {$ENDIF} + else + {$IFDEF CBuilder} + StrPCopy(ItemRec^.St, Copy(FEdit.Text, 1, MaxLength)) + {$ELSE} + ItemRec^.St := Copy(FEdit.Text, 1, MaxLength) + {$ENDIF} + else + if UseRunTimeItems then + {$IFDEF CBuilder} + StrPCopy(ItemRec^.RTSt, Copy(ItemRec^.RTItems[ItemRec^.Index], 1, MaxLength)) + {$ELSE} + ItemRec^.RTSt := Copy(ItemRec^.RTItems[ItemRec^.Index], 1, MaxLength) + {$ENDIF} + else + {$IFDEF CBuilder} + StrPCopy(ItemRec^.St, Copy(Items[ItemRec^.Index], 1, MaxLength)); + {$ELSE} + ItemRec^.St := Copy(Items[ItemRec^.Index], 1, MaxLength); + {$ENDIF} + end; + end; + PostMessage(FEdit.Handle, CM_RELEASE, 0, 0); + {FEdit.Free;} + FEdit := nil; + end; +{====================================================================} + +end. diff --git a/components/orpheus/ovctcedt.pas b/components/orpheus/ovctcedt.pas new file mode 100644 index 000000000..c2eee6ba8 --- /dev/null +++ b/components/orpheus/ovctcedt.pas @@ -0,0 +1,717 @@ +{*********************************************************} +{* OVCTCEDT.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovctcedt; + {-Orpheus Table Cell - Windows edit Control type} + +interface + +uses + {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, LclType, MyMisc, {$ENDIF} + SysUtils, Classes, Controls, Forms, StdCtrls, + OvcTCmmn, OvcTCell, OvcTCStr, + Graphics; { - for default color definition} + +type + TOvcTCStringEdit = class(TEdit) + protected {private} + FCell : TOvcBaseTableCell; + + protected + procedure WMChar(var Msg : TWMKey); message WM_CHAR; + procedure WMGetDlgCode(var Msg : TMessage); message WM_GETDLGCODE; + procedure WMKeyDown(var Msg : TWMKey); message WM_KEYDOWN; + procedure WMKillFocus(var Msg : TWMKillFocus); message WM_KILLFOCUS; + procedure WMSetFocus(var Msg : TWMSetFocus); message WM_SETFOCUS; + + property CellOwner : TOvcBaseTableCell + read FCell write FCell; + end; + + TOvcTCCustomString = class(TOvcTCBaseString) + protected {private} + FEdit : TOvcTCStringEdit; + FMaxLength : word; + FAutoAdvanceChar : boolean; + FAutoAdvanceLeftRight : boolean; + + protected + function GetCellEditor : TControl; override; + function GetModified : boolean; + + property AutoAdvanceChar : boolean + read FAutoAdvanceChar write FAutoAdvanceChar; + + property AutoAdvanceLeftRight : boolean + read FAutoAdvanceLeftRight write FAutoAdvanceLeftRight; + + property MaxLength : word + read FMaxLength write FMaxLength; + + public + function CreateEditControl(AOwner : TComponent) : TOvcTCStringEdit; virtual; + + function EditHandle : THandle; override; + procedure EditHide; override; + procedure EditMove(CellRect : TRect); override; + + procedure SaveEditedData(Data : pointer); override; + procedure StartEditing(RowNum : TRowNum; ColNum : TColNum; + CellRect : TRect; + const CellAttr : TOvcCellAttributes; + CellStyle: TOvcTblEditorStyle; + Data : pointer); override; + procedure StopEditing(SaveValue : boolean; + Data : pointer); override; + + property Modified : boolean + read GetModified; + end; + + TOvcTCString = class(TOvcTCCustomString) + published + {properties inherited from custom ancestor} + property Access default otxDefault; + property Adjust default otaDefault; + property AutoAdvanceChar default False; + property AutoAdvanceLeftRight default False; + property Color; + property Font; + property Hint; + property Margin default 4; + property MaxLength default 0; + property ShowHint default False; + property Table; + property TableColor default True; + property TableFont default True; + property TextHiColor default clBtnHighlight; + property TextStyle default tsFlat; + property UseWordWrap default False; + property UseASCIIZStrings default False; + + {events inherited from custom ancestor} + property OnChange; + property OnClick; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnOwnerDraw; + public + constructor Create(AOwner : TComponent); override; + end; + +type + TOvcTCMemoEdit = class(TMemo) + protected {private} + FCell : TOvcBaseTableCell; + + protected + procedure WMChar(var Msg : TWMKey); message WM_CHAR; + procedure WMGetDlgCode(var Msg : TMessage); message WM_GETDLGCODE; + procedure WMKeyDown(var Msg : TWMKey); message WM_KEYDOWN; + procedure WMKillFocus(var Msg : TWMKillFocus); message WM_KILLFOCUS; + procedure WMSetFocus(var Msg : TWMSetFocus); message WM_SETFOCUS; + + property CellOwner : TOvcBaseTableCell + read FCell write FCell; + end; + + TOvcTCCustomMemo = class(TOvcTCBaseString) + protected {private} + FEdit : TOvcTCMemoEdit; + FMaxLength : word; + FWantReturns : boolean; + FWantTabs : boolean; + + protected + function GetCellEditor : TControl; override; + function GetModified : boolean; + + property MaxLength : word + read FMaxLength write FMaxLength; + + property WantReturns : boolean + read FWantReturns write FWantReturns; + + property WantTabs : boolean + read FWantTabs write FWantTabs; + + public + constructor Create(AOwner : TComponent); override; + function CreateEditControl(AOwner : TComponent) : TOvcTCMemoEdit; virtual; + + function EditHandle : THandle; override; + procedure EditHide; override; + procedure EditMove(CellRect : TRect); override; + procedure SaveEditedData(Data : pointer); override; + procedure StartEditing(RowNum : TRowNum; ColNum : TColNum; + CellRect : TRect; + const CellAttr : TOvcCellAttributes; + CellStyle: TOvcTblEditorStyle; + Data : pointer); override; + procedure StopEditing(SaveValue : boolean; + Data : pointer); override; + + property Modified : boolean + read GetModified; + end; + + TOvcTCMemo = class(TOvcTCCustomMemo) + published + {properties inherited from custom ancestor} + property Access default otxDefault; + property Adjust default otaDefault; + property Color; + property Font; + property Hint; + property Margin default 4; + property MaxLength default 0; + property ShowHint default False; + property Table; + property TableColor default True; + property TableFont default True; + property TextHiColor default clBtnHighlight; + property TextStyle default tsFlat; + property WantReturns default False; + property WantTabs default False; + + {events inherited from custom ancestor} + property OnChange; + property OnClick; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnOwnerDraw; + end; + +implementation + +{===TOvcTCCustomString===============================================} +function TOvcTCCustomString.CreateEditControl(AOwner : TComponent) : TOvcTCStringEdit; + begin + Result := TOvcTCStringEdit.Create(AOwner); + end; +{--------} +function TOvcTCCustomString.EditHandle : THandle; + begin + if Assigned(FEdit) then + Result := FEdit.Handle + else + Result := 0; + end; +{--------} +procedure TOvcTCCustomString.EditHide; + begin + if Assigned(FEdit) then + with FEdit do + begin + SetWindowPos(FEdit.Handle, HWND_TOP, + 0, 0, 0, 0, + SWP_HIDEWINDOW or SWP_NOREDRAW or SWP_NOZORDER); + end; + end; +{--------} +procedure TOvcTCCustomString.EditMove(CellRect : TRect); + var + EditHandle : HWND; + begin + if Assigned(FEdit) then + begin + EditHandle := FEdit.Handle; + with CellRect do + SetWindowPos(EditHandle, HWND_TOP, + Left, Top, Right-Left, Bottom-Top, + SWP_SHOWWINDOW or SWP_NOREDRAW or SWP_NOZORDER); + InvalidateRect(EditHandle, nil, false); + UpdateWindow(EditHandle); + end; + end; +{--------} +function TOvcTCCustomString.GetCellEditor : TControl; + begin + Result := FEdit; + end; +{--------} +function TOvcTCCustomString.GetModified : boolean; + begin + if Assigned(FEdit) then + Result := FEdit.Modified + else Result := false; + end ; +{--------} +procedure TOvcTCCustomString.SaveEditedData(Data : pointer); + begin + if Assigned(Data) then + if UseASCIIZStrings then + FEdit.GetTextBuf(PAnsiChar(Data), MaxLength) + else + POvcShortString(Data)^ := Copy(FEdit.Text, 1, MaxLength); + end; +{--------} +procedure TOvcTCCustomString.StartEditing(RowNum : TRowNum; ColNum : TColNum; + CellRect : TRect; + const CellAttr : TOvcCellAttributes; + CellStyle: TOvcTblEditorStyle; + Data : pointer); + begin + FEdit := CreateEditControl(FTable); + with FEdit do + begin + if UseASCIIZStrings then + begin + if (Data = nil) then + SetTextBuf('') + else + SetTextBuf(PAnsiChar(Data)); + end + else + begin + if (Data = nil) then + Text := '' + else + Text := POvcShortString(Data)^; + end; + Color := CellAttr.caColor; + Font := CellAttr.caFont; + Font.Color := CellAttr.caFontColor; + Left := CellRect.Left; + Top := CellRect.Top; + Width := CellRect.Right - CellRect.Left; + Height := CellRect.Bottom - CellRect.Top; + TabStop := false; + CellOwner := Self; + MaxLength := Self.MaxLength; + Hint := Self.Hint; + ShowHint := Self.ShowHint; + Parent := FTable; + BorderStyle := bsNone; + Ctl3D := false; + case CellStyle of + tesBorder : BorderStyle := bsSingle; + tes3D : Ctl3D := true; + end;{case} + + OnChange := Self.OnChange; + OnClick := Self.OnClick; + OnDblClick := Self.OnDblClick; + OnDragDrop := Self.OnDragDrop; + OnDragOver := Self.OnDragOver; + OnEndDrag := Self.OnEndDrag; + OnEnter := Self.OnEnter; + OnExit := Self.OnExit; + OnKeyDown := Self.OnKeyDown; + OnKeyPress := Self.OnKeyPress; + OnKeyUp := Self.OnKeyUp; + OnMouseDown := Self.OnMouseDown; + OnMouseMove := Self.OnMouseMove; + OnMouseUp := Self.OnMouseUp; + end; + end; +{--------} +procedure TOvcTCCustomString.StopEditing(SaveValue : boolean; + Data : pointer); + + begin + try + if SaveValue and Assigned(Data) then + if UseASCIIZStrings then + FEdit.GetTextBuf(PAnsiChar(Data), MaxLength+1) + else + POvcShortString(Data)^ := Copy(FEdit.Text, 1, MaxLength); + finally + FEdit.Free; + FEdit := nil; + end; + end; +{====================================================================} + + +{===TOvcTCStringEdit===============================================} +procedure TOvcTCStringEdit.WMChar(var Msg : TWMKey); + var + CurText : string; + begin + if (Msg.CharCode <> 13) and {Enter} + (Msg.CharCode <> 9) and {Tab} + (Msg.CharCode <> 27) then {Escape} + inherited; + if TOvcTCCustomString(CellOwner).AutoAdvanceChar then + begin + CurText := Text; + if (length(CurText) >= MaxLength) then + begin + FillChar(Msg, sizeof(Msg), 0); + with Msg do + begin + Msg := WM_KEYDOWN; + CharCode := VK_RIGHT; + end; + CellOwner.SendKeyToTable(Msg); + end; + end; + end; +{--------} +procedure TOvcTCStringEdit.WMGetDlgCode(var Msg : TMessage); + begin + inherited; + if CellOwner.TableWantsTab then + Msg.Result := Msg.Result or DLGC_WANTTAB; + if CellOwner.TableWantsEnter then + Msg.Result := Msg.Result or DLGC_WANTALLKEYS; + end; +{--------} +procedure TOvcTCStringEdit.WMKeyDown(var Msg : TWMKey); + procedure GetSelection(var S, E : word); + type + LH = packed record L, H : word; end; + var + GetSel : longint; + begin + GetSel := SendMessage(Handle, EM_GETSEL, 0, 0); + S := LH(GetSel).L; + E := LH(GetSel).H; + end; + var + GridReply : TOvcTblKeyNeeds; + GridUsedIt : boolean; + SStart, SEnd : word; + begin + GridUsedIt := false; + GridReply := otkDontCare; + if (CellOwner <> nil) then + GridReply := CellOwner.FilterTableKey(Msg); + case GridReply of + otkMustHave : + begin + CellOwner.SendKeyToTable(Msg); + GridUsedIt := true; + end; + otkWouldLike : + case Msg.CharCode of + VK_PRIOR, VK_NEXT, VK_UP, VK_DOWN : + begin + CellOwner.SendKeyToTable(Msg); + GridUsedIt := true; + end; + VK_LEFT : + if TOvcTCCustomString(CellOwner).AutoAdvanceLeftRight then + begin + GetSelection(SStart, SEnd); + if (SStart = SEnd) and (SStart = 0) then + begin + CellOwner.SendKeyToTable(Msg); + GridUsedIt := true; + end; + end; + VK_RIGHT : + if TOvcTCCustomString(CellOwner).AutoAdvanceLeftRight then + begin + GetSelection(SStart, SEnd); + if ((SStart = SEnd) or (SStart = 0)) and (SEnd = GetTextLen) then + begin + CellOwner.SendKeyToTable(Msg); + GridUsedIt := true; + end; + end; + end; + end;{case} + + if not GridUsedIt then + inherited; + end; +{--------} +procedure TOvcTCStringEdit.WMKillFocus(var Msg : TWMKillFocus); + begin + inherited; + CellOwner.PostMessageToTable(ctim_KillFocus, Msg.FocusedWnd, 0); + end; +{--------} +procedure TOvcTCStringEdit.WMSetFocus(var Msg : TWMSetFocus); + begin + inherited; + CellOwner.PostMessageToTable(ctim_SetFocus, Msg.FocusedWnd, 0); + end; +{====================================================================} + + + + +{===TOvcTCCustomMemo=================================================} +constructor TOvcTCCustomMemo.Create(AOwner : TComponent); + begin + inherited Create(AOwner); + UseASCIIZStrings := true; + UseWordWrap := true; + end; +{--------} +function TOvcTCCustomMemo.CreateEditControl(AOwner : TComponent) : TOvcTCMemoEdit; + begin + Result := TOvcTCMemoEdit.Create(AOwner); + end; +{--------} +function TOvcTCCustomMemo.EditHandle : THandle; + begin + if Assigned(FEdit) then + Result := FEdit.Handle + else + Result := 0; + end; +{--------} +procedure TOvcTCCustomMemo.EditHide; + begin + if Assigned(FEdit) then + with FEdit do + begin + SetWindowPos(FEdit.Handle, HWND_TOP, + 0, 0, 0, 0, + SWP_HIDEWINDOW or SWP_NOREDRAW or SWP_NOZORDER); + end; + end; +{--------} +procedure TOvcTCCustomMemo.EditMove(CellRect : TRect); + begin + if Assigned(FEdit) then + begin + with CellRect do + SetWindowPos(FEdit.Handle, HWND_TOP, + Left, Top, Right-Left, Bottom-Top, + SWP_SHOWWINDOW or SWP_NOREDRAW or SWP_NOZORDER); + InvalidateRect(FEdit.Handle, nil, false); + UpdateWindow(FEdit.Handle); + end; + end; +{--------} +function TOvcTCCustomMemo.GetCellEditor : TControl; + begin + Result := FEdit; + end; +{--------} +function TOvcTCCustomMemo.GetModified : boolean; + begin + if Assigned(FEdit) then + Result := FEdit.Modified + else Result := false; + end ; +{--------} +procedure TOvcTCCustomMemo.StartEditing(RowNum : TRowNum; ColNum : TColNum; + CellRect : TRect; + const CellAttr : TOvcCellAttributes; + CellStyle: TOvcTblEditorStyle; + Data : pointer); + begin + FEdit := CreateEditControl(FTable); + with FEdit do + begin + if (Data = nil) then + SetTextBuf('') + else + SetTextBuf(PAnsiChar(Data)); + Color := CellAttr.caColor; + Font := CellAttr.caFont; + Font.Color := CellAttr.caFontColor; + MaxLength := Self.MaxLength; + WantReturns := Self.WantReturns; + WantTabs := Self.WantTabs; + Left := CellRect.Left; + Top := CellRect.Top; + Width := CellRect.Right - CellRect.Left; + Height := CellRect.Bottom - CellRect.Top; + Visible := true; + TabStop := false; + CellOwner := Self; + Hint := Self.Hint; + ShowHint := Self.ShowHint; + Parent := FTable; + BorderStyle := bsNone; + Ctl3D := false; + case CellStyle of + tesBorder : BorderStyle := bsSingle; + tes3D : Ctl3D := true; + end;{case} + + OnChange := Self.OnChange; + OnClick := Self.OnClick; + OnDblClick := Self.OnDblClick; + OnDragDrop := Self.OnDragDrop; + OnDragOver := Self.OnDragOver; + OnEndDrag := Self.OnEndDrag; + OnEnter := Self.OnEnter; + OnExit := Self.OnExit; + OnKeyDown := Self.OnKeyDown; + OnKeyPress := Self.OnKeyPress; + OnKeyUp := Self.OnKeyUp; + OnMouseDown := Self.OnMouseDown; + OnMouseMove := Self.OnMouseMove; + OnMouseUp := Self.OnMouseUp; + end; + end; +{--------} +procedure TOvcTCCustomMemo.StopEditing(SaveValue : boolean; + Data : pointer); + begin + try + if SaveValue and Assigned(Data) then + FEdit.GetTextBuf(PAnsiChar(Data), MaxLength); + finally + FEdit.Free; + FEdit := nil; + end; + end; + +procedure TOvcTCCustomMemo.SaveEditedData(Data : pointer); +begin + {stub out abstract method so BCB doesn't see this as an abstract class} +end; + +{====================================================================} + + +{===TOvcTCMemoEdit===============================================} +procedure TOvcTCMemoEdit.WMChar(var Msg : TWMKey); + begin + if (not CellOwner.TableWantsTab) or + (Msg.CharCode <> 9) then + inherited; + end; +{--------} +procedure TOvcTCMemoEdit.WMGetDlgCode(var Msg : TMessage); + begin + inherited; + if CellOwner.TableWantsTab then + Msg.Result := Msg.Result or DLGC_WANTTAB; + end; +{--------} +procedure TOvcTCMemoEdit.WMKeyDown(var Msg : TWMKey); + procedure GetSelection(var S, E : word); + type + LH = packed record L, H : word; end; + var + GetSel : longint; + begin + GetSel := SendMessage(Handle, EM_GETSEL, 0, 0); + S := LH(GetSel).L; + E := LH(GetSel).H; + end; + var + GridReply : TOvcTblKeyNeeds; + GridUsedIt : boolean; + SStart, SEnd : word; + begin + GridUsedIt := false; + GridReply := otkDontCare; + if (CellOwner <> nil) then + GridReply := CellOwner.FilterTableKey(Msg); + case GridReply of + otkMustHave : + begin + CellOwner.SendKeyToTable(Msg); + GridUsedIt := true; + end; + otkWouldLike : + case Msg.CharCode of + VK_RETURN : +{$IFNDEF LCL} + if not WantReturns then +{$ENDIF} + begin + CellOwner.SendKeyToTable(Msg); + GridUsedIt := true; + end; + VK_LEFT : + begin + GetSelection(SStart, SEnd); + if (SStart = SEnd) and (SStart = 0) then + begin + CellOwner.SendKeyToTable(Msg); + GridUsedIt := true; + end; + end; + VK_RIGHT : + begin + GetSelection(SStart, SEnd); + if ((SStart = SEnd) or (SStart = 0)) and (SEnd = GetTextLen) then + begin + CellOwner.SendKeyToTable(Msg); + GridUsedIt := true; + end; + end; + end; + end;{case} + + if not GridUsedIt then + inherited; + end; +{--------} +procedure TOvcTCMemoEdit.WMKillFocus(var Msg : TWMKillFocus); + begin + inherited; + CellOwner.PostMessageToTable(ctim_KillFocus, Msg.FocusedWnd, 0); + end; +{--------} +procedure TOvcTCMemoEdit.WMSetFocus(var Msg : TWMSetFocus); + begin + inherited; + CellOwner.PostMessageToTable(ctim_SetFocus, Msg.FocusedWnd, 0); + end; +{====================================================================} + +{===TOvcTCString===============================================} +constructor TOvcTCString.Create(AOwner : TComponent); + begin + inherited Create(AOwner); + end; + + +end. diff --git a/components/orpheus/ovctcell.pas b/components/orpheus/ovctcell.pas new file mode 100644 index 000000000..45cf2ca06 --- /dev/null +++ b/components/orpheus/ovctcell.pas @@ -0,0 +1,1378 @@ +{*********************************************************} +{* OVCTCELL.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovctcell; + {-Cell ancestor class; cell matrix class} + +interface + +uses + {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, LclType, MyMisc, {$ENDIF} + SysUtils, Graphics, Classes, Controls, + OvcTCmmn, OvcSpAry, OvcVer; + +type + TOvcBaseTableCell = class(TOvcTableCellAncestor) + protected {private} + {.Z+} + {property fields - even size} + FColor : TColor; + FFont : TFont; + FHint : string; + FMargin : Integer; + FReferences : longint; + FTable : TOvcTableAncestor; + FTextHiColor: TColor; + {property fields - odd size} + FAcceptActivationClick : boolean; + FAccess : TOvcTblAccess; + FAdjust : TOvcTblAdjust; + FShowHint : boolean; + FTableColor : boolean; + FTableFont : boolean; + FTextStyle : TOvcTextStyle; + Filler : Byte; + {property event fields} + FOnClick : TNotifyEvent; + FOnDblClick : TNotifyEvent; + FOnDragDrop : TDragDropEvent; + FOnDragOver : TDragOverEvent; + FOnEndDrag : TEndDragEvent; + FOnEnter : TNotifyEvent; + FOnExit : TNotifyEvent; + FOnKeyDown : TKeyEvent; + FOnKeyPress : TKeyPressEvent; + FOnKeyUp : TKeyEvent; + FOnMouseDown : TMouseEvent; + FOnMouseMove : TMouseMoveEvent; + FOnMouseUp : TMouseEvent; + FOnOwnerDraw : TCellPaintNotifyEvent; + {.Z-} + + tcBadColorValue : boolean; + tcBadFontValue : boolean; + tcNoConfigChange : boolean; + + {property methods} + function GetAbout : string; + procedure SetAbout(const Value : string); + + protected + {.Z+} + {property access} + function GetColor : TColor; + function GetCellEditor : TControl; virtual; + function GetFont : TFont; + + procedure SetAccess(A : TOvcTblAccess); + procedure SetAdjust(A : TOvcTblAdjust); + procedure SetColor(C : TColor); + procedure SetFont(F : TFont); + procedure SetHint(const H : string); + procedure SetMargin(M : Integer); + procedure SetTable(T : TOvcTableAncestor); + procedure SetTableColor(B : boolean); + procedure SetTableFont(B : boolean); + procedure SetTextHiColor(THC : TColor); + procedure SetTextStyle(TS : TOvcTextStyle); + + {property storage} + function IsColorStored : boolean; + function IsFontStored : boolean; + + {miscellaneous} + procedure tcChangeScale(M, D : integer); override; + procedure tcFontHasChanged(Sender : TObject); + procedure tcPaint(TableCanvas : TCanvas; + const CellRect : TRect; + RowNum : TRowNum; + ColNum : TColNum; + const CellAttr : TOvcCellAttributes; + Data : pointer); virtual; + procedure tcRetrieveTableColor; + function tcRetrieveTableActiveCol : TColNum; + function tcRetrieveTableActiveRow : TRowNum; + procedure tcRetrieveTableFont; + function tcRetrieveTableLockedCols : TColNum; + function tcRetrieveTableLockedRows : TRowNum; + {.Z-} + + {properties} + property Color : TColor + read GetColor write SetColor + stored IsColorStored; + + property TextHiColor : TColor + read FTextHiColor write SetTextHiColor; + + property Font : TFont + read GetFont write SetFont + stored IsFontStored; + + property Hint : string + read FHint write SetHint; + + property Margin : Integer + read FMargin write SetMargin; + + property ShowHint : boolean + read FShowHint write FShowHint; + + property TableColor : boolean + read FTableColor write SetTableColor; + + property TableFont : boolean + read FTableFont write SetTableFont; + + property TextStyle : TOvcTextStyle + read FTextStyle write SetTextStyle; + + {events} + property OnClick : TNotifyEvent + read FOnClick write FOnClick; + + property OnDblClick : TNotifyEvent + read FOnDblClick write FOnDblClick; + + property OnDragDrop : TDragDropEvent + read FOnDragDrop write FOnDragDrop; + + property OnDragOver : TDragOverEvent + read FOnDragOver write FOnDragOver; + + property OnEndDrag : TEndDragEvent + read FOnEndDrag write FOnEndDrag; + + property OnEnter : TNotifyEvent + read FOnEnter write FOnEnter; + + property OnExit : TNotifyEvent + read FOnExit write FOnExit; + + property OnKeyDown : TKeyEvent + read FOnKeyDown write FOnKeyDown; + + property OnKeyPress : TKeyPressEvent + read FOnKeyPress write FOnKeyPress; + + property OnKeyUp : TKeyEvent + read FOnKeyUp write FOnKeyUp; + + property OnMouseDown : TMouseEvent + read FOnMouseDown write FOnMouseDown; + + property OnMouseMove : TMouseMoveEvent + read FOnMouseMove write FOnMouseMove; + + property OnMouseUp : TMouseEvent + read FOnMouseUp write FOnMouseUp; + + property OnOwnerDraw : TCellPaintNotifyEvent + read FOnOwnerDraw write FOnOwnerDraw; + + public {protected} + {.Z+} + {internal use only methods} + procedure Notification(AComponent: TComponent; Operation: TOperation); override; + procedure tcResetTableValues; override; + + {methods to support third-party components in the data-aware table} + function SpecialCellSupported(Field : TObject) : Boolean; + virtual; + function SpecialCellDataSize : Integer; + virtual; + procedure SpecialCellDataTransfer(Field : TObject; Data : Pointer; Purpose : TOvcCellDataPurpose); + virtual; + {.Z-} + + public + constructor Create(AOwner : TComponent); override; + destructor Destroy; override; + + {reference counting} + procedure IncRefs; + procedure DecRefs; + + {Edit cell base methods to override} + function EditHandle : THandle; virtual; + procedure EditHide; virtual; + procedure EditMove(CellRect : TRect); virtual; + + {Editing base methods to override} + function CanSaveEditedData(SaveValue : boolean) : boolean; virtual; + function CanStopEditing(SaveValue : boolean) : boolean; {for Orpheus 1.0 compatibility} + function FilterTableKey(var Msg : TWMKey) : TOvcTblKeyNeeds; virtual; + {.Z+} + procedure PostMessageToTable(Msg, wParam, lParam : longint); + {.Z-} + procedure SendKeyToTable(var Msg : TWMKey); + procedure SaveEditedData(Data : pointer); virtual; + procedure StartEditing(RowNum : TRowNum; ColNum : TColNum; + CellRect : TRect; + const CellAttr : TOvcCellAttributes; + CellStyle: TOvcTblEditorStyle; + Data : pointer); virtual; + procedure StopEditing(SaveValue : boolean; + Data : pointer); virtual; + function TableWantsEnter : boolean; + function TableWantsTab : boolean; + + {painting} + {.Z+} + function DoOwnerDraw(TableCanvas : TCanvas; + const CellRect : TRect; + RowNum : TRowNum; + ColNum : TColNum; + const CellAttr : TOvcCellAttributes; + Data : pointer) : boolean; virtual; + {.Z-} + procedure Paint(TableCanvas : TCanvas; + const CellRect : TRect; + RowNum : TRowNum; + ColNum : TColNum; + const CellAttr : TOvcCellAttributes; + Data : pointer); + procedure ResolveAttributes(RowNum : TRowNum; ColNum : TColNum; + var CellAttr : TOvcCellAttributes); virtual; + + {properties} + property AcceptActivationClick : boolean + read FAcceptActivationClick write FAcceptActivationClick; + + property Access : TOvcTblAccess + read FAccess write SetAccess; + + property Adjust : TOvcTblAdjust + read FAdjust write SetAdjust; + + property CellEditor : TControl + read GetCellEditor; + + property References : longint + read FReferences; + + property Table : TOvcTableAncestor + read FTable write SetTable; + + published + property About : string + read GetAbout write SetAbout stored False; + end; + + TOvcTableCells = class + protected {private} + {.Z+} + {property fields} + FMatrix : TOvcSparseArray; + FOnCfgChanged : TNotifyEvent; + FTable : TOvcTableAncestor; + + {other fields} + tcCellAttrCount : longint; {count of non-blank cells} + {.Z-} + + protected + {.Z+} + function GetAccess(RowNum : TRowNum; ColNum : TColNum) : TOvcTblAccess; + function GetAdjust(RowNum : TRowNum; ColNum : TColNum) : TOvcTblAdjust; + function GetCell(RowNum : TRowNum; ColNum : TColNum) : TOvcBaseTableCell; + function GetColor(RowNum : TRowNum; ColNum : TColNum) : TColor; + function GetFont(RowNum : TRowNum; ColNum : TColNum) : TFont; + + procedure SetAccess(RowNum : TRowNum; ColNum : TColNum; A : TOvcTblAccess); + procedure SetAdjust(RowNum : TRowNum; ColNum : TColNum; A : TOvcTblAdjust); + procedure SetCell(RowNum : TRowNum; ColNum : TColNum; BTC : TOvcBaseTableCell); + procedure SetColor(RowNum : TRowNum; ColNum : TColNum; C : TColor); + procedure SetFont(RowNum : TRowNum; ColNum : TColNum; F : TFont); + {.Z-} + + public {protected} + {.Z+} + {internal use only methods} + procedure tcNotifyCellDeletion(Cell : TOvcBaseTableCell); + procedure tcDoCfgChanged; + + property OnCfgChanged : TNotifyEvent + write FOnCfgChanged; + property Table : TOvcTableAncestor + read FTable write FTable; + {.Z-} + + public + constructor Create(ATable : TOvcTableAncestor); + destructor Destroy; override; + + procedure DeleteCol(ColNum : TColNum); + procedure DeleteRow(RowNum : TRowNum); + procedure ExchangeCols(ColNum1, ColNum2 : TColNum); + procedure ExchangeRows(RowNum1, RowNum2 : TRowNum); + procedure InsertCol(ColNum : TColNum); + procedure InsertRow(RowNum : TRowNum); + + procedure ResetCell(RowNum : TRowNum; ColNum : TColNum); + procedure ResolveFullAttr(RowNum : TRowNum; ColNum : TColNum; + var SCA : TOvcSparseAttr); + + property Access [RowNum : TRowNum; ColNum : TColNum] : TOvcTblAccess + read GetAccess write SetAccess; + + property Adjust [RowNum : TRowNum; ColNum : TColNum] : TOvcTblAdjust + read GetAdjust write SetAdjust; + + property Cell [RowNum : TRowNum; ColNum : TColNum] : TOvcBaseTableCell + read GetCell write SetCell; + default; + + property Color [RowNum : TRowNum; ColNum : TColNum] : TColor + read GetColor write SetColor; + + property Font [RowNum : TRowNum; ColNum : TColNum] : TFont + read GetFont write SetFont; + end; + +implementation + +{===TOvcCustomCell===================================================} +constructor TOvcBaseTableCell.Create(AOwner : TComponent); + begin + inherited Create(AOwner); + + FAccess := otxDefault; + FAdjust := otaDefault; + FColor := tbDefTableColor; + FTextHiColor := clBtnHighlight; + FFont := TFont.Create; + FFont.OnChange := tcFontHasChanged; + FTableColor := true; + tcBadColorValue := true; + FTableFont := true; + tcBadFontValue := true; + FMargin := tbDefMargin; + end; +{--------} +destructor TOvcBaseTableCell.Destroy; + begin + Table := nil; + FFont.Free; + inherited Destroy; + end; +{--------} + +function TOvcBaseTableCell.EditHandle : THandle; +begin + {do nothing. just here to satisfy BCB} + Result := 0; +end; + +procedure TOvcBaseTableCell.EditHide; +begin + {do nothing. just here to satisfy BCB} +end; + +procedure TOvcBaseTableCell.EditMove(CellRect : TRect); +begin + {do nothing. just here to satisfy BCB} +end; + +function TOvcBaseTableCell.CanSaveEditedData(SaveValue : boolean) : boolean; + begin + Result := true; + end; +{--------} +function TOvcBaseTableCell.CanStopEditing(SaveValue : boolean) : boolean; + begin + Result := CanSaveEditedData(SaveValue); + end; +{--------} +procedure TOvcBaseTableCell.tcChangeScale(M, D : integer); + begin + if (M <> D) and (not TableFont) then + FFont.Size := MulDiv(FFont.Size, M, D); + end; +{--------} +procedure TOvcBaseTableCell.DecRefs; + begin + if (FReferences > 0) then + begin + dec(FReferences); + if (FReferences = 0) then + begin + FTable.tbExcludeCell(Self); + FTable := nil; + FOnCfgChanged := nil; + end; + end; + end; +{--------} +function TOvcBaseTableCell.DoOwnerDraw(TableCanvas : TCanvas; + const CellRect : TRect; + RowNum : TRowNum; + ColNum : TColNum; + const CellAttr : TOvcCellAttributes; + Data : pointer) : boolean; + begin + Result := false; + if Assigned(FOnOwnerDraw) then + FOnOwnerDraw(Self, TableCanvas, CellRect, RowNum, ColNum, CellAttr, Data, Result); + end; +{--------} +function TOvcBaseTableCell.FilterTableKey(var Msg : TWMKey) : TOvcTblKeyNeeds; + begin + if not Assigned(FTable) then + Result := otkDontCare + else + Result := FTable.FilterKey(Msg); + end; +{--------} +procedure TOvcBaseTableCell.tcFontHasChanged(Sender : TObject); + begin + if not tcNoConfigChange then + begin + FTableFont := false; + tcDoCfgChanged; + end; + end; +{--------} +function TOvcBaseTableCell.GetColor : TColor; + begin + if TableColor and tcBadColorValue then + tcRetrieveTableColor; + Result := FColor; + end; +{--------} +function TOvcBaseTableCell.GetCellEditor : TControl; + begin + Result := nil; + end; +{--------} +function TOvcBaseTableCell.GetFont : TFont; + begin + if TableFont and tcBadFontValue then + begin + tcNoConfigChange := true; + tcRetrieveTableFont; + tcNoConfigChange := false; + end; + Result := FFont; + end; +{--------} +procedure TOvcBaseTableCell.IncRefs; + begin + if (FReferences = 0) and Assigned(FTable) then + FTable.tbIncludeCell(Self); + inc(FReferences); + end; +{--------} +function TOvcBaseTableCell.IsColorStored : boolean; + begin + Result := not TableColor; + end; +{--------} +function TOvcBaseTableCell.IsFontStored : boolean; + begin + Result := not TableFont; + end; +{--------} +procedure TOvcBaseTableCell.Notification(AComponent: TComponent; Operation: TOperation); + begin + inherited Notification(AComponent, Operation); + if (AComponent is TOvcTableAncestor) and + (Operation = opRemove) and + (TOvcTableAncestor(AComponent) = FTable) then + begin + FTable := nil; + FOnCfgChanged := nil; + end; + end; +{--------} +procedure TOvcBaseTableCell.Paint(TableCanvas : TCanvas; + const CellRect : TRect; + RowNum : TRowNum; + ColNum : TColNum; + const CellAttr : TOvcCellAttributes; + Data : pointer); + begin + if not DoOwnerDraw(TableCanvas, CellRect, RowNum, ColNum, CellAttr, Data) then + tcPaint(TableCanvas, CellRect, RowNum, ColNum, CellAttr, Data); + end; +{--------} +procedure TOvcBaseTableCell.tcPaint(TableCanvas : TCanvas; + const CellRect : TRect; + RowNum : TRowNum; + ColNum : TColNum; + const CellAttr : TOvcCellAttributes; + Data : pointer); + begin + with TableCanvas do + begin + Brush.Color := CellAttr.caColor; + FillRect(CellRect); + end; + end; +{--------} +procedure TOvcBaseTableCell.PostMessageToTable(Msg, wParam, lParam : longint); + begin + if Assigned(FTable) and FTable.HandleAllocated then + PostMessage(FTable.Handle, Msg, wParam, lParam) + end; +{--------} +procedure TOvcBaseTableCell.tcResetTableValues; + begin + if Assigned(FTable) then + begin + if TableFont then + tcRetrieveTableFont; + if TableColor then + tcRetrieveTableColor; + end; + end; +{--------} +procedure TOvcBaseTableCell.ResolveAttributes(RowNum : TRowNum; ColNum : TColNum; + var CellAttr : TOvcCellAttributes); + begin + with CellAttr do + begin + caAccess := Access; + caAdjust := Adjust; + caColor := Color; + caFont.Assign(Font); + caFontColor := Font.Color; + caFontHiColor := TextHiColor; + caTextStyle := TextStyle; + end; + if Assigned(FTable) then + FTable.ResolveCellAttributes(RowNum, ColNum, CellAttr); + with CellAttr do + begin + if (caAccess = otxDefault) then + caAccess := tbDefAccess; + if (caAdjust = otaDefault) then + caAdjust := tbDefAdjust; + if (caColor = clOvcTableDefault) then + caColor := tbDefTableColor; + end; + end; +{--------} +procedure TOvcBaseTableCell.tcRetrieveTableColor; + begin + if Assigned(FTable) and FTable.HandleAllocated then + begin + FColor := SendMessage(FTable.Handle, ctim_QueryColor, 0, 0); + tcBadColorValue := false; + end + else + tcBadColorValue := true; + end; +{--------} +function TOvcBaseTableCell.tcRetrieveTableActiveCol : TColNum; + begin + Result := 0; + if Assigned(FTable) and FTable.HandleAllocated then + Result := SendMessage(FTable.Handle, ctim_QueryActiveCol, 0, 0); + end; +{--------} +function TOvcBaseTableCell.tcRetrieveTableActiveRow : TRowNum; + begin + Result := 0; + if Assigned(FTable) and FTable.HandleAllocated then + Result := SendMessage(FTable.Handle, ctim_QueryActiveRow, 0, 0); + end; +{--------} +procedure TOvcBaseTableCell.tcRetrieveTableFont; + var + TblFont : TFont; + begin + if Assigned(FTable) and FTable.HandleAllocated then + begin + TblFont := TFont(SendMessage(FTable.Handle, ctim_QueryFont, 0, 0)); + if Assigned(TblFont) then + FFont.Assign(TblFont); + tcBadFontValue := false; + FTableFont := true; + end + else + tcBadFontValue := true; + end; +{--------} +function TOvcBaseTableCell.tcRetrieveTableLockedCols : TColNum; + begin + Result := 0; + if Assigned(FTable) and FTable.HandleAllocated then + Result := SendMessage(FTable.Handle, ctim_QueryLockedCols, 0, 0); + end; +{--------} +function TOvcBaseTableCell.tcRetrieveTableLockedRows : TRowNum; + begin + Result := 0; + if Assigned(FTable) and FTable.HandleAllocated then + Result := SendMessage(FTable.Handle, ctim_QueryLockedRows, 0, 0); + end; +{--------} +procedure TOvcBaseTableCell.SendKeyToTable(var Msg : TWMKey); + begin + if Assigned(FTable) and FTable.HandleAllocated then + PostMessage(FTable.Handle, WM_KEYDOWN, Msg.CharCode, Msg.KeyData); + end; +{--------} +procedure TOvcBaseTableCell.SetAccess(A : TOvcTblAccess); + begin + if (A <> FAccess) then + begin + FAccess := A; + tcDoCfgChanged; + end; + end; +{--------} +procedure TOvcBaseTableCell.SetAdjust(A : TOvcTblAdjust); + begin + if (A <> FAdjust) then + begin + FAdjust := A; + tcDoCfgChanged; + end; + end; +{--------} +procedure TOvcBaseTableCell.SetColor(C : TColor); + begin + if (C <> FColor) then + begin + FColor := C; + FTableColor := false; + tcBadColorValue := false; + tcDoCfgChanged; + end; + end; +{--------} +procedure TOvcBaseTableCell.SetFont(F : TFont); + begin + FFont.Assign(F); + tcBadFontValue := false; + FTableFont := false; + tcDoCfgChanged; + end; +{--------} +procedure TOvcBaseTableCell.SetHint(const H : string); + begin + FHint := H; + end; +{--------} +procedure TOvcBaseTableCell.SetMargin(M : Integer); + begin + if (M >= 0) and (M <> FMargin) then + begin + FMargin := M; + tcDoCfgChanged; + end; + end; +{--------} +procedure TOvcBaseTableCell.SetTable(T : TOvcTableAncestor); + begin + if (T <> FTable) then + if (not Assigned(T)) or (T is TOvcTableAncestor) then + begin + if Assigned(FTable) and FTable.HandleAllocated then + SendMessage(FTable.Handle, ctim_RemoveCell, 0, longint(Self)); + FTable := T; + FOnCfgChanged := nil; + FReferences := 0; + tcResetTableValues; + end; + end; +{--------} +procedure TOvcBaseTableCell.SetTableColor(B : boolean); + begin + if (B <> FTableColor) then + begin + tcBadColorValue := false; + FTableColor := B; + if B then + tcRetrieveTableColor; + tcDoCfgChanged; + end; + end; +{--------} +procedure TOvcBaseTableCell.SetTableFont(B : boolean); + begin + if (B <> FTableFont) then + begin + tcBadFontValue := false; + if B then + tcRetrieveTableFont; + FTableFont := B; + tcDoCfgChanged; + end; + end; +{--------} +procedure TOvcBaseTableCell.SetTextHiColor(THC : TColor); + begin + if (THC <> FTextHiColor) then + begin + FTextHiColor := THC; + tcDoCfgChanged; + end; + end; +{--------} +procedure TOvcBaseTableCell.SetTextStyle(TS : TOvcTextStyle); + begin + if (TS <> FTextStyle) then + begin + FTextStyle := TS; + tcDoCfgChanged; + end; + end; +{--------} +procedure TOvcBaseTableCell.SaveEditedData(Data : pointer); +begin + {do nothing. just here to satisfy BCB} +end; + +procedure TOvcBaseTableCell.StartEditing(RowNum : TRowNum; ColNum : TColNum; + CellRect : TRect; + const CellAttr : TOvcCellAttributes; + CellStyle: TOvcTblEditorStyle; + Data : pointer); +begin + {do nothing. just here to satisfy BCB} +end; + +procedure TOvcBaseTableCell.StopEditing(SaveValue : boolean; + Data : pointer); +begin + {do nothing. just here to satisfy BCB} +end; + +function TOvcBaseTableCell.TableWantsEnter : boolean; + var + Typecast : record + case boolean of + false : (LI : longint); + true : (TblOpts : TOvcTblOptionSet); + end; + begin + Result := false; + if Assigned(FTable) and FTable.HandleAllocated then + begin + Typecast.LI := SendMessage(FTable.Handle, ctim_QueryOptions, 0, 0); + Result := otoEnterToArrow in Typecast.TblOpts; + end; + end; +{--------} +function TOvcBaseTableCell.TableWantsTab : boolean; + var + Typecast : record + case boolean of + false : (LI : longint); + true : (TblOpts : TOvcTblOptionSet); + end; + begin + Result := false; + if Assigned(FTable) and FTable.HandleAllocated then + begin + Typecast.LI := SendMessage(FTable.Handle, ctim_QueryOptions, 0, 0); + Result := otoTabToArrow in Typecast.TblOpts; + end; + end; + +function TOvcBaseTableCell.GetAbout : string; +begin + Result := OrVersionStr; +end; + +procedure TOvcBaseTableCell.SetAbout(const Value : string); +begin +end; + +{the following three methods should be implemented for descendant } +{cell components to allow them to be used by the data-aware table.} + +function TOvcBaseTableCell.SpecialCellSupported(Field : TObject) : Boolean; +begin + {return true if Field is a supported cell type for the data-aware table} + Result := False; +end; + +function TOvcBaseTableCell.SpecialCellDataSize : Integer; +begin + {return the size of the buffer needed to save data for this field/cell type} + Result := 0; +end; + +procedure TOvcBaseTableCell.SpecialCellDataTransfer( + Field : TObject; Data : Pointer; Purpose : TOvcCellDataPurpose); +begin + {handle transfer of data to/from Field/Pointer} + {as indicated by the value of Purpose:} + {cdpForPaint ..for painting} + {cdpForEdit ..for editing} + {cdpForSave ..for saving edited data} +end; + + +{====================================================================} + + +{===CellAttribute helper routines====================================} +function CellAttributeIsBlank(CA : POvcSparseAttr) : boolean; + begin + Result := true; + if Assigned(CA) then with CA^ do + Result := (scaAccess = otxDefault) and + (scaAdjust = otaDefault) and + (scaColor = clOvcTableDefault) and + (scaFont = nil) and + (scaCell = nil); + end; +{--------} +procedure DisposeCellAttribute(CA : POvcSparseAttr); + begin + if Assigned(CA) then with CA^ do + begin + scaFont.Free; + if Assigned(scaCell) then + TOvcBaseTableCell(scaCell).DecRefs; + Dispose(CA); + end; + end; +{--------} +function GetCellAttribute(SA : TOvcSparseArray; RowNum : TRowNum; ColNum : TColNum) : POvcSparseAttr; + var + WorkSA : TOvcSparseArray; + begin + Result := nil; + WorkSA := SA[RowNum]; + if Assigned(WorkSA) then + Result := POvcSparseAttr(WorkSA[ColNum]); + end; +{--------} +procedure InitCellAttribute(var SCA : TOvcSparseAttr); + begin + with SCA do + begin + scaAccess := otxDefault; + scaAdjust := otaDefault; + scaColor := clOvcTableDefault; + scaFont := nil; + scaCell := nil; + end; + end; +{--------} +function NewCellAttribute : POvcSparseAttr; + begin + New(Result); + InitCellAttribute(Result^); + end; +{--------} +function PutCellAttribute(SA : TOvcSparseArray; RowNum : TRowNum; ColNum : TColNum) : POvcSparseAttr; + var + WorkSA : TOvcSparseArray; + begin + Result := NewCellAttribute; + WorkSA := SA[RowNum]; + if not Assigned(WorkSA) then + begin + WorkSA := TOvcSparseArray.Create; + SA[RowNum] := WorkSA; + end; + WorkSA[ColNum] := Result; + end; +{--------} +procedure ResetCellAttribute(SA : TOvcSparseArray; RowNum : TRowNum; ColNum : TColNum); + var + WorkSA : TOvcSparseArray; + begin + WorkSA := SA[RowNum]; + if Assigned(WorkSA) then + WorkSA[ColNum] := nil; + end; +{====================================================================} + + +{===SparseArray iterators============================================} +type + PDelColRec = ^TDelColRec; + TDelColRec = packed record + dcrCellAttrCount : longint; + dcrColNum : longint; + end; + PExchColRec = ^TExchColRec; + TExchColRec = packed record + ecrColNum1 : longint; + ecrColNum2 : longint; + end; +{--------} +function DelCellAttribute(Index : longint; + Item : pointer; + ExtraData : pointer) : boolean; far; + var + CA : POvcSparseAttr absolute Item; + begin + DisposeCellAttribute(CA); + Result := true; + end; +{--------} +function DelSparseArray(Index : longint; + Item : pointer; + ExtraData : pointer) : boolean; far; + var + SL : TOvcSparseArray absolute Item; + begin + SL.ForAll(DelCellAttribute, false, ExtraData); + SL.Destroy; + Result := true; + end; +{--------} +function DelCellMinor(Index : longint; + Item : pointer; + ExtraData : pointer) : boolean; far; + var + CA : POvcSparseAttr absolute Item; + Cell : TOvcBaseTableCell absolute ExtraData; + begin + if (CA^.scaCell = Cell) then + begin + Cell.DecRefs; + CA^.scaCell := nil; + end; + Result := true; + end; +{--------} +function DelCellMajor(Index : longint; + Item : pointer; + ExtraData : pointer) : boolean; far; + var + SL : TOvcSparseArray absolute Item; + begin + SL.ForAll(DelCellMinor, false, ExtraData); + Result := true; + end; +{--------} +function DelCol(Index : longint; + Item : pointer; + ExtraData : pointer) : boolean; far; + var + SL : TOvcSparseArray absolute Item; + MyExtraData : PDelColRec absolute ExtraData; + CA : POvcSparseAttr; + begin + CA := POvcSparseAttr(SL[MyExtraData^.dcrColNum]); + if Assigned(CA) then + begin + dec(MyExtraData^.dcrCellAttrCount); + DisposeCellAttribute(CA); + end; + SL.Delete(MyExtraData^.dcrColNum); + Result := true; + end; +{--------} +function ExchCols(Index : longint; + Item : pointer; + ExtraData : pointer) : boolean; far; + var + SL : TOvcSparseArray absolute Item; + MyExtraData : PExchColRec absolute ExtraData; + begin + with MyExtraData^ do + SL.Exchange(ecrColNum1, ecrColNum2); + Result := true; + end; +{--------} +function InsCol(Index : longint; + Item : pointer; + ExtraData : pointer) : boolean; far; + var + SL : TOvcSparseArray absolute Item; + ColNum : longint absolute ExtraData; + begin + SL.Insert(ColNum, nil); + Result := true; + end; +{====================================================================} + + +{===TOvcTableCells===================================================} +constructor TOvcTableCells.Create; + begin + inherited Create; + FMatrix := TOvcSparseArray.Create; + end; +{--------} +destructor TOvcTableCells.Destroy; + var + DummyPtr : pointer; + begin + DummyPtr := nil; + FMatrix.ForAll(DelSparseArray, false, DummyPtr); + FMatrix.Destroy; + inherited Destroy; + end; +{--------} +procedure TOvcTableCells.DeleteCol(ColNum : TColNum); + var + MyExtraData : TDelColRec; + begin + if (tcCellAttrCount > 0) then + begin + MyExtraData.dcrCellAttrCount := tcCellAttrCount; + MyExtraData.dcrColNum := ColNum; + FMatrix.ForAll(DelCol, false, @MyExtraData); + tcCellAttrCount := MyExtraData.dcrCellAttrCount; + tcDoCfgChanged; + end; + end; +{--------} +procedure TOvcTableCells.DeleteRow(RowNum : TRowNum); + var + WorkSA : TOvcSparseArray; + begin + if (tcCellAttrCount > 0) then + begin + WorkSA := FMatrix[RowNum]; + if Assigned(WorkSA) then + begin + dec(tcCellAttrCount, WorkSA.ActiveCount); + WorkSA.ForAll(DelCellAttribute, false, nil); + end; + FMatrix.Delete(RowNum); + tcDoCfgChanged; + end; + end; +{--------} +procedure TOvcTableCells.ExchangeCols(ColNum1, ColNum2 : TColNum); + var + MyExtraData : TExchColRec; + begin + if (tcCellAttrCount > 0) then + begin + MyExtraData.ecrColNum1 := ColNum1; + MyExtraData.ecrColNum2 := ColNum2; + FMatrix.ForAll(ExchCols, false, @MyExtraData); + tcDoCfgChanged; + end; + end; +{--------} +procedure TOvcTableCells.ExchangeRows(RowNum1, RowNum2 : TRowNum); + begin + if (tcCellAttrCount > 0) then + begin + FMatrix.Exchange(RowNum1, RowNum2); + tcDoCfgChanged; + end; + end; +{--------} +function TOvcTableCells.GetAccess(RowNum : TRowNum; ColNum : TColNum) : TOvcTblAccess; + var + CellAttr : POvcSparseAttr; + begin + Result := otxDefault; + if (tcCellAttrCount > 0) then + begin + CellAttr := GetCellAttribute(FMatrix, RowNum, ColNum); + if Assigned(CellAttr) then + Result := CellAttr^.scaAccess; + end; + end; +{--------} +function TOvcTableCells.GetAdjust(RowNum : TRowNum; ColNum : TColNum) : TOvcTblAdjust; + var + CellAttr : POvcSparseAttr; + begin + Result := otaDefault; + if (tcCellAttrCount > 0) then + begin + CellAttr := GetCellAttribute(FMatrix, RowNum, ColNum); + if Assigned(CellAttr) then + Result := CellAttr^.scaAdjust; + end; + end; +{--------} +function TOvcTableCells.GetCell(RowNum : TRowNum; ColNum : TColNum) : TOvcBaseTableCell; + var + CellAttr : POvcSparseAttr; + begin + Result := nil; + if (tcCellAttrCount > 0) then + begin + CellAttr := GetCellAttribute(FMatrix, RowNum, ColNum); + if Assigned(CellAttr) then + Result := TOvcBaseTableCell(CellAttr^.scaCell); + end; + end; +{--------} +function TOvcTableCells.GetColor(RowNum : TRowNum; ColNum : TColNum) : TColor; + var + CellAttr : POvcSparseAttr; + begin + Result := clOvcTableDefault; + if (tcCellAttrCount > 0) then + begin + CellAttr := GetCellAttribute(FMatrix, RowNum, ColNum); + if Assigned(CellAttr) then + Result := CellAttr^.scaColor; + end; + end; +{--------} +function TOvcTableCells.GetFont(RowNum : TRowNum; ColNum : TColNum) : TFont; + var + CellAttr : POvcSparseAttr; + begin + Result := nil; + if (tcCellAttrCount > 0) then + begin + CellAttr := GetCellAttribute(FMatrix, RowNum, ColNum); + if Assigned(CellAttr) then + Result := CellAttr^.scaFont; + end; + end; +{--------} +procedure TOvcTableCells.InsertCol(ColNum : TColNum); + var + LI : longint; + begin + if (tcCellAttrCount > 0) then + begin + LI := ColNum; + FMatrix.ForAll(InsCol, false, pointer(LI)); + tcDoCfgChanged; + end; + end; +{--------} +procedure TOvcTableCells.InsertRow(RowNum : TRowNum); + begin + if (tcCellAttrCount > 0) then + begin + FMatrix.Insert(RowNum, nil); + tcDoCfgChanged; + end; + end; +{--------} +procedure TOvcTableCells.tcNotifyCellDeletion(Cell : TOvcBaseTableCell); + begin + if (tcCellAttrCount > 0) then + FMatrix.ForAll(DelCellMajor, false, Cell); + end; +{--------} +procedure TOvcTableCells.ResolveFullAttr(RowNum : TRowNum; ColNum : TColNum; + var SCA : TOvcSparseAttr); + var + CellAttr : POvcSparseAttr; + begin + if (tcCellAttrCount = 0) then + InitCellAttribute(SCA) + else + begin + CellAttr := GetCellAttribute(FMatrix, RowNum, ColNum); + if Assigned(CellAttr) then + SCA := CellAttr^ + else + InitCellAttribute(SCA); + end; + end; +{--------} +procedure TOvcTableCells.tcDoCfgChanged; + begin + if Assigned(FOnCfgChanged) then FOnCfgChanged(Self); + end; +{--------} +procedure TOvcTableCells.ResetCell(RowNum : TRowNum; ColNum : TColNum); + var + CellAttr : POvcSparseAttr; + begin + if (tcCellAttrCount > 0) then + begin + CellAttr := GetCellAttribute(FMatrix, RowNum, ColNum); + if Assigned(CellAttr) then + begin + DisposeCellAttribute(CellAttr); + ResetCellAttribute(FMatrix, RowNum, ColNum); + dec(tcCellAttrCount); + tcDoCfgChanged; + end; + end; + end; +{--------} +procedure TOvcTableCells.SetAccess(RowNum : TRowNum; ColNum : TColNum; A : TOvcTblAccess); + var + CellAttr : POvcSparseAttr; + begin + if (tcCellAttrCount = 0) then + CellAttr := nil + else + CellAttr := GetCellAttribute(FMatrix, RowNum, ColNum); + if not Assigned(CellAttr) then + begin + CellAttr := PutCellAttribute(FMatrix, RowNum, ColNum); + inc(tcCellAttrCount); + end; + CellAttr^.scaAccess := A; + if CellAttributeIsBlank(CellAttr) then + begin + DisposeCellAttribute(CellAttr); + ResetCellAttribute(FMatrix, RowNum, ColNum); + dec(tcCellAttrCount); + end; + tcDoCfgChanged; + end; +{--------} +procedure TOvcTableCells.SetAdjust(RowNum : TRowNum; ColNum : TColNum; A : TOvcTblAdjust); + var + CellAttr : POvcSparseAttr; + begin + if (tcCellAttrCount = 0) then + CellAttr := nil + else + CellAttr := GetCellAttribute(FMatrix, RowNum, ColNum); + if not Assigned(CellAttr) then + begin + CellAttr := PutCellAttribute(FMatrix, RowNum, ColNum); + inc(tcCellAttrCount); + end; + CellAttr^.scaAdjust := A; + if CellAttributeIsBlank(CellAttr) then + begin + DisposeCellAttribute(CellAttr); + ResetCellAttribute(FMatrix, RowNum, ColNum); + dec(tcCellAttrCount); + end; + tcDoCfgChanged; + end; +{--------} +procedure TOvcTableCells.SetCell(RowNum : TRowNum; ColNum : TColNum; BTC : TOvcBaseTableCell); + var + CellAttr : POvcSparseAttr; + DoIt : boolean; + begin + DoIt := false; + if Assigned(BTC) then + begin + if (BTC.References = 0) or + ((BTC.References > 0) and (BTC.Table = FTable)) then + DoIt := true; + end + else + DoIt := true; + + if DoIt then + begin + if (tcCellAttrCount = 0) then + CellAttr := nil + else + CellAttr := GetCellAttribute(FMatrix, RowNum, ColNum); + if not Assigned(CellAttr) then + begin + CellAttr := PutCellAttribute(FMatrix, RowNum, ColNum); + inc(tcCellAttrCount); + end; + if Assigned(CellAttr^.scaCell) then + TOvcBaseTableCell(CellAttr^.scaCell).DecRefs; + if Assigned(BTC) then + begin + if (BTC.References = 0) then + BTC.Table := FTable; + BTC.IncRefs; + end; + CellAttr^.scaCell := BTC; + if CellAttributeIsBlank(CellAttr) then + begin + DisposeCellAttribute(CellAttr); + ResetCellAttribute(FMatrix, RowNum, ColNum); + dec(tcCellAttrCount); + end; + tcDoCfgChanged; + end; + end; +{--------} +procedure TOvcTableCells.SetColor(RowNum : TRowNum; ColNum : TColNum; C : TColor); + var + CellAttr : POvcSparseAttr; + begin + if (tcCellAttrCount = 0) then + CellAttr := nil + else + CellAttr := GetCellAttribute(FMatrix, RowNum, ColNum); + if not Assigned(CellAttr) then + begin + CellAttr := PutCellAttribute(FMatrix, RowNum, ColNum); + inc(tcCellAttrCount); + end; + CellAttr^.scaColor := C; + if CellAttributeIsBlank(CellAttr) then + begin + DisposeCellAttribute(CellAttr); + ResetCellAttribute(FMatrix, RowNum, ColNum); + dec(tcCellAttrCount); + end; + tcDoCfgChanged; + end; +{--------} +procedure TOvcTableCells.SetFont(RowNum : TRowNum; ColNum : TColNum; F : TFont); + var + CellAttr : POvcSparseAttr; + begin + if (tcCellAttrCount = 0) then + CellAttr := nil + else + CellAttr := GetCellAttribute(FMatrix, RowNum, ColNum); + if not Assigned(CellAttr) then + begin + CellAttr := PutCellAttribute(FMatrix, RowNum, ColNum); + inc(tcCellAttrCount); + end; + with CellAttr^ do + begin + if not Assigned(F) then + begin + scaFont.Free; + scaFont := nil; + end + else + begin + if not Assigned(scaFont) then + scaFont := TFont.Create; + scaFont.Assign(F); + end; + end; + if CellAttributeIsBlank(CellAttr) then + begin + DisposeCellAttribute(CellAttr); + ResetCellAttribute(FMatrix, RowNum, ColNum); + dec(tcCellAttrCount); + end; + tcDoCfgChanged; + end; +{====================================================================} + +end. diff --git a/components/orpheus/ovctcgly.pas b/components/orpheus/ovctcgly.pas new file mode 100644 index 000000000..4823fe1c6 --- /dev/null +++ b/components/orpheus/ovctcgly.pas @@ -0,0 +1,462 @@ +{*********************************************************} +{* OVCTCGLY.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovctcgly; + {-Orpheus Table Cell - Glyph type} + +interface + +uses + {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, LclType, MyMisc, {$ENDIF} + SysUtils, Graphics, Classes, Controls, + OvcTCmmn, OvcTCell, OvcTGRes, OvcTCBmp; + +type + TOvcTCGlyphEdit = class(TCustomControl) + protected {private} + {.Z+} + FValue : Integer; + FCell : TOvcBaseTableCell; + FRow : TRowNum; + FCol : TColNum; + FCellAttr : TOvcCellAttributes; + {.Z-} + + protected + {.Z+} + procedure SetValue(V : integer); + + procedure WMGetDlgCode(var Msg : TMessage); message WM_GETDLGCODE; + procedure WMKeyDown(var Msg : TWMKey); message WM_KEYDOWN; + procedure WMKillFocus(var Msg : TWMKillFocus); message WM_KILLFOCUS; + procedure WMLButtonDown(var Msg : TWMMouse); message WM_LBUTTONDOWN; + procedure WMSetFocus(var Msg : TWMSetFocus); message WM_SETFOCUS; + {.Z-} + + public + constructor Create(AOwner : TComponent); override; + procedure Paint; override; + + property CellOwner : TOvcBaseTableCell + read FCell write FCell; + property Value : integer + read FValue write SetValue; + end; + + TOvcTCCustomGlyph = class(TOvcTCBaseBitMap) + protected {private} + {.Z+} + FCellGlyphs : TOvcCellGlyphs; + FEdit : TOvcTCGlyphEdit; + {.Z-} + + protected + {.Z+} + function GetCellEditor : TControl; override; + procedure SetCellGlyphs(CBG : TOvcCellGlyphs); + + procedure GlyphsHaveChanged(Sender : TObject); + + {painting} + procedure tcPaint(TableCanvas : TCanvas; + const CellRect : TRect; + RowNum : TRowNum; + ColNum : TColNum; + const CellAttr : TOvcCellAttributes; + Data : pointer); override; + {.Z-} + + {properties} + property CellGlyphs : TOvcCellGlyphs + read FCellGlyphs write SetCellGlyphs; + + public + {create/destroy} + constructor Create(AOwner : TComponent); override; + destructor Destroy; override; + function CreateEditControl : TOvcTCGlyphEdit; virtual; + + function CanAssignGlyphs(CBG : TOvcCellGlyphs) : boolean; virtual; + + function EditHandle : THandle; override; + procedure EditHide; override; + procedure EditMove(CellRect : TRect); override; + + procedure SaveEditedData(Data : pointer); override; + procedure StartEditing(RowNum : TRowNum; ColNum : TColNum; + CellRect : TRect; + const CellAttr : TOvcCellAttributes; + CellStyle: TOvcTblEditorStyle; + Data : pointer); override; + procedure StopEditing(SaveValue : boolean; + Data : pointer); override; + + end; + + TOvcTCGlyph = class(TOvcTCCustomGlyph) + published + {properties inherited from custom ancestor} + property AcceptActivationClick default True; + property Access default otxDefault; + property Adjust default otaDefault; + property CellGlyphs; + property Color; + property Hint; + property Margin default 4; + property ShowHint default False; + property Table; + property TableColor default True; + + {events inherited from custom ancestor} + property OnClick; + property OnDragDrop; + property OnDragOver; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnOwnerDraw; + end; + +implementation + + +{===TOvcTCCustomGlyph creation/destruction===========================} +constructor TOvcTCCustomGlyph.Create(AOwner : TComponent); + begin + inherited Create(AOwner); + FCellGlyphs := TOvcCellGlyphs.Create; + FCellGlyphs.OnCfgChanged := GlyphsHaveChanged; + FAcceptActivationClick := true; + end; +{--------} +destructor TOvcTCCustomGlyph.Destroy; + begin + FCellGlyphs.Free; + inherited Destroy; + end; +{--------} +function TOvcTCCustomGlyph.CanAssignGlyphs(CBG : TOvcCellGlyphs) : boolean; + begin + Result := true; + end; +{--------} +function TOvcTCCustomGlyph.CreateEditControl : TOvcTCGlyphEdit; + begin + Result := TOvcTCGlyphEdit.Create(FTable); + end; +{--------} +function TOvcTCCustomGlyph.GetCellEditor : TControl; + begin + Result := FEdit; + end; +{--------} +procedure TOvcTCCustomGlyph.GlyphsHaveChanged(Sender : TObject); + begin + tcDoCfgChanged; + end; +{--------} +procedure TOvcTCCustomGlyph.SetCellGlyphs(CBG : TOvcCellGlyphs); + begin + if CanAssignGlyphs(CBG) then + FCellGlyphs.Assign(CBG); + end; +{====================================================================} + + +{===TOvcTCCustomGlyph painting================================} +procedure TOvcTCCustomGlyph.tcPaint(TableCanvas : TCanvas; + const CellRect : TRect; + RowNum : TRowNum; + ColNum : TColNum; + const CellAttr : TOvcCellAttributes; + Data : pointer); + var + B : ^integer absolute Data; + BitMapInfo : TCellBitMapInfo; + begin + {set up a bitmap info record} + with BitMapInfo do + begin + BM := FCellGlyphs.BitMap; + ActiveCount := FCellGlyphs.ActiveGlyphCount; + Count := FCellGlyphs.GlyphCount; + if (Data = nil) then + begin + if (csDesigning in ComponentState) then + Index := (RowNum mod ActiveCount) {for testing purposes} + else + Index := -1 + end + else + Index := B^; + if (Index >= ActiveCount) then + Index := pred(ActiveCount); + end; + inherited tcPaint(TableCanvas, CellRect, RowNum, ColNum, CellAttr, @BitMapInfo); + end; +{====================================================================} + + +{===TOvcTCCustomGlyph editing========================================} +function TOvcTCCustomGlyph.EditHandle : THandle; + begin + if Assigned(FEdit) then + Result := FEdit.Handle + else + Result := 0; + end; +{--------} +procedure TOvcTCCustomGlyph.EditHide; + begin + if Assigned(FEdit) then + with FEdit do + begin + SetWindowPos(FEdit.Handle, HWND_TOP, + 0, 0, 0, 0, + SWP_HIDEWINDOW or SWP_NOREDRAW or SWP_NOZORDER); + end; + end; +{--------} +procedure TOvcTCCustomGlyph.EditMove(CellRect : TRect); + var + EditHandle : HWND; + begin + if Assigned(FEdit) then + begin + EditHandle := FEdit.Handle; + with CellRect do + SetWindowPos(EditHandle, HWND_TOP, + Left, Top, Right-Left, Bottom-Top, + SWP_SHOWWINDOW or SWP_NOREDRAW or SWP_NOZORDER); + InvalidateRect(EditHandle, nil, false); + UpdateWindow(EditHandle); + end; + end; +{--------} +procedure TOvcTCCustomGlyph.SaveEditedData(Data : pointer); + begin + if Assigned(Data) then + Integer(Data^) := FEdit.Value; + end; +{--------} +procedure TOvcTCCustomGlyph.StartEditing(RowNum : TRowNum; ColNum : TColNum; + CellRect : TRect; + const CellAttr : TOvcCellAttributes; + CellStyle: TOvcTblEditorStyle; + Data : pointer); + begin + FEdit := CreateEditControl; + with FEdit do + begin + CellOwner := Self; + if Data = nil then + Value := 0 + else + Value := Integer(Data^); + FRow := RowNum; + FCol := ColNum; + FCellAttr := CellAttr; + Color := CellAttr.caColor; + Ctl3D := false; + case CellStyle of + tes3D : Ctl3D := true; + end;{case} + Left := CellRect.Left; + Top := CellRect.Top; + Width := CellRect.Right - CellRect.Left; + Height := CellRect.Bottom - CellRect.Top; + Hint := Self.Hint; + ShowHint := Self.ShowHint; + Parent := FTable; + Visible := true; + TabStop := false; + + OnClick := Self.OnClick; + OnDblClick := Self.OnDblClick; + OnDragDrop := Self.OnDragDrop; + OnDragOver := Self.OnDragOver; + OnEndDrag := Self.OnEndDrag; + OnEnter := Self.OnEnter; + OnExit := Self.OnExit; + OnKeyDown := Self.OnKeyDown; + OnKeyPress := Self.OnKeyPress; + OnKeyUp := Self.OnKeyUp; + OnMouseDown := Self.OnMouseDown; + OnMouseMove := Self.OnMouseMove; + OnMouseUp := Self.OnMouseUp; + end; + end; +{--------} +procedure TOvcTCCustomGlyph.StopEditing(SaveValue : boolean; + Data : pointer); + begin + if SaveValue and Assigned(Data) then + Integer(Data^) := FEdit.Value; + FEdit.Free; + FEdit := nil; + end; +{====================================================================} + + +{---TOvcTCGlyphEdit===========================================} +constructor TOvcTCGlyphEdit.Create(AOwner : TComponent); + begin + inherited Create(AOwner); + ControlStyle := ControlStyle - [csDoubleClicks]; + end; +{--------} +procedure TOvcTCGlyphEdit.Paint; + var + R : TRect; + begin +{$IFNDEF LCL} + Windows.GetClientRect(Handle, R); +{$ELSE} + LclIntf.GetClientRect(Handle, R); +{$ENDIF} + FCell.Paint(Canvas, R, FRow, FCol, FCellAttr, @FValue); + end; +{--------} +procedure TOvcTCGlyphEdit.SetValue(V : integer); + begin + if (V <> FValue) then + begin + if (V < 0) then + V := 0 + else if (V >= TOvcTCGlyph(CellOwner).CellGlyphs.ActiveGlyphCount) then + V := TOvcTCGlyph(CellOwner).CellGlyphs.ActiveGlyphCount; + FValue := V; + if HandleAllocated then + begin + Invalidate; + Update; + end; + end; + end; +{--------} +procedure TOvcTCGlyphEdit.WMGetDlgCode(var Msg : TMessage); + begin + Msg.Result := DLGC_WANTARROWS; + if CellOwner.TableWantsTab then + Msg.Result := Msg.Result or DLGC_WANTTAB; + if CellOwner.TableWantsEnter then + Msg.Result := Msg.Result or DLGC_WANTALLKEYS; + end; +{--------} +procedure TOvcTCGlyphEdit.WMKeyDown(var Msg : TWMKey); + var + GridReply : TOvcTblKeyNeeds; + GridUsedIt : boolean; + begin + GridUsedIt := false; + GridReply := otkDontCare; + if (CellOwner <> nil) then + GridReply := CellOwner.FilterTableKey(Msg); + case GridReply of + otkMustHave : + begin + CellOwner.SendKeyToTable(Msg); + GridUsedIt := true; + end; + otkWouldLike : + if Msg.CharCode <> VK_SPACE then + begin + CellOwner.SendKeyToTable(Msg); + GridUsedIt := true; + end; + end;{case} + + if not GridUsedIt then + begin + inherited; + if (Msg.CharCode = VK_SPACE) then + begin + inc(FValue); + if (FValue >= TOvcTCGlyph(FCell).FCellGlyphs.ActiveGlyphCount) then + FValue := 0; + Invalidate; + Update; + + if ((@TOvcTCGlyph(FCell).FOnClick) <> nil) then + OnClick(Self); + end + else if (Msg.CharCode = VK_BACK) then + begin + dec(FValue); + if (FValue < 0) then + FValue := pred(TOvcTCGlyph(FCell).FCellGlyphs.ActiveGlyphCount); + Invalidate; + Update; + + if ((@TOvcTCGlyph(FCell).FOnClick) <> nil) then + OnClick(Self); + end; + end; + end; +{--------} +procedure TOvcTCGlyphEdit.WMLButtonDown(var Msg : TWMMouse); + begin + inc(FValue); + if (FValue >= TOvcTCGlyph(FCell).FCellGlyphs.ActiveGlyphCount) then + FValue := 0; + Invalidate; + Update; + + inherited; + end; +{--------} +procedure TOvcTCGlyphEdit.WMKillFocus(var Msg : TWMKillFocus); + begin + inherited; + CellOwner.PostMessageToTable(ctim_KillFocus, Msg.FocusedWnd, 0); + end; +{--------} +procedure TOvcTCGlyphEdit.WMSetFocus(var Msg : TWMSetFocus); + begin + inherited; + CellOwner.PostMessageToTable(ctim_SetFocus, Msg.FocusedWnd, 0); + end; +{====================================================================} + + +end. diff --git a/components/orpheus/ovctchdr.pas b/components/orpheus/ovctchdr.pas new file mode 100644 index 000000000..c474f6063 --- /dev/null +++ b/components/orpheus/ovctchdr.pas @@ -0,0 +1,467 @@ +{*********************************************************} +{* OVCTCHDR.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovctchdr; + {Orpheus Table Cell - Headers for columns and rows} + +interface + +uses + {$IFNDEF LCL} Windows, {$ELSE} LclIntf, {$ENDIF} + SysUtils, Graphics, Classes, OvcTCmmn, OvcTCell, OvcTCStr; + +type + TOvcTCColHead = class(TOvcTCBaseString) + protected {private} + {.Z+} + FHeadings : TStringList; + FShowActiveCol : boolean; + FShowLetters : boolean; + {.Z-} + + protected + {.Z+} + procedure SetHeadings(H : TStringList); + procedure SetShowActiveCol(SAC : boolean); + procedure SetShowLetters(SL : boolean); + + procedure tcPaint(TableCanvas : TCanvas; + const CellRect : TRect; + RowNum : TRowNum; + ColNum : TColNum; + const CellAttr : TOvcCellAttributes; + Data : pointer); override; + {.Z-} + + public {protected} + {.Z+} + procedure chColumnsChanged(ColNum1, ColNum2 : TColNum; Action : TOvcTblActions); + {.Z-} + + public + constructor Create(AOwner : TComponent); override; + destructor Destroy; override; + + published + property Headings : TStringList + read FHeadings write SetHeadings; + + property ShowActiveCol : boolean + read FShowActiveCol write SetShowActiveCol + default False; + + property ShowLetters : boolean + read FShowLetters write SetShowLetters + default True; + + {properties inherited from custom ancestor} + property About; + property Adjust default otaDefault; + property Color; + property Font; + property Margin default 4; + property Table; + property TableColor default True; + property TableFont default True; + property TextHiColor default clBtnHighlight; + property TextStyle default tsFlat; + property UseASCIIZStrings default False; + property UseWordWrap default False; + + {events inherited from custom ancestor} + property OnClick; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEndDrag; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnOwnerDraw; + end; + + TOvcTCRowHead = class(TOvcTCBaseString) + protected {private} + {.Z+} + FShowActiveRow : boolean; + FShowNumbers : boolean; + {.Z-} + + protected + {.Z+} + procedure SetShowActiveRow(SAR : boolean); + procedure SetShowNumbers(SN : boolean); + procedure tcPaint(TableCanvas : TCanvas; + const CellRect : TRect; + RowNum : TRowNum; + ColNum : TColNum; + const CellAttr : TOvcCellAttributes; + Data : pointer); override; + {.Z-} + + public + constructor Create(AOwner : TComponent); override; + + published + property ShowActiveRow : boolean + read FShowActiveRow write SetShowActiveRow + default False; + + property ShowNumbers : boolean + read FShowNumbers write SetShowNumbers + default True; + + {properties inherited from custom ancestor} + property About; + property Adjust default otaDefault; + property Color; + property Font; + property Margin default 4; + property Table; + property TableColor default True; + property TableFont default True; + property TextHiColor default clBtnHighlight; + property TextStyle default tsFlat; + + {events inherited from custom ancestor} + property OnClick; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEndDrag; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnOwnerDraw; + end; + +implementation + + + +{===TOvcTCColHead====================================================} +constructor TOvcTCColHead.Create(AOwner : TComponent); + begin + inherited Create(AOwner); + FHeadings := TStringList.Create; + Access := otxReadOnly; + UseASCIIZStrings := false; + {UseWordWrap := false;} + ShowLetters := true; + end; +{--------} +destructor TOvcTCColHead.Destroy; + begin + FHeadings.Free; + inherited Destroy; + end; +{--------} +procedure TOvcTCColHead.chColumnsChanged(ColNum1, ColNum2 : TColNum; + Action : TOvcTblActions); + var + MaxColNum : TColNum; + ColNum : TColNum; + Temp : string; + begin + case Action of + taInsert : + if (0 <= ColNum1) and (ColNum1 < FHeadings.Count) then + FHeadings.Insert(ColNum1, '') + else if (ColNum1 = FHeadings.Count) then + FHeadings.Add(''); + taDelete : + if (0 <= ColNum1) and (ColNum1 < FHeadings.Count) then + FHeadings.Delete(ColNum1); + taExchange : + begin + MaxColNum := MaxL(ColNum1, ColNum2); + if (MaxColNum >= FHeadings.Count) and (FHeadings.Count > 0) then + for ColNum := FHeadings.Count to MaxColNum do + FHeadings.Add(''); + if (0 <= ColNum1) and (0 <= ColNum2) and + (FHeadings.Count > 0) then + begin + Temp := FHeadings[ColNum1]; + FHeadings[ColNum1] := FHeadings[ColNum2]; + FHeadings[ColNum2] := Temp; + end; + end; + end; + end; +{--------} +procedure TOvcTCColHead.tcPaint(TableCanvas : TCanvas; + const CellRect : TRect; + RowNum : TRowNum; + ColNum : TColNum; + const CellAttr : TOvcCellAttributes; + Data : pointer); + {------} + procedure PaintAnArrow; + var + ArrowDim : Integer; + X, Y : Integer; + LeftPoint, RightPoint, BottomPoint : TPoint; + CellWidth : integer; + CellHeight : integer; + begin + CellWidth := CellRect.Right - CellRect.Left; + CellHeight := CellRect.Bottom - CellRect.Top; + with TableCanvas do + begin + Pen.Color := CellAttr.caFont.Color; + Brush.Color := Pen.Color; + ArrowDim := MinI(CellWidth, CellHeight) div 3; + case CellAttr.caAdjust of + otaTopLeft, otaCenterLeft, otaBottomLeft: + X := Margin; + otaTopRight, otaCenterRight, otaBottomRight: + X := CellWidth-Margin-ArrowDim; + else + X := (CellWidth - ArrowDim) div 2; + end;{case} + inc(X, CellRect.Left); + case CellAttr.caAdjust of + otaTopLeft, otaTopCenter, otaTopRight: + Y := Margin; + otaBottomLeft, otaBottomCenter, otaBottomRight: + Y := CellHeight-Margin-ArrowDim; + else + Y := (CellHeight - ArrowDim) div 2; + end;{case} + inc(Y, CellRect.Top); + LeftPoint := Point(X, Y); + RightPoint := Point(X+ArrowDim, Y); + BottomPoint := Point(X+(ArrowDim div 2), Y+ArrowDim); + Polygon([LeftPoint, RightPoint, BottomPoint]); + end; + end; + {------} + var + DataSt : POvcShortString absolute Data; + LockedCols: TColNum; + ActiveCol : TColNum; + WorkCol : TColNum; + C : string[1]; + HeadSt : ShortString; + CA : TOvcCellAttributes; + begin + CA := CellAttr; + if Assigned(FTable) then + begin + LockedCols := tcRetrieveTableLockedCols; + ActiveCol := tcRetrieveTableActiveCol; + end + else + begin + LockedCols := 0; + ActiveCol := -1; + end; + HeadSt := ''; + { Set the cell color and font } + if not TableColor then + CA.caColor := Color; + if not TableFont then begin + CA.caFont.Assign(Font); + CA.caFontColor := Font.Color; + end; + { if required show a down arrow for the active column } + if ShowActiveCol and (ColNum = ActiveCol) then + begin + {this call to inherited tcPaint blanks out the cell} + inherited tcPaint(TableCanvas, CellRect, RowNum, ColNum, CA, + @HeadSt); + PaintAnArrow; + end + else if ShowLetters then + begin + {convert the column number to the spreadsheet-style letters} + WorkCol := ColNum - LockedCols + 1; + HeadSt := '.'; + while (WorkCol > 0) do + begin + C := AnsiChar(pred(WorkCol) mod 26 + ord('A')); + System.Insert(C, HeadSt, 1); + WorkCol := pred(WorkCol) div 26; + end; + Delete(HeadSt, length(HeadSt), 1); + inherited tcPaint(TableCanvas, CellRect, RowNum, ColNum, CA, + @HeadSt); + end + else {Data points to a column heading} + begin + if Assigned(Data) then + HeadSt := DataSt^ + else if (0 <= ColNum) and (ColNum < Headings.Count) then + HeadSt := Headings[ColNum]; + inherited tcPaint(TableCanvas, CellRect, RowNum, ColNum, CA, + @HeadSt); + end; + end; +{--------} +procedure TOvcTCColHead.SetHeadings(H : TStringList); + begin + FHeadings.Assign(H); + tcDoCfgChanged; + end; +{--------} +procedure TOvcTCColHead.SetShowActiveCol(SAC : boolean); + begin + if (SAC <> ShowActiveCol) then + begin + FShowActiveCol := SAC; + tcDoCfgChanged; + end; + end; +{--------} +procedure TOvcTCColHead.SetShowLetters(SL : boolean); + begin + if (SL <> ShowLetters) then + begin + FShowLetters := SL; + tcDoCfgChanged; + end; + end; +{====================================================================} + +{===TOvcTCRowHead====================================================} +constructor TOvcTCRowHead.Create(AOwner : TComponent); + begin + inherited Create(AOwner); + Access := otxReadOnly; + UseASCIIZStrings := false; + UseWordWrap := false; + ShowNumbers := true; + end; +{--------} +procedure TOvcTCRowHead.tcPaint(TableCanvas : TCanvas; + const CellRect : TRect; + RowNum : TRowNum; + ColNum : TColNum; + const CellAttr : TOvcCellAttributes; + Data : pointer); + {------} + procedure PaintAnArrow; + var + ArrowDim : Integer; + X, Y : Integer; + TopPoint, BottomPoint, RightPoint : TPoint; + CellWidth : integer; + CellHeight : integer; + begin + CellWidth := CellRect.Right - CellRect.Left; + CellHeight := CellRect.Bottom - CellRect.Top; + with TableCanvas do + begin + Pen.Color := CellAttr.caFont.Color; + Brush.Color := Pen.Color; + ArrowDim := MinI(CellWidth-8, CellHeight div 3); + case CellAttr.caAdjust of + otaTopLeft, otaCenterLeft, otaBottomLeft : X := Margin; + otaTopRight, otaCenterRight, otaBottomRight : X := CellWidth-Margin-ArrowDim; + else + X := (CellWidth - ArrowDim) div 2; + end;{case} + inc(X, CellRect.Left); + case CellAttr.caAdjust of + otaTopLeft, otaTopCenter, otaTopRight : Y := Margin; + otaBottomLeft, otaBottomCenter, otaBottomRight : Y := CellHeight-Margin-ArrowDim; + else + Y := (CellHeight - ArrowDim) div 2; + end;{case} + inc(Y, CellRect.Top); + TopPoint := Point(X, Y); + BottomPoint := Point(X, Y+ArrowDim); + RightPoint := Point(X+ArrowDim, Y+(ArrowDim div 2)); + Polygon([RightPoint, TopPoint, BottomPoint]); + end; + end; + {------} + var + HeadSt : ShortString; + ActiveRow : TRowNum; + LockedRows : TRowNum; + WorkRow : TRowNum; + begin + if Assigned(FTable) then + begin + LockedRows := tcRetrieveTableLockedRows; + ActiveRow := tcRetrieveTableActiveRow; + end + else + begin + LockedRows := 0; + ActiveRow := -1; + end; + {display the row number, etc} + HeadSt := ''; + if (ShowActiveRow and (RowNum = ActiveRow)) then + begin + inherited tcPaint(TableCanvas, CellRect, RowNum, ColNum, CellAttr, @HeadSt); + PaintAnArrow; + end + else + begin + if ShowNumbers then + begin + WorkRow := (RowNum + 1) - LockedRows; + HeadSt := Format('%d', [WorkRow]); + end; + inherited tcPaint(TableCanvas, CellRect, RowNum, ColNum, CellAttr, @HeadSt); + end; + end; +{--------} +procedure TOvcTCRowHead.SetShowActiveRow(SAR : boolean); + begin + if (SAR <> ShowActiveRow) then + begin + FShowActiveRow := SAR; + tcDoCfgChanged; + end; + end; +{--------} +procedure TOvcTCRowHead.SetShowNumbers(SN : boolean); + begin + if (SN <> ShowNumbers) then + begin + FShowNumbers := SN; + tcDoCfgChanged; + end; + end; +{====================================================================} + + +end. diff --git a/components/orpheus/ovctcico.pas b/components/orpheus/ovctcico.pas new file mode 100644 index 000000000..7904ff5bb --- /dev/null +++ b/components/orpheus/ovctcico.pas @@ -0,0 +1,147 @@ +{*********************************************************} +{* OVCTCICO.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovctcico; + {-Orpheus Table Cell - Icon type} + +interface + +uses + {$IFNDEF LCL} Windows, {$ELSE} LclIntf, {$ENDIF} + SysUtils, Messages, Graphics, Classes, OvcTCmmn, OvcTCell; + +type + TOvcTCCustomIcon = class(TOvcBaseTableCell) + protected + {.Z+} + procedure tcPaint(TableCanvas : TCanvas; + const CellRect : TRect; + RowNum : TRowNum; + ColNum : TColNum; + const CellAttr : TOvcCellAttributes; + Data : pointer); override; + {.Z-} + public + {.Z+} + procedure ResolveAttributes(RowNum : TRowNum; ColNum : TColNum; + var CellAttr : TOvcCellAttributes); override; + {.Z-} + end; + + TOvcTCIcon = class(TOvcTCCustomIcon) + published + {properties inherited from custom ancestor} + property AcceptActivationClick default False; + property Access default otxDefault; + property Adjust default otaDefault; + property Color; + property Margin default 4; + property Table; + property TableColor default True; + property OnOwnerDraw; + end; + + +implementation + + +{===TOvcTCBaseBitMap=================================================} +procedure TOvcTCCustomIcon.tcPaint(TableCanvas : TCanvas; + const CellRect : TRect; + RowNum : TRowNum; + ColNum : TColNum; + const CellAttr : TOvcCellAttributes; + Data : pointer); + var + Icon : TIcon absolute Data; + Wd, Ht : integer; + CellWidth : integer; + CellHeight : integer; + Left, Top : integer; + CellAdj : TOvcTblAdjust; + begin + {blank out the cell (also sets the brush color)} + inherited tcPaint(TableCanvas, CellRect, RowNum, ColNum, CellAttr, Data); + {nothing else to do if the data is nil or the cell in invisible} + if (Data = nil) or + (CellAttr.caAccess = otxInvisible) then + Exit; + {make a note of the adjustment, calc the cell width and height} + CellAdj := CellAttr.caAdjust; + CellWidth := CellRect.Right - CellRect.Left; + CellHeight := CellRect.Bottom - CellRect.Top; + {get the width/height of the icon} + with Icon do + begin + Wd := Width; + Ht := Height; + end; + {calculate the destination position} + case CellAdj of + otaTopLeft, otaCenterLeft, otaBottomLeft : + Left := Margin; + otaTopRight, otaCenterRight, otaBottomRight : + Left := (CellWidth - Wd - Margin); + else + Left := (CellWidth - Wd) div 2; + end;{case} + inc(Left, CellRect.Left); + case CellAdj of + otaTopLeft, otaTopCenter, otaTopRight : + Top := Margin; + otaBottomLeft, otaBottomCenter, otaBottomRight : + Top := (CellHeight - Ht - Margin); + else + Top := (CellHeight - Ht) div 2; + end;{case} + inc(Top, CellRect.Top); + + TableCanvas.Draw(Left, Top, Icon); + end; +{--------} +procedure TOvcTCCustomIcon.ResolveAttributes(RowNum : TRowNum; ColNum : TColNum; + var CellAttr : TOvcCellAttributes); + begin + inherited ResolveAttributes(RowNum, ColNum, CellAttr); + case CellAttr.caAccess of + otxDefault, otxNormal : CellAttr.caAccess := otxReadOnly; + end;{case} + end; +{====================================================================} + + +end. diff --git a/components/orpheus/ovctcmmn.pas b/components/orpheus/ovctcmmn.pas new file mode 100644 index 000000000..df720b0f0 --- /dev/null +++ b/components/orpheus/ovctcmmn.pas @@ -0,0 +1,812 @@ +{*********************************************************} +{* OVCTCMMN.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovctcmmn; + {-Orpheus table: common unit} + +interface + +uses + {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, LclType, MyMisc, {$ENDIF} + SysUtils, Graphics, Forms, StdCtrls, Classes, Controls, + OvcBase, OvcData, OvcExcpt; + +{---Enumeration types} +type + TOvcTblAdjust = ( {data adjustment in cell} + otaDefault, {the default for the next higher class} + otaTopLeft, {top left hand corner} + otaTopCenter, {top, centered horizontally} + otaTopRight, {top right hand corner} + otaCenterLeft, {left hand side, centered vertically} + otaCenter, {centered vertically and horizontally} + otaCenterRight, {right hand side, centered vertically} + otaBottomLeft, {bottom left hand corner} + otaBottomCenter, {bottom, centered horizontally} + otaBottomRight); {bottom right hand corner} + + TOvcTblAccess = ( {cell access types} + otxDefault, {the default for the next higher class} + otxNormal, {read & write} + otxReadOnly, {read only, no write} + otxInvisible); {no read or write, ie invisible} + + TOvcTblState = ( {grid states} + {..Major} + otsFocused, { focused, or cell being edited} + otsUnfocused, { unfocused} + otsDesigning, { being designed} + {..Minor} + otsNormal, { normal} + otsEditing, { cell being edited} + otsHiddenEdit, { ditto, however currently hidden} + otsMouseSelect, { mouse is selecting} + otsShowSize, { row/col sizing cursor shown} + otsSizing, { row/col being resized} + otsShowMove, { row/col move cursor shown} + otsMoving, { row/col is being moved} + {..Qualifiers} + otsDoingRow, { moving/sizing a row} + otsDoingCol, { moving/sizing a column} + + otsANOther); + TOvcTblStates = set of TOvcTblState; + + TOvcTblKeyNeeds = ( {grid's requirements for keystrokes} + otkDontCare, {grid does not need key} + otkWouldLike, {grid would like key, but cell can take it} + otkMustHave); {grid must have key} + + TOvcTblRegion = ( {table regions} + otrInMain, {..main table area} + otrInLocked, {..locked row or col area} + otrInUnused, {..unused bit} + otrOutside); {..outside table client area} + + TOvcTblOption = ( {table options} + otoBrowseRow, {Highlight row when browsing} + otoNoRowResizing, {No run-time row resizing allowed} + otoNoColResizing, {No run-time column resizing allowed} + otoTabToArrow, {Tab moves cell to right, ShiftTab left} + otoEnterToArrow, {Enter stops editing and moves cell right} + otoAlwaysEditing, {Edit mode is always active} + otoNoSelection, {No run-time selection allowed} + otoMouseDragSelect, {dragging with mouse selects} + otoRowSelection, {clicking on row header selects entire row} + otoColSelection, {clicking on column header selects entire column} + otoThumbTrack, {Scrollbar thumb-tracking} + otoAllowColMoves, {Enable column moves} + otoAllowRowMoves); {Enable row moves} + TOvcTblOptionSet = set of TOvcTblOption; + + TOvcScrollBar = ( {scroll bar identifiers} + otsbVertical, {..the vertical one} + otsbHorizontal); {..the horizontal one} + + TOvcTblActions = ( {configuration actions on rows/columns} + taGeneral, {..general} + taSingle, {..changing a single row/column} + taAll, {..changing all rows/columns} + taInsert, {..inserting a row/column} + taDelete, {..deleting a row/column} + taExchange); {..exchanging two rows/columns} + + TOvcCellDataPurpose = ( {OnGetCellData data request purpose} + cdpForPaint, {..for painting} + cdpForEdit, {..for editing} + cdpForSave); {..for saving an edited data} + + TOvcTextStyle = ( {text painting styles} + tsFlat, {..flat} + tsRaised, {..raised look} + tsLowered); {..lowered look} + + TOvcTblSelectionType = ( {Internal selection type} + tstDeselectAll, {..deselect all selections} + tstAdditional); {..additional selection/deselection} + + TOvcTblEditorStyle = ( {Table's cell editor style} + tesNormal, {..normal (ie nothing special)} + tesBorder, {..with border} + tes3D); {..3D look} + +{---Row/Column number (index) types} +type + TRowNum = longint; {actually 0..2 billion} + TColNum = integer; {actually 0..16K} + +{---record types for cells---} +type + PCellBitMapInfo = ^TCellBitMapInfo; + TCellBitMapInfo = packed record + BM : TBitMap; {bitmap object to display} + Count : integer; {number of glyphs} + ActiveCount : integer; {number of active glyphs} + Index : integer; {index of glyph to display} + end; + + PCellComboBoxInfo = ^TCellComboBoxInfo; + TCellComboBoxInfo = packed record + Index : integer; {index into Items list} + {$IFDEF CBuilder} + case integer of + 0 : (St : array[0..255] of char); + 1 : (RTItems : TStrings; + RTSt : array[0..255] of char); + {$ELSE} + case integer of + 0 : (St : ShortString); {string value if Index = -1} + 1 : (RTItems : TStrings; {run-time items list} + RTSt : ShortString); {run-time string value if Index = -1} + {$ENDIF} + end; + + TOvcCellAttributes = packed record {display attributes for a cell} + caAccess : TOvcTblAccess; {..access rights} + caAdjust : TOvcTblAdjust; {..data adjustment} + caColor : TColor; {..background color} + caFont : TFont; {..text font} + caFontColor : TColor; {..text color} + caFontHiColor : TColor; {..text highlight color} + caTextStyle : TOvcTextStyle; {..text style} + end; + + +{---Table cell ancestor---} + TOvcTableCellAncestor = class(TComponent) + protected {private} + {.Z+} + FOnCfgChanged : TNotifyEvent; + {.Z-} + protected + {.Z+} + procedure tcChangeScale(M, D : integer); dynamic; + procedure tcDoCfgChanged; + {.Z-} + public {protected} + {.Z+} + procedure tcResetTableValues; virtual; abstract; + property OnCfgChanged : TNotifyEvent + write FOnCfgChanged; + {.Z-} + public + end; + +{---Table ancestor---} + + TOvcTableAncestor = class(TO32CustomControl) + protected {private} + FController : TOvcController; + taCellList : TList; + taLoadList : TStringList; + + function ControllerAssigned : Boolean; + procedure SetController(Value : TOvcController); virtual; + + protected + procedure CreateWnd; + override; + procedure Notification(AComponent : TComponent; Operation : TOperation); + override; + + {streaming routines} + procedure ChangeScale(M, D : integer); override; + procedure DefineProperties(Filer : TFiler); override; + procedure Loaded; override; + + procedure tbFinishLoadingCellList; + procedure tbReadCellData(Reader : TReader); + procedure tbWriteCellData(Writer : TWriter); + + procedure tbCellChanged(Sender : TObject); virtual; abstract; + + public {protected} + {internal use only methods} + procedure tbExcludeCell(Cell : TOvcTableCellAncestor); + procedure tbIncludeCell(Cell : TOvcTableCellAncestor); + procedure tbNotifyCellsOfTableChange; + + public + constructor Create(AOwner : TComponent); override; + destructor Destroy; override; + + property Controller : TOvcController + read FController + write SetController; + + function FilterKey(var Msg : TWMKey) : TOvcTblKeyNeeds; virtual; abstract; + procedure ResolveCellAttributes(RowNum : TRowNum; ColNum : TColNum; + var CellAttr : TOvcCellAttributes); virtual; abstract; + end; + +type + POvcSparseAttr = ^TOvcSparseAttr; +{attributes for cells in sparse matrix--INTERNAL USE} + TOvcSparseAttr = packed record + scaAccess : TOvcTblAccess; + scaAdjust : TOvcTblAdjust; + scaColor : TColor; + scaFont : TFont; + scaCell : TOvcTableCellAncestor; + end; + + POvcTableNumberArray = ^TOvcTableNumberArray; +{structure passed to GetDisplayedRow(Col)Numbers} + TOvcTableNumberArray = packed record + NumElements : longint; {..number of elements in Number array} + Count : longint; {..return count of used elements in Number array} + Number : array [0..29] of longint; {..Number array} + end; + +{---Row style type} +type + PRowStyle = ^TRowStyle; + TRowStyle = packed record + Height : Integer; {-1 means default} + Hidden : boolean; + end; + +{---Short string type (length-byte string)} +type + POvcShortString = ^ShortString; {pointer to shortstring} + +{---Exception classes} +type + EOrpheusTable = class(Exception); + +{---Notification events} +type + TRowNotifyEvent = procedure (Sender : TObject; RowNum : TRowNum) of object; + TColNotifyEvent = procedure (Sender : TObject; ColNum : TColNum) of object; + TColResizeEvent = procedure ( Sender: TObject; ColNum : TColNum; + NewWidth: Integer) of object; + TRowResizeEvent = procedure ( Sender: TObject; RowNum : TRowNum; + NewHeight: Integer) of object; + TCellNotifyEvent = procedure (Sender : TObject; + RowNum : TRowNum; ColNum : TColNum) of object; + TCellDataNotifyEvent = procedure (Sender : TObject; + RowNum : TRowNum; ColNum : TColNum; + var Data : pointer; + Purpose : TOvcCellDataPurpose) of object; + TCellAttrNotifyEvent = procedure (Sender : TObject; + RowNum : TRowNum; ColNum : TColNum; + var CellAttr : TOvcCellAttributes) of object; + TCellPaintNotifyEvent = procedure (Sender : TObject; + TableCanvas : TCanvas; + const CellRect : TRect; + RowNum : TRowNum; + ColNum : TColNum; + const CellAttr : TOvcCellAttributes; + Data : pointer; + var DoneIt : boolean) of object; + TCellBeginEditNotifyEvent = procedure (Sender : TObject; + RowNum : TRowNum; ColNum : TColNum; + var AllowIt : boolean) of object; + TCellEndEditNotifyEvent = procedure (Sender : TObject; + Cell : TOvcTableCellAncestor; + RowNum : TRowNum; ColNum : TColNum; + var AllowIt : boolean) of object; + TCellMoveNotifyEvent = procedure (Sender : TObject; Command : word; + var RowNum : TRowNum; + var ColNum : TColNum) of object; + TCellChangeNotifyEvent = procedure (Sender : TObject; + var RowNum : TRowNum; + var ColNum : TColNum) of object; + TRowChangeNotifyEvent = procedure (Sender : TObject; RowNum1, RowNum2 : TRowNum; + Action : TOvcTblActions) of object; + TColChangeNotifyEvent = procedure (Sender : TObject; ColNum1, ColNum2 : TColNum; + Action : TOvcTblActions) of object; + TSizeCellEditorNotifyEvent = procedure (Sender : TObject; + RowNum : TRowNum; + ColNum : TColNum; + var CellRect : TRect; + var CellStyle: TOvcTblEditorStyle) of object; + TSelectionIterator = function(RowNum1 : TRowNum; ColNum1 : TColNum; + RowNum2 : TRowNum; ColNum2 : TColNum; + ExtraData : pointer) : boolean of object; + + +{---Cell-Table interaction messages---} +const + ctim_Base = WM_USER + $4545; + ctim_QueryOptions = ctim_Base; + ctim_QueryColor = ctim_Base + 1; + ctim_QueryFont = ctim_Base + 2; + ctim_QueryLockedCols = ctim_Base + 3; + ctim_QueryLockedRows = ctim_Base + 4; + ctim_QueryActiveCol = ctim_Base + 5; + ctim_QueryActiveRow = ctim_Base + 6; + + ctim_RemoveCell = ctim_Base + 10; + ctim_StartEdit = ctim_Base + 11; + ctim_StartEditMouse = ctim_Base + 12; + ctim_StartEditKey = ctim_Base + 13; + + ctim_SetFocus = ctim_Base + 14; + ctim_KillFocus = ctim_Base + 15; + + ctim_LoadDefaultCells = ctim_Base + 20; + +{---Property defaults} +const + tbDefAccess = otxNormal; + tbDefAdjust = otaCenterLeft; + tbDefBorderStyle = bsSingle; + tbDefColCount = 10; + tbDefColWidth = 150; + tbDefGridColor = clBlack; + tbDefHeight = 100; + tbDefLockedCols = 1; + tbDefLockedRows = 1; + tbDefMargin = 4; + tbDefRowCount = 10; + tbDefRowHeight = 30; + tbDefScrollBars = ssBoth; + tbDefTableColor = clBtnFace; + tbDefWidth = 300; + +{---Default color for cells (to force them to table color)} +const + clOvcTableDefault = $2FFFFFF; + +{---Handy extra constants for table's CalcRowColFromXY method} +const + CRCFXY_RowAbove = -2; {Y is above all table cells} + CRCFXY_RowBelow = -1; {Y is below all table cells} + CRCFXY_ColToLeft = -2; {X is to left of all table cells} + CRCFXY_ColToRight = -1; {X is to right of all table cells} + +{---Handy extra constants for TRowNum variables, Row Heights} +const + RowLimitChanged = -2; + UseDefHt = -1; + +type {internal use only} + TOvcTblDisplayItem = packed record + Number : longint; + Offset : Integer; + end; + POvcTblDisplayArray = ^TOvcTblDisplayArray; + TOvcTblDisplayArray = packed record + AllocNm : word; + Count : word; + Ay : array [0..127] of TOvcTblDisplayItem; {127 is arbitrary} + end; + +{--Utility routines} +function MinI(X, Y : Integer) : Integer; + {Return the minimum of two integers} +function MaxI(X, Y : Integer) : Integer; + {Return the maximum of two integers} +function MaxL(A, B : longint) : longint; +function MinL(A, B : longint) : longint; + +function MakeRowStyle(AHeight : Integer; AHidden : boolean) : TRowStyle; + {-Make a row style variable from a height and hidden flag.} + +procedure TableError(const Msg : string); + {-Raise an exception with supplied string} +procedure TableErrorRes(StringCode : word); + {-Raise an exception with supplied string resource code} + +procedure AssignDisplayArray(var A : POvcTblDisplayArray; Num : word); + {-Table internal: (re)assign a display array} + +implementation + +{===Standard routines================================================} +{$IFDEF NoAsm} +function MinI(X, Y : Integer) : Integer; +begin + if X < Y then + Result := X + else + Result := Y; +end; + +function MaxI(X, Y : Integer) : Integer; +begin + if X >= Y then + Result := X + else + Result := Y; +end; + +{$ELSE} +function MinI(X, Y : Integer) : Integer; + {Return the minimum of two integers} +asm + cmp eax, edx + jle @@Exit + mov eax, edx +@@Exit: +end; +{--------} +function MaxI(X, Y : Integer) : Integer; + {Return the maximum of two integers} +asm + cmp eax, edx + jge @@Exit + mov eax, edx +@@Exit: +end; +{$ENDIF} +{--------} +procedure TableError(const Msg : string); + begin + raise EOrpheusTable.Create(Msg); + end; +{--------} +procedure TableErrorRes(StringCode : word); + begin + raise EOrpheusTable.Create(GetOrphStr(StringCode)); + end; +{--------} +function MaxL(A, B : longint) : longint; + begin + if (A < B) then Result := B else Result := A; + end; +{--------} +function MinL(A, B : longint) : longint; + begin + if (A < B) then Result := A else Result := B; + end; +{--------} +procedure AssignDisplayArray(var A : POvcTblDisplayArray; Num : word); + var + NewA : POvcTblDisplayArray; + NumToXfer : word; + begin + NewA := nil; + if (Num > 0) then + begin + GetMem(NewA, Num*sizeof(TOvcTblDisplayItem)+2*sizeof(word)); + {$IFOPT D+} + FillChar(NewA^, Num*sizeof(TOvcTblDisplayItem)+2*sizeof(word), $CC); + {$ENDIF} + if Assigned(A) then + begin + NumToXfer := MinL(Num, A^.Count); + if (NumToXfer > 0) then + Move(A^.Ay, NewA^.Ay, NumToXFer*sizeof(TOvcTblDisplayItem)); + end + else + NumToXfer := 0; + with NewA^ do + begin + AllocNm := Num; + Count := NumToXfer; + end; + end; + if Assigned(A) then + FreeMem(A, A^.AllocNm*sizeof(TOvcTblDisplayItem)+2*sizeof(word)); + A := NewA; + end; +{--------} +function MakeRowStyle(AHeight : Integer; AHidden : boolean) : TRowStyle; + begin + with Result do + begin + Height := AHeight; + Hidden := AHidden; + end; + end; +{====================================================================} + + +{===TOvcTableCellAncestor============================================} +procedure TOvcTableCellAncestor.tcChangeScale(M, D : integer); + begin + {do nothing at this level in the cell component hierarchy} + end; +{--------} +procedure TOvcTableCellAncestor.tcDoCfgChanged; + begin + if Assigned(FOnCfgChanged) then + FOnCfgChanged(Self); + end; +{====================================================================} + + +{===TOvcTableAncestor================================================} +constructor TOvcTableAncestor.Create(AOwner : TComponent); + begin + inherited Create(AOwner); + taCellList := TList.Create; + end; +{--------} +destructor TOvcTableAncestor.Destroy; + begin + taLoadList.Free; + taCellList.Free; + inherited Destroy; + end; +{--------} + +function TOvcTableAncestor.ControllerAssigned : Boolean; +begin + Result := Assigned(FController); +end; + +procedure TOvcTableAncestor.CreateWnd; +var + OurForm : TWinControl; + +begin + OurForm := GetImmediateParentForm(Self); + + {do this only when the component is first dropped on the form, not during loading} + if (csDesigning in ComponentState) and not (csLoading in ComponentState) then + ResolveController(OurForm, FController); + + if not Assigned(FController) and not (csLoading in ComponentState) then begin + {try to find a controller on this form that we can use} + FController := FindController(OurForm); + + {if not found and we are not designing, use default controller} + if not Assigned(FController) and not (csDesigning in ComponentState) then + FController := DefaultController; + end; + + inherited CreateWnd; +end; + +procedure TOvcTableAncestor.Notification(AComponent : TComponent; Operation : TOperation); +begin + inherited Notification(AComponent, Operation); + + if Operation = opRemove then begin + if (AComponent = FController) then + FController := nil; + end else if (Operation = opInsert) and (FController = nil) and + (AComponent is TOvcController) then + FController := TOvcController(AComponent); +end; + +procedure TOvcTableAncestor.SetController(Value : TOvcController); +begin + FController := Value; + if Value <> nil then + Value.FreeNotification(Self); +end; + +procedure TOvcTableAncestor.ChangeScale(M, D : integer); + var + i : integer; + begin + inherited ChangeScale(M, D); + if (M <> D) then + for i := 0 to pred(taCellList.Count) do + TOvcTableCellAncestor(taCellList[i]).tcChangeScale(M, D); + end; +{--------} +procedure TOvcTableAncestor.DefineProperties(Filer : TFiler); + begin + inherited DefineProperties(Filer); + Filer.DefineProperty('CellData', tbReadCellData, tbWriteCellData, true); + end; +{--------} +procedure TOvcTableAncestor.tbExcludeCell(Cell : TOvcTableCellAncestor); + begin + taCellList.Remove(pointer(Cell)); + end; +{--------} +procedure TOvcTableAncestor.tbFinishLoadingCellList; + {Local methods} + function GetImmediateParentForm(Control : TControl) : TWinControl; + var + ParentCtrl : TControl; + begin + ParentCtrl := Control.Parent; + {$IFDEF VERSION5} + while Assigned(ParentCtrl) and + (not ((ParentCtrl is TCustomForm) or + (ParentCtrl is TCustomFrame))) do + ParentCtrl := ParentCtrl.Parent; + Result := TWinControl(ParentCtrl); + {$ELSE} + while Assigned(ParentCtrl) and (not (ParentCtrl is TCustomForm)) do + ParentCtrl := ParentCtrl.Parent; + Result := TForm(ParentCtrl); + {$ENDIF} + end; + + {------} + + function FormNamesEqual(const CmptFormName, FormName : string) : boolean; + var + PosUL : integer; + begin + Result := true; + if (FormName = '') or (CmptFormName = FormName) then + Exit; + PosUL := length(FormName); + while (PosUL > 0) and (FormName[PosUL] <> '_') do + dec(PosUL); + if (PosUL > 0) then + if (CmptFormName = Copy(FormName, 1, pred(PosUL))) then + Exit; + Result := false; + end; + {------} + + function GetFormName(const S, FormName : string) : string; + var + PosDot : integer; + begin + PosDot := Pos('.', S); + if (PosDot <> 0) then + Result := Copy(S, 1, pred(PosDot)) + else + Result := FormName; + end; + {------} + + function GetComponentName(const S : string) : string; + var + PosDot : integer; + begin + PosDot := Pos('.', S); + if (PosDot <> 0) then + Result := Copy(S, succ(PosDot), length(S)) + else + Result := S; + end; + {------} +var + i : integer; + Form : TWinControl; + Compnt : TComponent; + DM : integer; + DataMod: TDataModule; + DMCount: integer; +begin + if Assigned(taLoadList) then + begin + {fixup the cell component list: the cells now exist} + try + Form := GetImmediateParentForm(Self); + for i := pred(taLoadList.Count) downto 0 do + if FormNamesEqual(GetFormName(taLoadList[i], Form.Name), + Form.Name) then + begin + Compnt := Form.FindComponent(GetComponentName(taLoadList[i])); + if Assigned(Compnt) and (Compnt is TOvcTableCellAncestor) then + begin + tbIncludeCell(TOvcTableCellAncestor(Compnt)); + taLoadList.Delete(i); + end; + end; + {fixup references to cell components on any data modules} + if (taLoadList.Count <> 0) then + begin + DM := 0; +{$IFNDEF LCL} + DMCount := Screen.DataModuleCount; +{$ELSE} + DMCount := 0; +{$ENDIF} + while (taLoadList.Count > 0) and (DM < DMCount) do + begin +{$IFNDEF LCL} + DataMod := Screen.DataModules[DM]; +{$ENDIF} + for i := pred(taLoadList.Count) downto 0 do + if (GetFormName(taLoadList[i], Form.Name) = DataMod.Name) then + begin + Compnt := DataMod.FindComponent(GetComponentName(taLoadList[i])); + if Assigned(Compnt) and (Compnt is TOvcTableCellAncestor) then + begin + tbIncludeCell(TOvcTableCellAncestor(Compnt)); + taLoadList.Delete(i); + end; + end; + inc(DM); + end; + end; + finally + taLoadList.Free; + taLoadList := nil; + end; + end; +end; +{--------} +procedure TOvcTableAncestor.tbIncludeCell(Cell : TOvcTableCellAncestor); + begin + if Assigned(Cell) then + with taCellList do + if (IndexOf(pointer(Cell)) = -1) then + begin + Add(pointer(Cell)); + Cell.OnCfgChanged := tbCellChanged; + end; + end; +{--------} +procedure TOvcTableAncestor.Loaded; + begin + inherited Loaded; + end; +{--------} +procedure TOvcTableAncestor.tbNotifyCellsOfTableChange; + var + i : integer; + begin + if Assigned(taCellList) then + for i := 0 to pred(taCellList.Count) do + TOvcTableCellAncestor(taCellList[i]).tcResetTableValues; + end; +{--------} +procedure TOvcTableAncestor.tbReadCellData(Reader : TReader); + begin + if Assigned(taLoadList) then + taLoadList.Clear + else + taLoadList := TStringList.Create; + with Reader do + begin + ReadListBegin; + while not EndOfList do + taLoadList.Add(ReadString); + ReadListEnd; + end; + end; +{--------} +procedure TOvcTableAncestor.tbWriteCellData(Writer : TWriter); + var + i : integer; + Cell : TOvcTableCellAncestor; + S : string; + begin + with Writer do + begin + WriteListBegin; + for i := 0 to pred(taCellList.Count) do + begin + Cell := TOvcTableCellAncestor(taCellList[i]); + S := Cell.Owner.Name; + if (S <> '') then + S := S + '.' + Cell.Name + else + S := Cell.Name; + WriteString(S); + end; + WriteListEnd; + end; + end; +{====================================================================} + +end. diff --git a/components/orpheus/ovctcsim.pas b/components/orpheus/ovctcsim.pas new file mode 100644 index 000000000..41a20b5ef --- /dev/null +++ b/components/orpheus/ovctcsim.pas @@ -0,0 +1,294 @@ +{*********************************************************} +{* OVCTCSIM.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovctcsim; + {-Orpheus Table Cell - Simple field type} + +interface + +uses + {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, LclType, MyMisc, {$ENDIF} + SysUtils, Classes, Controls, + OvcData, OvcEF, OvcSF, OvcTCmmn, OvcTCell, OvcTCBEF, + Graphics; { - for default color definition} + +type + {The editor class for TOvcTCSimpleField cell components} + TOvcTCSimpleFieldEdit = class(TOvcSimpleField) + protected {private} + {.Z+} + FCell : TOvcBaseTableCell; + {.Z-} + + protected + {.Z+} + procedure efMoveFocusToNextField; override; + procedure efMoveFocusToPrevField; override; + + procedure WMChar(var Msg : TWMKey); message WM_CHAR; + procedure WMGetDlgCode(var Msg : TMessage); message WM_GETDLGCODE; + procedure WMKeyDown(var Msg : TWMKey); message WM_KEYDOWN; + procedure WMKillFocus(var Msg : TWMKillFocus); message WM_KILLFOCUS; + procedure WMSetFocus(var Msg : TWMSetFocus); message WM_SETFOCUS; + {.Z-} + + published + property CellOwner : TOvcBaseTableCell + read FCell write FCell; + end; + + {The simple field cell component class} + TOvcTCCustomSimpleField = class(TOvcTCBaseEntryField) + protected + {.Z+} + function GetCellEditor : TControl; override; + function GetDataType : TSimpleDataType; + function GetPictureMask : AnsiChar; + + procedure SetDataType(DT : TSimpleDataType); + procedure SetPictureMask(PM : AnsiChar); + {.Z-} + + property DataType : TSimpleDataType + read GetDataType write SetDataType; + + property PictureMask : AnsiChar + read GetPictureMask write SetPictureMask; + + public + function CreateEntryField(AOwner : TComponent) : TOvcBaseEntryField; override; + end; + + TOvcTCSimpleField = class(TOvcTCCustomSimpleField) + published + {properties inherited from custom ancestor} + property Access default otxDefault; + property Adjust default otaDefault; + property CaretIns; + property CaretOvr; + property Color; + property ControlCharColor default clRed; + property DataType default sftString; + property DecimalPlaces default 0; + property EFColors; + property Font; + property Hint; + property Margin default 4; + property MaxLength default 15; + property Options default [efoCaretToEnd, efoTrimBlanks]; + property PadChar default ' '; + property PasswordChar default '*'; + property PictureMask default 'X'; + property RangeHi stored False; + property RangeLo stored False; + property ShowHint default False; + property Table; + property TableColor default True; + property TableFont default True; + property TextHiColor default clBtnHighlight; + property TextMargin default 2; + property TextStyle default tsFlat; + + {events inherited from custom ancestor} + property OnChange; + property OnClick; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEndDrag; + property OnEnter; + property OnError; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnOwnerDraw; + property OnUserCommand; + property OnUserValidation; + end; + + +implementation + + +{===TOvcTCCustomSimpleField=========================================} +function TOvcTCCustomSimpleField.CreateEntryField(AOwner : TComponent) : TOvcBaseEntryField; + begin + Result := TOvcTCSimpleFieldEdit.Create(AOwner); + TOvcTCSimpleFieldEdit(Result).CellOwner := Self; + end; +{--------} +function TOvcTCCustomSimpleField.GetCellEditor : TControl; + begin + Result := FEdit; + end; +{--------} +function TOvcTCCustomSimpleField.GetDataType : TSimpleDataType; + begin + if Assigned(FEdit) then Result := TOvcTCSimpleFieldEdit(FEdit).DataType + else Result := sftString; + end; +{--------} +function TOvcTCCustomSimpleField.GetPictureMask : AnsiChar; + begin + if Assigned(FEdit) then Result := TOvcTCSimpleFieldEdit(FEdit).PictureMask + else Result := pmAnyChar; + end; +{--------} +procedure TOvcTCCustomSimpleField.SetDataType(DT : TSimpleDataType); + begin + if Assigned(FEdit) then + begin + TOvcTCSimpleFieldEdit(FEdit).DataType := DT; + TOvcTCSimpleFieldEdit(FEditDisplay).DataType := DT; + end; + end; +{--------} +procedure TOvcTCCustomSimpleField.SetPictureMask(PM : AnsiChar); + begin + if Assigned(FEdit) then + begin + TOvcTCSimpleFieldEdit(FEdit).PictureMask := PM; + TOvcTCSimpleFieldEdit(FEditDisplay).PictureMask := PM; + end; + end; +{====================================================================} + + +{===TOvcTCSimpleFieldEdit==============================================} +procedure TOvcTCSimpleFieldEdit.efMoveFocusToNextField; + var + Msg : TWMKey; + begin + FillChar(Msg, sizeof(Msg), 0); + with Msg do + begin + Msg := WM_KEYDOWN; + CharCode := VK_RIGHT; + end; + CellOwner.SendKeyToTable(Msg); + end; +{--------} +procedure TOvcTCSimpleFieldEdit.efMoveFocusToPrevField; + var + Msg : TWMKey; + begin + FillChar(Msg, sizeof(Msg), 0); + with Msg do + begin + Msg := WM_KEYDOWN; + CharCode := VK_LEFT; + end; + CellOwner.SendKeyToTable(Msg); + end; +{--------} +procedure TOvcTCSimpleFieldEdit.WMChar(var Msg : TWMKey); + begin + if (Msg.CharCode <> 9) then {filter tab characters} + inherited; + end; +{--------} +procedure TOvcTCSimpleFieldEdit.WMGetDlgCode(var Msg : TMessage); + begin +{$IFNDEF LCL} + inherited; +{$ELSE} + inherited WMGetDlgCode(TWMNoParams(Msg)); +{$ENDIF} + if CellOwner.TableWantsTab then + Msg.Result := Msg.Result or DLGC_WANTTAB; + if CellOwner.TableWantsEnter then + Msg.Result := Msg.Result or DLGC_WANTALLKEYS; + end; +{--------} +procedure TOvcTCSimpleFieldEdit.WMKeyDown(var Msg : TWMKey); + var + GridReply : TOvcTblKeyNeeds; + GridUsedIt : boolean; + begin + GridUsedIt := false; + GridReply := otkDontCare; + if (CellOwner <> nil) then + GridReply := CellOwner.FilterTableKey(Msg); + case GridReply of + otkMustHave : + begin + {the entry field must also process this key - to restore its contents} + if (Msg.CharCode = VK_ESCAPE) then + Restore; + + CellOwner.SendKeyToTable(Msg); + GridUsedIt := true; + end; + otkWouldLike : + case Msg.CharCode of + VK_PRIOR, VK_NEXT, VK_UP, VK_DOWN : + begin +// TurboPower bug. Next line commented out and next two lines inserted. +// if ValidateSelf then + if not ValidateSelf then //Added - don't pass key to ancestor? + Exit; //Added + begin + CellOwner.SendKeyToTable(Msg); + GridUsedIt := true; + end; + end; + {Note: VK_LEFT, VK_RIGHT are processed by efMoveFocusToNext(Next)Field} + end; + end;{case} + + if not GridUsedIt then + inherited; + end; +{--------} +procedure TOvcTCSimpleFieldEdit.WMKillFocus(var Msg : TWMKillFocus); + begin + inherited; + CellOwner.PostMessageToTable(ctim_KillFocus, Msg.FocusedWnd, LastError); + end; +{--------} +procedure TOvcTCSimpleFieldEdit.WMSetFocus(var Msg : TWMSetFocus); + begin + inherited; + CellOwner.PostMessageToTable(ctim_SetFocus, Msg.FocusedWnd, 0); + end; +{====================================================================} + +end. diff --git a/components/orpheus/ovctcstr.pas b/components/orpheus/ovctcstr.pas new file mode 100644 index 000000000..e332cc2c4 --- /dev/null +++ b/components/orpheus/ovctcstr.pas @@ -0,0 +1,261 @@ +{*********************************************************} +{* OVCTCSTR.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovctcstr; + {-Orpheus Table Cell - base string type} + +interface + +uses + {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, Types, LclType, MyMisc, {$ENDIF} + SysUtils, Graphics, Classes, OvcTCmmn, OvcTCell; + +type + TOvcTCBaseString = class(TOvcBaseTableCell) + protected {private} + {.Z+} + FUseASCIIZStrings : boolean; + FUseWordWrap : boolean; + + FOnChange : TNotifyEvent; + {.Z-} + + protected + {.Z+} + procedure SetUseASCIIZStrings(AZS : boolean); + procedure SetUseWordWrap(WW : boolean); + + procedure tcPaint(TableCanvas : TCanvas; + const CellRect : TRect; + RowNum : TRowNum; + ColNum : TColNum; + const CellAttr : TOvcCellAttributes; + Data : pointer); override; + procedure tcPaintStrZ(TblCanvas : TCanvas; + const CellRect : TRect; + const CellAttr : TOvcCellAttributes; + StZ : PAnsiChar); + {.Z-} + + {properties} + property UseASCIIZStrings : boolean + read FUseASCIIZStrings write SetUseASCIIZStrings; + + property UseWordWrap : boolean + read FUseWordWrap write SetUseWordWrap; + + {events} + property OnChange : TNotifyEvent + read FOnChange write FOnChange; + public + constructor Create(AOwner : TComponent); override; + end; + + +implementation + + +{===TOvcTCBaseString==========================================} +constructor TOvcTCBaseString.Create(AOwner : TComponent); + begin + inherited Create(AOwner); + end; + +procedure TOvcTCBaseString.tcPaint(TableCanvas : TCanvas; + const CellRect : TRect; + RowNum : TRowNum; + ColNum : TColNum; + const CellAttr : TOvcCellAttributes; + Data : pointer); + var + S : POvcShortString absolute Data; + SZ: PAnsiChar absolute Data; + StZ : PAnsiChar; + SAsPChar : array [0..255] of AnsiChar; + StZAllocated : boolean; + IsEmptyString : boolean; + + begin + {blank out the cell} + inherited tcPaint(TableCanvas, CellRect, RowNum, ColNum, CellAttr, Data); + {if the cell is invisible or the passed data is nil and we're not + designing, all's done} + if (CellAttr.caAccess = otxInvisible) or + ((Data = nil) and not (csDesigning in ComponentState)) then + Exit; + {prepare to paint the string} + StZAllocated := false; + {for a null string, output the row:column in that format} + if (Data = nil) then + begin + StZ := StrAlloc(32); {should be ample} + StZAllocated := true; + StrFmt(StZ, '%d:%d', [RowNum, ColNum]); + end + {for an ASCIIZ string, just go paint it} + else if UseASCIIZStrings then + StZ := SZ + {for a Pascal shortstring, convert to an ASCIIZ version} + else + StZ := StrPCopy(SAsPChar, S^); + IsEmptyString := (StZ[0] = #0); + {now paint the ASCIIZ string} + try + if not IsEmptyString then + tcPaintStrZ(TableCanvas, CellRect, CellAttr, StZ); + finally + if StZAllocated then + StrDispose(StZ); + end; + end; +{--------} +procedure TOvcTCBaseString.tcPaintStrZ(TblCanvas : TCanvas; + const CellRect : TRect; + const CellAttr : TOvcCellAttributes; + StZ : PAnsiChar); + var + Size : TSize; + var + Wd : integer; + LenStZ : integer; + DTOpts : Cardinal; + R : TRect; + OurAdjust : TOvcTblAdjust; + begin + TblCanvas.Font := CellAttr.caFont; + TblCanvas.Font.Color := CellAttr.caFontColor; + + LenStZ := StrLen(StZ); + + R := CellRect; + InflateRect(R, -Margin div 2, -Margin div 2); + + if FUseWordWrap then + begin + DTOpts:= DT_NOPREFIX or DT_WORDBREAK; + case CellAttr.caAdjust of + otaTopLeft, otaCenterLeft, otaBottomLeft : + DTOpts := DTOpts or DT_LEFT; + otaTopRight, otaCenterRight, otaBottomRight : + DTOpts := DTOpts or DT_RIGHT; + else + DTOpts := DTOpts or DT_CENTER; + end;{case} + end + else + begin + DTOpts:= DT_NOPREFIX or DT_SINGLELINE; + + {make sure that if the string doesn't fit, we at least see + the first few characters} + GetTextExtentPoint32(TblCanvas.Handle, StZ, LenStZ, Size); + Wd := Size.cX; + OurAdjust := CellAttr.caAdjust; + if Wd > (R.Right - R.Left) then + case CellAttr.caAdjust of + otaTopCenter, otaTopRight : OurAdjust := otaTopLeft; + otaCenter, otaCenterRight : OurAdjust := otaCenterLeft; + otaBottomCenter, otaBottomRight : OurAdjust := otaBottomLeft; + end; + + case OurAdjust of + otaTopLeft, otaCenterLeft, otaBottomLeft : + DTOpts := DTOpts or DT_LEFT; + otaTopRight, otaCenterRight, otaBottomRight : + DTOpts := DTOpts or DT_RIGHT; + else + DTOpts := DTOpts or DT_CENTER; + end;{case} + case OurAdjust of + otaTopLeft, otaTopCenter, otaTopRight : + DTOpts := DTOpts or DT_TOP; + otaBottomLeft, otaBottomCenter, otaBottomRight : + DTOpts := DTOpts or DT_BOTTOM; + else + DTOpts := DTOpts or DT_VCENTER; + end;{case} + end; + + case CellAttr.caTextStyle of + tsFlat : + DrawText(TblCanvas.Handle, StZ, LenStZ, R, DTOpts); + tsRaised : + begin + OffsetRect(R, -1, -1); + TblCanvas.Font.Color := CellAttr.caFontHiColor; + DrawText(TblCanvas.Handle, StZ, LenStZ, R, DTOpts); + OffsetRect(R, 1, 1); + TblCanvas.Font.Color := CellAttr.caFontColor; + TblCanvas.Brush.Style := bsClear; + DrawText(TblCanvas.Handle, StZ, LenStZ, R, DTOpts); + TblCanvas.Brush.Style := bsSolid; + end; + tsLowered : + begin + OffsetRect(R, 1, 1); + TblCanvas.Font.Color := CellAttr.caFontHiColor; + DrawText(TblCanvas.Handle, StZ, LenStZ, R, DTOpts); + OffsetRect(R, -1, -1); + TblCanvas.Font.Color := CellAttr.caFontColor; + TblCanvas.Brush.Style := bsClear; + DrawText(TblCanvas.Handle, StZ, LenStZ, R, DTOpts); + TblCanvas.Brush.Style := bsSolid; + end; + end; + end; +{--------} +procedure TOvcTCBaseString.SetUseASCIIZStrings(AZS : boolean); + begin + if (AZS <> FUseASCIIZStrings) then + begin + FUseASCIIZStrings := AZS; + tcDoCfgChanged; + end; + end; +{--------} +procedure TOvcTCBaseString.SetUseWordWrap(WW : boolean); + begin + if (WW <> FUseWordWrap) then + begin + FUseWordWrap := WW; + tcDoCfgChanged; + end; + end; +{====================================================================} + + +end. diff --git a/components/orpheus/ovctgpns.pas b/components/orpheus/ovctgpns.pas new file mode 100644 index 000000000..bce8b6095 --- /dev/null +++ b/components/orpheus/ovctgpns.pas @@ -0,0 +1,263 @@ +{*********************************************************} +{* OVCTGPNS.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovctgpns; + {-Orpheus Table - grid pens} + +interface + +uses + Classes, Graphics; + +type + TGridEffect = (geNone, geVertical, geHorizontal, geBoth, ge3D); + +type + TOvcGridPen = class(TPersistent) + protected {private} + {.Z+} + FNormalColor : TColor; + FSecondColor : TColor; + FEffect : TGridEffect; + FStyle : TPenStyle; + + FOnCfgChanged : TNotifyEvent; + {.Z-} + + protected + {.Z+} + procedure SetNormalColor(C : TColor); + procedure SetSecondColor(C : TColor); + procedure SetEffect(E : TGridEffect); + procedure SetStyle(S : TPenStyle); + + procedure DoCfgChanged; + {.Z-} + + public {protected} + {.Z+} + property OnCfgChanged : TNotifyEvent + read FOnCfgChanged write FOnCfgChanged; + {.Z-} + + public + constructor Create; + procedure Assign(Source : TPersistent); override; + + published + property NormalColor : TColor + read FNormalColor write SetNormalColor; + + property SecondColor : TColor + read FSecondColor write SetSecondColor + default clBtnHighlight; + + property Style : TPenStyle + read FStyle write SetStyle; + + property Effect : TGridEffect + read FEffect write SetEffect; + end; + + TOvcGridPenSet = class(TPersistent) + protected {private} + {.Z+} + FNormalGrid : TOvcGridPen; + FLockedGrid : TOvcGridPen; + FCellWhenFocused : TOvcGridPen; + FCellWhenUnfocused : TOvcGridPen; + {.Z-} + + protected + {.Z+} + procedure SetOnCfgChanged(OC : TNotifyEvent); + {.Z-} + + public {protected} + {.Z+} + property OnCfgChanged : TNotifyEvent + write SetOnCfgChanged; + {.Z-} + + public + constructor Create; + destructor Destroy; override; + + procedure Assign(Source : TPersistent); override; + + published + property NormalGrid : TOvcGridPen + read FNormalGrid write FNormalGrid; + + property LockedGrid : TOvcGridPen + read FLockedGrid write FLockedGrid; + + property CellWhenFocused : TOvcGridPen + read FCellWhenFocused write FCellWhenFocused; + + property CellWhenUnfocused : TOvcGridPen + read FCellWhenUnfocused write FCellWhenUnfocused; + end; + +implementation + + +{===TOvcGridPen==========================================================} +constructor TOvcGridPen.Create; + begin + FNormalColor := clBtnShadow; + FSecondColor := clBtnHighlight; + FStyle := psSolid; + FEffect := geBoth; + end; +{--------} +procedure TOvcGridPen.Assign(Source : TPersistent); + var + Src : TOvcGridPen absolute Source; + begin + if (Source is TOvcGridPen) then + begin + FNormalColor := Src.NormalColor; + FSecondColor := Src.SecondColor; + FStyle := Src.Style; + FEffect := Src.Effect; + DoCfgChanged; + end; + end; +{--------} +procedure TOvcGridPen.DoCfgChanged; + begin + if Assigned(FOnCfgChanged) then + OnCfgChanged(Self); + end; +{--------} +procedure TOvcGridPen.SetNormalColor(C : TColor); + begin + if (C <> FNormalColor) then + begin + FNormalColor := C; + DoCfgChanged; + end; + end; +{--------} +procedure TOvcGridPen.SetSecondColor(C : TColor); + begin + if (C <> FSecondColor) then + begin + FSecondColor := C; + DoCfgChanged; + end; + end; +{--------} +procedure TOvcGridPen.SetStyle(S : TPenStyle); + begin + if (S <> FStyle) then + begin + FStyle := S; + DoCfgChanged; + end; + end; +{--------} +procedure TOvcGridPen.SetEffect(E : TGridEffect); + begin + if (E <> FEffect) then + begin + FEffect := E; + DoCfgChanged; + end; + end; +{=====================================================================} + + +{===TOvcGridPenSet=======================================================} +constructor TOvcGridPenSet.Create; + begin + FNormalGrid := TOvcGridPen.Create; + with FNormalGrid do + begin + Style := psDot; + end; + FLockedGrid := TOvcGridPen.Create; + with FLockedGrid do + begin + Effect := ge3D; + end; + FCellWhenFocused := TOvcGridPen.Create; + with FCellWhenFocused do + begin + NormalColor := clBlack; + end; + FCellWhenUnfocused := TOvcGridPen.Create; + with FCellWhenUnfocused do + begin + NormalColor := clBlack; + Style := psDash; + end; + end; +{--------} +destructor TOvcGridPenSet.Destroy; + begin + FNormalGrid.Free; + FLockedGrid.Free; + FCellWhenFocused.Free; + FCellWhenUnfocused.Free; + end; +{--------} +procedure TOvcGridPenSet.Assign(Source : TPersistent); + var + Src : TOvcGridPenSet absolute Source; + begin + if (Source is TOvcGridPenSet) then + begin + FNormalGrid.Assign(Src.NormalGrid); + FLockedGrid.Assign(Src.LockedGrid); + FCellWhenFocused.Assign(Src.CellWhenFocused); + FCellWhenUnfocused.Assign(Src.CellWhenUnfocused); + end; + end; +{--------} +procedure TOvcGridPenSet.SetOnCfgChanged(OC : TNotifyEvent); + begin + FNormalGrid.OnCfgChanged := OC; + FLockedGrid.OnCfgChanged := OC; + FCellWhenFocused.OnCfgChanged := OC; + FCellWhenUnfocused.OnCfgChanged := OC; + end; +{=====================================================================} + + +end. diff --git a/components/orpheus/ovctgres.pas b/components/orpheus/ovctgres.pas new file mode 100644 index 000000000..294c20e24 --- /dev/null +++ b/components/orpheus/ovctgres.pas @@ -0,0 +1,373 @@ +{*********************************************************} +{* OVCTGRES.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovctgres; + {-Orpheus glyph resource manager} + +interface + +uses + {$IFNDEF LCL} Windows, {$ELSE} LclIntf, {$ENDIF} + SysUtils, Classes, Graphics, OvcMisc; + +type + TOvcCellGlyphs = class(TPersistent) + protected {private} + {.Z+} + FResource : pointer; + FActiveGlyphCount : Integer; + FGlyphCount : Integer; + FOnCfgChanged : TNotifyEvent; + {.Z-} + protected + {.Z+} + function GetBitMap : TBitMap; + function GetIsDefault : boolean; + procedure SetActiveGlyphCount(G : Integer); + procedure SetBitMap(BM : TBitMap); + procedure SetGlyphCount(G : Integer); + procedure SetIsDefault(D : boolean); + + procedure CalcGlyphCount; + function IsNotDefault : boolean; + procedure DoCfgChanged; + {.Z-} + public {protected} + {.Z+} + property OnCfgChanged : TNotifyEvent + read FOnCfgChanged write FOnCfgChanged; + {.Z-} + + public + constructor Create; + destructor Destroy; override; + + procedure Assign(Source : TPersistent); override; + + published + {Note: must be in this order--IsDefault, BitMap, GlyphCount, ActiveGlyphCount} + property IsDefault : boolean + read GetIsDefault write SetIsDefault + stored true; + + property BitMap : TBitMap + read GetBitMap write SetBitMap + stored IsNotDefault; + + property GlyphCount : Integer + read FGlyphCount write SetGlyphCount; + + property ActiveGlyphCount : Integer + read FActiveGlyphCount write SetActiveGlyphCount; + end; + +implementation + + +type + PCellGlyphResource = ^TCellGlyphResource; + TCellGlyphResource = packed record + BitMap : TBitMap; + ResourceCount : Integer; + Next : PCellGlyphResource; + end; + + TGlyphResourceManager = class + private + FList : PCellGlyphResource; + DefRes : PCellGlyphResource; + protected + public + constructor Create; + destructor Destroy; override; + + function AllocResource(BM : TBitMap) : PCellGlyphResource; + procedure FreeResource(CBGR : PCellGlyphResource); + function ReallocResource(ToCBGR, FromCBGR : PCellGlyphResource) : PCellGlyphResource; + function DefaultResource : PCellGlyphResource; + end; + +var + CBResMgr : TGlyphResourceManager; + +function CreateNewResource : PCellGlyphResource; + var + Size : Integer; + begin + Size := sizeof(TCellGlyphResource); + GetMem(Result, Size); + FillChar(Result^, Size, 0); + with Result^ do + begin + ResourceCount := 1; + end; + end; + +procedure DestroyResource(ARes : PCellGlyphResource); + begin + FreeMem(ARes, sizeof(TCellGlyphResource)); + end; + +{===TGlyphResourceManager=========================================} +constructor TGlyphResourceManager.Create; + begin + DefRes := CreateNewResource; + with DefRes^ do + begin + BitMap := TBitMap.Create; +{$IFNDEF LCL} + BitMap.Handle := LoadBaseBitmap('ORTCCHECKGLYPHS'); +{$ELSE} + BitMap.LoadFromLazarusResource('ORTCCHECKGLYPHS'); +{$ENDIF} + end; + FList := DefRes; + end; +{--------} +destructor TGlyphResourceManager.Destroy; + var + Temp : PCellGlyphResource; + begin + while Assigned(FList) do + begin + Temp := FList; + FList := Temp^.Next; + Temp^.BitMap.Free; + DestroyResource(Temp); + end; + end; +{--------} +function TGlyphResourceManager.AllocResource(BM : TBitMap) : PCellGlyphResource; + var + NewRes : PCellGlyphResource; + begin + NewRes := CreateNewResource; + with NewRes^ do + begin + BitMap := TBitMap.Create; + BitMap.Assign(BM); + Next := FList; + end; + FList := NewRes; + Result := NewRes; + end; +{--------} +procedure TGlyphResourceManager.FreeResource(CBGR : PCellGlyphResource); + var + Temp, Dad : PCellGlyphResource; + begin + Temp := FList; + Dad := nil; + while (Temp <> nil) do + if (Temp = CBGR) then + begin + dec(Temp^.ResourceCount); + if (Temp^.ResourceCount = 0) then + begin + with Temp^ do + begin + if (Dad = nil) then + FList := Next + else Dad^.Next := Next; + BitMap.Free; + end; + DestroyResource(Temp); + end; + Temp := nil; {get out of loop} + end + else + begin + Dad := Temp; + Temp := Temp^.Next; + end; + end; +{--------} +function TGlyphResourceManager.ReallocResource(ToCBGR, FromCBGR : PCellGlyphResource) + : PCellGlyphResource; + var + Temp : PCellGlyphResource; + begin + FreeResource(FromCBGR); + Temp := FList; + while (Temp <> nil) do + if (Temp = ToCBGR) then + begin + inc(Temp^.ResourceCount); + Result := Temp; + Exit; + end + else + Temp := Temp^.Next; + Result := DefaultResource; + end; +{--------} +function TGlyphResourceManager.DefaultResource : PCellGlyphResource; + begin + inc(DefRes^.ResourceCount); + Result := DefRes; + end; +{====================================================================} + +{===TOvcCellGlyphs==================================================} +constructor TOvcCellGlyphs.Create; + begin + FResource := CBResMgr.DefaultResource; + CalcGlyphCount; + end; +{--------} +destructor TOvcCellGlyphs.Destroy; + begin + CBResMgr.FreeResource(PCellGlyphResource(FResource)); + end; +{--------} +procedure TOvcCellGlyphs.Assign(Source : TPersistent); + begin + if Source is TOvcCellGlyphs then begin + if (Source = nil) then + begin + CBResMgr.FreeResource(PCellGlyphResource(FResource)); + FResource := CBResMgr.DefaultResource; + end + else if (FResource <> TOvcCellGlyphs(Source).FResource) then + FResource := + CBResMgr.ReallocResource(PCellGlyphResource(TOvcCellGlyphs(Source).FResource), + PCellGlyphResource(FResource)); + CalcGlyphCount; + DoCfgChanged + end else inherited Assign(Source); + end; +{--------} +procedure TOvcCellGlyphs.CalcGlyphCount; + var + Temp : Integer; + begin + FGlyphCount := 1; + FActiveGlyphCount := 1; + with BitMap do + begin + if (Height > 0) then + begin + Temp := Width div Height; + if ((Temp * Height) = Width) then + begin + FGlyphCount := Temp; + FActiveGlyphCount := Temp; + end; + end; + end; + end; +{--------} +function TOvcCellGlyphs.GetBitMap : TBitMap; + begin + with PCellGlyphResource(FResource)^ do + Result := Bitmap; + end; +{--------} +function TOvcCellGlyphs.GetIsDefault : boolean; + begin + Result := FResource = pointer(CBResMgr.DefRes); + end; +{--------} +function TOvcCellGlyphs.IsNotDefault : boolean; + begin + Result := not IsDefault; + end; +{--------} +procedure TOvcCellGlyphs.DoCfgChanged; + begin + if Assigned(FOnCfgChanged) then + FOnCfgChanged(Self); + end; +{--------} +procedure TOvcCellGlyphs.SetActiveGlyphCount(G : Integer); + begin + if (G <> FActiveGlyphCount) and + (1 <= G) and (G <= GlyphCount)then + begin + FActiveGlyphCount := G; + DoCfgChanged; + end; + end; +{--------} +procedure TOvcCellGlyphs.SetBitMap(BM : TBitMap); + begin + CBResMgr.FreeResource(PCellGlyphResource(FResource)); + if (BM = nil) then + FResource := CBResMgr.DefaultResource + else + FResource := CBResMgr.AllocResource(BM); + CalcGlyphCount; + DoCfgChanged; + end; +{--------} +procedure TOvcCellGlyphs.SetGlyphCount(G : Integer); + begin + if (G <> FGlyphCount) then + begin + FGlyphCount := G; + FActiveGlyphCount := G; + DoCfgChanged; + end; + end; +{--------} +procedure TOvcCellGlyphs.SetIsDefault(D : boolean); + begin + if (D <> IsDefault) then + begin + if D then + Assign(nil) + else + BitMap := BitMap; {note: this actually does do something!} + CalcGlyphCount; + DoCfgChanged; + end; + end; +{====================================================================} + + +procedure DestroyManager; far; + begin + CBResMgr.Free; + end; + + +initialization + CBResMgr := TGlyphResourceManager.Create; + +finalization + DestroyManager; +end. diff --git a/components/orpheus/ovctsell.pas b/components/orpheus/ovctsell.pas new file mode 100644 index 000000000..84c47a858 --- /dev/null +++ b/components/orpheus/ovctsell.pas @@ -0,0 +1,704 @@ +{*********************************************************} +{* OVCTSELL.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovctsell; + {-Table cell selection list class} + +{Notes: + + The TOvcSelectionList class implements a data structure that stores which + cells in a table are selected. The structure is implemented as an array + of (sub)arrays, each element of the outer array pertaining to a single + column. The items in each subarray are ranges of rows that are selected. + Thus if the cells (in (row,col) format) (1,1)..(2,3) are all selected, + the structure will look like this: + Column Value + 0 nil + 1 array with 1 element: range row 1 to row 2 + 2 array with 1 element: range row 1 to row 2 + 3 array with 1 element: range row 1 to row 2 + 4 nil + ... + Adding a new selected cell at (4,2) would add an element to the third + column's subarray: a range from row 4 to row 4. + + To check whether a cell is selected or not, get the element of the array + pertaining to the column. If nil, the cell is not selected. If not, + search through the ranges sequentially until the cell's row falls into a + range. + + Adding a selected cell (or cells) will generally add a new row range + element to the relevant column array, but it might cause row range + mergings. Deselecting a cell (or cells) might cause range splittings and + mergings. + + To aid in dynamic selection of cells, the class remembers the 'current + range'. The table using this class will set the anchor cell address and + then periodically set the new active cell; the difference between these + is the current range. The class will move the current range to the above + data structure when the anchor cell is set. IsCellSelected and + HaveSelection will both look at this current range as well as the data + structure. Note that the current range could be for selecting as well as + deselecting cells: there's a flag to define which. + + One important assumption has been made. This is that generally there are + 'few' selections (obviously one can imagine the fanatical user who is + determined to see 1000 separate disjoint selections, but normally there + will be one selection to maybe half a dozen). In other words it will be + more efficient to code a sequential search internally rather than a + binary one, and other similar types of speed improvements have not been + used. +} + +interface + +uses + {$IFNDEF LCL} Windows, {$ELSE} LclIntf, {$ENDIF} SysUtils, OvcTCmmn; + +type + TOvcSelRowRange = packed record {a row range} + L, H : TRowNum; + end; + + POvcSelRRArray = ^TOvcSelRRArray; {an array of row ranges} + TOvcSelRRArray = packed record + RRCount : integer; + RRTotal : integer; + RRs : array [0..(MaxInt div sizeof(TOvcSelRowRange))-2] of TOvcSelRowRange; + end; + + POvcSelColArray = ^TOvcSelColArray; {an array of arrays of row ranges} + TOvcSelColArray = array [0..(MaxInt div sizeof(POvcSelRRArray))-1] of POvcSelRRArray; + + TOvcSelectionList = class {class to manage list of selected cells} + protected {private} + {.Z+} + {even sized} + slArray : POvcSelColArray; {array of arrays of row ranges} + slColCount : TColNum; {number of columns in slArray} + slColWithSelCount : TColNum; {num of columns with at least 1 selected cell} + slActiveCol : TColNum; {current active cell-column} + slActiveRow : TColNum; { -row} + slAnchorCol : TColNum; {current anchor-column} + slAnchorRow : TColNum; { -row} + slRowCount : TRowNum; {number of rows in slArray} + slColMin : TColNum; {current range-minimum column} + slColMax : TColNum; { -maximum column} + slRowMin : TRowNum; { -minimum row} + slRowMax : TRowNum; { -maximum row} + {odd sized} + slSelecting : boolean; {current range is for selection} + slEmptyRange : boolean; {current range is empty} + {.Z-} + protected + {.Z+} + procedure slDeselectCellRangeInCol(Row1, Row2 : TRowNum; ColNum : TColNum); + procedure slSelectCellRangeInCol(Row1, Row2 : TRowNum; ColNum : TColNum); + {.Z-} + public + constructor Create(RowCount : TRowNum; ColCount : TColNum); + {-Create a new instance for RowCount rows & ColCount columns} + destructor Destroy; override; + {-Destroy the instance} + + procedure DeselectAll; + {-Deselect all cells} + procedure DeselectCell(RowNum : TRowNum; ColNum : TColNum); + {-Deselect a single cell} + procedure DeselectCellRange(FromRow : TRowNum; FromCol : TColNum; + ToRow : TRowNum; ToCol : TColNum); + {-Deselect a range of cells} + procedure ExtendRange(RowNum : TRowNum; ColNum : TColNum; + IsSelecting : boolean); + {-Extend/shrink the current range to RowNum, ColNum} + function HaveSelection : boolean; + {-Return true if at least one cell is selected} + function IsCellSelected(RowNum : TRowNum; ColNum : TColNum) : boolean; + {-Return true if specified cell is selected} + procedure Iterate(SI : TSelectionIterator; ExtraData : pointer); + {-Iterate through all the selection ranges calling SI for each} + procedure SelectAll; + {-Select all cells} + procedure SelectCell(RowNum : TRowNum; ColNum : TColNum); + {-Mark a single cell as selected} + procedure SelectCellRange(FromRow : TRowNum; FromCol : TColNum; + ToRow : TRowNum; ToCol : TColNum); + {-Mark a range of cells as selected} + procedure SetColCount(ColCount : TColNum); + {-Change the number of columns} + procedure SetRangeAnchor(RowNum : TRowNum; ColNum : TColNum; + Action : TOvcTblSelectionType); + {-Set the anchor cell; if Action is tstAdditional the current + selection is stored, if not all DeselectAll is called} + procedure SetRowCount(RowCount : TRowNum); + {-Change the number of rows} + end; + +implementation + +const + RRArrayInc = 16; + RRElemSize = sizeof(TOvcSelRowRange); + +{===Helper routines==================================================} +function CalcRRArraySize(ElementCount : integer) : integer; + {-Given a number of elements, calcs the memory block size} + begin + Result := (ElementCount * RRElemSize) + (2 * sizeof(integer)); + end; +{--------} +procedure AllocRRArray(var RRA : POvcSelRRArray); + {-Allocates/grows a row range array} + var + NewTotal : integer; + NewArray: POvcSelRRArray; + begin + {are we growing a current allocation?} + if Assigned(RRA) then + begin + NewTotal := RRA^.RRTotal + RRArrayInc; + NewArray := AllocMem(CalcRRArraySize(NewTotal)); + NewArray^.RRTotal := NewTotal; + NewArray^.RRCount := RRA^.RRCount; + Move(RRA^.RRs, NewArray^.RRs, RRA^.RRCount * RRElemSize); + FreeMem(RRA, CalcRRArraySize(RRA^.RRTotal)); + RRA := NewArray; + end + {otherwise this is a new allocation} + else + begin + RRA := AllocMem(CalcRRArraySize(RRArrayInc)); + RRA^.RRTotal := RRArrayInc; + end; + end; +{--------} +procedure FreeRRArray(var RRA : POvcSelRRArray); + {-Frees a row range array} + begin + {Note: assumes RRA is not nil} + FreeMem(RRA, CalcRRArraySize(RRA^.RRTotal)); + RRA := nil; + end; +{--------} +procedure ReallocColArray(var CA : POvcSelColArray; OldCC, NewCC : TColNum); + {-Reallocates (ie allocs or frees or grows) a column array} + var + NewArray : POvcSelColArray; + i : integer; + begin + {if there's no change, forget it} + if (NewCC = OldCC) then + Exit; + {if the new array size is greater then just copy over the + old array's contents after clearing the new array} + if (NewCC > OldCC) then + begin + NewArray := AllocMem(NewCC * sizeof(pointer)); + if (OldCC > 0) then + Move(CA^, NewArray^, OldCC * sizeof(pointer)); + end + {if the new array size is smaller then we have to dispose of + the subarrays that will no longer be used, then copy over + the remaining elements (if any).} + else + begin + for i := NewCC to pred(OldCC) do + if Assigned(CA^[i]) then + FreeRRArray(CA^[i]); + if (NewCC = 0) then + NewArray := nil + else + begin + GetMem(NewArray, NewCC * sizeof(pointer)); + Move(CA^, NewArray^, NewCC * sizeof(pointer)); + end; + end; + {dispose of the old array, return the new one} + if (OldCC > 0) then + FreeMem(CA, OldCC * sizeof(pointer)); + CA := NewArray; + end; +{====================================================================} + + +{===TOvcSelectionList================================================} +constructor TOvcSelectionList.Create(RowCount : TRowNum; ColCount : TColNum); + begin + {inherited Create;} + SetRowCount(RowCount); + SetColCount(ColCount); + end; +{--------} +destructor TOvcSelectionList.Destroy; + begin + SetColCount(0); + {inherited Destroy;} + end; +{--------} +procedure TOvcSelectionList.DeselectAll; + var + ColNum : TColNum; + begin + if (slColWithSelCount > 0) then + begin + for ColNum := 0 to pred(slColCount) do + if Assigned(slArray^[ColNum]) then + FreeRRArray(slArray^[ColNum]); + slColWithSelCount := 0; + end; + slEmptyRange := true; + end; +{--------} +procedure TOvcSelectionList.DeselectCell(RowNum : TRowNum; ColNum : TColNum); + begin + {sanity checks} + if (RowNum < 0) or (RowNum >= slRowCount) or + (ColNum < 0) or (ColNum >= slColCount) then + Exit; + {do it} + slDeselectCellRangeInCol(RowNum, RowNum, ColNum); + end; +{--------} +procedure TOvcSelectionList.DeselectCellRange(FromRow : TRowNum; FromCol : TColNum; + ToRow : TRowNum; ToCol : TColNum); + var + ColNum : TColNum; + SwapTemp : longint; + begin + {save the caller from himself: sort the rows/cols into ascending order} + if FromRow > ToRow then + begin + SwapTemp := FromRow; + FromRow := ToRow; + ToRow := SwapTemp; + end; + if FromCol > ToCol then + begin + SwapTemp := FromCol; + FromCol := ToCol; + ToCol := SwapTemp; + end; + {sanity checks} + if (FromRow < 0) or (FromRow >= slRowCount) or + (ToRow < 0) or (ToRow >= slRowCount) or + (FromCol < 0) or (FromCol >= slColCount) or + (ToCol < 0) or (ToCol >= slColCount) then + Exit; + {for each column, deselect cells in that column} + for ColNum := FromCol to ToCol do + slDeselectCellRangeInCol(FromRow, ToRow, ColNum); + end; +{--------} +{$IFDEF SuppressWarnings} +{$WARNINGS OFF} +{$ENDIF} +procedure TOvcSelectionList.slDeselectCellRangeInCol(Row1, Row2 : TRowNum; + ColNum : TColNum); + var + Inx : integer; + i : integer; + RRA : POvcSelRRArray; + MustDelete : boolean; + StillGoing : boolean; + begin + Inx := 0; + {take care of the simple special case first: there are no + selections in the column at all} + if (not Assigned(slArray^[ColNum])) then + Exit; + {make sure the array has at least one spare element: we could + be splitting a range} + RRA := slArray^[ColNum]; + if (RRA^.RRCount = RRA^.RRTotal) then + begin + AllocRRArray(RRA); + slArray^[ColNum] := RRA; + end; + {with this array} + with RRA^ do + begin + {search for the place to delete from} + MustDelete := false; + for i := 0 to pred(RRCount) do + if (Row1 < RRs[i].L) then + begin + MustDelete := true; + Inx := i; + Break;{out of for loop} + end + else if (Row1 <= RRs[i].H) then + begin + MustDelete := true; + Inx := succ(i); + Break;{out of for loop} + end; + + {if the range to deselect appears after all other + ranges, just exit, nothing to do} + if not MustDelete then + Exit; + {walk through the array starting at pred(Inx) + and split/remove as we go} + if (Inx > 0) then + dec(Inx); + StillGoing := true; + while StillGoing and (Inx < RRCount) do + if (RRs[Inx].L < Row1) then + if (RRs[Inx].H < Row1) then + inc(Inx) + else {H >= Row1} if (RRs[Inx].H > Row2) then + begin + {split, the deselect range is entirely within this range} + Move(RRs[Inx], RRs[succ(Inx)], (RRCount-Inx)*RRElemSize); + inc(RRCount); + RRs[Inx].H := pred(Row1); + RRs[succ(Inx)].L := succ(Row2); + StillGoing := false; + end + else {H >= Row1 and <= Row2} + begin + RRs[Inx].H := pred(Row1); + inc(Inx); + end + else {L >= Row1} if (RRs[Inx].L <= Row2) then + if (RRs[Inx].H > Row2) then + begin + RRs[Inx].L := succ(Row2); + StillGoing := false; + end + else {H <= Row2} + begin + {delete the range completely} + dec(RRCount); + Move(RRs[succ(Inx)], RRs[Inx], (RRCount-Inx)*RRElemSize); + end + else {L >= Row1 and > Row2} + StillGoing := false; + end; + {check to see whether we've managed to deselect every cell, if so + free the row range array} + if (RRA^.RRCount = 0) then + begin + FreeRRArray(slArray^[ColNum]); + dec(slColWithSelCount); + end; + end; +{$IFDEF SuppressWarnings} +{$WARNINGS ON} +{$ENDIF} +{--------} +procedure TOvcSelectionList.ExtendRange(RowNum : TRowNum; ColNum : TColNum; + IsSelecting : boolean); + begin + if (RowNum < 0) or (RowNum >= slRowCount) or + (ColNum < 0) or (ColNum >= slColCount) then + Exit; + slSelecting := IsSelecting; + slActiveRow := RowNum; + slActiveCol := ColNum; + slEmptyRange := (slAnchorRow = RowNum) and (slAnchorCol = ColNum); + if not slEmptyRange then + begin + slColMin := MinL(slAnchorCol, ColNum); + slColMax := MaxL(slAnchorCol, ColNum); + slRowMin := MinL(slAnchorRow, RowNum); + slRowMax := MaxL(slAnchorRow, RowNum); + end; + end; +{--------} +function TOvcSelectionList.HaveSelection : boolean; + begin + Result := (not slEmptyRange) or (slColWithSelCount <> 0); + end; +{--------} +function TOvcSelectionList.IsCellSelected(RowNum : TRowNum; ColNum : TColNum) : boolean; + var + i : integer; + begin + {assume false, the cell is not selected} + Result := false; + {sanity checks} + if (RowNum < 0) or (RowNum >= slRowCount) or + (ColNum < 0) or (ColNum >= slColCount) then + Exit; + {check in current range} + if (not slEmptyRange) then + if (slColMin <= ColNum) and (ColNum <= slColMax) and + (slRowMin <= RowNum) and (RowNum <= slRowMax) then + begin + Result := slSelecting; + Exit; + end; + {if the column array exists, search through it; note we use a + sequential search: it'll be faster than a binary search for a + 'few' elements, and generally there will be 'few' elements} + if Assigned(slArray^[ColNum]) then with slArray^[ColNum]^ do + for i := 0 to pred(RRCount) do + if (RRs[i].L <= RowNum) and (RowNum <= RRs[i].H) then + begin + Result := true; + Exit; + end; + end; +{--------} +procedure TOvcSelectionList.Iterate(SI : TSelectionIterator; ExtraData : pointer); + var + ColNum : TColNum; + RangeNum : integer; + begin + {fix the current range} + if not slEmptyRange then + begin + if slSelecting then + SelectCellRange(slRowMin, slColMin, slRowMax, slColMax) + else + DeselectCellRange(slRowMin, slColMin, slRowMax, slColMax); + slEmptyRange := true; + end; + {iterate through the ranges} + for ColNum := 0 to pred(slColCount) do + if Assigned(slArray^[ColNum]) then + with slArray^[ColNum]^ do + for RangeNum := 0 to pred(RRCount) do + if not SI(RRs[RangeNum].L, ColNum, RRs[RangeNum].H, ColNum, ExtraData) then + Exit; + end; +{--------} +procedure TOvcSelectionList.SelectAll; + var + ColNum : TColNum; + begin + for ColNum := 0 to pred(slColCount) do + begin + if not Assigned(slArray^[ColNum]) then + AllocRRArray(slArray^[ColNum]); + with slArray^[ColNum]^ do + begin + RRCount := 1; + RRs[0].L := 0; + RRs[0].H := pred(slRowCount); + end; + end; + slColWithSelCount := slColCount; + end; +{--------} +procedure TOvcSelectionList.SelectCell(RowNum : TRowNum; ColNum : TColNum); + begin + {sanity checks} + if (RowNum < 0) or (RowNum >= slRowCount) or + (ColNum < 0) or (ColNum >= slColCount) then + Exit; + {do it} + slSelectCellRangeInCol(RowNum, RowNum, ColNum); + end; +{--------} +procedure TOvcSelectionList.SelectCellRange(FromRow : TRowNum; FromCol : TColNum; + ToRow : TRowNum; ToCol : TColNum); + var + ColNum : TColNum; + SwapTemp : longint; + begin + {save the caller from himself: sort the rows/cols into ascending order} + if FromRow > ToRow then + begin + SwapTemp := FromRow; + FromRow := ToRow; + ToRow := SwapTemp; + end; + if FromCol > ToCol then + begin + SwapTemp := FromCol; + FromCol := ToCol; + ToCol := SwapTemp; + end; + {sanity checks} + if (FromRow < 0) or (FromRow >= slRowCount) or + (ToRow < 0) or (ToRow >= slRowCount) or + (FromCol < 0) or (FromCol >= slColCount) or + (ToCol < 0) or (ToCol >= slColCount) then + Exit; + {for each column, select cells in that column} + for ColNum := FromCol to ToCol do + slSelectCellRangeInCol(FromRow, ToRow, ColNum); + end; +{--------} +{$IFDEF SuppressWarnings} +{$WARNINGS OFF} +{$ENDIF} +procedure TOvcSelectionList.slSelectCellRangeInCol(Row1, Row2 : TRowNum; + ColNum : TColNum); + var + i : integer; + Inx : integer; + NextInx : integer; + RRA : POvcSelRRArray; + MustInsert : boolean; + StillGoing : boolean; + AlreadyMerged: boolean; + begin + Inx := 0; + {take care of the simple special case first: there are no + selections in the column as yet} + if (not Assigned(slArray^[ColNum])) then + begin + AllocRRArray(slArray^[ColNum]); + inc(slColWithSelCount); + with slArray^[ColNum]^ do + begin + RRCount := 1; + RRs[0].L := Row1; + RRs[0].H := Row2; + end; + Exit; + end; + {make sure the array has at least one spare element} + RRA := slArray^[ColNum]; + if (RRA^.RRCount = RRA^.RRTotal) then + begin + AllocRRArray(RRA); + slArray^[ColNum] := RRA; + end; + {with this array} + with RRA^ do + begin + {search for the place to insert/merge} + MustInsert := false; + for i := 0 to pred(RRCount) do + if (Row1 < RRs[i].L) then + begin + MustInsert := true; + Inx := i; + Break;{out of for loop} + end; + {if the new range appears after all the other ranges, add it + to the end of the list; check to be able to merge it first} + if not MustInsert then + begin + if (Row1 <= succ(RRs[pred(RRCount)].H)) then + RRs[pred(RRCount)].H := MaxL(Row2, RRs[pred(RRCount)].H) + else + begin + RRs[RRCount].L := Row1; + RRs[RRCount].H := Row2; + inc(RRCount); + end; + Exit; + end; + {otherwise we must insert; first insert the new range} + Move(RRs[Inx], RRs[succ(Inx)], (RRCount-Inx) * RRElemSize); + RRs[Inx].L := Row1; + RRs[Inx].H := Row2; + inc(RRCount); + {now walk through the array starting at pred(Inx) and merge + ranges as we move forward} + if (Inx > 0) then + dec(Inx); + NextInx := succ(Inx); + AlreadyMerged := false; + StillGoing := true; + while StillGoing and (NextInx < RRCount) do + begin + if (succ(RRs[Inx].H) >= RRs[NextInx].L) then + begin + RRs[Inx].H := MaxL(RRs[Inx].H, RRs[NextInx].H); + inc(NextInx); + AlreadyMerged := true; + end + else if AlreadyMerged then + StillGoing := false + else + begin + inc(Inx); + inc(NextInx); + AlreadyMerged := true; + end; + end; + {by this point we know we must get rid of the elements + in between Inx and NextInx -- they've been merged into + other ranges} + if ((NextInx - Inx) > 1) then + begin + if (NextInx < RRCount) then + Move(RRs[NextInx], RRs[succ(Inx)], (RRCount-NextInx)*RRElemSize); + dec(RRCount, NextInx - Inx - 1); + end; + end; + end; +{$IFDEF SuppressWarnings} +{$WARNINGS ON} +{$ENDIF} +{--------} +procedure TOvcSelectionList.SetRangeAnchor(RowNum : TRowNum; ColNum : TColNum; + Action : TOvcTblSelectionType); + begin + {sanity checks} + if (RowNum < 0) or (RowNum >= slRowCount) or + (ColNum < 0) or (ColNum >= slColCount) then + Exit; + {what's happening? deselecting all, or adding a new range} + if (Action = tstDeselectAll) then + DeselectAll + else {an additional range is being set up} + if not slEmptyRange then + if slSelecting then + SelectCellRange(slRowMin, slColMin, slRowMax, slColMax) + else + DeselectCellRange(slRowMin, slColMin, slRowMax, slColMax); + slAnchorRow := RowNum; + slAnchorCol := ColNum; + slActiveRow := RowNum; + slActiveCol := ColNum; + slEmptyRange := true; + end; +{--------} +procedure TOvcSelectionList.SetColCount(ColCount : TColNum); + begin + if (ColCount >= 0) then + begin + ReallocColArray(slArray, slColCount, ColCount); + slColCount := ColCount; + end; + end; +{--------} +procedure TOvcSelectionList.SetRowCount(RowCount : TRowNum); + begin + if (RowCount >= 0) then + slRowCount := RowCount; + end; +{====================================================================} + +end. diff --git a/components/orpheus/ovcurl.pas b/components/orpheus/ovcurl.pas new file mode 100644 index 000000000..0ceb16ba0 --- /dev/null +++ b/components/orpheus/ovcurl.pas @@ -0,0 +1,310 @@ +{*********************************************************} +{* OVCURL.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +(*Changes) + + 01/23/02 - Added UnderlineURL property. +*) + + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovcurl; + {-URL label} + +interface + +uses + {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, LclType, MyMisc, {$ENDIF} + Classes, Controls, Dialogs, ExtCtrls, Graphics, Menus, + {$IFDEF MSWINDOWS} ShellAPI, {$ELSE} Unix, {$ENDIF} + StdCtrls, SysUtils, OvcVer; + +type + TOvcURL = class(TCustomLabel) + protected {private} + FCaption : string; + FHighlightColor : TColor; + FURL : string; + FUseVisitedColor : Boolean; + FVisitedColor : TColor; + + {internal variables} + urlTimer : TTimer; + urlFontColor : TColor; + + {property methods} + function GetAbout : string; + function GetUnderlineURL: Boolean; + procedure SetAbout(const Value : string); + procedure SetCaption(const Value : string); + procedure SetHighlightColor(const Value : TColor); + procedure SetUnderlineURL(Value: Boolean); + procedure SetURL(const Value : string); + procedure SetVisitedColor(const Value : TColor); + + {internal methods} + procedure TimerEvent(Sender : TObject); + + procedure Loaded; override; + + protected + procedure MouseMove(Shift : TShiftState; X, Y : Integer); + override; + + public + procedure Click; + override; + constructor Create(AOwner : TComponent); + override; + destructor Destroy; + override; + + published + property About : string + read GetAbout write SetAbout stored False; + property Caption : string + read FCaption write SetCaption; + property HighlightColor : TColor + read FHighlightColor write SetHighlightColor + default clRed; + property UnderlineURL: Boolean + read GetUnderlineURL write SetUnderlineURL + stored False; + property URL : string + read FURL write SetURL; + property UseVisitedColor : Boolean + read FUseVisitedColor write FUseVisitedColor + default False; + property VisitedColor : TColor + read FVisitedColor write SetVisitedColor + stored FUseVisitedColor + default clBlack; + + {$IFDEF VERSION4} + property Anchors; + property Constraints; + property DragKind; + {$ENDIF} + property Align; + property Alignment; + property AutoSize; + property Color; + property Cursor default crHandPoint; + property DragCursor; + property DragMode; + property Enabled; + property FocusControl; + property Font; + property ParentColor; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ShowAccelChar; + property ShowHint; + property Transparent default False; + property Layout; + property Visible; + property WordWrap; + property OnClick; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEndDrag; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnStartDrag; + end; + + +implementation + +const + BadColor = $02000000; + +{*** TOvcURL ***} +procedure TOvcURL.Loaded; +begin + inherited Loaded; + +// Font.Style := Font.Style + [fsUnderline]; + urlFontColor := BadColor; +end; + +procedure TOvcURL.Click; +{$IFDEF MSWINDOWS} +var + Buf : array[0..1023] of Char; +begin + if URL > '' then begin + StrPLCopy(Buf, URL, SizeOf(Buf)-1); + if ShellExecute(0, 'open', Buf, '', '', SW_SHOWNORMAL) <= 32 then + MessageBeep(0); + end; +{$ELSE} +begin + if URL > '' then begin + {$IFDEF DARWIN} + if Shell('Open ' + URL) = 127 then + MessageBeep(0); + {$ELSE} + if (GetBrowserPath = '') or + (Shell(GetBrowserPath + ' ' + URL) = 127) then + MessageBeep(0); + {$ENDIF} + end; +{$ENDIF} + + inherited Click; + + {change color to visited color if enabled} + if FUseVisitedColor then + urlFontColor := FVisitedColor; +end; + +constructor TOvcURL.Create(AOwner : TComponent); +begin + inherited Create(AOwner); + FHighlightColor := clRed; + Cursor := crHandPoint; + Font.Style := Font.Style + [fsUnderline]; +end; + +destructor TOvcURL.Destroy; +begin + if Assigned(urlTimer) then begin + urlTimer.Free; + urlTimer := nil; + end; + + inherited Destroy; +end; + +function TOvcURL.GetAbout : string; +begin + Result := OrVersionStr; +end; + +function TOvcURL.GetUnderlineURL: Boolean; +begin + result := fsUnderline in Font.Style; +end; + +procedure TOvcURL.MouseMove(Shift : TShiftState; X, Y : Integer); +begin + inherited MouseMove(Shift, X, Y); + + if PtInRect(ClientRect, Point(X, Y)) then begin + if not Assigned(urlTimer) then begin + {save current font color} + if urlFontColor = BadColor then + urlFontColor := Font.Color; + Font.Color := FHighlightColor; + urlTimer := TTimer.Create(Self); + urlTimer.Interval := 100; + urlTimer.OnTimer := TimerEvent; + urlTimer.Enabled := True; + end; + end; +end; + +procedure TOvcURL.SetAbout(const Value : string); +begin +end; + +procedure TOvcURL.SetCaption(const Value : string); +begin + FCaption := Value; + if FCaption > '' then + inherited Caption := FCaption + else + inherited Caption := URL; +end; + +procedure TOvcURL.SetHighlightColor(const Value: TColor); +begin + if Value = clNone then + FHighlightColor := Font.Color + else + FHighlightColor := Value; + + {reset stored color} + urlFontColor := BadColor; +end; + +{ - added} +procedure TOvcURL.SetUnderlineURL(Value: Boolean); +begin + if Value then + Font.Style := Font.Style + [fsUnderline] + else + Font.Style := Font.Style - [fsUnderline]; +end; + +procedure TOvcURL.SetURL(const Value : string); +begin + FURL := Value; + if FCaption = '' then + inherited Caption := URL; +end; + +procedure TOvcURL.SetVisitedColor(const Value : TColor); +begin + if Value = clNone then + FVisitedColor := Font.Color + else + FVisitedColor := Value; + + {reset stored color} + urlFontColor := BadColor; +end; + +procedure TOvcURL.TimerEvent(Sender : TObject); +var + Pt : TPoint; +begin + GetCursorPos(Pt); + Pt := ScreentoClient(Pt); + if not PtInRect(ClientRect, Pt) then begin + urlTimer.Free; + urlTimer := nil; + Font.Color := urlFontColor; + Repaint; + end; +end; + + +end. diff --git a/components/orpheus/ovcuser.pas b/components/orpheus/ovcuser.pas new file mode 100644 index 000000000..4c60b1453 --- /dev/null +++ b/components/orpheus/ovcuser.pas @@ -0,0 +1,186 @@ +{*********************************************************} +{* OVCUSER.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovcuser; + {-User data class} + +interface + +uses + SysUtils, + OvcData; + +type + {class for implementing user-defined mask and substitution characters} + TOvcUserData = class(TObject) + {.Z+} + protected {private} + FUserCharSets : TUserCharSets; + FForceCase : TForceCase; + FSubstChars : TSubstChars; + + {property methods} + function GetForceCase(Index : TForceCaseRange) : TCaseChange; + {-get the case changing behavior of the specified user mask character} + function GetSubstChar(Index : TSubstCharRange) : AnsiChar; + {-get the meaning of the specified substitution character} + function GetUserCharSet(Index : TUserSetRange) : TCharSet; + {-get the specified user-defined character set} + procedure SetForceCase(Index : TForceCaseRange; CC : TCaseChange); + {-set the case changing behavior of the specified user mask character} + procedure SetSubstChar(Index : TSubstCharRange; SC : AnsiChar); + {-set the meaning of the specified substitution character} + procedure SetUserCharSet(Index : TUserSetRange; const US : TCharSet); + {-set the specified user-defined character set} + + public + constructor Create; + {.Z+} + + property ForceCase[Index : TForceCaseRange] : TCaseChange + read GetForceCase + write SetForceCase; + + property SubstChars[Index : TSubstCharRange] : AnsiChar + read GetSubstChar + write SetSubstChar; + + property UserCharSet[Index : TUserSetRange] : TCharSet + read GetUserCharSet + write SetUserCharSet; + end; + +var + {global default user data object} + OvcUserData : TOvcUserData; + + +implementation + + +{*** TOvcUserData ***} + +const + DefUserCharSets : TUserCharSets = ( + {User1} [#1..#255], {User2} [#1..#255], {User3} [#1..#255], + {User4} [#1..#255], {User5} [#1..#255], {User6} [#1..#255], + {User7} [#1..#255], {User8} [#1..#255] ); + + DefForceCase : TForceCase = ( + mcNoChange, mcNoChange, mcNoChange, mcNoChange, + mcNoChange, mcNoChange, mcNoChange, mcNoChange); + + DefSubstChars : TSubstChars = ( + Subst1, Subst2, Subst3, Subst4, Subst5, Subst6, Subst7, Subst8); + +constructor TOvcUserData.Create; +begin + inherited Create; + + FUserCharSets := DefUserCharSets; + FForceCase := DefForceCase; + FSubstChars := DefSubstChars; +end; + +function TOvcUserData.GetForceCase(Index : TForceCaseRange) : TCaseChange; + {-get the case changing behavior of the specified user mask character} +begin + case Index of + pmUser1..pmUser8 : Result := FForceCase[Index]; + else + Result := mcNoChange; + end; +end; + +function TOvcUserData.GetSubstChar(Index : TSubstCharRange) : AnsiChar; + {-get the meaning of the specified substitution character} +begin + case Index of + Subst1..Subst8 : Result := FSubstChars[Index]; + else + Result := #0; + end; +end; + +function TOvcUserData.GetUserCharSet(Index : TUserSetRange) : TCharSet; + {-get the specified user-defined character set} +begin + case Index of + pmUser1..pmUser8 : Result := FUserCharSets[Index]; + end; +end; + +procedure TOvcUserData.SetForceCase(Index : TForceCaseRange; CC : TCaseChange); + {-set the case changing behavior of the specified user mask character} +begin + case Index of + pmUser1..pmUser8 : FForceCase[Index] := CC; + end; +end; + +procedure TOvcUserData.SetSubstChar(Index : TSubstCharRange; SC : AnsiChar); + {-set the meaning of the specified substitution character} +begin + case Index of + Subst1..Subst8 : FSubstChars[Index] := SC; + end; +end; + +procedure TOvcUserData.SetUserCharSet(Index : TUserSetRange; const US : TCharSet); + {-set the specified user-defined character set} +begin + case Index of + pmUser1..pmUser8 : FUserCharSets[Index] := US-[#0]; + end; +end; + + +{*** exit procedure ***} + +procedure DestroyGlobalUserData; far; +begin + OvcUserData.Free +end; + + +initialization + {create instance of default user data class} + OvcUserData := TOvcUserData.Create; + +finalization + DestroyGlobalUserData; +end. diff --git a/components/orpheus/ovcver.pas b/components/orpheus/ovcver.pas new file mode 100644 index 000000000..f8f647c14 --- /dev/null +++ b/components/orpheus/ovcver.pas @@ -0,0 +1,48 @@ +{*********************************************************} +{* OVCVER.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I OVC.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} + +unit ovcver; + {-Versioning defines and methods} + +interface + +const + OrVersionStr = 'v4.06'; + +implementation + +end. diff --git a/components/orpheus/ovcvlb.pas b/components/orpheus/ovcvlb.pas new file mode 100644 index 000000000..66836365f --- /dev/null +++ b/components/orpheus/ovcvlb.pas @@ -0,0 +1,2490 @@ +{*********************************************************} +{* OVCVLB.PAS 4.06 *} +{*********************************************************} + +{* ***** BEGIN LICENSE BLOCK ***** *} +{* Version: MPL 1.1 *} +{* *} +{* The contents of this file are subject to the Mozilla Public License *} +{* Version 1.1 (the "License"); you may not use this file except in *} +{* compliance with the License. You may obtain a copy of the License at *} +{* http://www.mozilla.org/MPL/ *} +{* *} +{* Software distributed under the License is distributed on an "AS IS" basis, *} +{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} +{* for the specific language governing rights and limitations under the *} +{* License. *} +{* *} +{* The Original Code is TurboPower Orpheus *} +{* *} +{* The Initial Developer of the Original Code is TurboPower Software *} +{* *} +{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} +{* TurboPower Software Inc. All Rights Reserved. *} +{* *} +{* Contributor(s): *} +{* *} +{* ***** END LICENSE BLOCK ***** *} + +{$I Ovc.INC} + +{$B-} {Complete Boolean Evaluation} +{$I+} {Input/Output-Checking} +{$P+} {Open Parameters} +{$T-} {Typed @ Operator} +{.W-} {Windows Stack Frame} +{$X+} {Extended Syntax} +//{$Q-} {Arithmatic-Overflow Checking} <== Does this hide Turbopower bugs? + +unit ovcvlb; + {-Virtual list box component} + +interface + +uses + {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, Types, LclType, MyMisc, {$ENDIF} + Classes, Controls, Forms, Graphics, StdCtrls, Menus, + SysUtils, OvcBase, OvcData, OvcCmd, OvcConst, OvcMisc, OvcExcpt, OvcColor; + +const + vlbMaxTabStops = 128; {maximum number of tab stops} + +const + {default property values} + vlDefAutoRowHeight = True; + vlDefAlign = alNone; + vlDefBorderStyle = bsSingle; + vlDefColor = clWindow; + vlDefColumns = 255; + vlDefCtl3D = True; + vlDefHeaderBack = clBtnFace; + vlDefHeaderText = clBtnText; + vlDefHeight = 150; + vlDefIntegralHeight = True; + vlDefItemIndex = -1; + vlDefMultiSelect = False; + vlDefNumItems = MaxLongInt; + vlDefOwnerDraw = False; + vlDefParentColor = False; + vlDefParentCtl3D = True; + vlDefParentFont = True; + vlDefProtectBack = clRed; + vlDefProtectText = clWhite; + vlDefRowHeight = 17; + vlDefScrollBars = ssVertical; + vlDefSelectBack = clHighlight; + vlDefSelectText = clHighlightText; + vlDefShowHeader = False; + vlDefTopIndex = 0; + vlDefTabStop = True; + vlDefUseTabStops = False; + vlDefWidth = 100; + +type + TCharToItemEvent = + procedure(Sender : TObject; Ch : Char; var Index : LongInt) + of object; + {-event to notify caller of a key press and return new item index} + TDrawItemEvent = + procedure(Sender : TObject; Index : LongInt; Rect : TRect; const S : string) + of object; + {-event to allow user to draw the cell items} + TGetItemEvent = + procedure(Sender : TObject; Index : LongInt; var ItemString : string) + of object; + {-event to get string to display} + TGetItemColorEvent = + procedure(Sender : TObject; Index : LongInt; var FG, BG : TColor) + of object; + {-event to get color of the item cell} + TGetItemStatusEvent = + procedure(Sender : TObject; Index : LongInt; var Protect : Boolean) + of object; + {-event to get the protected status item cell} + THeaderClickEvent = + procedure(Sender : TObject; Point : TPoint) + of object; + {-event to notify of a mouse click in the header area} + TIsSelectedEvent = + procedure(Sender : TObject; Index : LongInt; var Selected : Boolean) + of object; + {-event to get the current selection status from the user} + TSelectEvent = + procedure(Sender : TObject; Index : LongInt; Selected : Boolean) + of object; + {-event to notify of a selection change} + TTopIndexChanged = + procedure(Sender : TObject; NewTopIndex : LongInt) + of object; + {-event to notify when the top index changes} + +type + TTabStopArray = array[0..vlbMaxTabStops] of Integer; + TBuffer = array[0..255] of AnsiChar; + +type + TOvcCustomVirtualListBox = class(TOvcCustomControlEx) + {.Z+} + protected {private} + {property variables} + FItemIndex : LongInt; {selected item} + FAutoRowHeight : Boolean; {true to handle row height calc} + FBorderStyle : TBorderStyle;{border style to use} + FColumns : Integer; {number of char columns} + FFillColor : TColor; + FHeader : string; {the column header} + FHeaderColor : TOvcColors; {header line colors} + FIntegralHeight : Boolean; {adjust height based on font} + FMultiSelect : Boolean; {allow multiple selections} + FNumItems : LongInt; {total number of items} + FOwnerDraw : Boolean; {true if user will draw rows} + FProtectColor : TOvcColors; {protected item colors} + FRowHeight : Integer; {height of one row} + FScrollBars : TScrollStyle;{scroll bar style to use} + FSelectColor : TOvcColors; {selected item color} + FShowHeader : Boolean; {true to use the header} + FSmoothScroll : Boolean; {use smooth scrolling (duh) } + FTopIndex : LongInt; {item at top of window} + FUseTabStops : Boolean; {true to use tab stops} + FWheelDelta : Integer; + + {event variables} + FOnCharToItem : TCharToItemEvent; + FOnClickHeader : THeaderClickEvent; + FOnDrawItem : TDrawItemEvent; + FOnGetItem : TGetItemEvent; + FOnGetItemColor : TGetItemColorEvent; + FOnGetItemStatus : TGetItemStatusEvent; + FOnIsSelected : TIsSelectedEvent; + FOnSelect : TSelectEvent; + FOnTopIndexChanged : TTopIndexChanged; + FOnUserCommand : TUserCommandEvent; + + {internal/working variables} + lAnchor : LongInt; {anchor point for extended selections} + lDivisor : LongInt; {divisor for scroll bars} + lDlgUnits : Integer; {used for tab spacing} + lFocusedIndex : LongInt; {index of the focused item} + lHaveHS : Boolean; {if True, we have a horizontal scroll bar} + lHaveVS : Boolean; {if True, we have a vertical scroll bar} + lHDelta : LongInt; {horizontal scroll delta} + lHighIndex : LongInt; {highest allowable index} + lNumTabStops : 0..vlbMaxTabStops; {number of tab stops in tabstop array} + lRows : Integer; {number of rows in window} + lString : TBuffer; {temp item string buffer} + lTabs : TTabStopArray; + lUpdating : Integer; {user updating flag} + lVSHigh : Integer; {vertical scroll limit} + lVMargin : Integer; {extra vertical line margin} + MousePassThru : Boolean; + + {property methods} + procedure SetAutoRowHeight(Value : Boolean); + {-set use of auto row height calculations} + procedure SetBorderStyle(const Value : TBorderStyle); + {-set the style used for the border} + procedure SetColumns(const Value: Integer); + procedure SetHeader(const Value : string); + {-set the header at top of list box} + procedure SetIntegralHeight(Value : Boolean); + {-set use of integral font height adjustment} + procedure SetMultiSelect(Value : Boolean); virtual; + {-set ability to select multiple items} + procedure InternalSetNumItems(Value : LongInt; Paint, UpdateIndices : Boolean); + {-set the number of items in the list box} + procedure SetNumItems(Value : LongInt); + {-set the number of items in the list box} + procedure SetRowHeight(Value : Integer); + {-set height of cell row} + procedure SetScrollBars(const Value : TScrollStyle); virtual; + {-set use of vertical and horizontal scroll bars} + procedure SetShowHeader(Value : Boolean); + {-set the header at top of list box} + + {internal methods} + procedure vlbAdjustIntegralHeight; + {-adjust height of the list box} + procedure vlbCalcFontFields; virtual; + {-calculate sizes based on font selection} + procedure vlbClearAllItems; + {-clear the highlight from all items} + procedure vlbClearSelRange(First, Last : LongInt); + {-clear the selection for the given range of indexes} + procedure vlbColorChanged(AColor: TObject); + {-a color has changed, refresh display} + procedure vlbDragSelection(First, Last : LongInt); + {-drag the selection} + procedure vlbDrawFocusRect(Index : LongInt); + {-draw the focus rectangle} + procedure vlbDrawHeader; + {-draw the header and text area} + procedure vlbExtendSelection(Index : LongInt); + {-process Shift-LMouseBtn} + procedure vlbHScrollPrim(Delta : Integer); + {-scroll horizontally} + procedure vlbInitScrollInfo; + {-setup scroll bar range and initial position} + procedure vlbMakeItemVisible(Index : LongInt); + {-make sure the item is visible} + procedure vlbNewActiveItem(Index : LongInt); + {-set the currently selected item} + function vlbScaleDown(N : LongInt) : Integer; + {-scale down index for scroll bar use} + function vlbScaleUp(N : LongInt) : LongInt; + {-scale up scroll index to our index} + procedure vlbSelectRangePrim(First, Last : LongInt; Select : Boolean); + {-change the selection for the given range of indexes} + procedure vlbSetAllItemsPrim(Select : Boolean); + {-primitive routine thats acts on all items} + procedure vlbSetFocusedIndex(Index : LongInt); + {-set focus to this item. invalidate previous} + procedure vlbSetHScrollPos; + {-set the horizontal scroll position} + procedure vlbSetHScrollRange; + {-set the horizontal scroll range} + procedure vlbSetSelRange(First, Last : LongInt); + {-set the selection on for the given range of indexes} + procedure vlbSetVScrollPos; + {-set the vertical scroll position} + procedure vlbSetVScrollRange; + {-set the vertical scroll range} + procedure vlbToggleSelection(Index : LongInt); + {-process Ctrl-LMouseBtn} + procedure vlbValidateItem(Index : LongInt); + {-validate the area for this item} + procedure vlbVScrollPrim(Delta : Integer); + {-scroll vertically} + + {VCL control messages} + procedure CMCtl3DChanged(var Message: TMessage); + message CM_CTL3DCHANGED; + procedure CMFontChanged(var Message: TMessage); + message CM_FONTCHANGED; + + {windows message methods} + procedure WMChar(var Msg : TWMChar); + message WM_CHAR; + procedure WMEraseBkgnd(var Msg : TWMEraseBkgnd); + message WM_ERASEBKGND; + procedure WMGetDlgCode(var Msg : TWMGetDlgCode); + message WM_GETDLGCODE; + procedure WMHScroll(var Msg : TWMScroll); + message WM_HSCROLL; + procedure WMKeyDown(var Msg : TWMKeyDown); + message WM_KEYDOWN; + procedure WMKillFocus(var Msg : TWMKillFocus); + message WM_KILLFOCUS; + procedure WMLButtonDown(var Msg : TWMLButtonDown); + message WM_LBUTTONDOWN; + procedure WMLButtonDblClk(var Msg : TWMLButtonDblClk); + message WM_LBUTTONDBLCLK; + procedure WMMouseActivate(var Msg : TWMMouseActivate); + message WM_MOUSEACTIVATE; + procedure WMSetFocus(var Msg : TWMSetFocus); + message WM_SETFOCUS; + procedure WMSize(var Msg : TWMSize); + message WM_SIZE; + procedure WMVScroll(var Msg : TWMScroll); + message WM_VSCROLL; + + {list box messages} + procedure LBGetCaretIndex(var Msg : TMessage); + message LB_GETCARETINDEX; + procedure LBGetCount(var Msg : TMessage); + message LB_GETCOUNT; + procedure LBGetCurSel(var Msg : TMessage); + message LB_GETCURSEL; + procedure LBGetItemHeight(var Msg : TMessage); + message LB_GETITEMHEIGHT; + procedure LBGetItemRect(var Msg : TMessage); + message LB_GETITEMRECT; + procedure LBGetSel(var Msg : TMessage); + message LB_GETSEL; + procedure LBGetTopIndex(var Msg : TMessage); + message LB_GETTOPINDEX; + procedure LBResetContent(var Msg : TMessage); + message LB_RESETCONTENT; + procedure LBSelItemRange(var Msg : TMessage); + message LB_SELITEMRANGE; + procedure LBSetCurSel(var Msg : TMessage); + message LB_SETCURSEL; + procedure LBSetSel(var Msg : TMessage); + message LB_SETSEL; + procedure LBSetTabStops(var Msg : TMessage); + message LB_SETTABSTOPS; + procedure LBSetTopIndex(var Msg : TMessage); + message LB_SETTOPINDEX; + + protected + procedure ChangeScale(M, D : Integer); + override; + procedure CreateParams(var Params: TCreateParams); + override; + procedure CreateWnd; + override; + procedure DragCanceled; + override; + procedure Paint; + override; + procedure WndProc(var Message: TMessage); + override; + + {event wrappers} + function DoOnCharToItem(Ch : AnsiChar) : LongInt; + dynamic; + {-call the OnCharToItem event, if assigned} + procedure DoOnClickHeader(Point : TPoint); + dynamic; + {-call the OnClickHeader event, if assigned} + procedure DoOnDrawItem(Index : LongInt; Rect : TRect; const S : string); + virtual; + {-call the OnDrawItem event, if assigned} + function DoOnGetItem(Index : LongInt) : PAnsiChar; + virtual; + {-call the OnGetItem event, if assigned} + procedure DoOnGetItemColor(Index : LongInt; var FG, BG : TColor); + virtual; + {-call the OnGetItemColor event, if assigned} + function DoOnGetItemStatus(Index : LongInt) : Boolean; + virtual; + {-call the OnGetItemStatus event, if assigned} + function DoOnIsSelected(Index : LongInt) : Boolean; + virtual; + {-call the OnIsSelected event, if assigned} + procedure DoOnMouseWheel(Shift : TShiftState; Delta, XPos, YPos : SmallInt); + override; + procedure DoOnSelect(Index : LongInt; Selected : Boolean); + dynamic; + {-call the OnSelect event, if assigned} + procedure DoOnTopIndexChanged(NewTopIndex : LongInt); + dynamic; + {-call the OnTopIndexChanged event, if assigned} + procedure DoOnUserCommand(Command : Word); + dynamic; + {-perform notification of a user command} + + {virtual property methods} + procedure SetItemIndex(Index : LongInt); + virtual; + {-change the currently selected item} + procedure SetTopIndex(Index : LongInt); + virtual; + {-set the index of the first visible entry in the list} + procedure ForceTopIndex(Index : LongInt; ThumbTracking : Boolean); + virtual; + {-re-set the index of the first visible entry in the list - even if it doesn't change} + + procedure SimulatedClick; + virtual; + {-generates a click event when called. Called from SetItemIndex. Introduced so that + descendants can turn off the behavior.} + function IsValidIndex(Index : LongInt) : Boolean; + + {.Z-} + + {protected properties} + property AutoRowHeight : Boolean + read FAutoRowHeight write SetAutoRowHeight default vlDefAutoRowHeight; + property BorderStyle : TBorderStyle + read FBorderStyle write SetBorderStyle default vlDefBorderStyle; + property Columns : Integer + read FColumns write SetColumns default vlDefColumns; + property Header : string + read FHeader write SetHeader; + property HeaderColor : TOvcColors + read FHeaderColor write FHeaderColor; + property IntegralHeight : Boolean + read FIntegralHeight write SetIntegralHeight default vlDefIntegralHeight; + property MultiSelect : Boolean + read FMultiSelect write SetMultiSelect default vlDefMultiSelect; + property NumItems : LongInt + read FNumItems write SetNumItems default vlDefNumItems; + property OwnerDraw : Boolean + read FOwnerDraw write FOwnerDraw default vlDefOwnerDraw; + property ProtectColor : TOvcColors + read FProtectColor write FProtectColor; + property RowHeight : Integer + read FRowHeight write SetRowHeight default vlDefRowHeight; + property ScrollBars : TScrollStyle + read FScrollBars write SetScrollBars default vlDefScrollBars; + property SelectColor : TOvcColors + read FSelectColor write FSelectColor; + property ShowHeader : Boolean + read FShowHeader write SetShowHeader default vlDefShowHeader; + property UseTabStops : Boolean + read FUseTabStops write FUseTabStops default vlDefUseTabStops; + property WheelDelta: Integer + read FWheelDelta write FWheelDelta default 3; + {protected events} + property OnCharToItem : TCharToItemEvent + read FOnCharToItem write FOnCharToItem; + property OnClickHeader : THeaderClickEvent + read FOnClickHeader write FOnClickHeader; + property OnDrawItem : TDrawItemEvent + read FOnDrawItem write FOnDrawItem; + property OnGetItem : TGetItemEvent + read FOnGetItem write FOnGetItem; + property OnGetItemColor : TGetItemColorEvent + read FOnGetItemColor write FOnGetItemColor; + property OnGetItemStatus : TGetItemStatusEvent + read FOnGetItemStatus write FOnGetItemStatus; + property OnIsSelected : TIsSelectedEvent + read FOnIsSelected write FOnIsSelected; + property OnSelect : TSelectEvent + read FOnSelect write FOnSelect; + property OnTopIndexChanged : TTopIndexChanged + read FOnTopIndexChanged write FOnTopIndexChanged; + property OnUserCommand : TUserCommandEvent + read FOnUserCommand write FOnUserCommand; + + public + + {.Z+} + constructor Create(AOwner : TComponent); + override; + destructor Destroy; + override; + {.Z-} + + procedure BeginUpdate; virtual; + {-user is updating the list items--don't paint} + procedure CenterCurrentLine; + {- center the currently selected line (if any) on screen} + procedure CenterLine(Index : Integer); + {- center the specified line (if any) vertically on screen} + procedure DeselectAll; + {-deselect all items} + procedure DrawItem(Index : LongInt); + {-invalidate and update the area for this item} + procedure EndUpdate; virtual; + {-user is done updating the list items--force repaint} + procedure InsertItemsAt(Items : LongInt; Index : LongInt); + {-increase NumItems with Items amount while scrolling window down from Index} + procedure DeleteItemsAt(Items : LongInt; Index : LongInt); + {-decrease NumItems with Items amount while scrolling window up from Index} + procedure InvalidateItem(Index : LongInt); + {-invalidate the area for this item} + function ItemAtPos(Pos : TPoint; Existing : Boolean) : LongInt; + {-return the index of the cell that contains the point Pos} + procedure Scroll(HDelta, VDelta : Integer); + {-scroll the list by the give delta amount} + procedure SelectAll; + {-select all items} + procedure SetBounds(ALeft, ATop, AWidth, AHeight : Integer); + override; + procedure SetTabStops(const Tabs : array of Integer); + {-set tab stop positions} + + {public properties} + property Canvas; + + property ItemIndex : LongInt + read FItemIndex write SetItemIndex; + property FillColor : TColor read FFillColor write FFillColor; + property SmoothScroll : Boolean + read FSmoothScroll write FSmoothScroll default True; + property TopIndex : LongInt + read FTopIndex write SetTopIndex; + end; + + TOvcVirtualListBox = class(TOvcCustomVirtualListBox) + published + property AutoRowHeight; + property BorderStyle; + property Columns; + property Header; + property HeaderColor; + property IntegralHeight; + property MultiSelect; + property NumItems; + property OwnerDraw; + property ProtectColor; + property RowHeight; + property ScrollBars; + property SelectColor; + property ShowHeader; + property SmoothScroll; + property UseTabStops; + property WheelDelta; + property OnCharToItem; + property OnClickHeader; + property OnDrawItem; + property OnGetItem; + property OnGetItemColor; + property OnGetItemStatus; + property OnIsSelected; + property OnSelect; + property OnTopIndexChanged; + property OnUserCommand; + + {inherited properties} + {$IFDEF VERSION4} + property Anchors; + property Constraints; + property DragKind; + {$ENDIF} + property Align; + property Color; + property Controller; + property Ctl3D; + property DragCursor; + property DragMode; + property Enabled; + property Font; + property ParentColor default vlDefParentColor; + property ParentCtl3D default vlDefParentCtl3D; + property ParentFont default vlDefParentFont; + property ParentShowHint; + property PopupMenu; + property ShowHint; + property TabOrder; + property TabStop default vlDefTabStop; + property Visible; + + {inherited events} + property AfterEnter; + property AfterExit; + property OnClick; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnStartDrag; + end; + + +implementation + +{const + vlbWheelDelta = 3;} {changed to property} + +{*** TOvcVirtualListBox ***} + +procedure TOvcCustomVirtualListBox.BeginUpdate; + {-user is updating the list items--don't paint} +begin + inc(lUpdating); +end; + +procedure TOvcCustomVirtualListBox.CenterCurrentLine; +{- center the currently selected line (if any) on screen} +begin + if ItemIndex <> -1 then + TopIndex := ItemIndex - (lRows div 2); +end; + +procedure TOvcCustomVirtualListBox.CenterLine(Index : Integer); +begin + if Index <> -1 then + TopIndex := Index - (lRows div 2); +end; + +procedure TOvcCustomVirtualListBox.ChangeScale(M, D : Integer); +begin + inherited ChangeScale(M, D); + + if M <> D then begin + {scale row height} + FRowHeight := MulDiv(FRowHeight, M, D); + + vlbCalcFontFields; + vlbAdjustIntegralHeight; + vlbCalcFontFields; + vlbInitScrollInfo; + Refresh; + end; +end; + +procedure TOvcCustomVirtualListBox.CMCtl3DChanged(var Message: TMessage); +begin + if (csLoading in ComponentState) or not HandleAllocated then + Exit; + + if NewStyleControls and (FBorderStyle = bsSingle) then +{$IFNDEF LCL} + RecreateWnd; +{$ELSE} + MyMisc.RecreateWnd(Self); +{$ENDIF} + + inherited; +end; + +procedure TOvcCustomVirtualListBox.CMFontChanged(var Message: TMessage); +begin + inherited; + + if (csLoading in ComponentState) then + Exit; + + if not HandleAllocated then + Exit; + + {reset internal size variables} + if FIntegralHeight then begin + vlbCalcFontFields; + vlbAdjustIntegralHeight; + end; + + vlbCalcFontFields; + vlbInitScrollInfo; +end; + +constructor TOvcCustomVirtualListBox.Create(AOwner : TComponent); +begin + inherited Create(AOwner); + + FillColor := Color; + FSmoothScroll := True; + + if NewStyleControls then + ControlStyle := ControlStyle + [csClickEvents, csCaptureMouse, csOpaque] + else + ControlStyle := ControlStyle + [csClickEvents, csCaptureMouse, csOpaque, csFramed]; + + {set default values for inherited persistent properties} + Align := vlDefAlign; + Color := vlDefColor; + Ctl3D := vlDefCtl3D; + Height := vlDefHeight; + ParentColor := vlDefParentColor; + ParentCtl3D := vlDefParentCtl3D; + ParentFont := vlDefParentFont; + TabStop := vlDefTabStop; + Width := vlDefWidth; + + {set default values for new persistent properties} + FAutoRowHeight := vlDefAutoRowHeight; + FBorderStyle := vlDefBorderStyle; + FColumns := vlDefColumns; + FHeader := ''; + FIntegralHeight := vlDefIntegralHeight; + FItemIndex := vlDefItemIndex; + FMultiSelect := vlDefMultiSelect; + FNumItems := vlDefNumItems; + FOwnerDraw := vlDefOwnerDraw; + FRowHeight := vlDefRowHeight; + FScrollBars := vlDefScrollBars; + FShowHeader := vlDefShowHeader; + FTopIndex := vlDefTopIndex; + FUseTabStops := vlDefUseTabStops; + + {set defaults for internal variables} + lHDelta := 0; + lHaveHS := False; + lHaveVS := False; + + lAnchor := 0; + lFocusedIndex := 0; {-1;} + + lNumTabStops := 0; + FillChar(lTabs, SizeOf(lTabs), #0); + + {create and initialize color objects} + FHeaderColor := TOvcColors.Create(vlDefHeaderText, vlDefHeaderBack); + FHeaderColor.OnColorChange := vlbColorChanged; + FProtectColor := TOvcColors.Create(vlDefProtectText, vlDefProtectBack); + FProtectColor.OnColorChange := vlbColorChanged; + FSelectColor := TOvcColors.Create(vlDefSelectText, vlDefSelectBack); + FSelectColor.OnColorChange := vlbColorChanged; + FWheelDelta := 3; +end; + +procedure TOvcCustomVirtualListBox.CreateParams(var Params: TCreateParams); +begin + inherited CreateParams(Params); + + with Params do + Style := Style or DWord(ScrollBarStyles[FScrollBars]) + or DWord(BorderStyles[FBorderStyle]); + if NewStyleControls and Ctl3D and (FBorderStyle = bsSingle) then begin + Params.Style := Params.Style and not WS_BORDER; + Params.ExStyle := Params.ExStyle or WS_EX_CLIENTEDGE; + end; + +{$IFDEF LCL} + if not (csDesigning in ComponentState) then + inherited SetBorderStyle(FBorderStyle); //Crashes IDE for some reason +{$ENDIF} +end; + +procedure TOvcCustomVirtualListBox.CreateWnd; +begin + inherited CreateWnd; + + {do we have scroll bars} + lHaveVS := FScrollBars in [ssVertical, ssBoth]; + lHaveHS := FScrollBars in [ssHorizontal, ssBoth]; + lHighIndex := Pred(FNumItems); + + lFocusedIndex := 0; {-1;} + + {determine the height of one row and number of rows} + vlbCalcFontFields; + vlbAdjustIntegralHeight; + + {setup scroll bar info} + vlbInitScrollInfo; +end; + +function TOvcCustomVirtualListBox.DoOnCharToItem(Ch : AnsiChar) : LongInt; +begin + Result := FItemIndex; + if Assigned(FOnCharToItem) then + FOnCharToItem(Self, Ch, Result); +end; + +procedure TOvcCustomVirtualListBox.DoOnClickHeader(Point : TPoint); +begin + if Assigned(FOnClickHeader) then + FOnClickHeader(Self, Point); +end; + +procedure TOvcCustomVirtualListBox.DoOnDrawItem(Index : LongInt; Rect : TRect; + const S : string); +begin + if Assigned(FOnDrawItem) then + FOnDrawItem(Self, Index, Rect, S); +end; + +function TOvcCustomVirtualListBox.DoOnGetItem(Index : LongInt) : PAnsiChar; + {-returns the string representing Nth item} +var + S : string; +begin + if Assigned(FOnGetItem) {$IFDEF LCL} and not (csDesigning in ComponentState) {$ENDIF} then begin + S := ''; + FOnGetItem(Self, Index, S); + StrPCopy(lString, S); + Result := @lString[0]; + end else if csDesigning in ComponentState then begin + StrPCopy(lString, Format(GetOrphStr(SCSampleListItem), [Index])); + Result := @lString[0]; + end else + Result := StrPCopy(lString, Format(GetOrphStr(SCGotItemWarning), [Index])); +end; + +procedure TOvcCustomVirtualListBox.DoOnGetItemColor(Index : LongInt; var FG, BG : TColor); +begin + if Assigned(FOnGetItemColor) then + FOnGetItemColor(Self, Index, FG, BG); +end; + +function TOvcCustomVirtualListBox.DoOnGetItemStatus(Index : LongInt) : Boolean; +begin + Result := False; + if Assigned(FOnGetItemStatus) then + FOnGetItemStatus(Self, Index, Result); +end; + +function TOvcCustomVirtualListBox.DoOnIsSelected(Index : LongInt) : Boolean; + {-returns the selected status for the "Index" item} +begin + if csDesigning in ComponentState then + Result := Index = 0 + else begin + Result := (Index = FItemIndex); + if FMultiSelect then begin + if Assigned(FOnIsSelected) then + FOnIsSelected(Self, Index, Result) + else + raise EOnIsSelectedNotAssigned.Create; + end; + end; +end; + +procedure TOvcCustomVirtualListBox.DoOnMouseWheel(Shift : TShiftState; Delta, XPos, YPos : SmallInt); +var + I : Integer; +begin + inherited DoOnMouseWheel(Shift, Delta, XPos, YPos); + + if Delta < 0 then begin + for I := 1 to {vlb}WheelDelta do + Perform(WM_VSCROLL, MAKELONG(SB_LINEDOWN, 0), 0); + end else if Delta > 0 then begin + for I := 1 to {vlb}WheelDelta do + Perform(WM_VSCROLL, MAKELONG(SB_LINEUP, 0), 0); + end; +end; + +procedure TOvcCustomVirtualListBox.DoOnSelect(Index : LongInt; Selected : Boolean); + {-notify of selection change} +begin + if csDesigning in ComponentState then + Exit; + + if FMultiSelect then begin + if Assigned(FOnSelect) then begin + {select if not protected-deselect always} + if (not Selected) or (not DoOnGetItemStatus(Index)) then + FOnSelect(Self, Index, Selected); + end else + raise EOnSelectNotAssigned.Create; + end; +end; + +procedure TOvcCustomVirtualListBox.DoOnTopIndexChanged(NewTopIndex : LongInt); + {-call the OnTopIndexChanged event, if assigned} +begin + if Assigned(FOnTopIndexChanged) then + FOnTopIndexChanged(Self, NewTopIndex); +end; + +procedure TOvcCustomVirtualListBox.DoOnUserCommand(Command : Word); + {-perform notification of a user command} +begin + if Assigned(FOnUserCommand) then + FOnUserCommand(Self, Command); +end; + +procedure TOvcCustomVirtualListBox.DeselectAll; + {-deselect all items} +begin + vlbSetAllItemsPrim(False {deselect}); +end; + +procedure TOvcCustomVirtualListBox.DrawItem(Index : LongInt); + {-invalidate and update the area for this item} +begin + InvalidateItem(Index); + Update; +end; + +destructor TOvcCustomVirtualListBox.Destroy; +begin + {if lUpdating <> 0 then debug code} + {raise Exception.Create('Mismatched BeginUpdate/EndUpdate');} + FHeaderColor.Free; + FProtectColor.Free; + FSelectColor.Free; + + inherited Destroy; +end; + +procedure TOvcCustomVirtualListBox.EndUpdate; + {-user is done updating the list items--force repaint} +begin + dec(lUpdating); + if lUpdating < 0 then + raise Exception.Create('Mismatched BeginUpdate/EndUpdate'); + if lUpdating = 0 then + Invalidate; +end; + +function ScrollCanvas(Canvas : TCanvas; R : TRect; EastWest : Boolean; Distance : Integer; + Smooth : Boolean) : TRect; +var + UpdRect : TRect; + NextStep,StepSize : Integer; + {OldColor : TColor;} +begin + if Distance = 0 then begin + Result := Rect(0,0,0,0); + exit; + end; + if Smooth then + StepSize := MaxI((Abs(Distance) div 4), MinI(2, Abs(Distance))) + else + StepSize := Abs(Distance); + Result := R; + if EastWest then + if abs(Distance) < (Result.Right-Result.Left+1) then + if Distance < 0 then + Result.Left := Result.Right + Distance + else + Result.Right := Result.Left + Distance + else + else + if abs(Distance) < (Result.Bottom-Result.Top+1) then + if Distance < 0 then + Result.Top := Result.Bottom + Distance + else + Result.Bottom := Result.Top + Distance; + repeat + if Distance > 0 then + if Distance > StepSize then + NextStep := StepSize + else + NextStep := Distance + else + if Distance < -StepSize then + NextStep := -StepSize + else + NextStep := Distance; + if EastWest then + ScrollDC(Canvas.Handle,NextStep,0,R,R,0,@UpdRect) + else + ScrollDC(Canvas.Handle,0,NextStep,R,R,0,@UpdRect); + UnionRect(Result, UpdRect, Result); + dec(Distance,NextStep); + until Distance = 0; +end; + +procedure TOvcCustomVirtualListBox.InsertItemsAt(Items : LongInt; Index : LongInt); + {-increase NumItems with Items amount while scrolling window down from Index} +var + CR : TRect; + AbsBottom : Integer; + OldItemIndex : Integer; +begin + OldItemIndex := ItemIndex; + ItemIndex := -1; + InternalSetNumItems(NumItems + Items,False,False); + if (lUpdating = 0) then + if (Index-FTopIndex) < lRows then begin + AbsBottom := (ClientRect.Bottom div FRowHeight) * FRowHeight; + if Index >= FTopIndex then begin + CR := Rect(0, (Index-FTopIndex+Ord(FShowHeader))*FRowHeight, ClientWidth, AbsBottom); + {Make sure the canvas is updated, + because we will be validating the scrolled portion.} + CR := ScrollCanvas(Canvas, CR, False, Items*FRowHeight, FSmoothScroll); + InvalidateRect(Handle,@CR,False); + end else begin + CR := Rect(0, (Ord(FShowHeader))*FRowHeight, ClientWidth, AbsBottom); + Update; + {Make sure the canvas is updated, + because we will be validating the scrolled portion.} + CR := ScrollCanvas(Canvas, CR, False, Items*FRowHeight, FSmoothScroll); + InvalidateRect(Handle, @CR, False); + Update; + end; + end; + if OldItemIndex >= Index then + inc(OldItemIndex,Items); + ItemIndex := OldItemIndex; +end; + +procedure TOvcCustomVirtualListBox.DeleteItemsAt(Items : LongInt; Index : LongInt); + {-decrease NumItems with Items amount while scrolling window up from Index} +var + CR : TRect; + AbsBottom,OldItemIndex : Integer; +begin + OldItemIndex := ItemIndex; + ItemIndex := -1; + if lUpdating = 0 then + Update; + InternalSetNumItems(NumItems - Items,False,False); + if lUpdating = 0 then begin + if (Index-FTopIndex) < lRows then begin + AbsBottom := (ClientRect.Bottom div FRowHeight) * FRowHeight; + if Index >= FTopIndex then begin + CR := Rect(0, (Index-FTopIndex+Ord(FShowHeader))*FRowHeight, ClientWidth, AbsBottom); + CR := ScrollCanvas(Canvas, CR, False, -Items*FRowHeight, FSmoothScroll); + InvalidateRect(Handle,@CR,False); + Update; + end else begin + CR := Rect(0, (Ord(FShowHeader))*FRowHeight, ClientWidth, AbsBottom); + CR := ScrollCanvas(Canvas, CR, False, -Items*FRowHeight, FSmoothScroll); + InvalidateRect(Handle,@CR,False); + Update; + end; + end; + end; + if OldItemIndex >= Index+Items then + dec(OldItemIndex,Items) + else + if OldItemIndex >= Index then + OldItemIndex := -1; + ItemIndex := OldItemIndex; + if TopIndex + lRows > FNumItems then + ForceTopIndex(FNumItems - 1, True) + else + ForceTopIndex(TopIndex, False); +end; + +procedure TOvcCustomVirtualListBox.InvalidateItem(Index : LongInt); + {-invalidate the area for this item} +var + CR : TRect; +begin + if (Index >= FTopIndex) and (Index-FTopIndex < lRows) then begin {visible?} + CR := Rect(0, (Index-FTopIndex+Ord(FShowHeader))*FRowHeight, ClientWidth, 0); + CR.Bottom := CR.Top+FRowHeight; + InvalidateRect(Handle, @CR, True); + end; +end; + +function TOvcCustomVirtualListBox.ItemAtPos(Pos : TPoint; + Existing : Boolean) : LongInt; + {-return the index of the cell that contains the point Pos} +begin + if (Pos.Y < Ord(FShowHeader)*FRowHeight) then begin + if Existing then + Result := -1 + else + Result := 0; + end else if (Pos.Y >= ClientHeight) then begin + if Existing then + Result := -1 + else + Result := lHighIndex; + end else begin {convert to an index} + Result := FTopIndex-Ord(FShowHeader)+(Pos.Y div FRowHeight); + {test for click below last item (IntegralHeight not set)} + if ClientHeight mod FRowHeight > 0 then + if Result > FTopIndex+lRows-1 then + Result := FTopIndex+lRows-1; + if Result > NumItems then + if Existing then + Result := -1 + else + Result := NumItems; + end; +end; + +procedure TOvcCustomVirtualListBox.LBGetCaretIndex(var Msg : TMessage); +begin + Msg.Result := lFocusedIndex; +end; + +procedure TOvcCustomVirtualListBox.LBGetCount(var Msg : TMessage); +begin + Msg.Result := FNumItems; +end; + +procedure TOvcCustomVirtualListBox.LBGetCurSel(var Msg : TMessage); +begin + Msg.Result := FItemIndex; +end; + +procedure TOvcCustomVirtualListBox.LBGetItemHeight(var Msg : TMessage); +begin + Msg.Result := FRowHeight; +end; + +procedure TOvcCustomVirtualListBox.LBGetItemRect(var Msg : TMessage); +begin + PRect(Msg.LParam)^ := + Rect(0, (Msg.WParam - FTopIndex) * FRowHeight, + ClientWidth, (Msg.WParam - FTopIndex) * FRowHeight + FRowHeight); +end; + +procedure TOvcCustomVirtualListBox.LBGetSel(var Msg : TMessage); +begin + if (Msg.wParam >= 0) and (Msg.wParam <= lHighIndex) then + Msg.Result := Ord(DoOnIsSelected(Msg.wParam)) + else + Msg.Result := LB_ERR; +end; + +procedure TOvcCustomVirtualListBox.LBGetTopIndex(var Msg : TMessage); +begin + Msg.Result := FTopIndex; +end; + +procedure TOvcCustomVirtualListBox.LBResetContent(var Msg : TMessage); +begin + NumItems := 0; +end; + +procedure TOvcCustomVirtualListBox.LBSelItemRange(var Msg : TMessage); +begin + if FMultiSelect and (Msg.wParamLo <= lHighIndex) + and (Msg.wParamHi <= lHighIndex) then begin + vlbSelectRangePrim(Msg.lParamLo, Msg.lParamHi, Msg.wParam > 0); + Msg.Result := 0; + end else + Msg.Result := LB_ERR; +end; + +procedure TOvcCustomVirtualListBox.LBSetCurSel(var Msg : TMessage); +begin + if FMultiSelect and (Msg.wParam >= -1) and (Msg.wParam <= lHighIndex) then begin + SetItemIndex(Msg.wParam); + if Msg.wParam = $FFFF then + Msg.Result := LB_ERR + else + Msg.Result := 0; + end else + Msg.Result := LB_ERR; +end; + +procedure TOvcCustomVirtualListBox.LBSetSel(var Msg : TMessage); +begin + if FMultiSelect and (Msg.lParam >= -1) and (Msg.lParam <= lHighIndex) then begin + if Msg.lParam = -1 then + vlbSetAllItemsPrim(Msg.wParam > 0) + else begin + DoOnSelect(Msg.lParam, Msg.wParam > 0); + InvalidateItem(Msg.lParam); + end; + Msg.Result := 0; + end else + Msg.Result := LB_ERR; +end; + +procedure TOvcCustomVirtualListBox.LBSetTabStops(var Msg : TMessage); +type + IA = TTabStopArray; + IP = ^IA; +var + I : Integer; +begin + lNumTabStops := Msg.wParam; + if lNumTabStops > vlbMaxTabStops then begin + lNumTabStops := vlbMaxTabStops; + Msg.Result := 0; {didn't set all tabs} + end else + Msg.Result := 1; + + for I := 0 to Pred(lNumTabStops) do + lTabs[I] := IP(Msg.lParam)^[I] * lDlgUnits; +end; + +procedure TOvcCustomVirtualListBox.LBSetTopIndex(var Msg : TMessage); +begin + if (Msg.wParam >= 0) and (Msg.wParam <= lHighIndex) then begin + SetTopIndex(Msg.wParam); + Msg.Result := 0; + end else + Msg.Result := LB_ERR; +end; + +procedure TOvcCustomVirtualListBox.Paint; +var + I : Integer; + ST : PAnsiChar; + CR : TRect; + IR : TRect; + Clip : TRect; + Last : Integer; + + procedure DrawItem(N : LongInt; Row : Integer); + {-Draw item N at Row} + var + S : PAnsiChar; + FGColor : TColor; + BGColor : TColor; + DX : Integer; + begin + {get bounding rectangle} + CR.Top := Pred(Row)*FRowHeight; + CR.Bottom := CR.Top+FRowHeight; + + {do we have anything to paint} + if Bool(IntersectRect(IR, Clip, CR)) then begin + + {get colors} + if DoOnGetItemStatus(N) then begin + BGColor := FProtectColor.BackColor; + FGColor := FProtectColor.TextColor; + end else if DoOnIsSelected(N) and (Row <= lRows+Ord(FShowHeader)) then begin + BGColor := FSelectColor.BackColor; + FGColor := FSelectColor.TextColor; + end else begin + BGColor := Color; + FGColor := Font.Color; + DoOnGetItemColor(N, FGColor, BGColor); + end; + + {assign colors to our canvas} + Canvas.Brush.Color := BGColor; + Canvas.Font.Color := FGColor; + + {clear the line} + Canvas.FillRect(CR); + + {get the string} + if N <= lHighIndex then begin + ST := DoOnGetItem(N); + if lHDelta >= LongInt(StrLen(ST)) then + S := nil + else + S := @ST[lHDelta]; + end else + S := nil; + + {draw the string} + if S <> nil then begin + if FOwnerDraw then + DoOnDrawItem(N, CR, StrPas(S)) + else if FUseTabStops then begin + DX := 0; + if lHDelta > 0 then begin + {measure portion of string to the left of the window} + DX := LOWORD(GetTabbedTextExtent(Canvas.Handle, + ST, lHDelta, lNumTabStops, lTabs)); + end; + TabbedTextOut(Canvas.Handle, CR.Left+2, CR.Top, + S, StrLen(S), lNumTabStops, lTabs, -DX) + end else + ExtTextOut(Canvas.Handle, CR.Left+2, CR.Top, + ETO_CLIPPED + ETO_OPAQUE, @CR, S, StrLen(S), nil); + end; + end; + end; + +begin + {exit if the updating flag is set} + if lUpdating > 0 then + Exit; + + Canvas.Font := Font; + + {we will erase our own background} + SetBkMode(Canvas.Handle, TRANSPARENT); + + {get the client rectangle} + CR := ClientRect; + + {get the clipping region} +{$IFNDEF LCL} + GetClipBox(Canvas.Handle, Clip); +{$ELSE} + GetClipBox(Canvas.Handle, @Clip); +{$ENDIF} + + {do we have a header?} + if FShowHeader then begin + if Bool(IntersectRect(IR, Clip, Rect(CR.Left, CR.Top, CR.Right, FRowHeight))) then + vlbDrawHeader; + end; + + {calculate last visible item} + Last := lRows; + if Last > NumItems then + Last := NumItems; + + {display each row} + for I := 1 to Last do + DrawItem(FTopIndex+Pred(I), I+Ord(FShowHeader)); + + {paint any blank area below last item} + CR.Top := FRowHeight * (Last+Ord(FShowHeader)); + if CR.Top < ClientHeight then begin + CR.Bottom := ClientHeight; + {clear the area} + Canvas.Brush.Color := Color; + Canvas.FillRect(CR); + end; + + Canvas.Brush.Color := Color; + Canvas.Font.Color := Font.Color; + if Canvas.Handle > 0 then {force colors to be selected into canvas}; + {conditionally, draw the focus rect} + if lFocusedIndex <> -1 then + vlbDrawFocusRect(lFocusedIndex); +end; + +procedure TOvcCustomVirtualListBox.DragCanceled; +var + M: TWMMouse; + P, MousePos: TPoint; +begin + with M do + begin + Msg := WM_LBUTTONDOWN; + GetCursorPos(MousePos); + P := ScreenToClient(MousePos); + Pos := PointToSmallPoint(P); + Keys := 0; + Result := 0; + end; + DefaultHandler(M); + M.Msg := WM_LBUTTONUP; + DefaultHandler(M); +end; + +procedure TOvcCustomVirtualListBox.WndProc(var Message: TMessage); +begin + {for auto drag mode, let listbox handle itself, instead of TControl} + if not (csDesigning in ComponentState) and ((Message.Msg = WM_LBUTTONDOWN) or + (Message.Msg = WM_LBUTTONDBLCLK)) and not Dragging then + begin + if DragMode = dmAutomatic then + begin + if IsControlMouseMsg(TWMMouse(Message)) then + Exit; + ControlState := ControlState + [csLButtonDown]; + Dispatch(Message); {overrides TControl's BeginDrag} + Exit; + end; + end; + inherited WndProc(Message); +end; + +procedure TOvcCustomVirtualListBox.Scroll(HDelta, VDelta : Integer); + {-scroll the list by the give delta amount} +begin + if HDelta <> 0 then + vlbHScrollPrim(HDelta); + + if VDelta <> 0 then + vlbVScrollPrim(VDelta); +end; + +procedure TOvcCustomVirtualListBox.SelectAll; + {-select all items} +begin + vlbSetAllItemsPrim(True {select}); +end; + +procedure TOvcCustomVirtualListBox.SetAutoRowHeight(Value : Boolean); + {-set use of auto row height calculations} +begin + if Value <> FAutoRowHeight then begin + FAutoRowHeight := Value; + if FAutoRowHeight then begin + vlbCalcFontFields; + vlbAdjustIntegralHeight; + vlbCalcFontFields; + vlbInitScrollInfo; + Refresh; + end; + end; +end; + +procedure TOvcCustomVirtualListBox.SetBorderStyle(const Value : TBorderStyle); + {-set the style used for the border} +begin + if Value <> FBorderStyle then begin + FBorderStyle := Value; +{$IFNDEF LCL} + RecreateWnd; +{$ELSE} + MyMisc.RecreateWnd(Self); +{$ENDIF} + end; +end; + +procedure TOvcCustomVirtualListBox.SetBounds(ALeft, ATop, AWidth, AHeight : Integer); +begin + if not (Align in [alNone, alTop, alBottom]) then + FIntegralHeight := False; + + inherited SetBounds(ALeft, ATop, AWidth, AHeight); +end; + +procedure TOvcCustomVirtualListBox.SetHeader(const Value : string); + {-set the header at top of list box} +begin + if Value <> FHeader then begin + FHeader := Value; + {toggle show header flag as appropriate} + if (csDesigning in ComponentState) and not (csLoading in ComponentState) then + ShowHeader := FHeader <> ''; + Repaint; + end; +end; + +procedure TOvcCustomVirtualListBox.SetIntegralHeight(Value : Boolean); + {-set use of integral font height adjustment} +begin + if (Value <> FIntegralHeight) and (Align in [alNone, alTop, alBottom]) then begin + FIntegralHeight := Value; + if FIntegralHeight then begin + vlbCalcFontFields; + vlbAdjustIntegralHeight; + vlbCalcFontFields; + vlbInitScrollInfo; + end; + end; +end; + +procedure TOvcCustomVirtualListBox.SetItemIndex(Index : LongInt); + {-change the currently selected item} +begin + {verify valid index} + if Index > lHighIndex then + if lHighIndex < 0 then + Index := -1 + else + Index := lHighIndex; + + {do we need to do any more} + if (Index = FItemIndex) then + Exit; + + {erase current selection} + InvalidateItem(FItemIndex); + + {if Index <> -1 then} + DoOnSelect(FItemIndex, False); + + {set the newly selected item index} + FItemIndex := Index; + {lFocusedIndex := -1;} + Update; + + if csDesigning in ComponentState then + Exit; + + {vlbMakeItemVisible(Index);} + if FItemIndex > -1 then begin + vlbMakeItemVisible(Index); + DoOnSelect(FItemIndex, True); + end; + if FItemIndex <> -1 then + vlbSetFocusedIndex(FItemIndex) + else + vlbSetFocusedIndex(0); + DrawItem(FItemIndex); + + {notify of an index change} + if not MouseCapture then + SimulatedClick; +end; + +procedure TOvcCustomVirtualListBox.SimulatedClick; +begin + Click; +end; + +function TOvcCustomVirtualListBox.IsValidIndex(Index : LongInt) : Boolean; +begin + Result := (Index >= 0) and (Index <= lHighIndex); +end; + +procedure TOvcCustomVirtualListBox.SetMultiSelect(Value : Boolean); + {-set ability to select multiple items} +begin + if (csDesigning in ComponentState) or (csLoading in ComponentState) then + if Value <> FMultiSelect then + FMultiSelect := Value; +end; + +procedure TOvcCustomVirtualListBox.InternalSetNumItems(Value : LongInt; Paint, UpdateIndices : Boolean); + {-set the number of items in the list box} +var + OldNumItems : LongInt; +begin + if Value <> FNumItems then begin + if (Value < 0) then + Value := MaxLongInt; + + OldNumItems := FNumItems; + {set new item index} + FNumItems := Value; + + {reset high index} + lHighIndex := Pred(FNumItems); + {reset horizontal offset} + lHDelta := 0; + + {reset selected item} + if UpdateIndices then + if not (csLoading in ComponentState) then begin + if ItemIndex >= FNumItems then + ItemIndex := -1; + if TopIndex + lRows > FNumItems then + ForceTopIndex(FNumItems - 1, True) + else + ForceTopIndex(TopIndex, False); + end; + if Paint and ((NumItems <= lRows) or (OldNumItems <= lRows)) then + Repaint; + + vlbInitScrollInfo; + end; +end; + +procedure TOvcCustomVirtualListBox.SetNumItems(Value : LongInt); + {-set the number of items in the list box} +begin + InternalSetNumItems(Value, True, True); +end; + +procedure TOvcCustomVirtualListBox.SetRowHeight(Value : Integer); + {-set height of cell row} +begin + if Value <> FRowHeight then begin + FRowHeight := Value; + if not (csLoading in ComponentState) then + AutoRowHeight := False; + vlbCalcFontFields; + vlbAdjustIntegralHeight; + vlbCalcFontFields; + vlbInitScrollInfo; + Refresh; + end; +end; + +procedure TOvcCustomVirtualListBox.SetScrollBars(const Value : TScrollStyle); + {-set use of vertical and horizontal scroll bars} +begin + if Value <> FScrollBars then begin + FScrollBars := Value; + lHaveVS := (FScrollBars = ssVertical) or (FScrollBars = ssBoth); + lHaveHS := (FScrollBars = ssHorizontal) or (FScrollBars = ssBoth); +{$IFNDEF LCL} + RecreateWnd; +{$ELSE} + MyMisc.RecreateWnd(Self); +{$ENDIF} + end; +end; + +procedure TOvcCustomVirtualListBox.SetShowHeader(Value : Boolean); + {-set show flag for the header} +begin + if Value <> FShowHeader then begin + FShowHeader := Value; + Refresh; + end; +end; + +procedure TOvcCustomVirtualListBox.SetTabStops(const Tabs : array of Integer); + {-set tab stop positions} +var + I : Integer; +begin + HandleNeeded; + lNumTabStops := High(Tabs)+1; + if lNumTabStops > vlbMaxTabStops then + lNumTabStops := vlbMaxTabStops; + for I := 0 to Pred(lNumTabStops) do + lTabs[I] := Tabs[I] * lDlgUnits; +end; + +procedure TOvcCustomVirtualListBox.ForceTopIndex(Index : LongInt; ThumbTracking : Boolean); + {-set the index of the first visible entry in the list} +var + DY : LongInt; + SaveD : LongInt; + ClipBox, + TmpArea, + ClipArea : TRect; + Inv : TRect; +begin + if (Index >= 0) and (Index <= lHighIndex) then begin + Update; + SaveD := FTopIndex; + {if we can't make the requested item the top one, at least show it} + if Index + lRows -1 <= lHighIndex then + FTopIndex := Index + else + FTopIndex := lHighIndex - lRows + 1; + + {check for valid index} + if FTopIndex < 0 then + FTopIndex := 0; + if FTopIndex = SaveD then + Exit; + vlbSetVScrollPos; + ClipArea := ClientRect; + {adjust top of the clipping region to exclude the header, if any} + if FShowHeader then with ClipArea do + Top := Top + FRowHeight; + +{$IFNDEF LCL} + if GetClipBox(Canvas.Handle, ClipBox) <> SIMPLEREGION then +{$ELSE} + if GetClipBox(Canvas.Handle, @ClipBox) <> SIMPLEREGION then +{$ENDIF} + InvalidateRect(Handle, @ClipArea, True) + else begin + InterSectRect(ClipArea, ClipArea, ClipBox); + + TmpArea := ClipArea; + TmpArea.Bottom := ClipArea.Bottom; + {adjust bottom of the clipping region to an even number of rows} + with ClipArea do + Bottom := (Bottom div FRowHeight) * FRowHeight; + TmpArea.Top := ClipArea.Bottom; + {if ThumbTracking then + InvalidateRect(Handle, @ClipArea, True) + else} begin + DY := (SaveD - FTopIndex); + if Abs(DY) > lRows then + DY := lRows; + DY := DY * FRowHeight; + Update; + {Make sure the canvas is updated, + because we will be validating the scrolled portion.} + Inv := ScrollCanvas(Canvas, ClipArea, False, DY, (not ThumbTracking) and FSmoothScroll); + InvalidateRect(Handle, @Inv, False); + InvalidateRect(Handle, @TmpArea, False); + if SaveD <> FTopIndex then begin + DoOnTopIndexChanged(FTopIndex); + SaveD := FTopIndex; + end; + Update; + end; + end; + vlbSetFocusedIndex(FItemIndex); + + {notify that top index has changed} + if SaveD <> FTopIndex then + DoOnTopIndexChanged(FTopIndex); + end; +end; + +procedure TOvcCustomVirtualListBox.SetTopIndex(Index : LongInt); + {-set the index of the first visible entry in the list} +begin + if csDesigning in ComponentState then + Exit; + + if Index <> FTopIndex then + ForceTopIndex(Index, False); +end; + +procedure TOvcCustomVirtualListBox.vlbAdjustIntegralHeight; +begin + if (csDesigning in ComponentState) and + not (csLoading in ComponentState) then + if FIntegralHeight then + if ClientHeight mod FRowHeight <> 0 then + ClientHeight := (ClientHeight div FRowHeight) * FRowHeight; +end; + +procedure TOvcCustomVirtualListBox.vlbCalcFontFields; +var + Alpha : string; +begin + if not HandleAllocated then + Exit; + + Alpha := GetOrphStr(SCAlphaString); + + {set the canvas font} + Canvas.Font := Self.Font; + + {determine the height of one row} + if FAutoRowHeight and not (csLoading in ComponentState) then + FRowHeight := Canvas.TextHeight(GetOrphStr(SCTallLowChars)) + lVMargin; + lRows := (ClientHeight div FRowHeight)-Ord(FShowHeader); + if lRows < 1 then + lRows := 1; + + {calculate the base dialog unit for tab spacing} + lDlgUnits := (Canvas.TextWidth(Alpha) div Length(Alpha)) div 4 +end; + +procedure TOvcCustomVirtualListBox.vlbClearAllItems; + {-clear the highlight from all items} +begin + vlbSetAllItemsPrim(False); +end; + +procedure TOvcCustomVirtualListBox.vlbClearSelRange(First, Last : LongInt); + {-clear the selection for the given range of indexes} +begin + vlbSelectRangePrim(First, Last, False); +end; + +procedure TOvcCustomVirtualListBox.vlbColorChanged(AColor: TObject); + {-a color has changed, refresh display} +begin + Refresh; +end; + +procedure TOvcCustomVirtualListBox.vlbDrawFocusRect(Index : LongInt); + {-draw the focus rectangle} +var + CR : TRect; +begin + if Index < 0 then exit; + if Focused then begin + if (Index >= FTopIndex) and (Index-FTopIndex <= Pred(lRows)) then begin + CR := ClientRect; + CR.Top := (Index-FTopIndex+Ord(FShowHeader))*FRowHeight; + CR.Bottom := CR.Top + FRowHeight; + Canvas.DrawFocusRect(CR); + end; + end; + lFocusedIndex := Index; +end; + +procedure TOvcCustomVirtualListBox.vlbDragSelection(First, Last : LongInt); + {-drag the selection} +var + I : LongInt; + OutSide : Boolean; +begin + + {set new active item} + vlbNewActiveItem(Last); + + {remove selection from visible selected items not in range} + for I := FTopIndex to FTopIndex+Pred(lRows) do begin + if First <= Last then + OutSide := (I < First) or (I > Last) + else + OutSide := (I < Last) or (I > First); + + if DoOnIsSelected(I) and OutSide then + InvalidateItem(I); + + end; + + {deselect all items} + DoOnSelect(-1, False); + + {select new range} + vlbSetSelRange(First, Last); + vlbSetFocusedIndex(Last); + Update; +end; + +procedure TOvcCustomVirtualListBox.vlbDrawHeader; + {-draw the header and text} +var + R : TRect; + Buf : array[0..255] of AnsiChar; + S : PAnsiChar; + DX : Integer; +begin + {get the printable area of the header text} + StrPCopy(Buf, FHeader); + if lHDelta >= LongInt(StrLen(Buf)) then + S := ' ' {space to erase last character from header} + else + S := @Buf[lHDelta]; + + Canvas.Font := Font; + with Canvas do begin + {draw header text} + Brush.Color := FHeaderColor.BackColor; + Font.Color := FHeaderColor.TextColor; + + R := Bounds(0, 0, Width, FRowHeight-1); + + {clear the line} + Canvas.FillRect(R); + + if S <> nil then + if FUseTabStops then begin + DX := 0; + if lHDelta > 0 then begin + {measure portion of string to the left of the window} + DX := LOWORD(GetTabbedTextExtent(Canvas.Handle, Buf, lHDelta, + lNumTabStops, lTabs)); + end; + TabbedTextOut(Canvas.Handle, 2, 0, + S, StrLen(S), lNumTabStops, lTabs, -DX) + end else + ExtTextOut(Canvas.Handle, 2, 0, ETO_OPAQUE + ETO_CLIPPED, + @R, S, StrLen(S), nil); + + {draw border line} + Pen.Color := clBlack; + PolyLine([Point(R.Left, R.Bottom), Point(R.Right, R.Bottom)]); + + {draw ctl3d highlight} + if Ctl3D then begin + Pen.Color := clBtnHighlight; + PolyLine([Point(R.Left, R.Bottom-1), + Point(R.Left, R.Top), + Point(R.Right, R.Top)]); + end; + end; +end; + +procedure TOvcCustomVirtualListBox.vlbExtendSelection(Index : LongInt); + {-process Shift-LMouseBtn} +begin + {verify valid index} + if Index < 0 then + Index := 0 + else if Index > lHighIndex then + Index := lHighIndex; + + {clear current selections} + vlbClearAllItems; + + {set selection for all items from the active one to the currently selected item} + vlbSetSelRange(lAnchor, Index); + + {set new active item} + FItemIndex := Index; + vlbSetFocusedIndex(FItemIndex); + Update; +end; + +procedure TOvcCustomVirtualListBox.vlbHScrollPrim(Delta : Integer); +var + SaveD : LongInt; +begin + SaveD := lHDelta; + if Delta < 0 then + if Delta > lHDelta then + lHDelta := 0 + else + Inc(lHDelta, Delta) + else + if LongInt(lHDelta)+Delta > LongInt(FColumns) then + lHDelta := FColumns + else + Inc(lHDelta, Delta); + + if lhDelta < 0 then + lhDelta := 0; + + if lHDelta <> SaveD then begin + vlbSetHScrollPos; + Refresh; + end; +end; + +procedure TOvcCustomVirtualListBox.vlbInitScrollInfo; + {-setup scroll bar range and initial position} +begin + if not HandleAllocated then + Exit; + + {initialize scroll bars, if any} + vlbSetVScrollRange; + vlbSetVScrollPos; + vlbSetHScrollRange; + vlbSetHScrollPos; +end; + +procedure TOvcCustomVirtualListBox.vlbMakeItemVisible(Index : LongInt); + {-make sure the item is visible} +begin + if Index < FTopIndex then + TopIndex := Index + else if Index+LongInt($80000000) > (FTopIndex+Pred(lRows))+LongInt($80000000) then begin + TopIndex := Index-Pred(lRows); + if FTopIndex < 0 then + TopIndex := 0; + end; +end; + +procedure TOvcCustomVirtualListBox.vlbNewActiveItem(Index : LongInt); + {-set the currently selected item} +begin + {verify valid index} + if Index < 0 then + Index := 0 + else if Index > lHighIndex then + Index := lHighIndex; + + {set the newly selected item index} + FItemIndex := Index; + vlbMakeItemVisible(Index); + DoOnSelect(Index, True); + InvalidateItem(Index); +end; + +function TOvcCustomVirtualListBox.vlbScaleDown(N : LongInt) : Integer; +begin + Result := N div lDivisor; +end; + +function TOvcCustomVirtualListBox.vlbScaleUp(N : LongInt) : LongInt; +begin + Result := N * lDivisor; +end; + +procedure TOvcCustomVirtualListBox.vlbSelectRangePrim(First, Last : LongInt; Select : Boolean); + {-change the selection for the given range of indexes} +var + I : LongInt; +begin + if First <= Last then begin + for I := First to Last do begin + DoOnSelect(I, Select); + InvalidateItem(I); + end; + end else begin + for I := First downto Last do begin + DoOnSelect(I, Select); + InvalidateItem(I); + end; + end; +end; + +procedure TOvcCustomVirtualListBox.vlbSetAllItemsPrim(Select : Boolean); + {-primitive routine thats acts on all items} +var + I : LongInt; + LastIndex : LongInt; +begin + {determine highest index to test} + LastIndex := FTopIndex+Pred(lRows); + if LastIndex > Pred(FNumItems) then + LastIndex := Pred(FNumItems); + + {invalidate items that require repainting} + for I := FTopIndex to LastIndex do + if DoOnIsSelected(I) <> Select then + InvalidateItem(I); + + {select or deselect all items} + DoOnSelect(-1, Select); +end; + +procedure TOvcCustomVirtualListBox.vlbSetFocusedIndex(Index : LongInt); + {-set focus index to this item. invalidate previous} +begin + if Index <> lFocusedIndex then begin + InvalidateItem(lFocusedIndex); + + lFocusedIndex := Index; + InvalidateItem(lFocusedIndex); + end; +end; + +{ rewritten - see below +procedure TOvcCustomVirtualListBox.vlbSetHScrollPos; +begin + if lHaveHS then + SetScrollPos(Handle, SB_HORZ, lHDelta, True); +end; +} + +{ rewritten} +procedure TOvcCustomVirtualListBox.vlbSetHScrollPos; +var + SI : TScrollInfo; +begin + if lHaveHS and HandleAllocated then begin + with SI do begin + cbSize := SizeOf(SI); + fMask := SIF_RANGE or SIF_PAGE or SIF_POS; + nMin := 0; + nMax := FColumns; + nPage := FColumns div 2; + nPos := lhDelta; + nTrackPos := nPos; + end; + SetScrollInfo(Handle, SB_HORZ, SI, True); + end; +end; + +{ rewritten - see below +procedure TOvcCustomVirtualListBox.vlbSetHScrollRange; +begin + if lHaveHS then + SetScrollRange(Handle, SB_HORZ, 0, FColumns, False); +end; +} + +{ rewritten} +procedure TOvcCustomVirtualListBox.vlbSetHScrollRange; +{var + SI : TScrollInfo;} +begin + vlbSetHScrollPos; + (* + if lHaveHS then + begin + with SI do + begin + fMask := {SIF_PAGE + }SIF_RANGE; + nMin := 1; + nMax := FColumns - ClientWidth; + //nPage := nMax div 10; + cbSize := SizeOf(SI); + end; + SetScrollInfo(Handle, SB_HORZ, SI, False); + end; + *) +end; + +procedure TOvcCustomVirtualListBox.vlbSetSelRange(First, Last : LongInt); + {-set the selection on for the given range of indexes} +begin + vlbSelectRangePrim(First, Last, True); +end; + +procedure TOvcCustomVirtualListBox.vlbSetVScrollPos; +var + SI : TScrollInfo; +begin + if not HandleAllocated then + Exit; + with SI do begin + cbSize := SizeOf(SI); + fMask := SIF_RANGE or SIF_PAGE or SIF_POS; + nMin := 0; + nMax := Pred(lVSHigh); + nPage := lRows; + nPos := vlbScaleDown(FTopIndex); + nTrackPos := nPos; + end; + SetScrollInfo(Handle, SB_VERT, SI, True); +end; + +procedure TOvcCustomVirtualListBox.vlbSetVScrollRange; +var + ItemRange : LongInt; +begin + ItemRange := FNumItems; + lDivisor := 1; + if ItemRange < lRows then + lVSHigh := 1 + else if ItemRange <= High(SmallInt) then + lVSHigh := ItemRange + else begin + lDivisor := 2*(ItemRange div 32768); + lVSHigh := ItemRange div lDivisor; + end; + + if lHaveVS then + if not ((FNumItems > lRows) or (csDesigning in ComponentState)) then + lvSHigh := 0 + else + else + lvSHigh := 0; + vlbSetVScrollPos; +end; + +procedure TOvcCustomVirtualListBox.vlbToggleSelection(Index : LongInt); + {-process Ctrl-LMouseBtn} +var + WasSelected : Boolean; +begin + if (Index < 0) or (Index > lHighIndex) then + exit; + {toggle highlight} + WasSelected := DoOnIsSelected(Index); + DoOnSelect(Index, not WasSelected); + vlbSetFocusedIndex(Index); + DrawItem(Index); + {set new active item} + FItemIndex := Index; + {and anchor point} + lAnchor := Index; +end; + +procedure TOvcCustomVirtualListBox.vlbValidateItem(Index : LongInt); + {-validate the area for this item} +var + CR : TRect; +begin + if (Index >= FTopIndex) and (Index-FTopIndex < lRows) then begin {visible?} + CR := Rect(0, (Index-FTopIndex+Ord(FShowHeader))*FRowHeight, ClientWidth, 0); + CR.Bottom := CR.Top+FRowHeight; + ValidateRect(Handle, @CR); + end; +end; + +procedure TOvcCustomVirtualListBox.vlbVScrollPrim(Delta : Integer); +var + I : LongInt; +begin + I := FTopIndex+Delta; + if I < 0 then + if Delta > 0 then + I := lHighIndex + else + I := 0 + else if (I > lHighIndex-Pred(lRows)) then begin + if lHighIndex > Pred(lRows) then + I := lHighIndex-Pred(lRows) + else + I := 0; + end; + + SetTopIndex(I); +end; + +procedure TOvcCustomVirtualListBox.WMChar(var Msg : TWMChar); +var + L : LongInt; +begin + inherited; + + L := DoOnCharToItem(AnsiChar(Msg.CharCode)); + if (L >= 0) and (L <= lHighIndex) then + SetItemIndex(L); +end; + +procedure TOvcCustomVirtualListBox.WMEraseBkgnd(var Msg : TWMEraseBkGnd); +begin + {indicate that we have processed this message} + Msg.Result := 1; +end; + +procedure TOvcCustomVirtualListBox.WMGetDlgCode(var Msg : TWMGetDlgCode); +begin + inherited; + + Msg.Result := Msg.Result or DLGC_WANTCHARS or DLGC_WANTARROWS; +end; + +procedure TOvcCustomVirtualListBox.WMHScroll(var Msg : TWMHScroll); +begin + case Msg.ScrollCode of + SB_LINERIGHT : vlbHScrollPrim(+1); + SB_LINELEFT : vlbHScrollPrim(-1); + SB_PAGERIGHT : vlbHScrollPrim(+10); + SB_PAGELEFT : vlbHScrollPrim(-10); + SB_THUMBPOSITION, SB_THUMBTRACK : + if lHDelta <> Msg.Pos then begin + lHDelta := Msg.Pos; + vlbSetHScrollPos; + Refresh; + end; + end; +end; + +procedure TOvcCustomVirtualListBox.WMKeyDown(var Msg : TWMKeyDown); +var + I : LongInt; + Cmd : Word; +begin + inherited; + + Cmd := Controller.EntryCommands.Translate(TMessage(Msg)); + if Cmd <> ccNone then begin + + {filter invalid commands} + case Cmd of + ccExtendHome, ccExtendEnd, ccExtendPgUp, + ccExtendPgDn, ccExtendUp, ccExtendDown : + if not FMultiSelect then + Exit; + end; + + case Cmd of + ccLeft : + if lHaveHs then begin + if lHDelta > 0 then begin + Dec(lHDelta); + vlbSetHScrollPos; + Refresh; + end; + end else begin + if FItemIndex > 0 then begin + vlbClearAllItems; + SetItemIndex(FItemIndex-1); + lAnchor := FItemIndex; + end; + end; + ccRight : + if lHaveHs then begin + if lHDelta < FColumns then begin + Inc(lHDelta); + vlbSetHScrollPos; + Refresh; + end; + end else begin + if FItemIndex < lHighIndex then begin + vlbClearAllItems; + SetItemIndex(FItemIndex+1); + lAnchor := FItemIndex; + end; + end; + ccUp : + if FItemIndex > 0 then begin + vlbClearAllItems; + SetItemIndex(FItemIndex-1); + lAnchor := FItemIndex; + end; + ccDown : + if FItemIndex < lHighIndex then begin + vlbClearAllItems; + SetItemIndex(FItemIndex+1); + lAnchor := FItemIndex; + end; + ccHome : + if FItemIndex <> 0 then begin + vlbClearAllItems; + SetItemIndex(0); + lAnchor := FItemIndex; + end; + ccEnd : + if (FNumItems > 0) and (FItemIndex <> lHighIndex) then begin + vlbClearAllItems; + SetItemIndex(lHighIndex); + lAnchor := FItemIndex; + end; + ccPrevPage : + if FNumItems > 0 then begin + if lRows = 1 then + I := Pred(FItemIndex) + else + I := FItemIndex-Pred(lRows); + if I < 0 then + I := 0; + if I <> FItemIndex then begin + vlbClearAllItems; + SetItemIndex(I); + lAnchor := FItemIndex; + end; + end; + ccNextPage : + if FNumItems > 0 then begin + if lRows = 1 then begin + if FItemIndex < lHighIndex then + I := Succ(FItemIndex) + else + I := lHighIndex; + end else if FItemIndex <= lHighIndex-Pred(lRows) then + I := FItemIndex+Pred(lRows) + else + I := lHighIndex; + if I <> FItemIndex then begin + vlbClearAllItems; + SetItemIndex(I); + lAnchor := FItemIndex; + end; + end; + ccExtendHome : + if FItemIndex > 0 then begin + vlbNewActiveItem(0); + vlbExtendSelection(0); + end; + ccExtendEnd : + if FItemIndex < lHighIndex then begin + vlbNewActiveItem(lHighIndex); + vlbExtendSelection(lHighIndex); + end; + ccExtendPgUp : + begin + I := FItemIndex-Pred(lRows); + vlbNewActiveItem(I); + vlbExtendSelection(I); + end; + ccExtendPgDn : + begin + I := FItemIndex+Pred(lRows); + vlbNewActiveItem(I); + vlbExtendSelection(I); + end; + ccExtendUp : + begin + I := FItemIndex-1; + vlbNewActiveItem(I); + vlbExtendSelection(I); + end; + ccExtendDown : + begin + I := FItemIndex+1; + vlbNewActiveItem(I); + vlbExtendSelection(I); + end; + else + {do user command notification for user commands} + if Cmd >= ccUserFirst then + DoOnUserCommand(Cmd); + end; + + {indicate that this message was processed} + Msg.Result := 0; + end; +end; + +procedure TOvcCustomVirtualListBox.WMKillFocus(var Msg : TWMKillFocus); +begin + inherited; + + {re-draw focused item to erase focus rect} + DrawItem(lFocusedIndex); +end; + +procedure TOvcCustomVirtualListBox.WMLButtonDown(var Msg : TWMLButtonDown); +var + I : LongInt; + LastI : LongInt; + LButton : Byte; + CtrlKeyDown : Boolean; + ShiftKeyDown : Boolean; + + function PointToIndex : LongInt; + var + Pt : TPoint; + begin + GetCursorPos(Pt); + Pt := ScreenToClient(Pt); + if Pt.Y < Ord(FShowHeader)*FRowHeight then begin + {speed up as the cursor moves farther away} + Result := FTopIndex+(Pt.Y div FRowHeight)-1; + if Result < 0 then + Result := 0; + end else if Pt.Y >= ClientHeight then begin + {speed up as the cursor moves farther away} + Result := FTopIndex+(Pt.Y div FRowHeight); + if Result > lHighIndex then + Result := lHighIndex; + end else begin + {convert to an index} + Result := FTopIndex-Ord(FShowHeader)+(Pt.Y div FRowHeight); + if ClientHeight mod FRowHeight > 0 then + if Result > FTopIndex-1 + lRows then + Result := FTopIndex-1 + lRows; + end; + end; + +var + ItemNo : Integer; + ShiftState: TShiftState; +begin + ShiftState := KeysToShiftState(Msg.Keys); + if (DragMode = dmAutomatic) and FMultiSelect then + begin + if not (ssShift in ShiftState) or (ssCtrl in ShiftState) then + begin + ItemNo := ItemAtPos(SmallPointToPoint(Msg.Pos), True); + if (ItemNo >= 0) and (DoOnIsSelected(ItemNo)) then + begin + BeginDrag (False); + Exit; + end; + end; + end; + inherited; + if (DragMode = dmAutomatic) and not (FMultiSelect and + ((ssCtrl in ShiftState) or (ssShift in ShiftState))) then + BeginDrag(False); + + if MousePassThru then exit; + + {solve problem with minimized modeless dialogs and MDI child windows} + {that contain virtual ListBox components} + if not Focused and CanFocus then +{$IFNDEF LCL} + Windows.SetFocus(Handle); +{$ELSE} + LclIntf.SetFocus(Handle); +{$ENDIF} + + {is this click on the header?} + if FShowHeader and (Msg.YPos < FRowHeight) then begin + DoOnClickHeader(Point(Msg.XPos, Msg.YPos)); + Exit; + end; + + if (FNumItems <> 0) then begin + {get the actual left button} + LButton := GetLeftButton; + + {get the key state} + if FMultiSelect then begin + CtrlKeyDown := GetKeyState(VK_CONTROL) and $8000 <> 0; + ShiftKeyDown := GetKeyState(VK_SHIFT) and $8000 <> 0; + end else begin + CtrlKeyDown := False; + ShiftKeyDown := False; + end; + + if CtrlKeyDown then + vlbToggleSelection(PointToIndex) + else if ShiftKeyDown then + vlbExtendSelection(PointToIndex) + else begin + vlbClearAllItems; + + {reselect the active item} + if FItemIndex <> -1 then begin + DoOnSelect(FItemIndex, True); + vlbSetFocusedIndex(FItemIndex); + end; + + {watch the mouse position while the left button is down} + LastI := -1; + repeat + I := PointToIndex; + if I <= lHighIndex then + if not FMultiSelect or (LastI = -1) then begin + SetItemIndex(I); + lAnchor := I; + LastI := I; + end else begin + {extend/shrink the selection to follow the mouse} + if I <> LastI then begin + vlbDragSelection(lAnchor, I); + LastI := I; + end; + end; + Application.ProcessMessages; {Gasp} +{$IFDEF MSWINDOWS} + until ({$IFNDEF LCL} GetAsyncKeyState(LButton) {$ELSE} GetKeyState(LButton) {$ENDIF} and $8000 = 0) +{$ELSE} //GTK GetKeyState returns 0 + until (not (csLButtonDown in ControlState)) +{$ENDIF} + or Dragging or (GetCapture <> Handle); + + end; + end; +end; + +procedure TOvcCustomVirtualListBox.WMLButtonDblClk(var Msg : TWMLButtonDblClk); +begin + {is this click below the header, if any} + if (Msg.YPos > FRowHeight * Ord(FShowHeader)) then + inherited + else + {say we processed this message} + Msg.Result := 0; +end; + +procedure TOvcCustomVirtualListBox.WMMouseActivate(var Msg : TWMMouseActivate); +begin + if (csDesigning in ComponentState) or (GetFocus = Handle) then + inherited + else begin + if Controller.ErrorPending then + Msg.Result := MA_NOACTIVATEANDEAT + else + Msg.Result := MA_ACTIVATE; + end; +end; + +procedure TOvcCustomVirtualListBox.WMSetFocus(var Msg : TWMSetFocus); +begin + inherited; + + Update; + DrawItem(lFocusedIndex); +end; + +procedure TOvcCustomVirtualListBox.WMSize(var Msg : TWMSize); +begin + if FRowHeight > 0 then begin + {integral font height adjustment} + vlbCalcFontFields; + vlbAdjustIntegralHeight; + vlbCalcFontFields; + vlbInitScrollInfo; + + {reposition so that items are displayed at bottom of list} + if lRows + FTopIndex - 1 >= FNumItems then + if NumItems-lRows >= 0 then + TopIndex := NumItems-lRows + else + TopIndex := 0; + end; + + inherited; +end; + +procedure TOvcCustomVirtualListBox.WMVScroll(var Msg : TWMVScroll); +var + I : LongInt; +begin + case Msg.ScrollCode of + SB_LINEUP : vlbVScrollPrim(-1); + SB_LINEDOWN : vlbVScrollPrim(+1); + SB_PAGEDOWN : vlbVScrollPrim(+Pred(lRows)); + SB_PAGEUP : vlbVScrollPrim(-Pred(lRows)); + SB_THUMBPOSITION, SB_THUMBTRACK : + begin + if Msg.Pos = 0 then + I := 0 + else if Msg.Pos = lVSHigh then + if lRows >= FNumItems then + I := 0 + else + I := lHighIndex-Pred(lRows) + else + I := vlbScaleUp(Msg.Pos); + ForceTopIndex(I,True); + end; + end; +end; + +{ new} +procedure TOvcCustomVirtualListBox.SetColumns(const Value: Integer); +begin + if Value <> FColumns then begin + FColumns := Value; + vlbInitScrollInfo; + end; +end; + +end. diff --git a/components/orpheus/tests/TestLabel/project1.bdsproj b/components/orpheus/tests/TestLabel/project1.bdsproj new file mode 100644 index 000000000..21fa37665 --- /dev/null +++ b/components/orpheus/tests/TestLabel/project1.bdsproj @@ -0,0 +1,175 @@ + + + + + + + + + + + + project1.dpr + + + 7.0 + + + 8 + 0 + 1 + 1 + 0 + 0 + 1 + 1 + 1 + 0 + 0 + 1 + 0 + 1 + 1 + 1 + 1 + 1 + 0 + 1 + 0 + 1 + 0 + 1 + 1 + 1 + True + True + WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; + + False + + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + False + False + False + True + True + True + True + True + True + + + + 0 + 0 + False + 1 + False + False + False + 16384 + 1048576 + 4194304 + + + + + + + + C:\Orpheus4\FPC + vcl;rtl;vclx;indy;vclie;xmlrtl;inetdbbde;inet;inetdbxpress;dbrtl;soaprtl;dsnap;VclSmp;dbexpress;vcldb;dbxcds;inetdb;bdertl;vcldbx;adortl;teeui;teedb;tee;ibxpress;visualclx;visualdbclx;vclactnband;vclshlctrls;IntrawebDB_50_70;Intraweb_50_70;Rave50CLX;Rave50VCL;dclOffice2k + + + False + + + + + + False + + + True + False + + + + $00000000 + + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1033 + 1252 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + diff --git a/components/orpheus/tests/TestLabel/project1.cfg b/components/orpheus/tests/TestLabel/project1.cfg new file mode 100644 index 000000000..45be3be19 --- /dev/null +++ b/components/orpheus/tests/TestLabel/project1.cfg @@ -0,0 +1,38 @@ +-$A8 +-$B- +-$C+ +-$D+ +-$E- +-$F- +-$G+ +-$H+ +-$I+ +-$J- +-$K- +-$L+ +-$M- +-$N+ +-$O+ +-$P+ +-$Q+ +-$R+ +-$S- +-$T+ +-$U- +-$V+ +-$W- +-$X+ +-$YD +-$Z1 +-cg +-AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; +-H+ +-W+ +-M +-$M16384,1048576 +-K$00400000 +-LE"c:\delphi7\Projects\Bpl" +-LN"c:\delphi7\Projects\Bpl" +-w-UNSAFE_TYPE +-w-UNSAFE_CODE +-w-UNSAFE_CAST diff --git a/components/orpheus/tests/TestLabel/project1.dof b/components/orpheus/tests/TestLabel/project1.dof new file mode 100644 index 000000000..a964abf67 --- /dev/null +++ b/components/orpheus/tests/TestLabel/project1.dof @@ -0,0 +1,136 @@ +[FileVersion] +Version=7.0 +[Compiler] +A=8 +B=0 +C=1 +D=1 +E=0 +F=0 +G=1 +H=1 +I=1 +J=0 +K=0 +L=1 +M=0 +N=1 +O=1 +P=1 +Q=1 +R=1 +S=0 +T=1 +U=0 +V=1 +W=0 +X=1 +Y=1 +Z=1 +ShowHints=1 +ShowWarnings=1 +UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; +NamespacePrefix= +SymbolDeprecated=1 +SymbolLibrary=1 +SymbolPlatform=1 +UnitLibrary=1 +UnitPlatform=1 +UnitDeprecated=1 +HResultCompat=1 +HidingMember=1 +HiddenVirtual=1 +Garbage=1 +BoundsError=1 +ZeroNilCompat=1 +StringConstTruncated=1 +ForLoopVarVarPar=1 +TypedConstVarPar=1 +AsgToTypedConst=1 +CaseLabelRange=1 +ForVariable=1 +ConstructingAbstract=1 +ComparisonFalse=1 +ComparisonTrue=1 +ComparingSignedUnsigned=1 +CombiningSignedUnsigned=1 +UnsupportedConstruct=1 +FileOpen=1 +FileOpenUnitSrc=1 +BadGlobalSymbol=1 +DuplicateConstructorDestructor=1 +InvalidDirective=1 +PackageNoLink=1 +PackageThreadVar=1 +ImplicitImport=1 +HPPEMITIgnored=1 +NoRetVal=1 +UseBeforeDef=1 +ForLoopVarUndef=1 +UnitNameMismatch=1 +NoCFGFileFound=1 +MessageDirective=1 +ImplicitVariants=1 +UnicodeToLocale=1 +LocaleToUnicode=1 +ImagebaseMultiple=1 +SuspiciousTypecast=1 +PrivatePropAccessor=1 +UnsafeType=0 +UnsafeCode=0 +UnsafeCast=0 +[Linker] +MapFile=0 +OutputObjs=0 +ConsoleApp=1 +DebugInfo=0 +RemoteSymbols=0 +MinStackSize=16384 +MaxStackSize=1048576 +ImageBase=4194304 +ExeDescription= +[Directories] +OutputDir= +UnitOutputDir= +PackageDLLOutputDir= +PackageDCPOutputDir= +SearchPath= +Packages=vcl;rtl;vclx;indy;vclie;xmlrtl;inetdbbde;inet;inetdbxpress;dbrtl;soaprtl;dsnap;VclSmp;dbexpress;vcldb;dbxcds;inetdb;bdertl;vcldbx;adortl;teeui;teedb;tee;ibxpress;visualclx;visualdbclx;vclactnband;vclshlctrls;IntrawebDB_50_70;Intraweb_50_70;Rave50CLX;Rave50VCL;dclOffice2k +Conditionals= +DebugSourceDirs= +UsePackages=0 +[Parameters] +RunParams= +HostApplication= +Launcher= +UseLauncher=0 +DebugCWD= +[Language] +ActiveLang= +ProjectLang= +RootDir= +[Version Info] +IncludeVerInfo=0 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1033 +CodePage=1252 +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= diff --git a/components/orpheus/tests/TestLabel/project1.dpr b/components/orpheus/tests/TestLabel/project1.dpr new file mode 100644 index 000000000..8a2e82e5d --- /dev/null +++ b/components/orpheus/tests/TestLabel/project1.dpr @@ -0,0 +1,18 @@ +program Project1; + +uses +{$IFDEF LCL} + Interfaces, +{$ENDIF} + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$IFDEF MSWINDOWS} +{$R *.res} +{$ENDIF} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/components/orpheus/tests/TestLabel/project1.lpi b/components/orpheus/tests/TestLabel/project1.lpi new file mode 100644 index 000000000..8f104d268 --- /dev/null +++ b/components/orpheus/tests/TestLabel/project1.lpi @@ -0,0 +1,110 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/components/orpheus/tests/TestLabel/project1.res b/components/orpheus/tests/TestLabel/project1.res new file mode 100644 index 000000000..3adc0361f Binary files /dev/null and b/components/orpheus/tests/TestLabel/project1.res differ diff --git a/components/orpheus/tests/TestLabel/unit1.dfm b/components/orpheus/tests/TestLabel/unit1.dfm new file mode 100644 index 000000000..257f4f0f5 --- /dev/null +++ b/components/orpheus/tests/TestLabel/unit1.dfm @@ -0,0 +1,48 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Width = 386 + Height = 340 + Caption = 'Form1' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object OvcLabel1: TOvcLabel + Left = 64 + Top = 32 + Width = 257 + Height = 49 + Caption = 'Fancy Raised Label' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clGray + Font.Height = -26 + Font.Name = 'Times New Roman' + Font.Style = [] + ParentColor = False + end + object OvcLabel2: TOvcLabel + Left = 64 + Top = 112 + Width = 257 + Height = 49 + Appearance = apSunken + Caption = 'Fancy Sunken Label' + Color = clBtnFace + ColorScheme = csCustom + CustomSettings.HighlightDirection = sdDownRight + CustomSettings.ShadowDirection = sdUpLeft + Font.Charset = DEFAULT_CHARSET + Font.Color = clGray + Font.Height = -26 + Font.Name = 'Times New Roman' + Font.Style = [] + ParentColor = False + end +end diff --git a/components/orpheus/tests/TestLabel/unit1.lfm b/components/orpheus/tests/TestLabel/unit1.lfm new file mode 100644 index 000000000..68d194c57 --- /dev/null +++ b/components/orpheus/tests/TestLabel/unit1.lfm @@ -0,0 +1,44 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Width = 378 + Height = 306 + Caption = 'Form1' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Style = [] + PixelsPerInch = 96 + TextHeight = 13 + object OvcLabel1: TOvcLabel + Left = 64 + Top = 32 + Width = 257 + Height = 49 + Caption = 'Fancy Raised Label' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clGray + Font.Height = -26 + Font.Style = [] + ParentColor = False + end + object OvcLabel2: TOvcLabel + Left = 64 + Top = 112 + Width = 257 + Height = 49 + Appearance = apSunken + Caption = 'Fancy Sunken Label' + Color = clBtnFace + ColorScheme = csCustom + CustomSettings.HighlightDirection = sdDownRight + CustomSettings.ShadowDirection = sdUpLeft + Font.Charset = DEFAULT_CHARSET + Font.Color = clGray + Font.Height = -26 + Font.Style = [] + ParentColor = False + end +end diff --git a/components/orpheus/tests/TestLabel/unit1.lrs b/components/orpheus/tests/TestLabel/unit1.lrs new file mode 100644 index 000000000..264227b13 --- /dev/null +++ b/components/orpheus/tests/TestLabel/unit1.lrs @@ -0,0 +1,16 @@ +LazarusResources.Add('TForm1','FORMDATA',[ + 'TPF0'#6'TForm1'#5'Form1'#4'Left'#3#192#0#3'Top'#2'r'#5'Width'#3'z'#1#6'Heigh' + +'t'#3'2'#1#7'Caption'#6#5'Form1'#5'Color'#7#9'clBtnFace'#12'Font.Charset'#7 + +#15'DEFAULT_CHARSET'#10'Font.Color'#7#12'clWindowText'#11'Font.Height'#2#245 + +#10'Font.Style'#11#0#13'PixelsPerInch'#2'`'#10'TextHeight'#2#13#0#9'TOvcLabe' + +'l'#9'OvcLabel1'#4'Left'#2'@'#3'Top'#2' '#5'Width'#3#1#1#6'Height'#2'1'#7'Ca' + +'ption'#6#18'Fancy Raised Label'#5'Color'#7#9'clBtnFace'#12'Font.Charset'#7 + +#15'DEFAULT_CHARSET'#10'Font.Color'#7#6'clGray'#11'Font.Height'#2#230#10'Fon' + +'t.Style'#11#0#11'ParentColor'#8#0#0#9'TOvcLabel'#9'OvcLabel2'#4'Left'#2'@'#3 + +'Top'#2'p'#5'Width'#3#1#1#6'Height'#2'1'#10'Appearance'#7#8'apSunken'#7'Capt' + +'ion'#6#18'Fancy Sunken Label'#5'Color'#7#9'clBtnFace'#11'ColorScheme'#7#8'c' + +'sCustom!CustomSettings.HighlightDirection'#7#11'sdDownRight'#30'CustomSetti' + +'ngs.ShadowDirection'#7#8'sdUpLeft'#12'Font.Charset'#7#15'DEFAULT_CHARSET'#10 + +'Font.Color'#7#6'clGray'#11'Font.Height'#2#230#10'Font.Style'#11#0#11'Parent' + +'Color'#8#0#0#0 +]); diff --git a/components/orpheus/tests/TestLabel/unit1.pas b/components/orpheus/tests/TestLabel/unit1.pas new file mode 100644 index 000000000..1ea0615b9 --- /dev/null +++ b/components/orpheus/tests/TestLabel/unit1.pas @@ -0,0 +1,37 @@ +unit Unit1; + +interface + +uses + {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, LclType, LResources, {$ENDIF} + SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, ovclabel; + +type + + { TForm1 } + + TForm1 = class(TForm) + OvcLabel1: TOvcLabel; + OvcLabel2: TOvcLabel; + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$IFNDEF LCL} +{$R *.dfm} +{$ENDIF} + +initialization +{$IFDEF LCL} +{$I Unit1.lrs} {Include form's resource file} +{$ENDIF} + +end. diff --git a/components/orpheus/tests/TestRLbl/project1.bdsproj b/components/orpheus/tests/TestRLbl/project1.bdsproj new file mode 100644 index 000000000..21fa37665 --- /dev/null +++ b/components/orpheus/tests/TestRLbl/project1.bdsproj @@ -0,0 +1,175 @@ + + + + + + + + + + + + project1.dpr + + + 7.0 + + + 8 + 0 + 1 + 1 + 0 + 0 + 1 + 1 + 1 + 0 + 0 + 1 + 0 + 1 + 1 + 1 + 1 + 1 + 0 + 1 + 0 + 1 + 0 + 1 + 1 + 1 + True + True + WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; + + False + + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + False + False + False + True + True + True + True + True + True + + + + 0 + 0 + False + 1 + False + False + False + 16384 + 1048576 + 4194304 + + + + + + + + C:\Orpheus4\FPC + vcl;rtl;vclx;indy;vclie;xmlrtl;inetdbbde;inet;inetdbxpress;dbrtl;soaprtl;dsnap;VclSmp;dbexpress;vcldb;dbxcds;inetdb;bdertl;vcldbx;adortl;teeui;teedb;tee;ibxpress;visualclx;visualdbclx;vclactnband;vclshlctrls;IntrawebDB_50_70;Intraweb_50_70;Rave50CLX;Rave50VCL;dclOffice2k + + + False + + + + + + False + + + True + False + + + + $00000000 + + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1033 + 1252 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + diff --git a/components/orpheus/tests/TestRLbl/project1.cfg b/components/orpheus/tests/TestRLbl/project1.cfg new file mode 100644 index 000000000..45be3be19 --- /dev/null +++ b/components/orpheus/tests/TestRLbl/project1.cfg @@ -0,0 +1,38 @@ +-$A8 +-$B- +-$C+ +-$D+ +-$E- +-$F- +-$G+ +-$H+ +-$I+ +-$J- +-$K- +-$L+ +-$M- +-$N+ +-$O+ +-$P+ +-$Q+ +-$R+ +-$S- +-$T+ +-$U- +-$V+ +-$W- +-$X+ +-$YD +-$Z1 +-cg +-AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; +-H+ +-W+ +-M +-$M16384,1048576 +-K$00400000 +-LE"c:\delphi7\Projects\Bpl" +-LN"c:\delphi7\Projects\Bpl" +-w-UNSAFE_TYPE +-w-UNSAFE_CODE +-w-UNSAFE_CAST diff --git a/components/orpheus/tests/TestRLbl/project1.dof b/components/orpheus/tests/TestRLbl/project1.dof new file mode 100644 index 000000000..a964abf67 --- /dev/null +++ b/components/orpheus/tests/TestRLbl/project1.dof @@ -0,0 +1,136 @@ +[FileVersion] +Version=7.0 +[Compiler] +A=8 +B=0 +C=1 +D=1 +E=0 +F=0 +G=1 +H=1 +I=1 +J=0 +K=0 +L=1 +M=0 +N=1 +O=1 +P=1 +Q=1 +R=1 +S=0 +T=1 +U=0 +V=1 +W=0 +X=1 +Y=1 +Z=1 +ShowHints=1 +ShowWarnings=1 +UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; +NamespacePrefix= +SymbolDeprecated=1 +SymbolLibrary=1 +SymbolPlatform=1 +UnitLibrary=1 +UnitPlatform=1 +UnitDeprecated=1 +HResultCompat=1 +HidingMember=1 +HiddenVirtual=1 +Garbage=1 +BoundsError=1 +ZeroNilCompat=1 +StringConstTruncated=1 +ForLoopVarVarPar=1 +TypedConstVarPar=1 +AsgToTypedConst=1 +CaseLabelRange=1 +ForVariable=1 +ConstructingAbstract=1 +ComparisonFalse=1 +ComparisonTrue=1 +ComparingSignedUnsigned=1 +CombiningSignedUnsigned=1 +UnsupportedConstruct=1 +FileOpen=1 +FileOpenUnitSrc=1 +BadGlobalSymbol=1 +DuplicateConstructorDestructor=1 +InvalidDirective=1 +PackageNoLink=1 +PackageThreadVar=1 +ImplicitImport=1 +HPPEMITIgnored=1 +NoRetVal=1 +UseBeforeDef=1 +ForLoopVarUndef=1 +UnitNameMismatch=1 +NoCFGFileFound=1 +MessageDirective=1 +ImplicitVariants=1 +UnicodeToLocale=1 +LocaleToUnicode=1 +ImagebaseMultiple=1 +SuspiciousTypecast=1 +PrivatePropAccessor=1 +UnsafeType=0 +UnsafeCode=0 +UnsafeCast=0 +[Linker] +MapFile=0 +OutputObjs=0 +ConsoleApp=1 +DebugInfo=0 +RemoteSymbols=0 +MinStackSize=16384 +MaxStackSize=1048576 +ImageBase=4194304 +ExeDescription= +[Directories] +OutputDir= +UnitOutputDir= +PackageDLLOutputDir= +PackageDCPOutputDir= +SearchPath= +Packages=vcl;rtl;vclx;indy;vclie;xmlrtl;inetdbbde;inet;inetdbxpress;dbrtl;soaprtl;dsnap;VclSmp;dbexpress;vcldb;dbxcds;inetdb;bdertl;vcldbx;adortl;teeui;teedb;tee;ibxpress;visualclx;visualdbclx;vclactnband;vclshlctrls;IntrawebDB_50_70;Intraweb_50_70;Rave50CLX;Rave50VCL;dclOffice2k +Conditionals= +DebugSourceDirs= +UsePackages=0 +[Parameters] +RunParams= +HostApplication= +Launcher= +UseLauncher=0 +DebugCWD= +[Language] +ActiveLang= +ProjectLang= +RootDir= +[Version Info] +IncludeVerInfo=0 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1033 +CodePage=1252 +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= diff --git a/components/orpheus/tests/TestRLbl/project1.dpr b/components/orpheus/tests/TestRLbl/project1.dpr new file mode 100644 index 000000000..8a2e82e5d --- /dev/null +++ b/components/orpheus/tests/TestRLbl/project1.dpr @@ -0,0 +1,18 @@ +program Project1; + +uses +{$IFDEF LCL} + Interfaces, +{$ENDIF} + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$IFDEF MSWINDOWS} +{$R *.res} +{$ENDIF} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/components/orpheus/tests/TestRLbl/project1.lpi b/components/orpheus/tests/TestRLbl/project1.lpi new file mode 100644 index 000000000..b5aee6158 --- /dev/null +++ b/components/orpheus/tests/TestRLbl/project1.lpi @@ -0,0 +1,108 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/components/orpheus/tests/TestRLbl/project1.res b/components/orpheus/tests/TestRLbl/project1.res new file mode 100644 index 000000000..3adc0361f Binary files /dev/null and b/components/orpheus/tests/TestRLbl/project1.res differ diff --git a/components/orpheus/tests/TestRLbl/unit1.dfm b/components/orpheus/tests/TestRLbl/unit1.dfm new file mode 100644 index 000000000..cd79d3f9e --- /dev/null +++ b/components/orpheus/tests/TestRLbl/unit1.dfm @@ -0,0 +1,78 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Width = 443 + Height = 327 + Caption = 'Form1' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object OvcRotatedLabel1: TOvcRotatedLabel + Left = 56 + Top = 32 + Width = 153 + Height = 25 + AutoSize = False + Caption = 'Not rotated' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -13 + Font.Name = 'Arial' + Font.Style = [] + ShadowedText = False + end + object OvcRotatedLabel2: TOvcRotatedLabel + Left = 56 + Top = 80 + Width = 153 + Height = 57 + AutoSize = False + Caption = 'Rotated 15 degrees' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -13 + Font.Name = 'Arial' + Font.Style = [] + FontAngle = 15 + OriginY = 30 + ShadowedText = False + end + object OvcRotatedLabel3: TOvcRotatedLabel + Left = 56 + Top = 160 + Width = 153 + Height = 57 + AutoSize = False + Caption = 'Rotated -15 degrees' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -13 + Font.Name = 'Arial' + Font.Style = [] + FontAngle = -15 + OriginX = 5 + ShadowedText = False + end + object OvcRotatedLabel4: TOvcRotatedLabel + Left = 264 + Top = 32 + Width = 65 + Height = 185 + AutoSize = False + Caption = 'Rotated 90 degrees' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -13 + Font.Name = 'Arial' + Font.Style = [] + FontAngle = 90 + OriginY = 175 + ShadowedText = False + end +end diff --git a/components/orpheus/tests/TestRLbl/unit1.lfm b/components/orpheus/tests/TestRLbl/unit1.lfm new file mode 100644 index 000000000..957b6fa76 --- /dev/null +++ b/components/orpheus/tests/TestRLbl/unit1.lfm @@ -0,0 +1,72 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Width = 435 + Height = 293 + Caption = 'Form1' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Style = [] + PixelsPerInch = 96 + TextHeight = 13 + object OvcRotatedLabel1: TOvcRotatedLabel + Left = 56 + Top = 32 + Width = 153 + Height = 25 + AutoSize = False + Caption = 'Not rotated' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -13 + Font.Style = [] + ShadowedText = False + end + object OvcRotatedLabel2: TOvcRotatedLabel + Left = 56 + Top = 80 + Width = 153 + Height = 57 + AutoSize = False + Caption = 'Rotated 15 degrees' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -13 + Font.Style = [] + FontAngle = 15 + OriginY = 30 + ShadowedText = False + end + object OvcRotatedLabel3: TOvcRotatedLabel + Left = 56 + Top = 160 + Width = 153 + Height = 57 + AutoSize = False + Caption = 'Rotated -15 degrees' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -13 + Font.Style = [] + FontAngle = -15 + OriginX = 5 + ShadowedText = False + end + object OvcRotatedLabel4: TOvcRotatedLabel + Left = 264 + Top = 32 + Width = 65 + Height = 185 + AutoSize = False + Caption = 'Rotated 90 degrees' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -13 + Font.Style = [] + FontAngle = 90 + OriginY = 175 + ShadowedText = False + end +end diff --git a/components/orpheus/tests/TestRLbl/unit1.lrs b/components/orpheus/tests/TestRLbl/unit1.lrs new file mode 100644 index 000000000..1393256cc --- /dev/null +++ b/components/orpheus/tests/TestRLbl/unit1.lrs @@ -0,0 +1,23 @@ +LazarusResources.Add('TForm1','FORMDATA',[ + 'TPF0'#6'TForm1'#5'Form1'#4'Left'#3#192#0#3'Top'#2'r'#5'Width'#3#179#1#6'Heig' + +'ht'#3'%'#1#7'Caption'#6#5'Form1'#5'Color'#7#9'clBtnFace'#12'Font.Charset'#7 + +#15'DEFAULT_CHARSET'#10'Font.Color'#7#12'clWindowText'#11'Font.Height'#2#245 + +#10'Font.Style'#11#0#13'PixelsPerInch'#2'`'#10'TextHeight'#2#13#0#16'TOvcRot' + +'atedLabel'#16'OvcRotatedLabel1'#4'Left'#2'8'#3'Top'#2' '#5'Width'#3#153#0#6 + +'Height'#2#25#8'AutoSize'#8#7'Caption'#6#11'Not rotated'#12'Font.Charset'#7 + +#15'DEFAULT_CHARSET'#10'Font.Color'#7#12'clWindowText'#11'Font.Height'#2#243 + +#10'Font.Style'#11#0#12'ShadowedText'#8#0#0#16'TOvcRotatedLabel'#16'OvcRotat' + +'edLabel2'#4'Left'#2'8'#3'Top'#2'P'#5'Width'#3#153#0#6'Height'#2'9'#8'AutoSi' + +'ze'#8#7'Caption'#6#18'Rotated 15 degrees'#12'Font.Charset'#7#15'DEFAULT_CHA' + +'RSET'#10'Font.Color'#7#12'clWindowText'#11'Font.Height'#2#243#10'Font.Style' + +#11#0#9'FontAngle'#2#15#7'OriginY'#2#30#12'ShadowedText'#8#0#0#16'TOvcRotate' + +'dLabel'#16'OvcRotatedLabel3'#4'Left'#2'8'#3'Top'#3#160#0#5'Width'#3#153#0#6 + +'Height'#2'9'#8'AutoSize'#8#7'Caption'#6#19'Rotated -15 degrees'#12'Font.Cha' + +'rset'#7#15'DEFAULT_CHARSET'#10'Font.Color'#7#12'clWindowText'#11'Font.Heigh' + +'t'#2#243#10'Font.Style'#11#0#9'FontAngle'#2#241#7'OriginX'#2#5#12'ShadowedT' + +'ext'#8#0#0#16'TOvcRotatedLabel'#16'OvcRotatedLabel4'#4'Left'#3#8#1#3'Top'#2 + +' '#5'Width'#2'A'#6'Height'#3#185#0#8'AutoSize'#8#7'Caption'#6#18'Rotated 90' + +' degrees'#12'Font.Charset'#7#15'DEFAULT_CHARSET'#10'Font.Color'#7#12'clWind' + +'owText'#11'Font.Height'#2#243#10'Font.Style'#11#0#9'FontAngle'#2'Z'#7'Origi' + +'nY'#3#175#0#12'ShadowedText'#8#0#0#0 +]); diff --git a/components/orpheus/tests/TestRLbl/unit1.pas b/components/orpheus/tests/TestRLbl/unit1.pas new file mode 100644 index 000000000..3fb43a467 --- /dev/null +++ b/components/orpheus/tests/TestRLbl/unit1.pas @@ -0,0 +1,36 @@ +unit Unit1; + +interface + +uses + {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, LclType, LResources, {$ENDIF} + SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, ovcbase, ovcrlbl; + +type + TForm1 = class(TForm) + OvcRotatedLabel1: TOvcRotatedLabel; + OvcRotatedLabel2: TOvcRotatedLabel; + OvcRotatedLabel3: TOvcRotatedLabel; + OvcRotatedLabel4: TOvcRotatedLabel; + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$IFNDEF LCL} +{$R *.dfm} +{$ENDIF} + +initialization +{$IFDEF LCL} +{$I Unit1.lrs} {Include form's resource file} +{$ENDIF} + +end. diff --git a/components/orpheus/tests/TestTable/manifest.rc b/components/orpheus/tests/TestTable/manifest.rc new file mode 100644 index 000000000..f2751735a --- /dev/null +++ b/components/orpheus/tests/TestTable/manifest.rc @@ -0,0 +1 @@ +1 24 project1.exe.manifest diff --git a/components/orpheus/tests/TestTable/manifest.res b/components/orpheus/tests/TestTable/manifest.res new file mode 100644 index 000000000..76d7a3174 Binary files /dev/null and b/components/orpheus/tests/TestTable/manifest.res differ diff --git a/components/orpheus/tests/TestTable/project1.bdsproj b/components/orpheus/tests/TestTable/project1.bdsproj new file mode 100644 index 000000000..21fa37665 --- /dev/null +++ b/components/orpheus/tests/TestTable/project1.bdsproj @@ -0,0 +1,175 @@ + + + + + + + + + + + + project1.dpr + + + 7.0 + + + 8 + 0 + 1 + 1 + 0 + 0 + 1 + 1 + 1 + 0 + 0 + 1 + 0 + 1 + 1 + 1 + 1 + 1 + 0 + 1 + 0 + 1 + 0 + 1 + 1 + 1 + True + True + WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; + + False + + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + False + False + False + True + True + True + True + True + True + + + + 0 + 0 + False + 1 + False + False + False + 16384 + 1048576 + 4194304 + + + + + + + + C:\Orpheus4\FPC + vcl;rtl;vclx;indy;vclie;xmlrtl;inetdbbde;inet;inetdbxpress;dbrtl;soaprtl;dsnap;VclSmp;dbexpress;vcldb;dbxcds;inetdb;bdertl;vcldbx;adortl;teeui;teedb;tee;ibxpress;visualclx;visualdbclx;vclactnband;vclshlctrls;IntrawebDB_50_70;Intraweb_50_70;Rave50CLX;Rave50VCL;dclOffice2k + + + False + + + + + + False + + + True + False + + + + $00000000 + + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1033 + 1252 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + diff --git a/components/orpheus/tests/TestTable/project1.cfg b/components/orpheus/tests/TestTable/project1.cfg new file mode 100644 index 000000000..45be3be19 --- /dev/null +++ b/components/orpheus/tests/TestTable/project1.cfg @@ -0,0 +1,38 @@ +-$A8 +-$B- +-$C+ +-$D+ +-$E- +-$F- +-$G+ +-$H+ +-$I+ +-$J- +-$K- +-$L+ +-$M- +-$N+ +-$O+ +-$P+ +-$Q+ +-$R+ +-$S- +-$T+ +-$U- +-$V+ +-$W- +-$X+ +-$YD +-$Z1 +-cg +-AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; +-H+ +-W+ +-M +-$M16384,1048576 +-K$00400000 +-LE"c:\delphi7\Projects\Bpl" +-LN"c:\delphi7\Projects\Bpl" +-w-UNSAFE_TYPE +-w-UNSAFE_CODE +-w-UNSAFE_CAST diff --git a/components/orpheus/tests/TestTable/project1.dof b/components/orpheus/tests/TestTable/project1.dof new file mode 100644 index 000000000..a964abf67 --- /dev/null +++ b/components/orpheus/tests/TestTable/project1.dof @@ -0,0 +1,136 @@ +[FileVersion] +Version=7.0 +[Compiler] +A=8 +B=0 +C=1 +D=1 +E=0 +F=0 +G=1 +H=1 +I=1 +J=0 +K=0 +L=1 +M=0 +N=1 +O=1 +P=1 +Q=1 +R=1 +S=0 +T=1 +U=0 +V=1 +W=0 +X=1 +Y=1 +Z=1 +ShowHints=1 +ShowWarnings=1 +UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; +NamespacePrefix= +SymbolDeprecated=1 +SymbolLibrary=1 +SymbolPlatform=1 +UnitLibrary=1 +UnitPlatform=1 +UnitDeprecated=1 +HResultCompat=1 +HidingMember=1 +HiddenVirtual=1 +Garbage=1 +BoundsError=1 +ZeroNilCompat=1 +StringConstTruncated=1 +ForLoopVarVarPar=1 +TypedConstVarPar=1 +AsgToTypedConst=1 +CaseLabelRange=1 +ForVariable=1 +ConstructingAbstract=1 +ComparisonFalse=1 +ComparisonTrue=1 +ComparingSignedUnsigned=1 +CombiningSignedUnsigned=1 +UnsupportedConstruct=1 +FileOpen=1 +FileOpenUnitSrc=1 +BadGlobalSymbol=1 +DuplicateConstructorDestructor=1 +InvalidDirective=1 +PackageNoLink=1 +PackageThreadVar=1 +ImplicitImport=1 +HPPEMITIgnored=1 +NoRetVal=1 +UseBeforeDef=1 +ForLoopVarUndef=1 +UnitNameMismatch=1 +NoCFGFileFound=1 +MessageDirective=1 +ImplicitVariants=1 +UnicodeToLocale=1 +LocaleToUnicode=1 +ImagebaseMultiple=1 +SuspiciousTypecast=1 +PrivatePropAccessor=1 +UnsafeType=0 +UnsafeCode=0 +UnsafeCast=0 +[Linker] +MapFile=0 +OutputObjs=0 +ConsoleApp=1 +DebugInfo=0 +RemoteSymbols=0 +MinStackSize=16384 +MaxStackSize=1048576 +ImageBase=4194304 +ExeDescription= +[Directories] +OutputDir= +UnitOutputDir= +PackageDLLOutputDir= +PackageDCPOutputDir= +SearchPath= +Packages=vcl;rtl;vclx;indy;vclie;xmlrtl;inetdbbde;inet;inetdbxpress;dbrtl;soaprtl;dsnap;VclSmp;dbexpress;vcldb;dbxcds;inetdb;bdertl;vcldbx;adortl;teeui;teedb;tee;ibxpress;visualclx;visualdbclx;vclactnband;vclshlctrls;IntrawebDB_50_70;Intraweb_50_70;Rave50CLX;Rave50VCL;dclOffice2k +Conditionals= +DebugSourceDirs= +UsePackages=0 +[Parameters] +RunParams= +HostApplication= +Launcher= +UseLauncher=0 +DebugCWD= +[Language] +ActiveLang= +ProjectLang= +RootDir= +[Version Info] +IncludeVerInfo=0 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1033 +CodePage=1252 +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= diff --git a/components/orpheus/tests/TestTable/project1.dpr b/components/orpheus/tests/TestTable/project1.dpr new file mode 100644 index 000000000..bd55dc21a --- /dev/null +++ b/components/orpheus/tests/TestTable/project1.dpr @@ -0,0 +1,22 @@ +program Project1; + +uses +{$IFDEF LCL} + Interfaces, +{$ENDIF} + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$IFDEF MSWINDOWS} +{$R *.res} {Include program's icon resource file} +{$ENDIF} + +{$IFNDEF FPC} //With FPC, assume .exe can find .manifest file at runtime +{$R manifest.res} {Include program's manifest in .exe for XP theme support} +{$ENDIF} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/components/orpheus/tests/TestTable/project1.exe.manifest b/components/orpheus/tests/TestTable/project1.exe.manifest new file mode 100644 index 000000000..3a04c4188 --- /dev/null +++ b/components/orpheus/tests/TestTable/project1.exe.manifest @@ -0,0 +1,23 @@ + + + + + + project1 + + + + + + + diff --git a/components/orpheus/tests/TestTable/project1.lpi b/components/orpheus/tests/TestTable/project1.lpi new file mode 100644 index 000000000..fc9c97397 --- /dev/null +++ b/components/orpheus/tests/TestTable/project1.lpi @@ -0,0 +1,108 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/components/orpheus/tests/TestTable/project1.res b/components/orpheus/tests/TestTable/project1.res new file mode 100644 index 000000000..3adc0361f Binary files /dev/null and b/components/orpheus/tests/TestTable/project1.res differ diff --git a/components/orpheus/tests/TestTable/unit1.dfm b/components/orpheus/tests/TestTable/unit1.dfm new file mode 100644 index 000000000..8be1fa257 --- /dev/null +++ b/components/orpheus/tests/TestTable/unit1.dfm @@ -0,0 +1,141 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Width = 776 + Height = 480 + Caption = 'Form1' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'Arial' + Font.Style = [] + OldCreateOrder = False + OnCreate = FormCreate + OnDestroy = FormDestroy + DesignSize = ( + 768 + 446) + PixelsPerInch = 96 + TextHeight = 14 + object OvcTable1: TOvcTable + Left = 16 + Top = 16 + Width = 737 + Height = 409 + Anchors = [akLeft, akTop, akRight, akBottom] + Color = clWindow + Controller = OvcController1 + GridPenSet.NormalGrid.NormalColor = clBtnShadow + GridPenSet.NormalGrid.Style = psDot + GridPenSet.NormalGrid.Effect = geBoth + GridPenSet.LockedGrid.NormalColor = clBtnShadow + GridPenSet.LockedGrid.Style = psSolid + GridPenSet.LockedGrid.Effect = ge3D + GridPenSet.CellWhenFocused.NormalColor = clBlack + GridPenSet.CellWhenFocused.Style = psSolid + GridPenSet.CellWhenFocused.Effect = geBoth + GridPenSet.CellWhenUnfocused.NormalColor = clBlack + GridPenSet.CellWhenUnfocused.Style = psDash + GridPenSet.CellWhenUnfocused.Effect = geBoth + LockedRowsCell = OvcTCColHead1 + Options = [otoNoRowResizing, otoNoColResizing, otoTabToArrow, otoEnterToArrow, otoAlwaysEditing, otoNoSelection, otoThumbTrack] + TabOrder = 0 + OnGetCellData = OvcTable1GetCellData + CellData = ( + 'Form1.OvcTCColHead1' + 'Form1.OvcTCRowHead1' + 'Form1.OvcTCString1' + 'Form1.OvcTCMemo1' + 'Form1.OvcTCCheckBox1' + 'Form1.OvcTCComboBox1' + 'Form1.OvcTCBitMap1') + RowData = ( + 35) + ColData = ( + 110 + False + True + 'Form1.OvcTCRowHead1' + 90 + False + True + 'Form1.OvcTCString1' + 150 + False + True + 'Form1.OvcTCMemo1' + 110 + False + True + 'Form1.OvcTCCheckBox1' + 160 + False + True + 'Form1.OvcTCComboBox1' + 90 + False + True + 'Form1.OvcTCBitMap1') + end + object OvcTCColHead1: TOvcTCColHead + Headings.Strings = ( + 'TOvcTCRowHead' + 'TOvcTCString' + 'TOvcTCMemo' + 'TOvcTCCheckBox' + 'TOvcTCComboBox' + 'TOvcTCBitmap') + ShowLetters = False + Adjust = otaCenter + Table = OvcTable1 + Left = 48 + end + object OvcTCRowHead1: TOvcTCRowHead + Adjust = otaCenter + Table = OvcTable1 + Left = 80 + end + object OvcTCString1: TOvcTCString + AutoAdvanceLeftRight = True + Table = OvcTable1 + Left = 144 + end + object OvcTCMemo1: TOvcTCMemo + Table = OvcTable1 + Left = 264 + end + object OvcTCCheckBox1: TOvcTCCheckBox + Adjust = otaCenter + CellGlyphs.IsDefault = True + CellGlyphs.GlyphCount = 3 + CellGlyphs.ActiveGlyphCount = 2 + Table = OvcTable1 + Left = 384 + end + object OvcTCComboBox1: TOvcTCComboBox + Style = csDropDownList + Table = OvcTable1 + OnChange = OvcTCComboBox1Change + Left = 512 + end + object OvcTCBitMap1: TOvcTCBitMap + Adjust = otaTopCenter + Table = OvcTable1 + Left = 624 + end + object OvcController1: TOvcController + EntryCommands.TableList = ( + 'Default' + True + () + 'WordStar' + False + () + 'Grid' + False + ()) + Epoch = 2000 + Left = 16 + end +end diff --git a/components/orpheus/tests/TestTable/unit1.lfm b/components/orpheus/tests/TestTable/unit1.lfm new file mode 100644 index 000000000..91ab455a3 --- /dev/null +++ b/components/orpheus/tests/TestTable/unit1.lfm @@ -0,0 +1,136 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Width = 768 + Height = 446 + Caption = 'Form1' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Style = [] + OnCreate = FormCreate + OnDestroy = FormDestroy + PixelsPerInch = 96 + TextHeight = 14 + object OvcTable1: TOvcTable + Left = 16 + Top = 16 + Width = 737 + Height = 409 + Anchors = [akLeft, akTop, akRight, akBottom] + Color = clWindow + Controller = OvcController1 + GridPenSet.NormalGrid.NormalColor = clBtnShadow + GridPenSet.NormalGrid.Style = psDot + GridPenSet.NormalGrid.Effect = geBoth + GridPenSet.LockedGrid.NormalColor = clBtnShadow + GridPenSet.LockedGrid.Style = psSolid + GridPenSet.LockedGrid.Effect = ge3D + GridPenSet.CellWhenFocused.NormalColor = clBlack + GridPenSet.CellWhenFocused.Style = psSolid + GridPenSet.CellWhenFocused.Effect = geBoth + GridPenSet.CellWhenUnfocused.NormalColor = clBlack + GridPenSet.CellWhenUnfocused.Style = psDash + GridPenSet.CellWhenUnfocused.Effect = geBoth + LockedRowsCell = OvcTCColHead1 + Options = [otoNoRowResizing, otoNoColResizing, otoTabToArrow, otoEnterToArrow, otoAlwaysEditing, otoNoSelection, otoThumbTrack] + TabOrder = 0 + OnGetCellData = OvcTable1GetCellData + CellData = ( + 'Form1.OvcTCColHead1' + 'Form1.OvcTCRowHead1' + 'Form1.OvcTCString1' + 'Form1.OvcTCMemo1' + 'Form1.OvcTCCheckBox1' + 'Form1.OvcTCComboBox1' + 'Form1.OvcTCBitMap1') + RowData = ( + 35) + ColData = ( + 110 + False + True + 'Form1.OvcTCRowHead1' + 90 + False + True + 'Form1.OvcTCString1' + 150 + False + True + 'Form1.OvcTCMemo1' + 110 + False + True + 'Form1.OvcTCCheckBox1' + 160 + False + True + 'Form1.OvcTCComboBox1' + 90 + False + True + 'Form1.OvcTCBitMap1') + end + object OvcTCColHead1: TOvcTCColHead + Headings.Strings = ( + 'TOvcTCRowHead' + 'TOvcTCString' + 'TOvcTCMemo' + 'TOvcTCCheckBox' + 'TOvcTCComboBox' + 'TOvcTCBitmap') + ShowLetters = False + Adjust = otaCenter + Table = OvcTable1 + Top = 48 + end + object OvcTCRowHead1: TOvcTCRowHead + Adjust = otaCenter + Table = OvcTable1 + Top = 80 + end + object OvcTCString1: TOvcTCString + AutoAdvanceLeftRight = True + Table = OvcTable1 + Top = 144 + end + object OvcTCMemo1: TOvcTCMemo + Table = OvcTable1 + Top = 264 + end + object OvcTCCheckBox1: TOvcTCCheckBox + Adjust = otaCenter + CellGlyphs.IsDefault = True + CellGlyphs.GlyphCount = 3 + CellGlyphs.ActiveGlyphCount = 2 + Table = OvcTable1 + Top = 384 + end + object OvcTCComboBox1: TOvcTCComboBox + Style = csDropDownList + Table = OvcTable1 + OnChange = OvcTCComboBox1Change + Top = 512 + end + object OvcTCBitMap1: TOvcTCBitMap + Adjust = otaTopCenter + Table = OvcTable1 + Top = 624 + end + object OvcController1: TOvcController + EntryCommands.TableList = ( + 'Default' + True + () + 'WordStar' + False + () + 'Grid' + False + ()) + Epoch = 2000 + Top = 16 + end +end diff --git a/components/orpheus/tests/TestTable/unit1.lrs b/components/orpheus/tests/TestTable/unit1.lrs new file mode 100644 index 000000000..24a4df006 --- /dev/null +++ b/components/orpheus/tests/TestTable/unit1.lrs @@ -0,0 +1,42 @@ +LazarusResources.Add('TForm1','FORMDATA',[ + 'TPF0'#6'TForm1'#5'Form1'#4'Left'#3#192#0#3'Top'#2'r'#5'Width'#3#0#3#6'Height' + +#3#190#1#7'Caption'#6#5'Form1'#5'Color'#7#9'clBtnFace'#12'Font.Charset'#7#15 + +'DEFAULT_CHARSET'#10'Font.Color'#7#12'clWindowText'#11'Font.Height'#2#245#10 + +'Font.Style'#11#0#8'OnCreate'#7#10'FormCreate'#9'OnDestroy'#7#11'FormDestroy' + +#13'PixelsPerInch'#2'`'#10'TextHeight'#2#14#0#9'TOvcTable'#9'OvcTable1'#4'Le' + +'ft'#2#16#3'Top'#2#16#5'Width'#3#225#2#6'Height'#3#153#1#7'Anchors'#11#6'akL' + +'eft'#5'akTop'#7'akRight'#8'akBottom'#0#5'Color'#7#8'clWindow'#10'Controller' + +#7#14'OvcController1!GridPenSet.NormalGrid.NormalColor'#7#11'clBtnShadow'#27 + +'GridPenSet.NormalGrid.Style'#7#5'psDot'#28'GridPenSet.NormalGrid.Effect'#7#6 + +'geBoth!GridPenSet.LockedGrid.NormalColor'#7#11'clBtnShadow'#27'GridPenSet.L' + +'ockedGrid.Style'#7#7'psSolid'#28'GridPenSet.LockedGrid.Effect'#7#4'ge3D&Gri' + +'dPenSet.CellWhenFocused.NormalColor'#7#7'clBlack GridPenSet.CellWhenFocused' + +'.Style'#7#7'psSolid!GridPenSet.CellWhenFocused.Effect'#7#6'geBoth(GridPenSe' + +'t.CellWhenUnfocused.NormalColor'#7#7'clBlack"GridPenSet.CellWhenUnfocused.S' + +'tyle'#7#6'psDash#GridPenSet.CellWhenUnfocused.Effect'#7#6'geBoth'#14'Locked' + +'RowsCell'#7#13'OvcTCColHead1'#7'Options'#11#16'otoNoRowResizing'#16'otoNoCo' + +'lResizing'#13'otoTabToArrow'#15'otoEnterToArrow'#16'otoAlwaysEditing'#14'ot' + +'oNoSelection'#13'otoThumbTrack'#0#8'TabOrder'#2#0#13'OnGetCellData'#7#20'Ov' + +'cTable1GetCellData'#8'CellData'#1#6#19'Form1.OvcTCColHead1'#6#19'Form1.OvcT' + +'CRowHead1'#6#18'Form1.OvcTCString1'#6#16'Form1.OvcTCMemo1'#6#20'Form1.OvcTC' + +'CheckBox1'#6#20'Form1.OvcTCComboBox1'#6#18'Form1.OvcTCBitMap1'#0#7'RowData' + +#1#2'#'#0#7'ColData'#1#2'n'#8#9#6#19'Form1.OvcTCRowHead1'#2'Z'#8#9#6#18'Form' + +'1.OvcTCString1'#3#150#0#8#9#6#16'Form1.OvcTCMemo1'#2'n'#8#9#6#20'Form1.OvcT' + +'CCheckBox1'#3#160#0#8#9#6#20'Form1.OvcTCComboBox1'#2'Z'#8#9#6#18'Form1.OvcT' + +'CBitMap1'#0#0#0#13'TOvcTCColHead'#13'OvcTCColHead1'#16'Headings.Strings'#1#6 + +#13'TOvcTCRowHead'#6#12'TOvcTCString'#6#10'TOvcTCMemo'#6#14'TOvcTCCheckBox'#6 + +#14'TOvcTCComboBox'#6#12'TOvcTCBitmap'#0#11'ShowLetters'#8#6'Adjust'#7#9'ota' + +'Center'#5'Table'#7#9'OvcTable1'#3'Top'#2'0'#0#0#13'TOvcTCRowHead'#13'OvcTCR' + +'owHead1'#6'Adjust'#7#9'otaCenter'#5'Table'#7#9'OvcTable1'#3'Top'#2'P'#0#0#12 + +'TOvcTCString'#12'OvcTCString1'#20'AutoAdvanceLeftRight'#9#5'Table'#7#9'OvcT' + +'able1'#3'Top'#3#144#0#0#0#10'TOvcTCMemo'#10'OvcTCMemo1'#5'Table'#7#9'OvcTab' + +'le1'#3'Top'#3#8#1#0#0#14'TOvcTCCheckBox'#14'OvcTCCheckBox1'#6'Adjust'#7#9'o' + +'taCenter'#20'CellGlyphs.IsDefault'#9#21'CellGlyphs.GlyphCount'#2#3#27'CellG' + +'lyphs.ActiveGlyphCount'#2#2#5'Table'#7#9'OvcTable1'#3'Top'#3#128#1#0#0#14'T' + +'OvcTCComboBox'#14'OvcTCComboBox1'#5'Style'#7#14'csDropDownList'#5'Table'#7#9 + +'OvcTable1'#8'OnChange'#7#20'OvcTCComboBox1Change'#3'Top'#3#0#2#0#0#12'TOvcT' + +'CBitMap'#12'OvcTCBitMap1'#6'Adjust'#7#12'otaTopCenter'#5'Table'#7#9'OvcTabl' + +'e1'#3'Top'#3'p'#2#0#0#14'TOvcController'#14'OvcController1'#23'EntryCommand' + +'s.TableList'#1#6#7'Default'#9#1#0#6#8'WordStar'#8#1#0#6#4'Grid'#8#1#0#0#5'E' + +'poch'#3#208#7#3'Top'#2#16#0#0#0 +]); diff --git a/components/orpheus/tests/TestTable/unit1.pas b/components/orpheus/tests/TestTable/unit1.pas new file mode 100644 index 000000000..4b673ccaa --- /dev/null +++ b/components/orpheus/tests/TestTable/unit1.pas @@ -0,0 +1,147 @@ +unit Unit1; + +interface + +uses + {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, LclType, LResources, {$ENDIF} + SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, + ovcbase, ovctcbmp, ovctccbx, ovctcgly, ovctcbox, ovctcedt, + ovctchdr, ovctcmmn, ovctcell, ovctcstr, ovctable; + +const + MaxDataRecs = 20; + MaxStrLen = 100; + MaxMemoLen = 1000; + cnStr = 1; {Column numbers for controls} + cnMemo = 2; + cnCheckbox = 3; + cnCombo = 4; + cnBitmap = 5; + +type + TDataRec = record + Str : string[MaxStrLen]; + Memo : array[0..MaxMemoLen] of Char; + Check : TCheckBoxState; + ComboIndex : Integer; + Bitmap : TBitmap; + end; + + TDataArray = array[1..MaxDataRecs] of TDataRec; + + TForm1 = class(TForm) + OvcTable1: TOvcTable; + OvcController1: TOvcController; + OvcTCColHead1: TOvcTCColHead; + OvcTCRowHead1: TOvcTCRowHead; + OvcTCString1: TOvcTCString; + OvcTCMemo1: TOvcTCMemo; + OvcTCCheckBox1: TOvcTCCheckBox; + OvcTCComboBox1: TOvcTCComboBox; + OvcTCBitMap1: TOvcTCBitMap; + procedure FormCreate(Sender: TObject); + procedure FormDestroy(Sender: TObject); + procedure OvcTable1GetCellData(Sender: TObject; RowNum, + ColNum: Integer; var Data: Pointer; Purpose: TOvcCellDataPurpose); + procedure OvcTCComboBox1Change(Sender: TObject); + private + BmpPath : string; {Path to Orpheus .bmp files} + DataArray : TDataArray; {A place to store data entered in table} + public + end; + +var + Form1: TForm1; + + +implementation + +{$IFNDEF LCL} +{$R *.dfm} {Link Delphi form file} +{$ENDIF} + +procedure TForm1.FormCreate(Sender: TObject); + {Initialize the main form. + Do anything that needs to be done before the form + can be displayed.} +var + SearchResult : Integer; + SearchRec : TSearchRec; +begin + OvcTable1.RowLimit := MaxDataRecs + OvcTable1.LockedRows; + + OvcTCString1.MaxLength := MaxStrLen; {Be sure to set this here or in form} + OvcTCMemo1.MaxLength := MaxMemoLen; + + {Populate cell combo box with names of Orpheus control bitmap files. + Assumes bitmap files are two levels up from program.} + BmpPath := ExtractFilePath(ParamStr(0)) + '..' + PathDelim + '..' + PathDelim; + OvcTCComboBox1.Items.Add(' (None)'); {So we can "unselect"} + try + SearchResult := FindFirst(BmpPath + 'TO*.bmp', 0, SearchRec); + while SearchResult = 0 do {Do until no more matching files found} + begin + OvcTCComboBox1.Items.Add(SearchRec.Name); + SearchResult := FindNext(SearchRec); + end; + finally + FindClose(SearchRec); + end; +end; {TForm1.FormCreate} + + +procedure TForm1.FormDestroy(Sender: TObject); +var + RecNum : Integer; +begin + for RecNum := 1 to MaxDataRecs do {Free any TBitmap's created} + DataArray[RecNum].Bitmap.Free; +end; {TForm1.FormDestroy} + + +procedure TForm1.OvcTable1GetCellData(Sender: TObject; RowNum, + ColNum: Integer; var Data: Pointer; Purpose: TOvcCellDataPurpose); + {This event handler is called when the table needs data to display + or edit in a cell or a place to save a cell's edited data.} +begin + Data := nil; + if (RowNum < OvcTable1.LockedRows) or (RowNum > OvcTable1.RowLimit) then + Exit; + + case ColNum of + cnStr : Data := @DataArray[RowNum].Str; + cnMemo : Data := @DataArray[RowNum].Memo; + cnCheckbox : Data := @DataArray[RowNum].Check; + cnCombo : Data := @DataArray[RowNum].ComboIndex; + cnBitmap : Data := pointer(DataArray[RowNum].Bitmap); + end; +end; {TForm1.OvcTable1GetCellData} + + +procedure TForm1.OvcTCComboBox1Change(Sender: TObject); + {This event handler is called whenever combo box selection + changes. + Note: TOvcTCComboBox is not descended from TCustomComboBox, but + its editing control (Sender) is, so okay to typecast it in order + to reference ItemIndex.} +begin + DataArray[OvcTable1.ActiveRow].Bitmap.Free; + DataArray[OvcTable1.ActiveRow].Bitmap := nil; + if TCustomComboBox(Sender).ItemIndex > 0 then {Bitmap file selected?} + begin + DataArray[OvcTable1.ActiveRow].Bitmap := TBitmap.Create; + DataArray[OvcTable1.ActiveRow].Bitmap.LoadFromFile( + BmpPath + OvcTCComboBox1.Items[TCustomComboBox(Sender).ItemIndex]); + end; + OvcTable1.AllowRedraw := False; + OvcTable1.InvalidateCell(OvcTable1.ActiveRow, cnBitmap); {Force display of bitmap} + OvcTable1.AllowRedraw := True; +end; {TForm1.OvcTCComboBox1Change} + + +initialization +{$IFDEF LCL} +{$I unit1.lrs} {Include form's Lazarus resource file} +{$ENDIF} + +end. diff --git a/components/orpheus/tests/TestURL/project1.bdsproj b/components/orpheus/tests/TestURL/project1.bdsproj new file mode 100644 index 000000000..21fa37665 --- /dev/null +++ b/components/orpheus/tests/TestURL/project1.bdsproj @@ -0,0 +1,175 @@ + + + + + + + + + + + + project1.dpr + + + 7.0 + + + 8 + 0 + 1 + 1 + 0 + 0 + 1 + 1 + 1 + 0 + 0 + 1 + 0 + 1 + 1 + 1 + 1 + 1 + 0 + 1 + 0 + 1 + 0 + 1 + 1 + 1 + True + True + WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; + + False + + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + False + False + False + True + True + True + True + True + True + + + + 0 + 0 + False + 1 + False + False + False + 16384 + 1048576 + 4194304 + + + + + + + + C:\Orpheus4\FPC + vcl;rtl;vclx;indy;vclie;xmlrtl;inetdbbde;inet;inetdbxpress;dbrtl;soaprtl;dsnap;VclSmp;dbexpress;vcldb;dbxcds;inetdb;bdertl;vcldbx;adortl;teeui;teedb;tee;ibxpress;visualclx;visualdbclx;vclactnband;vclshlctrls;IntrawebDB_50_70;Intraweb_50_70;Rave50CLX;Rave50VCL;dclOffice2k + + + False + + + + + + False + + + True + False + + + + $00000000 + + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1033 + 1252 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + diff --git a/components/orpheus/tests/TestURL/project1.cfg b/components/orpheus/tests/TestURL/project1.cfg new file mode 100644 index 000000000..45be3be19 --- /dev/null +++ b/components/orpheus/tests/TestURL/project1.cfg @@ -0,0 +1,38 @@ +-$A8 +-$B- +-$C+ +-$D+ +-$E- +-$F- +-$G+ +-$H+ +-$I+ +-$J- +-$K- +-$L+ +-$M- +-$N+ +-$O+ +-$P+ +-$Q+ +-$R+ +-$S- +-$T+ +-$U- +-$V+ +-$W- +-$X+ +-$YD +-$Z1 +-cg +-AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; +-H+ +-W+ +-M +-$M16384,1048576 +-K$00400000 +-LE"c:\delphi7\Projects\Bpl" +-LN"c:\delphi7\Projects\Bpl" +-w-UNSAFE_TYPE +-w-UNSAFE_CODE +-w-UNSAFE_CAST diff --git a/components/orpheus/tests/TestURL/project1.dof b/components/orpheus/tests/TestURL/project1.dof new file mode 100644 index 000000000..a964abf67 --- /dev/null +++ b/components/orpheus/tests/TestURL/project1.dof @@ -0,0 +1,136 @@ +[FileVersion] +Version=7.0 +[Compiler] +A=8 +B=0 +C=1 +D=1 +E=0 +F=0 +G=1 +H=1 +I=1 +J=0 +K=0 +L=1 +M=0 +N=1 +O=1 +P=1 +Q=1 +R=1 +S=0 +T=1 +U=0 +V=1 +W=0 +X=1 +Y=1 +Z=1 +ShowHints=1 +ShowWarnings=1 +UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; +NamespacePrefix= +SymbolDeprecated=1 +SymbolLibrary=1 +SymbolPlatform=1 +UnitLibrary=1 +UnitPlatform=1 +UnitDeprecated=1 +HResultCompat=1 +HidingMember=1 +HiddenVirtual=1 +Garbage=1 +BoundsError=1 +ZeroNilCompat=1 +StringConstTruncated=1 +ForLoopVarVarPar=1 +TypedConstVarPar=1 +AsgToTypedConst=1 +CaseLabelRange=1 +ForVariable=1 +ConstructingAbstract=1 +ComparisonFalse=1 +ComparisonTrue=1 +ComparingSignedUnsigned=1 +CombiningSignedUnsigned=1 +UnsupportedConstruct=1 +FileOpen=1 +FileOpenUnitSrc=1 +BadGlobalSymbol=1 +DuplicateConstructorDestructor=1 +InvalidDirective=1 +PackageNoLink=1 +PackageThreadVar=1 +ImplicitImport=1 +HPPEMITIgnored=1 +NoRetVal=1 +UseBeforeDef=1 +ForLoopVarUndef=1 +UnitNameMismatch=1 +NoCFGFileFound=1 +MessageDirective=1 +ImplicitVariants=1 +UnicodeToLocale=1 +LocaleToUnicode=1 +ImagebaseMultiple=1 +SuspiciousTypecast=1 +PrivatePropAccessor=1 +UnsafeType=0 +UnsafeCode=0 +UnsafeCast=0 +[Linker] +MapFile=0 +OutputObjs=0 +ConsoleApp=1 +DebugInfo=0 +RemoteSymbols=0 +MinStackSize=16384 +MaxStackSize=1048576 +ImageBase=4194304 +ExeDescription= +[Directories] +OutputDir= +UnitOutputDir= +PackageDLLOutputDir= +PackageDCPOutputDir= +SearchPath= +Packages=vcl;rtl;vclx;indy;vclie;xmlrtl;inetdbbde;inet;inetdbxpress;dbrtl;soaprtl;dsnap;VclSmp;dbexpress;vcldb;dbxcds;inetdb;bdertl;vcldbx;adortl;teeui;teedb;tee;ibxpress;visualclx;visualdbclx;vclactnband;vclshlctrls;IntrawebDB_50_70;Intraweb_50_70;Rave50CLX;Rave50VCL;dclOffice2k +Conditionals= +DebugSourceDirs= +UsePackages=0 +[Parameters] +RunParams= +HostApplication= +Launcher= +UseLauncher=0 +DebugCWD= +[Language] +ActiveLang= +ProjectLang= +RootDir= +[Version Info] +IncludeVerInfo=0 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1033 +CodePage=1252 +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= diff --git a/components/orpheus/tests/TestURL/project1.dpr b/components/orpheus/tests/TestURL/project1.dpr new file mode 100644 index 000000000..8a2e82e5d --- /dev/null +++ b/components/orpheus/tests/TestURL/project1.dpr @@ -0,0 +1,18 @@ +program Project1; + +uses +{$IFDEF LCL} + Interfaces, +{$ENDIF} + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$IFDEF MSWINDOWS} +{$R *.res} +{$ENDIF} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/components/orpheus/tests/TestURL/project1.lpi b/components/orpheus/tests/TestURL/project1.lpi new file mode 100644 index 000000000..8560250b9 --- /dev/null +++ b/components/orpheus/tests/TestURL/project1.lpi @@ -0,0 +1,108 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/components/orpheus/tests/TestURL/project1.res b/components/orpheus/tests/TestURL/project1.res new file mode 100644 index 000000000..3adc0361f Binary files /dev/null and b/components/orpheus/tests/TestURL/project1.res differ diff --git a/components/orpheus/tests/TestURL/unit1.dfm b/components/orpheus/tests/TestURL/unit1.dfm new file mode 100644 index 000000000..d5ada538f --- /dev/null +++ b/components/orpheus/tests/TestURL/unit1.dfm @@ -0,0 +1,33 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Width = 511 + Height = 362 + Caption = 'Form1' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object OvcURL1: TOvcURL + Left = 96 + Top = 56 + Width = 138 + Height = 13 + Hint = 'http://www.lazarus.freepascal.org' + Caption = 'URL link to Lazarus Web site' + URL = 'http://www.lazarus.freepascal.org' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [fsUnderline] + ParentFont = False + ParentShowHint = False + ShowHint = True + end +end diff --git a/components/orpheus/tests/TestURL/unit1.lfm b/components/orpheus/tests/TestURL/unit1.lfm new file mode 100644 index 000000000..bf187dcff --- /dev/null +++ b/components/orpheus/tests/TestURL/unit1.lfm @@ -0,0 +1,30 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Width = 503 + Height = 328 + Caption = 'Form1' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Style = [] + PixelsPerInch = 96 + TextHeight = 13 + object OvcURL1: TOvcURL + Left = 96 + Top = 56 + Width = 138 + Height = 13 + Hint = 'http://www.lazarus.freepascal.org' + Caption = 'URL link to Lazarus Web site' + URL = 'http://www.lazarus.freepascal.org' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Style = [fsUnderline] + ParentFont = False + ParentShowHint = False + ShowHint = True + end +end diff --git a/components/orpheus/tests/TestURL/unit1.lrs b/components/orpheus/tests/TestURL/unit1.lrs new file mode 100644 index 000000000..1726bb4b5 --- /dev/null +++ b/components/orpheus/tests/TestURL/unit1.lrs @@ -0,0 +1,12 @@ +LazarusResources.Add('TForm1','FORMDATA',[ + 'TPF0'#6'TForm1'#5'Form1'#4'Left'#3#192#0#3'Top'#2'r'#5'Width'#3#247#1#6'Heig' + +'ht'#3'H'#1#7'Caption'#6#5'Form1'#5'Color'#7#9'clBtnFace'#12'Font.Charset'#7 + +#15'DEFAULT_CHARSET'#10'Font.Color'#7#12'clWindowText'#11'Font.Height'#2#245 + +#10'Font.Style'#11#0#13'PixelsPerInch'#2'`'#10'TextHeight'#2#13#0#7'TOvcURL' + +#7'OvcURL1'#4'Left'#2'`'#3'Top'#2'8'#5'Width'#3#138#0#6'Height'#2#13#4'Hint' + +#6'!http://www.lazarus.freepascal.org'#7'Caption'#6#28'URL link to Lazarus W' + +'eb site'#3'URL'#6'!http://www.lazarus.freepascal.org'#12'Font.Charset'#7#15 + +'DEFAULT_CHARSET'#10'Font.Color'#7#12'clWindowText'#11'Font.Height'#2#245#10 + +'Font.Style'#11#11'fsUnderline'#0#10'ParentFont'#8#14'ParentShowHint'#8#8'Sh' + +'owHint'#9#0#0#0 +]); diff --git a/components/orpheus/tests/TestURL/unit1.pas b/components/orpheus/tests/TestURL/unit1.pas new file mode 100644 index 000000000..5487257d2 --- /dev/null +++ b/components/orpheus/tests/TestURL/unit1.pas @@ -0,0 +1,33 @@ +unit Unit1; + +interface + +uses + {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, LclType, LResources, {$ENDIF} + SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, ovcurl; + +type + TForm1 = class(TForm) + OvcURL1: TOvcURL; + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$IFNDEF LCL} +{$R *.dfm} +{$ENDIF} + +initialization +{$IFDEF LCL} +{$I unit1.lrs} {Include form's resource file} +{$ENDIF} + +end. diff --git a/components/orpheus/tests/TestVLB/project1.bdsproj b/components/orpheus/tests/TestVLB/project1.bdsproj new file mode 100644 index 000000000..21fa37665 --- /dev/null +++ b/components/orpheus/tests/TestVLB/project1.bdsproj @@ -0,0 +1,175 @@ + + + + + + + + + + + + project1.dpr + + + 7.0 + + + 8 + 0 + 1 + 1 + 0 + 0 + 1 + 1 + 1 + 0 + 0 + 1 + 0 + 1 + 1 + 1 + 1 + 1 + 0 + 1 + 0 + 1 + 0 + 1 + 1 + 1 + True + True + WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; + + False + + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + False + False + False + True + True + True + True + True + True + + + + 0 + 0 + False + 1 + False + False + False + 16384 + 1048576 + 4194304 + + + + + + + + C:\Orpheus4\FPC + vcl;rtl;vclx;indy;vclie;xmlrtl;inetdbbde;inet;inetdbxpress;dbrtl;soaprtl;dsnap;VclSmp;dbexpress;vcldb;dbxcds;inetdb;bdertl;vcldbx;adortl;teeui;teedb;tee;ibxpress;visualclx;visualdbclx;vclactnband;vclshlctrls;IntrawebDB_50_70;Intraweb_50_70;Rave50CLX;Rave50VCL;dclOffice2k + + + False + + + + + + False + + + True + False + + + + $00000000 + + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1033 + 1252 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + diff --git a/components/orpheus/tests/TestVLB/project1.cfg b/components/orpheus/tests/TestVLB/project1.cfg new file mode 100644 index 000000000..45be3be19 --- /dev/null +++ b/components/orpheus/tests/TestVLB/project1.cfg @@ -0,0 +1,38 @@ +-$A8 +-$B- +-$C+ +-$D+ +-$E- +-$F- +-$G+ +-$H+ +-$I+ +-$J- +-$K- +-$L+ +-$M- +-$N+ +-$O+ +-$P+ +-$Q+ +-$R+ +-$S- +-$T+ +-$U- +-$V+ +-$W- +-$X+ +-$YD +-$Z1 +-cg +-AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; +-H+ +-W+ +-M +-$M16384,1048576 +-K$00400000 +-LE"c:\delphi7\Projects\Bpl" +-LN"c:\delphi7\Projects\Bpl" +-w-UNSAFE_TYPE +-w-UNSAFE_CODE +-w-UNSAFE_CAST diff --git a/components/orpheus/tests/TestVLB/project1.dof b/components/orpheus/tests/TestVLB/project1.dof new file mode 100644 index 000000000..a964abf67 --- /dev/null +++ b/components/orpheus/tests/TestVLB/project1.dof @@ -0,0 +1,136 @@ +[FileVersion] +Version=7.0 +[Compiler] +A=8 +B=0 +C=1 +D=1 +E=0 +F=0 +G=1 +H=1 +I=1 +J=0 +K=0 +L=1 +M=0 +N=1 +O=1 +P=1 +Q=1 +R=1 +S=0 +T=1 +U=0 +V=1 +W=0 +X=1 +Y=1 +Z=1 +ShowHints=1 +ShowWarnings=1 +UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; +NamespacePrefix= +SymbolDeprecated=1 +SymbolLibrary=1 +SymbolPlatform=1 +UnitLibrary=1 +UnitPlatform=1 +UnitDeprecated=1 +HResultCompat=1 +HidingMember=1 +HiddenVirtual=1 +Garbage=1 +BoundsError=1 +ZeroNilCompat=1 +StringConstTruncated=1 +ForLoopVarVarPar=1 +TypedConstVarPar=1 +AsgToTypedConst=1 +CaseLabelRange=1 +ForVariable=1 +ConstructingAbstract=1 +ComparisonFalse=1 +ComparisonTrue=1 +ComparingSignedUnsigned=1 +CombiningSignedUnsigned=1 +UnsupportedConstruct=1 +FileOpen=1 +FileOpenUnitSrc=1 +BadGlobalSymbol=1 +DuplicateConstructorDestructor=1 +InvalidDirective=1 +PackageNoLink=1 +PackageThreadVar=1 +ImplicitImport=1 +HPPEMITIgnored=1 +NoRetVal=1 +UseBeforeDef=1 +ForLoopVarUndef=1 +UnitNameMismatch=1 +NoCFGFileFound=1 +MessageDirective=1 +ImplicitVariants=1 +UnicodeToLocale=1 +LocaleToUnicode=1 +ImagebaseMultiple=1 +SuspiciousTypecast=1 +PrivatePropAccessor=1 +UnsafeType=0 +UnsafeCode=0 +UnsafeCast=0 +[Linker] +MapFile=0 +OutputObjs=0 +ConsoleApp=1 +DebugInfo=0 +RemoteSymbols=0 +MinStackSize=16384 +MaxStackSize=1048576 +ImageBase=4194304 +ExeDescription= +[Directories] +OutputDir= +UnitOutputDir= +PackageDLLOutputDir= +PackageDCPOutputDir= +SearchPath= +Packages=vcl;rtl;vclx;indy;vclie;xmlrtl;inetdbbde;inet;inetdbxpress;dbrtl;soaprtl;dsnap;VclSmp;dbexpress;vcldb;dbxcds;inetdb;bdertl;vcldbx;adortl;teeui;teedb;tee;ibxpress;visualclx;visualdbclx;vclactnband;vclshlctrls;IntrawebDB_50_70;Intraweb_50_70;Rave50CLX;Rave50VCL;dclOffice2k +Conditionals= +DebugSourceDirs= +UsePackages=0 +[Parameters] +RunParams= +HostApplication= +Launcher= +UseLauncher=0 +DebugCWD= +[Language] +ActiveLang= +ProjectLang= +RootDir= +[Version Info] +IncludeVerInfo=0 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1033 +CodePage=1252 +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= diff --git a/components/orpheus/tests/TestVLB/project1.dpr b/components/orpheus/tests/TestVLB/project1.dpr new file mode 100644 index 000000000..8a2e82e5d --- /dev/null +++ b/components/orpheus/tests/TestVLB/project1.dpr @@ -0,0 +1,18 @@ +program Project1; + +uses +{$IFDEF LCL} + Interfaces, +{$ENDIF} + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$IFDEF MSWINDOWS} +{$R *.res} +{$ENDIF} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/components/orpheus/tests/TestVLB/project1.lpi b/components/orpheus/tests/TestVLB/project1.lpi new file mode 100644 index 000000000..aac4d2625 --- /dev/null +++ b/components/orpheus/tests/TestVLB/project1.lpi @@ -0,0 +1,110 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/components/orpheus/tests/TestVLB/project1.res b/components/orpheus/tests/TestVLB/project1.res new file mode 100644 index 000000000..3adc0361f Binary files /dev/null and b/components/orpheus/tests/TestVLB/project1.res differ diff --git a/components/orpheus/tests/TestVLB/unit1.dfm b/components/orpheus/tests/TestVLB/unit1.dfm new file mode 100644 index 000000000..0a8cee980 --- /dev/null +++ b/components/orpheus/tests/TestVLB/unit1.dfm @@ -0,0 +1,44 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Width = 554 + Height = 437 + Caption = 'Form1' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Label1: TLabel + Left = 64 + Top = 304 + Width = 425 + Height = 33 + AutoSize = False + Caption = 'Double-click an item in list' + Color = clBtnHighlight + ParentColor = False + end + object OvcVirtualListBox1: TOvcVirtualListBox + Left = 64 + Top = 40 + Width = 425 + Height = 238 + Header = 'Header goes here' + HeaderColor.BackColor = clBtnFace + HeaderColor.TextColor = clBtnText + ProtectColor.BackColor = clRed + ProtectColor.TextColor = clWhite + RowHeight = 13 + SelectColor.BackColor = clHighlight + SelectColor.TextColor = clHighlightText + ShowHeader = True + OnGetItem = OvcVirtualListBox1GetItem + TabOrder = 0 + OnDblClick = OvcVirtualListBox1DblClick + end +end diff --git a/components/orpheus/tests/TestVLB/unit1.lfm b/components/orpheus/tests/TestVLB/unit1.lfm new file mode 100644 index 000000000..4f68005b6 --- /dev/null +++ b/components/orpheus/tests/TestVLB/unit1.lfm @@ -0,0 +1,42 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Width = 546 + Height = 403 + Caption = 'Form1' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Style = [] + PixelsPerInch = 96 + TextHeight = 13 + object Label1: TLabel + Left = 64 + Top = 304 + Width = 425 + Height = 33 + AutoSize = False + Caption = 'Double-click an item in list' + Color = clBtnHighlight + ParentColor = False + end + object OvcVirtualListBox1: TOvcVirtualListBox + Left = 64 + Top = 40 + Width = 425 + Height = 238 + Header = 'Header goes here' + HeaderColor.BackColor = clBtnFace + HeaderColor.TextColor = clBtnText + ProtectColor.BackColor = clRed + ProtectColor.TextColor = clWhite + RowHeight = 13 + SelectColor.BackColor = clHighlight + SelectColor.TextColor = clHighlightText + ShowHeader = True + OnGetItem = OvcVirtualListBox1GetItem + TabOrder = 0 + OnDblClick = OvcVirtualListBox1DblClick + end +end diff --git a/components/orpheus/tests/TestVLB/unit1.lrs b/components/orpheus/tests/TestVLB/unit1.lrs new file mode 100644 index 000000000..7ab55e598 --- /dev/null +++ b/components/orpheus/tests/TestVLB/unit1.lrs @@ -0,0 +1,16 @@ +LazarusResources.Add('TForm1','FORMDATA',[ + 'TPF0'#6'TForm1'#5'Form1'#4'Left'#3#192#0#3'Top'#2'r'#5'Width'#3'"'#2#6'Heigh' + +'t'#3#147#1#7'Caption'#6#5'Form1'#5'Color'#7#9'clBtnFace'#12'Font.Charset'#7 + +#15'DEFAULT_CHARSET'#10'Font.Color'#7#12'clWindowText'#11'Font.Height'#2#245 + +#10'Font.Style'#11#0#13'PixelsPerInch'#2'`'#10'TextHeight'#2#13#0#6'TLabel'#6 + +'Label1'#4'Left'#2'@'#3'Top'#3'0'#1#5'Width'#3#169#1#6'Height'#2'!'#8'AutoSi' + +'ze'#8#7'Caption'#6#28'Double-click an item in list'#5'Color'#7#14'clBtnHigh' + +'light'#11'ParentColor'#8#0#0#18'TOvcVirtualListBox'#18'OvcVirtualListBox1'#4 + +'Left'#2'@'#3'Top'#2'('#5'Width'#3#169#1#6'Height'#3#238#0#6'Header'#6#16'He' + +'ader goes here'#21'HeaderColor.BackColor'#7#9'clBtnFace'#21'HeaderColor.Tex' + +'tColor'#7#9'clBtnText'#22'ProtectColor.BackColor'#7#5'clRed'#22'ProtectColo' + +'r.TextColor'#7#7'clWhite'#9'RowHeight'#2#13#21'SelectColor.BackColor'#7#11 + +'clHighlight'#21'SelectColor.TextColor'#7#15'clHighlightText'#10'ShowHeader' + +#9#9'OnGetItem'#7#25'OvcVirtualListBox1GetItem'#8'TabOrder'#2#0#10'OnDblClic' + +'k'#7#26'OvcVirtualListBox1DblClick'#0#0#0 +]); diff --git a/components/orpheus/tests/TestVLB/unit1.pas b/components/orpheus/tests/TestVLB/unit1.pas new file mode 100644 index 000000000..ba13fc47b --- /dev/null +++ b/components/orpheus/tests/TestVLB/unit1.pas @@ -0,0 +1,49 @@ +unit Unit1; + +interface + +uses + {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, LclType, LResources, {$ENDIF} + SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, ovcbase, ovcvlb, StdCtrls; + +type + TForm1 = class(TForm) + OvcVirtualListBox1: TOvcVirtualListBox; + Label1: TLabel; + procedure OvcVirtualListBox1GetItem(Sender: TObject; Index: Integer; + var ItemString: String); + procedure OvcVirtualListBox1DblClick(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$IFNDEF LCL} +{$R *.dfm} +{$ENDIF} + +procedure TForm1.OvcVirtualListBox1GetItem(Sender: TObject; Index: Integer; + var ItemString: String); +begin + ItemString := 'Item ' + IntToStr(Index); +end; + +procedure TForm1.OvcVirtualListBox1DblClick(Sender: TObject); +begin + Label1.Caption := + 'You double-clicked item ' + IntToStr(OvcVirtualListBox1.ItemIndex); +end; + +initialization +{$IFDEF LCL} +{$I unit1.lrs} {Include form's resource file} +{$ENDIF} + +end.