From ea69f79199e862e1d7f298202d9130415145cf31 Mon Sep 17 00:00:00 2001 From: graemeg Date: Sat, 27 Sep 2008 21:30:19 +0000 Subject: * Phase 2 of the unit rename is complete. The gui units have now been renamed. * UI Designer has been updated to reflect the new gui unit names. --- src/corelib/fpg_main.pas | 4 +- src/corelib/fpg_pofiles.pas | 1 - src/corelib/fpg_widget.pas | 3 +- src/corelib/gdi/fpgui_toolkit.lpk | 644 ++++++------- src/corelib/gdi/fpgui_toolkit.pas | 14 +- src/corelib/x11/fpg_x11.pas | 2 +- src/corelib/x11/fpgui_toolkit.lpk | 124 +-- src/corelib/x11/fpgui_toolkit.pas | 14 +- src/gui/db/fpgui_db.pas | 2 +- src/gui/fpg_animation.pas | 185 ++++ src/gui/fpg_basegrid.pas | 1206 ++++++++++++++++++++++++ src/gui/fpg_button.pas | 765 +++++++++++++++ src/gui/fpg_checkbox.pas | 216 +++++ src/gui/fpg_combobox.pas | 676 ++++++++++++++ src/gui/fpg_customgrid.pas | 362 +++++++ src/gui/fpg_dialogs.pas | 1387 +++++++++++++++++++++++++++ src/gui/fpg_edit.pas | 1865 +++++++++++++++++++++++++++++++++++++ src/gui/fpg_editcombo.pas | 776 +++++++++++++++ src/gui/fpg_form.pas | 429 +++++++++ src/gui/fpg_gauge.pas | 572 ++++++++++++ src/gui/fpg_grid.pas | 517 ++++++++++ src/gui/fpg_hint.pas | 226 +++++ src/gui/fpg_hyperlink.pas | 138 +++ src/gui/fpg_iniutils.pas | 245 +++++ src/gui/fpg_label.pas | 255 +++++ src/gui/fpg_listbox.pas | 1142 +++++++++++++++++++++++ src/gui/fpg_listview.pas | 1753 ++++++++++++++++++++++++++++++++++ src/gui/fpg_memo.pas | 1459 +++++++++++++++++++++++++++++ src/gui/fpg_menu.pas | 1325 ++++++++++++++++++++++++++ src/gui/fpg_mru.pas | 276 ++++++ src/gui/fpg_panel.pas | 754 +++++++++++++++ src/gui/fpg_popupcalendar.pas | 807 ++++++++++++++++ src/gui/fpg_progressbar.pas | 227 +++++ src/gui/fpg_radiobutton.pas | 377 ++++++++ src/gui/fpg_scrollbar.pas | 581 ++++++++++++ src/gui/fpg_splitter.pas | 470 ++++++++++ src/gui/fpg_style.pas | 315 +++++++ src/gui/fpg_tab.pas | 843 +++++++++++++++++ src/gui/fpg_trackbar.pas | 647 +++++++++++++ src/gui/fpg_tree.pas | 1835 ++++++++++++++++++++++++++++++++++++ src/gui/gui_animation.pas | 185 ---- src/gui/gui_basegrid.pas | 1206 ------------------------ src/gui/gui_button.pas | 765 --------------- src/gui/gui_checkbox.pas | 216 ----- src/gui/gui_combobox.pas | 676 -------------- src/gui/gui_customgrid.pas | 362 ------- src/gui/gui_dialogs.pas | 1387 --------------------------- src/gui/gui_edit.pas | 1865 ------------------------------------- src/gui/gui_editcombo.pas | 776 --------------- src/gui/gui_form.pas | 429 --------- src/gui/gui_gauge.pas | 572 ------------ src/gui/gui_grid.pas | 517 ---------- src/gui/gui_hint.pas | 226 ----- src/gui/gui_hyperlink.pas | 138 --- src/gui/gui_iniutils.pas | 245 ----- src/gui/gui_label.pas | 255 ----- src/gui/gui_listbox.pas | 1142 ----------------------- src/gui/gui_listview.pas | 1753 ---------------------------------- src/gui/gui_memo.pas | 1459 ----------------------------- src/gui/gui_menu.pas | 1325 -------------------------- src/gui/gui_mru.pas | 276 ------ src/gui/gui_panel.pas | 754 --------------- src/gui/gui_popupcalendar.pas | 807 ---------------- src/gui/gui_progressbar.pas | 227 ----- src/gui/gui_radiobutton.pas | 377 -------- src/gui/gui_scrollbar.pas | 581 ------------ src/gui/gui_splitter.pas | 470 ---------- src/gui/gui_style.pas | 315 ------- src/gui/gui_tab.pas | 843 ----------------- src/gui/gui_trackbar.pas | 647 ------------- src/gui/gui_tree.pas | 1835 ------------------------------------ src/gui/logo.inc | 2 +- uidesigner/newformdesigner.pas | 24 +- uidesigner/vfddesigner.pas | 18 +- uidesigner/vfdeditors.pas | 6 +- uidesigner/vfdfile.pas | 10 +- uidesigner/vfdformparser.pas | 2 +- uidesigner/vfdforms.pas | 18 +- uidesigner/vfdmain.pas | 4 +- uidesigner/vfdpropeditgrid.pas | 22 +- uidesigner/vfdprops.pas | 8 +- uidesigner/vfdutils.pas | 12 +- uidesigner/vfdwidgets.pas | 38 +- 83 files changed, 23117 insertions(+), 23117 deletions(-) create mode 100644 src/gui/fpg_animation.pas create mode 100644 src/gui/fpg_basegrid.pas create mode 100644 src/gui/fpg_button.pas create mode 100644 src/gui/fpg_checkbox.pas create mode 100644 src/gui/fpg_combobox.pas create mode 100644 src/gui/fpg_customgrid.pas create mode 100644 src/gui/fpg_dialogs.pas create mode 100644 src/gui/fpg_edit.pas create mode 100644 src/gui/fpg_editcombo.pas create mode 100644 src/gui/fpg_form.pas create mode 100644 src/gui/fpg_gauge.pas create mode 100644 src/gui/fpg_grid.pas create mode 100644 src/gui/fpg_hint.pas create mode 100644 src/gui/fpg_hyperlink.pas create mode 100644 src/gui/fpg_iniutils.pas create mode 100644 src/gui/fpg_label.pas create mode 100644 src/gui/fpg_listbox.pas create mode 100644 src/gui/fpg_listview.pas create mode 100644 src/gui/fpg_memo.pas create mode 100644 src/gui/fpg_menu.pas create mode 100644 src/gui/fpg_mru.pas create mode 100644 src/gui/fpg_panel.pas create mode 100644 src/gui/fpg_popupcalendar.pas create mode 100644 src/gui/fpg_progressbar.pas create mode 100644 src/gui/fpg_radiobutton.pas create mode 100644 src/gui/fpg_scrollbar.pas create mode 100644 src/gui/fpg_splitter.pas create mode 100644 src/gui/fpg_style.pas create mode 100644 src/gui/fpg_tab.pas create mode 100644 src/gui/fpg_trackbar.pas create mode 100644 src/gui/fpg_tree.pas delete mode 100644 src/gui/gui_animation.pas delete mode 100644 src/gui/gui_basegrid.pas delete mode 100644 src/gui/gui_button.pas delete mode 100644 src/gui/gui_checkbox.pas delete mode 100644 src/gui/gui_combobox.pas delete mode 100644 src/gui/gui_customgrid.pas delete mode 100644 src/gui/gui_dialogs.pas delete mode 100644 src/gui/gui_edit.pas delete mode 100644 src/gui/gui_editcombo.pas delete mode 100644 src/gui/gui_form.pas delete mode 100644 src/gui/gui_gauge.pas delete mode 100644 src/gui/gui_grid.pas delete mode 100644 src/gui/gui_hint.pas delete mode 100644 src/gui/gui_hyperlink.pas delete mode 100644 src/gui/gui_iniutils.pas delete mode 100644 src/gui/gui_label.pas delete mode 100644 src/gui/gui_listbox.pas delete mode 100644 src/gui/gui_listview.pas delete mode 100644 src/gui/gui_memo.pas delete mode 100644 src/gui/gui_menu.pas delete mode 100644 src/gui/gui_mru.pas delete mode 100644 src/gui/gui_panel.pas delete mode 100644 src/gui/gui_popupcalendar.pas delete mode 100644 src/gui/gui_progressbar.pas delete mode 100644 src/gui/gui_radiobutton.pas delete mode 100644 src/gui/gui_scrollbar.pas delete mode 100644 src/gui/gui_splitter.pas delete mode 100644 src/gui/gui_style.pas delete mode 100644 src/gui/gui_tab.pas delete mode 100644 src/gui/gui_trackbar.pas delete mode 100644 src/gui/gui_tree.pas diff --git a/src/corelib/fpg_main.pas b/src/corelib/fpg_main.pas index 58b8f6e4..9a0abf9e 100644 --- a/src/corelib/fpg_main.pas +++ b/src/corelib/fpg_main.pas @@ -386,8 +386,8 @@ uses fpg_constants, fpg_stringutils, fpg_widget, - gui_dialogs, - gui_hint; + fpg_dialogs, + fpg_hint; var fpgTimers: TList; diff --git a/src/corelib/fpg_pofiles.pas b/src/corelib/fpg_pofiles.pas index 806e1dc7..3af333fe 100644 --- a/src/corelib/fpg_pofiles.pas +++ b/src/corelib/fpg_pofiles.pas @@ -54,7 +54,6 @@ interface uses Classes, SysUtils, - Contnrs, fpg_stringhashlist; type diff --git a/src/corelib/fpg_widget.pas b/src/corelib/fpg_widget.pas index e471dd9d..5b3535e7 100644 --- a/src/corelib/fpg_widget.pas +++ b/src/corelib/fpg_widget.pas @@ -167,7 +167,8 @@ function FindKeyboardFocus: TfpgWidget; implementation uses - math, fpg_constants, gui_hint; + fpg_constants, + fpg_hint; var diff --git a/src/corelib/gdi/fpgui_toolkit.lpk b/src/corelib/gdi/fpgui_toolkit.lpk index 61ab6a60..31b266e3 100644 --- a/src/corelib/gdi/fpgui_toolkit.lpk +++ b/src/corelib/gdi/fpgui_toolkit.lpk @@ -1,324 +1,324 @@ - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + +"/> - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +"/> + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/src/corelib/gdi/fpgui_toolkit.pas b/src/corelib/gdi/fpgui_toolkit.pas index 49c99c7a..d4a92342 100644 --- a/src/corelib/gdi/fpgui_toolkit.pas +++ b/src/corelib/gdi/fpgui_toolkit.pas @@ -10,13 +10,13 @@ uses fpg_base, fpg_main, fpg_cmdlineparams, fpg_command_intf, fpg_constants, fpg_extinterpolation, fpg_imagelist, fpg_imgfmt_bmp, fpg_pofiles, fpg_popupwindow, fpg_stdimages, fpg_stringhashlist, fpg_translations, - fpg_stringutils, fpg_utils, fpg_widget, fpg_wuline, gui_animation, - gui_basegrid, gui_button, gui_checkbox, gui_combobox, gui_customgrid, - gui_dialogs, gui_editcombo, gui_edit, gui_form, gui_gauge, gui_grid, - gui_hyperlink, gui_iniutils, gui_label, gui_listbox, gui_listview, gui_memo, - gui_menu, gui_mru, gui_panel, gui_popupcalendar, gui_progressbar, - gui_radiobutton, gui_scrollbar, gui_style, gui_tab, gui_trackbar, gui_tree, - fpgui_db, fpg_gdi, fpg_impl, gui_splitter, gui_hint; + fpg_stringutils, fpg_utils, fpg_widget, fpg_wuline, fpg_animation, + fpg_basegrid, fpg_button, fpg_checkbox, fpg_combobox, fpg_customgrid, + fpg_dialogs, fpg_editcombo, fpg_edit, fpg_form, fpg_gauge, fpg_grid, + fpg_hyperlink, fpg_iniutils, fpg_label, fpg_listbox, fpg_listview, fpg_memo, + fpg_menu, fpg_mru, fpg_panel, fpg_popupcalendar, fpg_progressbar, + fpg_radiobutton, fpg_scrollbar, fpg_style, fpg_tab, fpg_trackbar, fpg_tree, + fpgui_db, fpg_gdi, fpg_impl, fpg_splitter, fpg_hint; implementation diff --git a/src/corelib/x11/fpg_x11.pas b/src/corelib/x11/fpg_x11.pas index 66fa7a62..4c7fa049 100644 --- a/src/corelib/x11/fpg_x11.pas +++ b/src/corelib/x11/fpg_x11.pas @@ -303,7 +303,7 @@ uses fpg_widget, fpg_popupwindow, fpg_stringutils, // used for GetTextWidth - gui_form, // for modal event support + fpg_form, // for modal event support cursorfont, xatom; // used for XA_WM_NAME diff --git a/src/corelib/x11/fpgui_toolkit.lpk b/src/corelib/x11/fpgui_toolkit.lpk index e3a6b911..376b0224 100644 --- a/src/corelib/x11/fpgui_toolkit.lpk +++ b/src/corelib/x11/fpgui_toolkit.lpk @@ -175,120 +175,120 @@ - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + - - + + @@ -307,12 +307,12 @@ - - + + - - + + diff --git a/src/corelib/x11/fpgui_toolkit.pas b/src/corelib/x11/fpgui_toolkit.pas index 504536a2..4d37c9c8 100644 --- a/src/corelib/x11/fpgui_toolkit.pas +++ b/src/corelib/x11/fpgui_toolkit.pas @@ -11,13 +11,13 @@ uses fpg_extinterpolation, fpg_imagelist, fpg_imgfmt_bmp, fpg_pofiles, fpg_popupwindow, fpg_stdimages, fpg_stringhashlist, fpg_translations, fpg_stringutils, fpg_utils, fpg_widget, fpg_wuline, fpg_impl, fpg_x11, - fpg_netlayer_x11, fpg_keyconv_x11, fpg_xft_x11, gui_animation, gui_basegrid, - gui_button, gui_checkbox, gui_combobox, gui_customgrid, gui_dialogs, - gui_editcombo, gui_edit, gui_form, gui_gauge, gui_grid, gui_hyperlink, - gui_iniutils, gui_label, gui_listbox, gui_listview, gui_memo, gui_menu, - gui_mru, gui_panel, gui_popupcalendar, gui_progressbar, gui_radiobutton, - gui_scrollbar, gui_style, gui_tab, gui_trackbar, gui_tree, fpgui_db, - gui_splitter, gui_hint; + fpg_netlayer_x11, fpg_keyconv_x11, fpg_xft_x11, fpg_animation, fpg_basegrid, + fpg_button, fpg_checkbox, fpg_combobox, fpg_customgrid, fpg_dialogs, + fpg_editcombo, fpg_edit, fpg_form, fpg_gauge, fpg_grid, fpg_hyperlink, + fpg_iniutils, fpg_label, fpg_listbox, fpg_listview, fpg_memo, fpg_menu, + fpg_mru, fpg_panel, fpg_popupcalendar, fpg_progressbar, fpg_radiobutton, + fpg_scrollbar, fpg_style, fpg_tab, fpg_trackbar, fpg_tree, fpgui_db, + fpg_splitter, fpg_hint; implementation diff --git a/src/gui/db/fpgui_db.pas b/src/gui/db/fpgui_db.pas index dd2381de..1e814ba0 100644 --- a/src/gui/db/fpgui_db.pas +++ b/src/gui/db/fpgui_db.pas @@ -29,7 +29,7 @@ uses Classes, db, fpg_widget, - gui_label{, gui_edit}; + fpg_label{, fpg_edit}; type diff --git a/src/gui/fpg_animation.pas b/src/gui/fpg_animation.pas new file mode 100644 index 00000000..b95d83ac --- /dev/null +++ b/src/gui/fpg_animation.pas @@ -0,0 +1,185 @@ +{ + fpGUI - Free Pascal GUI Toolkit + + Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this + distribution, for details of the copyright. + + See the file COPYING.modifiedLGPL, included in this distribution, + for details about redistributing fpGUI. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + Description: + It's a simple little component that animates an image that contains + multiple frames (in a horizontal direction). See the Animation + demo for image examples. +} + +unit fpg_animation; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, + fpg_base, + fpg_main, + fpg_widget; + +type + + TfpgBaseImgAnim = class(TfpgWidget) + private + FFrameCount: integer; + FImageFilename: TfpgString; + FImage: TfpgImage; + FInterval: integer; + FTimer: TfpgTimer; + FPos: integer; + FImageWidth: TfpgCoord; + FTransparent: Boolean; + procedure InternalTimerFired(Sender: TObject); + procedure SetAnimPosition(const AValue: integer); + procedure SetInterval(const AValue: integer); + procedure RecalcImageWidth; + protected + procedure HandlePaint; override; + procedure SetEnabled(const AValue: boolean); override; + procedure SetImageFilename(const AValue: TfpgString); virtual; + // + property Interval: integer read FInterval write SetInterval default 50; + property ImageFileName: TfpgString read FImageFilename write SetImageFilename; + property IsTransparent: Boolean read FTransparent write FTransparent default True; + property FrameCount: integer read FFrameCount write FFrameCount default 4; + property Position: integer read FPos write SetAnimPosition default 0; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + end; + + + TfpgImgAnim = class(TfpgBaseImgAnim) + public + property Position; + published + property Enabled; + property Interval; + property ImageFileName; + property IsTransparent; + property FrameCount; + end; + + +implementation + +uses + SysUtils, + fpg_imgfmt_bmp, + fpg_utils; + + +{ TfpgBaseImgAnim } + +procedure TfpgBaseImgAnim.InternalTimerFired(Sender: TObject); +begin + Repaint; + inc(FPos); + if FPos > FrameCount-1 then + FPos := 0; +end; + +procedure TfpgBaseImgAnim.SetAnimPosition(const AValue: integer); +begin + if FTimer.Enabled then + Exit; // ignore position because animation is running + if AValue < 0 then + FPos := 0 + else + FPos := AValue; + Repaint; +end; + +procedure TfpgBaseImgAnim.SetInterval(const AValue: integer); +begin + if FInterval = AValue then + Exit; //==> + FInterval := AValue; + FTimer.Interval := FInterval; + RecalcImageWidth; +end; + +procedure TfpgBaseImgAnim.RecalcImageWidth; +begin + FImageWidth := FImage.Width div FrameCount; + FPos := 0; +end; + +procedure TfpgBaseImgAnim.HandlePaint; +begin + if (FImageFilename = '') or (FImage = nil) then + Exit; //==> + Canvas.BeginDraw; + Canvas.Clear(clWindowBackground); + Canvas.DrawImagePart(0, 0, FImage, (FImageWidth * FPos), 0, FImageWidth, FImage.Height); + Canvas.EndDraw; +end; + +procedure TfpgBaseImgAnim.SetEnabled(const AValue: boolean); +begin + inherited SetEnabled(AValue); + FTimer.Enabled := FEnabled; +end; + +procedure TfpgBaseImgAnim.SetImageFilename(const AValue: TfpgString); +begin + if FImageFilename = AValue then + Exit; //==> + + if Trim(AValue) = '' then + Exit; //==> + + if not fpgFileExists(AValue) then + raise Exception.CreateFmt('The file <%s> does not exist.', [AValue]) + else + FImageFilename := AValue; + + FTimer.Enabled := False; + FImage.Free; + FImage := LoadImage_BMP(FImageFilename); + if FTransparent then + begin + FImage.CreateMaskFromSample(0, 0); + FImage.UpdateImage; + end; + RecalcImageWidth; + Repaint; +end; + +constructor TfpgBaseImgAnim.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FPos := 0; + FFrameCount := 4; + FInterval := 50; + FImage := nil; + FEnabled := False; + FTransparent := True; + + FTimer := TfpgTimer.Create(FInterval); + FTimer.OnTimer := @InternalTimerFired; +end; + +destructor TfpgBaseImgAnim.Destroy; +begin + FTimer.Enabled := False; + FTimer.Free; + FImage.Free; + inherited Destroy; +end; + + +end. + diff --git a/src/gui/fpg_basegrid.pas b/src/gui/fpg_basegrid.pas new file mode 100644 index 00000000..a1cc01d0 --- /dev/null +++ b/src/gui/fpg_basegrid.pas @@ -0,0 +1,1206 @@ +{ + fpGUI - Free Pascal GUI Toolkit + + Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this + distribution, for details of the copyright. + + See the file COPYING.modifiedLGPL, included in this distribution, + for details about redistributing fpGUI. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + Description: + Defines a Base Grid control. Usable as the base for any grid type of + component. +} + +unit fpg_basegrid; + +{$mode objfpc}{$H+} + +{.$Define DEBUG} + +interface + +uses + Classes, + SysUtils, + fpg_base, + fpg_main, + fpg_widget, + fpg_scrollbar; + +type + + TfpgGridDrawState = set of (gdSelected, gdFocused, gdFixed); + + TfpgFocusChangeNotify = procedure(Sender: TObject; ARow, ACol: Integer) of object; + TfpgRowChangeNotify = procedure(Sender: TObject; ARow: Integer) of object; + TfpgCanSelectCellEvent = procedure(Sender: TObject; const ARow, ACol: Integer; var ACanSelect: boolean) of object; + TfpgDrawCellEvent = procedure(Sender: TObject; const ARow, ACol: Integer; const ARect: TfpgRect; const AFlags: TfpgGridDrawState; var ADefaultDrawing: boolean) of object; + + // widget options + TfpgGridOption = (go_HideFocusRect); + TfpgGridOptions = set of TfpgGridOption; + + // Column 2 is special just for testing purposes. Descendant classes will + // override that special behavior anyway. + TfpgBaseGrid = class(TfpgWidget) + private + FColResizing: boolean; + FDragPos: integer; // used for column resizing + FOnDrawCell: TfpgDrawCellEvent; + FResizedCol: integer; // used for column resizing + FDefaultColWidth: integer; + FDefaultRowHeight: integer; + FFocusCol: Integer; + FFocusRow: Integer; + FHeaderHeight: integer; + FOnCanSelectCell: TfpgCanSelectCellEvent; + FOnFocusChange: TfpgFocusChangeNotify; + FOnRowChange: TfpgRowChangeNotify; + FPrevCol: Integer; + FPrevRow: Integer; + FFirstRow: Integer; + FFirstCol: Integer; + FMargin: integer; + FFont: TfpgFont; + FHeaderFont: TfpgFont; + FRowSelect: boolean; + FScrollBarStyle: TfpgScrollStyle; + FShowGrid: boolean; + FShowHeader: boolean; + FTemp: integer; + FVScrollBar: TfpgScrollBar; + FHScrollBar: TfpgScrollBar; + FUpdateCount: integer; + FOptions: TfpgGridOptions; + function GetFontDesc: string; + function GetHeaderFontDesc: string; + procedure HScrollBarMove(Sender: TObject; position: integer); + procedure SetFontDesc(const AValue: string); + procedure SetHeaderFontDesc(const AValue: string); + procedure SetRowSelect(const AValue: boolean); + procedure SetScrollBarStyle(const AValue: TfpgScrollStyle); + procedure VScrollBarMove(Sender: TObject; position: integer); + procedure SetDefaultColWidth(const AValue: integer); + procedure SetDefaultRowHeight(const AValue: integer); + procedure SetFocusCol(const AValue: Integer); + procedure SetFocusRow(const AValue: Integer); + procedure CheckFocusChange; + procedure SetShowGrid(const AValue: boolean); + procedure SetShowHeader(const AValue: boolean); + function VisibleLines: Integer; + function VisibleWidth: integer; + function VisibleHeight: integer; + procedure SetFirstRow(const AValue: Integer); + protected + property UpdateCount: integer read FUpdateCount; + procedure UpdateScrollBars; virtual; + function GetHeaderText(ACol: Integer): string; virtual; + function GetColumnWidth(ACol: Integer): integer; virtual; + procedure SetColumnWidth(ACol: Integer; const AValue: integer); virtual; + function GetColumnBackgroundColor(ACol: Integer): TfpgColor; virtual; + procedure SetColumnBackgroundColor(ACol: Integer; const AValue: TfpgColor); virtual; + function GetColumnTextColor(ACol: Integer): TfpgColor; virtual; + procedure SetColumnTextColor(ACol: Integer; const AValue: TfpgColor); virtual; + function GetColumnCount: Integer; virtual; + function GetRowCount: Integer; virtual; + function CanSelectCell(const ARow, ACol: Integer): boolean; + function DoDrawCellEvent(ARow, ACol: Integer; ARect: TfpgRect; AFlags: TfpgGridDrawState): boolean; virtual; + procedure DoCanSelectCell(const ARow, ACol: Integer; var ACanSelect: boolean); + procedure DrawCell(ARow, ACol: Integer; ARect: TfpgRect; AFlags: TfpgGridDrawState); virtual; + procedure DrawHeader(ACol: Integer; ARect: TfpgRect; AFlags: integer); virtual; + procedure DrawGrid(ARow, ACol: Integer; ARect: TfpgRect; AFlags: integer); virtual; + procedure HandlePaint; override; + procedure HandleShow; override; + procedure HandleResize(awidth, aheight: TfpgCoord); override; + procedure HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override; + procedure HandleMouseScroll(x, y: integer; shiftstate: TShiftState; delta: smallint); override; + procedure HandleMouseMove(x, y: integer; btnstate: word; shiftstate: TShiftState); override; + procedure HandleLMouseUp(x, y: integer; shiftstate: TShiftState); override; + procedure HandleLMouseDown(x, y: integer; shiftstate: TShiftState); override; + procedure FollowFocus; virtual; + property DefaultColWidth: integer read FDefaultColWidth write SetDefaultColWidth default 64; + property DefaultRowHeight: integer read FDefaultRowHeight write SetDefaultRowHeight; + property Font: TfpgFont read FFont; + property FontDesc: string read GetFontDesc write SetFontDesc; + property HeaderFont: TfpgFont read FHeaderFont; + property HeaderFontDesc: string read GetHeaderFontDesc write SetHeaderFontDesc; + property FocusCol: Integer read FFocusCol write SetFocusCol default -1; + property FocusRow: Integer read FFocusRow write SetFocusRow default -1; + property RowSelect: boolean read FRowSelect write SetRowSelect; + property ColumnCount: Integer read GetColumnCount; + property RowCount: Integer read GetRowCount; + property ShowHeader: boolean read FShowHeader write SetShowHeader default True; + property ShowGrid: boolean read FShowGrid write SetShowGrid default True; + property ScrollBarStyle: TfpgScrollStyle read FScrollBarStyle write SetScrollBarStyle default ssAutoBoth; + property HeaderHeight: integer read FHeaderHeight; +// property ColResizing: boolean read FColResizing write FColResizing; + property ColumnWidth[ACol: Integer]: integer read GetColumnWidth write SetColumnWidth; + property ColumnBackgroundColor[ACol: Integer]: TfpgColor read GetColumnBackgroundColor write SetColumnBackgroundColor; + property ColumnTextColor[ACol: Integer]: TfpgColor read GetColumnTextColor write SetColumnTextColor; + property VisibleRows: Integer read VisibleLines; + property TopRow: Integer read FFirstRow write SetFirstRow; + property Options: TfpgGridOptions read FOptions write FOptions default []; + property OnDrawCell: TfpgDrawCellEvent read FOnDrawCell write FOnDrawCell; + property OnFocusChange: TfpgFocusChangeNotify read FOnFocusChange write FOnFocusChange; + property OnRowChange: TfpgRowChangeNotify read FOnRowChange write FOnRowChange; + property OnCanSelectCell: TfpgCanSelectCellEvent read FOnCanSelectCell write FOnCanSelectCell; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure AfterConstruction; override; + procedure Update; + procedure BeginUpdate; + procedure EndUpdate; + procedure MouseToCell(X, Y: Integer; var ACol, ARow: Integer); + end; + + +implementation + +{ TfpgBaseGrid } + +procedure TfpgBaseGrid.HScrollBarMove(Sender: TObject; position: integer); +begin + if FFirstCol <> position then + begin + if Position < 0 then + Position := 0; + FFirstCol := position; + RePaint; + end; +end; + +function TfpgBaseGrid.GetFontDesc: string; +begin + Result := FFont.FontDesc; +end; + +function TfpgBaseGrid.GetHeaderFontDesc: string; +begin + Result := FHeaderFont.FontDesc; +end; + +procedure TfpgBaseGrid.SetFontDesc(const AValue: string); +begin + FFont.Free; + FFont := fpgGetFont(AValue); + if DefaultRowHeight < FFont.Height + 2 then + DefaultRowHeight := FFont.Height + 2; + RePaint; +end; + +procedure TfpgBaseGrid.SetHeaderFontDesc(const AValue: string); +begin + FHeaderFont.Free; + FHeaderFont := fpgGetFont(AValue); + if FHeaderHeight < FHeaderFont.Height + 2 then + FHeaderHeight := FHeaderFont.Height + 2; + RePaint; +end; + +procedure TfpgBaseGrid.SetRowSelect(const AValue: boolean); +begin + if FRowSelect = AValue then + Exit; //==> + FRowSelect := AValue; + RePaint; +end; + +procedure TfpgBaseGrid.SetScrollBarStyle(const AValue: TfpgScrollStyle); +begin + if FScrollBarStyle = AValue then + Exit; //==> + FScrollBarStyle := AValue; +end; + +procedure TfpgBaseGrid.VScrollBarMove(Sender: TObject; position: integer); +begin + if FFirstRow <> position then + begin + FFirstRow := position; + RePaint; + end; +end; + +procedure TfpgBaseGrid.SetDefaultColWidth(const AValue: integer); +begin + if FDefaultColWidth = AValue then + Exit; //==> + FDefaultColWidth := AValue; + RePaint; +end; + +procedure TfpgBaseGrid.SetDefaultRowHeight(const AValue: integer); +begin + if FDefaultRowHeight = AValue then + Exit; //==> + FDefaultRowHeight := AValue; + RePaint; +end; + +function TfpgBaseGrid.GetColumnWidth(ACol: Integer): integer; +begin + Result := 50; +end; + +procedure TfpgBaseGrid.SetColumnWidth(ACol: Integer; const AValue: integer); +begin + // GetColumnWidth and SetColumnWidth will be overriden in decendant! + // Column 2 is special just for testing purposes + if (ACol = 2) and (AValue <> FTemp) then + begin + FTemp := AValue; + UpdateScrollBars; + Repaint; + end; +end; + +function TfpgBaseGrid.GetColumnBackgroundColor(ACol: Integer): TfpgColor; +begin + // implemented in descendant +end; + +procedure TfpgBaseGrid.SetColumnBackgroundColor(ACol: Integer; const AValue: TfpgColor); +begin + // implemented in descendant +end; + +function TfpgBaseGrid.GetColumnTextColor(ACol: Integer): TfpgColor; +begin + // implemented in descendant +end; + +procedure TfpgBaseGrid.SetColumnTextColor(ACol: Integer; const AValue: TfpgColor); +begin + // implemented in descendant +end; + +function TfpgBaseGrid.GetColumnCount: Integer; +begin + Result := 7; +end; + +function TfpgBaseGrid.GetRowCount: Integer; +begin + Result := 24; +end; + +function TfpgBaseGrid.CanSelectCell(const ARow, ACol: Integer): boolean; +begin + Result := (ARow >= 0) and (ACol >= 0) and (ARow < RowCount) and (ACol < ColumnCount); + if Result then + DoCanSelectCell(ARow, ACol, Result); +end; + +function TfpgBaseGrid.DoDrawCellEvent(ARow, ACol: Integer; ARect: TfpgRect; + AFlags: TfpgGridDrawState): boolean; +begin + Result := True; + if Assigned(OnDrawCell) then + FOnDrawCell(self, ARow, ACol, ARect, AFlags, Result); +end; + +procedure TfpgBaseGrid.DoCanSelectCell(const ARow, ACol: Integer; var + ACanSelect: boolean); +begin + if Assigned(OnCanSelectCell) then + FOnCanSelectCell(self, ARow, ACol, ACanSelect); +end; + +procedure TfpgBaseGrid.DrawCell(ARow, ACol: Integer; ARect: TfpgRect; AFlags: TfpgGridDrawState); +var + s: string; +begin + s := 'c(' + IntToStr(ARow) + ',' + IntToStr(ACol) + ')'; + if (ARow = 5) and (ACol = 2) then + s := 'Here lives Graeme!'; + if not Enabled then + Canvas.SetTextColor(clShadow1); + Canvas.DrawText(ARect, s, [txtHCenter, txtVCenter]); +end; + +procedure TfpgBaseGrid.DrawHeader(ACol: Integer; ARect: TfpgRect; AFlags: integer); +var + s: string; + r: TfpgRect; + x: integer; +begin + // Here we can implement a head style check + Canvas.DrawButtonFace(ARect, [btfIsEmbedded]); + r := ARect; + InflateRect(r, -2, -2); + Canvas.AddClipRect(r); // text may not overshoot header border +(* + // drawing grid lines + Canvas.SetColor(clGridLines); + Canvas.DrawLine(r.Left, r.Bottom+1, r.Right+1, r.Bottom+1); // horizontal bottom + Canvas.DrawLine(r.Right+1, r.Top, r.Right+1, r.Bottom+1); // vertical right + + if (ACol mod 2) = 0 then + Canvas.SetColor(clGridHeader) + else + Canvas.SetColor(clMagenta); + Canvas.FillRectangle(ARect); +*) + + Canvas.SetTextColor(clText1); + s := GetHeaderText(ACol); + x := (ARect.Left + (ARect.Width div 2)) - (FHeaderFont.TextWidth(s) div 2); + if x < 1 then + x := 1; + fpgStyle.DrawString(Canvas, x, ARect.Top+1, s, Enabled); +end; + +procedure TfpgBaseGrid.DrawGrid(ARow, ACol: Integer; ARect: TfpgRect; + AFlags: integer); +begin + // default is inside bottom/right edge or cell + Canvas.SetColor(clGridLines); + Canvas.DrawLine(ARect.Left, ARect.Bottom, ARect.Right, ARect.Bottom); // cell bottom + Canvas.DrawLine(ARect.Right, ARect.Bottom, ARect.Right, ARect.Top-1); // cell right +end; + +procedure TfpgBaseGrid.SetFocusCol(const AValue: Integer); +begin + if FFocusCol = AValue then + Exit; //==> + FFocusCol := AValue; + + // apply min/max limit + if FFocusCol < 0 then + FFocusCol := 0; + if FFocusCol > ColumnCount-1 then + FFocusCol := ColumnCount-1; + + FollowFocus; + CheckFocusChange; +end; + +procedure TfpgBaseGrid.SetFocusRow(const AValue: Integer); +begin + if FFocusRow = AValue then + Exit; //==> + FFocusRow := AValue; + + // apply min/max limit + if FFocusRow < 0 then + FFocusRow := 0; + if FFocusRow > RowCount-1 then + FFocusRow := RowCount-1; + + FollowFocus; + CheckFocusChange; +end; + +procedure TfpgBaseGrid.CheckFocusChange; +begin + if ((FPrevCol <> FFocusCol) and not RowSelect) or (FPrevRow <> FFocusRow) then + if Assigned(FOnFocusChange) then + FOnFocusChange(self, FFocusRow, FFocusCol); + + if (FPrevRow <> FFocusRow) then + if Assigned(FOnRowChange) then + FOnRowChange(self, FFocusRow); + + FPrevCol := FFocusCol; + FPrevRow := FFocusRow; +end; + +procedure TfpgBaseGrid.SetShowGrid(const AValue: boolean); +begin + if FShowGrid = AValue then + Exit; //==> + FShowGrid := AValue; + RePaint; +end; + +procedure TfpgBaseGrid.SetShowHeader(const AValue: boolean); +begin + if FShowHeader = AValue then + Exit; //==> + FShowHeader := AValue; + UpdateScrollBars; + RePaint; +end; + +// Return the fully visible lines only. Partial lines not counted +function TfpgBaseGrid.VisibleLines: Integer; +var + hh: integer; +begin + if FHScrollBar.Visible then + hh := FHScrollbar.Height + else + hh := 0; + if ShowHeader then + hh := hh + FHeaderHeight+1; + Result := (Height - (2*FMargin) - hh) div FDefaultRowHeight; +end; + +function TfpgBaseGrid.VisibleWidth: integer; +var + sw: integer; +begin + if FVScrollBar.Visible then + sw := FVScrollBar.Width-1 + else + sw := 0; + Result := Width - (FMargin*2) - sw; +end; + +function TfpgBaseGrid.VisibleHeight: integer; +var + sw: integer; +begin + if FHScrollBar.Visible then + sw := FHScrollBar.Height-1 + else + sw := 0; + Result := Height - (FMargin*2) - sw; +end; + +procedure TfpgBaseGrid.SetFirstRow(const AValue: Integer); +begin + if FFirstRow = AValue then + Exit; //==> + if AValue < ((RowCount - VisibleLines)) then + FFirstRow := AValue + else + FFirstRow := (RowCount - VisibleLines); + UpdateScrollBars; + RePaint; +end; + +procedure TfpgBaseGrid.UpdateScrollBars; +var + HWidth: integer; + VHeight: integer; + vw: integer; + cw: integer; + i: integer; +begin + VHeight := Height - 4; + HWidth := Width - 4; + + vw := VisibleWidth; + cw := 0; + for i := 0 to ColumnCount-1 do + cw := cw + ColumnWidth[i]; + + // This needs improving while resizing + if cw > vw then + FHScrollBar.Visible := not (FScrollBarStyle in [ssNone, ssVertical]) + else + begin + FHScrollBar.Visible := False; + FFirstCol := 0; + end; + + // This needs improving while resizing + if (RowCount > VisibleLines) then + FVScrollBar.Visible := not (FScrollBarStyle in [ssNone, ssHorizontal]) + else + begin + FVScrollBar.Visible := False; + FFirstRow := 0; + end; + + if FVScrollBar.Visible then + begin + Dec(HWidth, FVScrollBar.Width); + FVScrollBar.Min := 0; + if RowCount > 0 then + FVScrollBar.SliderSize := VisibleLines / RowCount + else + FVScrollBar.SliderSize := 0; + FVScrollBar.Max := RowCount-VisibleLines; + FVScrollBar.Position := FFirstRow; + FVScrollBar.RepaintSlider; + end; + + if FHScrollBar.Visible then + begin + Dec(VHeight, FHScrollBar.Height); + FHScrollBar.Min := 0; + FHScrollBar.SliderSize := 0.2; + FHScrollBar.Max := ColumnCount-1; + FHScrollBar.Position := FFirstCol; + FHScrollBar.RepaintSlider; + end; + + FHScrollBar.Top := Height -FHScrollBar.Height - 2; + FHScrollBar.Left := 2; + FHScrollBar.Width := HWidth; + + FVScrollBar.Top := 2; + FVScrollBar.Left := Width - FVScrollBar.Width - 2; + FVScrollBar.Height := VHeight; + + FVScrollBar.UpdateWindowPosition; + FHScrollBar.UpdateWindowPosition; +end; + +function TfpgBaseGrid.GetHeaderText(ACol: Integer): string; +begin + Result := 'Head ' + IntToStr(ACol); +end; + +procedure TfpgBaseGrid.HandlePaint; +var + r: TfpgRect; + r2: TfpgRect; + col: Integer; + row: Integer; + clipr: TfpgRect; // clip rectangle + drawstate: TfpgGridDrawState; +begin + drawstate := []; + Canvas.BeginDraw; +// inherited HandlePaint; + Canvas.ClearClipRect; + + r.SetRect(0, 0, Width, Height); + Canvas.DrawControlFrame(r); + + InflateRect(r, -2, -2); + Canvas.SetClipRect(r); + Canvas.SetColor(FBackgroundColor); + Canvas.FillRectangle(r); + + clipr.SetRect(FMargin, FMargin, VisibleWidth, VisibleHeight); + r := clipr; + + if (ColumnCount > 0) and ShowHeader then + begin + // Drawing horizontal headers + r.Height := FHeaderHeight; + Canvas.SetFont(FHeaderFont); + for col := FFirstCol to ColumnCount-1 do + begin + r.Width := ColumnWidth[col]; + Canvas.SetClipRect(clipr); + Canvas.AddClipRect(r); + DrawHeader(col, r, 0); + inc(r.Left, r.Width); + if r.Left >= clipr.Right then + Break; // small optimization. Don't draw what we can't see + end; + inc(r.Top, r.Height); + end; + + if (RowCount > 0) and (ColumnCount > 0) then + begin + // Drawing cells + r.Height := DefaultRowHeight; + Canvas.SetFont(FFont); + + for row := FFirstRow to RowCount-1 do + begin + r.Left := FMargin; + for col := FFirstCol to ColumnCount-1 do + begin + r.Width := ColumnWidth[col]; + Canvas.SetClipRect(clipr); + + if (row = FFocusRow) and (RowSelect or (col = FFocusCol)) and not (go_HideFocusRect in FOptions) then + begin + if FFocused then + begin + Canvas.SetColor(clSelection); + Canvas.SetTextColor(clSelectionText); + end + else + begin + Canvas.SetColor(clInactiveSel); + Canvas.SetTextColor(clInactiveSelText); + end; + end + else + begin + Canvas.SetColor(ColumnBackgroundColor[col]); + Canvas.SetTextColor(ColumnTextColor[col]); + end; + Canvas.AddClipRect(r); + Canvas.FillRectangle(r); + // setup drawstate + if FFocused then + Include(drawstate, gdFocused); + if (row = FFocusRow) and (col = FFocusCol) then + Include(drawstate, gdSelected); + + if DoDrawCellEvent(row, col, r, drawstate) then + DrawCell(row, col, r, drawstate); + + // drawing grid lines + if FShowGrid then + DrawGrid(row, col, r, 0); + + inc(r.Left, r.Width); + if r.Left >= clipr.Right then + Break; // small optimization. Don't draw what we can't see + end; +// Inc(r.Top, FDefaultRowHeight+1); + inc(r.Top, r.Height); + if r.Top >= clipr.Bottom then + break; + end; + end; // item drawing + + Canvas.SetClipRect(clipr); + Canvas.SetColor(FBackgroundColor); + + // clearing after the last column + if r.Left <= clipr.Right then + begin + r2.Left := r.Left; + r2.Top := clipr.Top; + r2.SetRight(clipr.Right); + r2.Height := clipr.Height; + Canvas.FillRectangle(r2); + end; + + // clearing after the last row + if r.Top <= clipr.Bottom then + begin + r.Left := clipr.Left; + r.Width := clipr.Width; + r.SetBottom(clipr.Bottom); + Canvas.FillRectangle(r); + end; + + // The little square in the bottom right corner + if FHScrollBar.Visible and FVScrollBar.Visible then + begin + Canvas.ClearClipRect; + Canvas.SetColor(clButtonFace); + Canvas.FillRectangle(FHScrollBar.Left+FHScrollBar.Width, + FVScrollBar.Top+FVScrollBar.Height, + FVScrollBar.Width, + FHScrollBar.Height); + end; + + Canvas.EndDraw; +end; + +procedure TfpgBaseGrid.HandleShow; +begin + inherited HandleShow; + if (csLoading in ComponentState) then + Exit; + UpdateScrollBars; +end; + +procedure TfpgBaseGrid.HandleResize(awidth, aheight: TfpgCoord); +begin + inherited HandleResize(awidth, aheight); + if (csLoading in ComponentState) then + Exit; //==> + if csUpdating in ComponentState then + Exit; //==> + if HasHandle then + UpdateScrollBars; +end; + +procedure TfpgBaseGrid.HandleKeyPress(var keycode: word; + var shiftstate: TShiftState; var consumed: boolean); +var + w: integer; + r: integer; +begin + consumed := True; + case keycode of + keyRight: + begin + if RowSelect then + begin + w := 0; + FFocusCol := FFirstCol; + while FFocusCol < ColumnCount do + begin + inc(w, ColumnWidth[FFocusCol]+1); + if w + ColumnWidth[FFocusCol+1]+1 > VisibleWidth then + Break; + inc(FFocusCol); + end; + end; + + if CanSelectCell(FFocusRow, FFocusCol+1) then + begin + inc(FFocusCol); + FollowFocus; + RePaint; + end; + end; + + keyLeft: + begin + if RowSelect then + FFocusCol := FFirstCol; + if CanSelectCell(FFocusRow, FFocusCol-1) then + begin + dec(FFocusCol); + FollowFocus; + RePaint; + end; + end; + + keyUp: + begin + if CanSelectCell(FFocusRow-1, FFocusCol) then + begin + dec(FFocusRow); + FollowFocus; + RePaint; + end; + end; + + keyDown: + begin + if CanSelectCell(FFocusRow+1, FFocusCol) then + begin + inc(FFocusRow); + FollowFocus; + RePaint; + end; + end; + + keyPageUp: + begin + r := FFocusRow-VisibleLines; + if r < 0 then + r := 0; + + if (FFocusRow <> 0) and CanSelectCell(r, FFocusCol) then + begin + FFocusRow := r; + FollowFocus; + RePaint; + end; + end; + + keyPageDown: + begin + r := FFocusRow+VisibleLines; + if r > (RowCount-1) then + r := RowCount-1; + + if (FFocusRow <> (RowCount-1)) and CanSelectCell(r, FFocusCol) then + begin + FFocusRow := r; + FollowFocus; + RePaint; + end; + end; + + keyHome: + begin + if FRowSelect then + begin + if (FFocusRow <> 0) and CanSelectCell(0, FFocusCol) then + begin + FFocusRow := 0; + FollowFocus; + RePaint; + end; + end + else if (FFocusCol <> 0) and CanSelectCell(FFocusRow, 0) then + begin + FFocusCol := 0; + FollowFocus; + RePaint; + end; + end; + + keyEnd: + begin + if FRowSelect then + begin + if (FFocusRow <> (RowCount-1)) and CanSelectCell(RowCount-1, FFocusCol) then + begin + FFocusRow := RowCount-1; + FollowFocus; + RePaint; + end; + end + else if (FFocusCol <> (ColumnCount-1)) and CanSelectCell(FFocusRow, ColumnCount-1) then + begin + FFocusCol := ColumnCount-1; + FollowFocus; + RePaint; + end; + end; + + else + consumed := False; + end; + + if consumed then + CheckFocusChange; + + inherited HandleKeyPress(keycode, shiftstate, consumed); +end; + +procedure TfpgBaseGrid.HandleMouseScroll(x, y: integer; shiftstate: TShiftState; delta: smallint); +var + lRow: Integer; + lCol: Integer; +begin + inherited HandleMouseScroll(x, y, shiftstate, delta); + + lRow := FFirstRow; + lCol := FFirstCol; + + if delta > 0 then // scroll down + inc(FFirstRow, abs(delta)) + else // scroll up + if FFirstRow > 0 then + dec(FFirstRow, abs(delta)); + + // apply limits + if FFirstRow > RowCount - VisibleLines then + FFirstRow := RowCount - VisibleLines; + if FFirstRow < 0 then + FFirstRow := 0; + + // scroll left/right + // If vertical scrollbar is not visible, but + // horizontal is. Mouse wheel will scroll horizontally. :) + if FHScrollBar.Visible and (not FVScrollBar.Visible) then + begin + if delta > 0 then // scroll right + begin + if FFirstCol < (ColumnCount-1) then + inc(FFirstCol); + end + else + begin + if FFirstCol > 0 then + dec(FFirstCol); + end; + end; + + if (lRow <> FFirstRow) or (lCol <> FFirstCol) then + begin + UpdateScrollBars; + RePaint; + end; +end; + +procedure TfpgBaseGrid.HandleMouseMove(x, y: integer; btnstate: word; shiftstate: TShiftState); +var + hh: integer; + cw: integer; + n: integer; + colresize: boolean; +begin + inherited HandleMouseMove(x, y, btnstate, shiftstate); + + if (ColumnCount = 0) or (RowCount = 0) then + Exit; //==> + + if FColResizing then + begin + if (btnstate and 1) = 0 then + FColResizing := False + else + begin + cw := ColumnWidth[FResizedCol]+x-FDragPos; + if cw < 1 then + cw := 1; + SetColumnWidth(FResizedCol, cw); + FDragPos := x; + end; + end + else if ShowHeader then + begin + colresize := False; + hh := FHeaderHeight; + + if (y <= FMargin + hh) then // we are over the Header row + begin + cw := 0; + for n := FFirstCol to ColumnCount-1 do + begin + inc(cw, ColumnWidth[n]); + // Resizing is enabled 4 pixel either way of the cell border + if ((x >= (FMargin+cw - 4)) and (x <= (FMargin+cw+4))) or + (cw > (FMargin + VisibleWidth)) and (x >= FMargin + VisibleWidth-4) then + begin + colresize := True; + Break; + end; + + if cw > VisibleWidth then + Break; + end; { if } + end; { if/else } + + if colresize then + MouseCursor := mcSizeEW + else + MouseCursor := mcDefault; + end; { if/else } +end; + +procedure TfpgBaseGrid.HandleLMouseUp(x, y: integer; shiftstate: TShiftState); +begin + inherited HandleLMouseUp(x, y, shiftstate); + + {$IFDEF DEBUG} + if FColResizing then + Writeln('Column ', FResizedCol,' width = ', ColumnWidth[FResizedCol]); + {$ENDIF} + + FColResizing := False; + MouseCursor := mcDefault; +end; + +procedure TfpgBaseGrid.HandleLMouseDown(x, y: integer; shiftstate: TShiftState); +var + hh: integer; + n: Integer; + cw: integer; + nw: integer; + prow: Integer; + pcol: Integer; +begin + inherited HandleLMouseDown(x, y, shiftstate); + + if (ColumnCount = 0) or (RowCount = 0) then + Exit; //==> + + pcol := FFocusCol; + prow := FFocusRow; + + // searching for the appropriate character position + if ShowHeader then + hh := FHeaderHeight+1 + else + hh := 0; + + if ShowHeader and (y <= FMargin+hh) then // inside Header row + begin + {$IFDEF DEBUG} Writeln('header click...'); {$ENDIF} + cw := 0; + for n := FFirstCol to ColumnCount-1 do + begin + inc(cw, ColumnWidth[n]); + if (x >= (FMargin+cw - 4)) and (x <= (FMargin+cw + 4)) then + begin + {$IFDEF DEBUG} Writeln('column resize...'); {$ENDIF} + FColResizing := True; + FResizedCol := n; + FDragPos := x; + Break; + end + else if (cw > FMargin+VisibleWidth) and (x >= FMargin+VisibleWidth-4) then + begin + FColResizing := True; + FResizedCol := n; + FDragPos := x; + nw := ColumnWidth[FResizedCol] - (cw+FMargin-x); + if nw > 0 then + SetColumnWidth(FResizedCol, nw ); + Break; + end; { if/else } + + if cw > VisibleWidth then + Break; + end; { for } + end + else + begin // Selecting a Cell via mouse + MouseToCell(x, y, FFocusCol, FFocusRow); + end; { if/else } + + if not CanSelectCell(FFocusRow, FFocusCol) then + begin + // restore previous values + FFocusRow := prow; + FFocusCol := pcol; + end; + + if (prow <> FFocusRow) or (pcol <> FFocusCol) then + begin + FollowFocus; + Repaint; + end; + + if FColResizing then + MouseCursor := mcSizeEW; + + CheckFocusChange; +end; + +procedure TfpgBaseGrid.FollowFocus; +var + n: Integer; + w: TfpgCoord; +begin + if (RowCount > 0) and (FFocusRow < 0) then + FFocusRow := 0; + if FFocusRow > RowCount-1 then + FFocusRow := RowCount-1; + + if (ColumnCount > 0) and (FFocusCol < 0) then + FFocusCol := 0; + if FFocusCol > ColumnCount-1 then + FFocusCol := ColumnCount-1; + + if FFirstRow < 0 then + FFirstRow := 0; + if FFirstCol < 0 then + FFirstCol := 0; + + if FFocusRow < FFirstRow then + FFirstRow := FFocusRow + else + begin + if (FFirstRow + VisibleLines) <= FFocusRow then + FFirstRow := (FFocusRow - VisibleLines) + 1; // scroll last partial row into view + end; { if/else } + + if FFocusCol < FFirstCol then + FFirstCol := FFocusCol + else + begin + w := 0; + for n := FFocusCol downto FFirstCol do + begin + w := w + ColumnWidth[n]+1; + if w > VisibleWidth then + begin + if n = FFocusCol then + FFirstCol := n + else + FFirstCol := n+1; + break; + end; + end; { for } + end; { if/else } + + UpdateScrollBars; +end; + +constructor TfpgBaseGrid.Create(AOwner: TComponent); +begin + Updating; + inherited Create(AOwner); + Focusable := True; + Width := 120; + Height := 80; + FFocusCol := -1; + FPrevCol := -1; + FFocusRow := -1; + FPrevRow := -1; + FFirstRow := 0; + FFirstCol := 0; + FMargin := 2; + FShowHeader := True; + FShowGrid := True; + FRowSelect := False; + FScrollBarStyle := ssAutoBoth; + FUpdateCount := 0; + FOptions := []; + + FFont := fpgGetFont('#Grid'); + FHeaderFont := fpgGetFont('#GridHeader'); + + FTemp := 50; // Just to prove that ColumnWidth does adjust. + FDefaultColWidth := 64; + FDefaultRowHeight := FFont.Height + 2; + FHeaderHeight := FHeaderFont.Height + 2; + FBackgroundColor := clBoxColor; + FColResizing := False; + + MinHeight := HeaderHeight + DefaultRowHeight + FMargin; + MinWidth := DefaultColWidth + FMargin; + + FVScrollBar := TfpgScrollBar.Create(self); + FVScrollBar.Orientation := orVertical; + FVScrollBar.Visible := False; + FVScrollBar.OnScroll := @VScrollBarMove; + + FHScrollBar := TfpgScrollBar.Create(self); + FHScrollBar.Orientation := orHorizontal; + FHScrollBar.Visible := False; + FHScrollBar.OnScroll := @HScrollBarMove; + FHScrollBar.ScrollStep := 5; +end; + +destructor TfpgBaseGrid.Destroy; +begin + FOnRowChange := nil; + FOnFocusChange := nil; + FFont.Free; + FHeaderFont.Free; + inherited Destroy; +end; + +procedure TfpgBaseGrid.AfterConstruction; +begin + inherited AfterConstruction; + Updated; +end; + +procedure TfpgBaseGrid.Update; +begin + UpdateScrollBars; + FollowFocus; + RePaint; +end; + +procedure TfpgBaseGrid.BeginUpdate; +begin + Inc(FUpdateCount); + Updating; +end; + +procedure TfpgBaseGrid.EndUpdate; +begin + if FUpdateCount > 0 then + begin + Dec(FUpdateCount); + if FUpdateCount = 0 then + begin + Updated; + RePaint; + end; + end; +end; + +procedure TfpgBaseGrid.MouseToCell(X, Y: Integer; var ACol, ARow: Integer); +var + hh: integer; + cw: integer; + n: Integer; +begin + if ShowHeader then + hh := FHeaderHeight+1 + else + hh := 0; + + ARow := FFirstRow + ((y - FMargin - hh) div FDefaultRowHeight); + if ARow > RowCount-1 then + ARow := RowCount-1; + + cw := 0; + for n := FFirstCol to ColumnCount-1 do + begin + inc(cw, ColumnWidth[n]); + if FMargin+cw >= x then + begin + ACol := n; + Break; + end; + end; +end; + + +end. + diff --git a/src/gui/fpg_button.pas b/src/gui/fpg_button.pas new file mode 100644 index 00000000..fdb2f634 --- /dev/null +++ b/src/gui/fpg_button.pas @@ -0,0 +1,765 @@ +{ + fpGUI - Free Pascal GUI Toolkit + + Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this + distribution, for details of the copyright. + + See the file COPYING.modifiedLGPL, included in this distribution, + for details about redistributing fpGUI. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + Description: + Defines a push button control. +} + +unit fpg_button; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, + SysUtils, + fpg_base, + fpg_main, + fpg_widget, + fpg_command_intf; + +type + + TImageLayout = (ilImageLeft, ilImageTop, ilImageRight, ilImageBottom); + + { TfpgBaseButton } + + TfpgBaseButton = class(TfpgWidget, ICommandHolder) + private + FCommand: ICommand; + FImageLayout: TImageLayout; + FFlat: Boolean; + FImageName: string; + FClicked: Boolean; + FShowImage: Boolean; + FClickOnPush: Boolean; + FGroupIndex: integer; + FAllowAllUp: boolean; + FModalResult: TfpgModalResult; + function GetFontDesc: string; + procedure SetDefault(const AValue: boolean); + procedure SetEmbedded(const AValue: Boolean); + procedure SetFlat(const AValue: Boolean); + procedure SetFontDesc(const AValue: string); + procedure SetImageLayout(const AValue: TImageLayout); + procedure SetImageName(const AValue: string); + procedure SetText(const AValue: string); + procedure SetDown(AValue: Boolean); + procedure SetImageMargin(const Value: integer); + procedure SetImageSpacing(const Value: integer); + function GetAllowDown: Boolean; + procedure SetAllowDown(const Value: Boolean); + procedure SetAllowAllUp(const Value: boolean); + procedure DoPush; + procedure DoRelease(x, y: integer); + protected + FImageMargin: integer; + FImageSpacing: integer; + FEmbedded: Boolean; + FDown: Boolean; + FImage: TfpgImage; + FText: string; + FFont: TfpgFont; + FDefault: boolean; + FState: integer; // 0 - normal // 1 - hover + procedure SetShowImage(AValue: Boolean); + procedure HandlePaint; override; + procedure HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override; + procedure HandleKeyRelease(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override; + procedure HandleLMouseDown(X, Y: integer; ShiftState: TShiftState); override; + procedure HandleLMouseUp(x, y: integer; shiftstate: TShiftState); override; + procedure HandleMouseExit; override; + procedure HandleMouseEnter; override; + { When buttons are in a toggle state (GroupIndex > 0), are all buttons in the group + allowed to be up. } + property AllowAllUp: boolean read FAllowAllUp write SetAllowAllUp default False; + { Buttons behave like toggle buttons. This is an alias for GroupIndex > 0 } + property AllowDown: Boolean read GetAllowDown write SetAllowDown; + property Default: boolean read FDefault write SetDefault default False; + property Down: Boolean read FDown write SetDown; + { The button will not show focus. It might also have a different down state (look). + This is similar to Focusable = False, but the appearance of the down state might differ. } + property Embedded: Boolean read FEmbedded write SetEmbedded default False; + property Flat: Boolean read FFlat write SetFlat default False; + property FontDesc: string read GetFontDesc write SetFontDesc; + { Used in combination with AllowDown and AllowAllUp. Allows buttons in the same + group to work together. } + property GroupIndex: integer read FGroupIndex write FGroupIndex default 0; + property ImageMargin: integer read FImageMargin write SetImageMargin default 3; + property ImageName: string read FImageName write SetImageName; + property ImageSpacing: integer read FImageSpacing write SetImageSpacing default -1; + property ImageLayout: TImageLayout read FImageLayout write SetImageLayout default ilImageLeft; + property ModalResult: TfpgModalResult read FModalResult write FModalResult default mrNone; + property ShowImage: Boolean read FShowImage write SetShowImage default True; + property Text: string read FText write SetText; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure Click; + function GetCommand: ICommand; // ICommandHolder interface + procedure SetCommand(ACommand: ICommand); // ICommandHolder interface + property Font: TfpgFont read FFont; + end; + + + { A standard push button component. + + If you want toolbar style buttons you need to set the following properties: + AllowAllUp = True; AllowDown = True; + and each button's GroupIndex must be greater than 0, but not the same as any + other button. + + If you want toggle buttons - only one button my be down at a time: + Set AllowAllUp = False and AllowDown = True + AllowDown = True will automatically set the GroupIndex = 1. If you want more + than one set of toggle buttons in a Parent, you need to manually set the + GroupIndex property instead. All buttons with the same GroupIndex work + together. } + TfpgButton = class(TfpgBaseButton) + published + property AllowAllUp; + property AllowDown; + property BackgroundColor default clButtonFace; + property Default; + property Down; + property Embedded; + property Flat; + property FontDesc; + property GroupIndex; + property Hint; + property ImageLayout; + property ImageMargin; + property ImageName; + property ImageSpacing; + property ModalResult; + property ParentShowHint; + property ShowHint; + property ShowImage; + property Text; + property TextColor; + property TabOrder; + property OnMouseExit; + property OnMouseEnter; + property OnClick; + end; + + +function CreateButton(AOwner: TComponent; x, y, w: TfpgCoord; AText: string; + AOnClickEvent: TNotifyEvent; AImage: string = ''): TfpgButton; + + +implementation + +uses + fpg_form; {$Note Try and remove this fpg_form dependency.} + +function CreateButton(AOwner: TComponent; x, y, w: TfpgCoord; AText: string; + AOnClickEvent: TNotifyEvent; AImage: string): TfpgButton; +begin + Result := TfpgButton.Create(AOwner); + Result.Text := AText; + Result.SetPosition(x, y, w, Result.Height); // font was used to calculate height. + Result.OnClick := AOnClickEvent; + Result.ImageName := AImage; +end; + +{ TfpgBaseButton } + +procedure TfpgBaseButton.SetDown(AValue: Boolean); +begin + if AValue <> FDown then + begin + FDown := AValue; + if AllowDown then + RePaint; + end; +end; + +procedure TfpgBaseButton.SetShowImage(AValue: Boolean); +begin + if AValue <> FShowImage then + begin + FShowImage := AValue; + if (FImage <> nil) and ShowImage then + RePaint; + end; +end; + +procedure TfpgBaseButton.SetText(const AValue: string); +begin + if FText = AValue then + Exit; + FText := AValue; + RePaint; +end; + +procedure TfpgBaseButton.SetImageName(const AValue: string); +begin + FImageName := AValue; + FImage := fpgImages.GetImage(FImageName); + Repaint; +end; + +function TfpgBaseButton.GetFontDesc: string; +begin + Result := FFont.FontDesc; +end; + +procedure TfpgBaseButton.SetDefault(const AValue: boolean); +var + i: integer; + wg: TfpgWidget; +begin + if FDefault = AValue then + Exit; //==> + FDefault := AValue; + + // Clear other buttons Default state + if FDefault and (Parent <> nil) then + begin + for i := 0 to Parent.ComponentCount-1 do + begin + wg := TfpgWidget(Parent.Components[i]); + if (wg <> nil) and (wg <> self) and (wg is TfpgBaseButton) then + begin + TfpgBaseButton(wg).Default := False; + end; + end; { for } + end; { if } + + RePaint; +end; + +procedure TfpgBaseButton.SetEmbedded(const AValue: Boolean); +begin + if FEmbedded = AValue then + Exit; + FEmbedded := AValue; +end; + +procedure TfpgBaseButton.SetFlat(const AValue: Boolean); +begin + if FFlat = AValue then + Exit; //==> + FFlat := AValue; + if FFlat then + FDefault := False; // you can't have it all! +end; + +procedure TfpgBaseButton.SetFontDesc(const AValue: string); +begin + FFont.Free; + FFont := fpgGetFont(AValue); + RePaint; +end; + +constructor TfpgBaseButton.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FText := 'Button'; + FFont := fpgGetFont('#Label1'); + FHeight := FFont.Height + 8; + FWidth := 80; + FFocusable := True; + FTextColor := Parent.TextColor; + FBackgroundColor := clButtonFace; + OnClick := nil; + FDown := False; + FClicked := False; + FDown := False; + FClickOnPush := False; + FGroupIndex := 0; + FImage := nil; + FImageName := ''; + FShowImage := True; + FImageLayout := ilImageLeft; + FImageMargin := 3; // image is 3 pixels from edge of button. -1 will centre image. + FImageSpacing := -1; // text is centered in remaining space + FModalResult := mrNone; + FEmbedded := False; + FDefault := False; + FAllowAllUp := False; + FState := 0; +end; + +destructor TfpgBaseButton.Destroy; +begin + FImage := nil; + FText := ''; + FFont.Free; + inherited Destroy; +end; + +procedure TfpgBaseButton.HandlePaint; + + procedure CalculatePositions (var ImageX, ImageY, TextX, TextY : integer); + var {clientHeight, clientWidth,} textWidth, textHeight : integer; + w : integer; + begin + if text = '' then + begin + textWidth := 0; + textHeight := 0; + end + else + begin + textWidth := FFont.TextWidth (Text); + textHeight := FFont.Height; + // Only single line texts will be placed correctly. + // Normally FFont.TextHeight should be used (not yet implemented) + end; + if FImageLayout in [ilImageLeft, ilImageRight] then + begin + TextY := (Height - textHeight) div 2; + // center vertically + if FShowImage and assigned (FImage) then + begin + ImageY := (Height - FImage.Height) div 2; + // horizontal places if image and text + if FImageMargin = -1 then + begin // Free space between border and image is the same as between border and text + if FImageSpacing = -1 then // free space between image/text = border/text = border/image + begin + w := (Width - FImage.Width - textWidth) div 3; + if w < 3 then // minimal margin from border for rectangle/focusrect/... + w := 3; + if FImageLayout = ilImageLeft then + begin + ImageX := w; + TextX := Width - w - textWidth; + end + else // if FImageLayout = ilImageRight then + begin + ImageX := Width - w - FImage.width; + TextX := w; + end; + end + else // fixed space between image/text + begin + w := (Width - FImageSpacing - FImage.width - textWidth) div 2; + if w < 3 then // minimal margin from border for rectangle/focusrect/... + w := 3; + if FImageLayout = ilImageLeft then + begin + ImageX := w; + TextX := w + FImage.width + FImageSpacing; + end + else // if FImageLayout = ilImageRight then + begin + ImageX := width - w - FImage.Width; + TextX := w; + end; + end; + end + else // Fixed image + begin + if FImageLayout = ilImageLeft then + begin + ImageX := FImageMargin + 3; + if FImageSpacing = -1 then + begin + w := (Width - FImage.Width - ImageX - textWidth) div 2; + if w < 0 then + w := 0; + end + else + w := FImageSpacing; + TextX := ImageX + FImage.width + w; + end + else // if FImageLayout = ilImageRight then + begin + ImageX := Width - FImageMargin - 3 - FImage.width; + if FImageSpacing = -1 then + begin + w := (Width - FImageMargin - FImage.width - textWidth) div 2; + if w < 3 then + w := 3; + TextX := w; + end + else + begin + textX := ImageX - textWidth - FImageSpacing; + if textX < 3 then + textX := 3; + end; + end; + end; + end + else + begin // no image, + ImageY := 0; + ImageX := 0; + TextX := (Width - textWidth) div 2; + end; + end + else // if ImageLayout in [ilImageTop, ilImageBottom] then + begin + TextX := (Width - textWidth) div 2; + // center horizontaly + if FShowImage and assigned (FImage) then + begin + ImageX := (Width - FImage.Width) div 2; + // vertical places if image and text + if FImageMargin = -1 then + begin // Free space between border and image is the same as between border and text + if FImageSpacing = -1 then // free space between image/text = border/text = border/image + begin + w := (Height - FImage.Height - textHeight) div 3; + if w < 3 then // minimal margin from border for rectangle/focusrect/... + w := 3; + if FImageLayout = ilImageTop then + begin + ImageY := w; + TextY := Height - w - textHeight; + end + else // if FImageLayout = ilImageBottom then + begin + ImageY := Height - w - FImage.Height; + TextY := w; + end; + end + else // fixed space between image/text + begin + w := (Height - FImageSpacing - FImage.Height - textHeight) div 2; + if w < 3 then // minimal margin from border for rectangle/focusrect/... + w := 3; + if FImageLayout = ilImageTop then + begin + ImageY := w; + TextY := w + FImage.Height + FImageSpacing; + end + else // if FImageLayout = ilImageRight then + begin + ImageY := Height - w - FImage.Height; + TextY := w; + end; + end; + end + else // Fixed image + begin + if FImageLayout = ilImageTop then + begin + ImageY := FImageMargin + 3; + if FImageSpacing = -1 then + begin + w := (Height - FImage.Height - ImageY - textHeight) div 2; + if w < 0 then + w := 0; + end + else + w := FImageSpacing; + TextY := ImageY + FImage.Height + w; + end + else // if FImageLayout = ilImageRight then + begin + ImageY := Height - FImageMargin - 3 - FImage.Height; + if FImageSpacing = -1 then + begin + w := (Height - FImageMargin - FImage.Height - textHeight) div 2; + if w < 3 then + w := 3; + TextY := w; + end + else + begin + textY := ImageY - textHeight - FImageSpacing; + if textY < 3 then + textY := 3; + end; + end; + end; + end + else + begin // no image, + ImageY := 0; + ImageX := 0; + TextY := (Height - textHeight) div 2; + end; + end; + end; + + +var + AText: string; + tx, ty, ix, iy: integer; + r: TfpgRect; + pofs: integer; + lBtnFlags: TFButtonFlags; + clr: TfpgColor; + +begin +// inherited HandlePaint; + Canvas.ClearClipRect; + + r.SetRect(0, 0, Width, Height); + + lBtnFlags := []; + if FDown then + Include(lBtnFlags, btfIsPressed); + + if FFocused and (not FEmbedded) then + Include(lBtnFlags, btfHasFocus); + + if FEmbedded then + Include(lBtnFlags, btfIsEmbedded); + + // In the UI Designer we want the button more visible + if not (csDesigning in ComponentState) then + begin + if FFlat and (FState = 1) then // mouse over + Include(lBtnFlags, btfHover) + else if FFlat then + Include(lBtnFlags, btfFlat); + end; + + if not FFlat and FDefault then + Include(lBtnFlags, btfIsDefault); + + if FBackgroundColor <> clButtonFace then + begin + clr := fpgColorToRGB(clButtonFace); + fpgSetNamedColor(clButtonface, FBackgroundColor); + Canvas.DrawButtonFace(r, lBtnFlags); + fpgSetNamedColor(clButtonface, clr); + end + else + Canvas.DrawButtonFace(r, lBtnFlags); + + if FFocused and (not FEmbedded) then + begin + InflateRect(r, -3, -3); + Canvas.DrawFocusRect(r); + end; + + Canvas.SetTextColor(FTextColor); + Canvas.SetColor(clText1); + + Canvas.SetClipRect(r); + Canvas.SetFont(Font); + AText := FText; + + if FDown then + pofs := 1 + else + pofs := 0; + + CalculatePositions (ix, iy, tx, ty); + + if FShowImage and assigned (FImage) then + Canvas.DrawImage(ix + pofs, iy + pofs, FImage); + + fpgStyle.DrawString(Canvas, tx+pofs, ty+pofs, Text, Enabled); +end; + +procedure TfpgBaseButton.DoPush; +var + n: integer; + c: TComponent; +begin + FClickOnPush := (not FDown) and AllowDown; + + // search the other buttons in the group + for n := 0 to Parent.ComponentCount - 1 do + begin + c := Parent.Components[n]; + if (c <> self) and (c is TfpgBaseButton) then + with TfpgBaseButton(c) do + if GroupIndex = self.GroupIndex then + Down := False; + end; + + FDown := True; + FClicked := True; + + RePaint; + if FClickOnPush then + Click; +end; + +procedure TfpgBaseButton.DoRelease(x, y: integer); +var + r: TfpgRect; +begin + r.SetRect(0, 0, Width, Height); + if AllowDown then + begin + if FDown and (not FClickOnPush) and FAllowAllUp then + begin + FDown := False; + RePaint; + fpgApplication.ProcessMessages; + if PtInRect(r, Point(x, y)) then + Click; + end; + end + else + begin + if FDown and FClicked then + begin + FDown := False; + RePaint; + fpgApplication.ProcessMessages; + if PtInRect(r, Point(x, y)) then + Click; + end; + end; + + FClickOnPush := False; + FClicked := False; +end; + +procedure TfpgBaseButton.HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); +begin + if (keycode = keyReturn) or (keycode = keySpace) or (keycode = keyPEnter) then + begin + DoPush; + Consumed := True; + end + else + inherited; +end; + +procedure TfpgBaseButton.HandleKeyRelease(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); +begin + if (keycode = keyReturn) or (keycode = keySpace) or (keycode = keyPEnter) then + begin + DoRelease(1, 1); // fake co-ordinates to it executes the Click + Consumed := True; + end + else + inherited; +end; + +procedure TfpgBaseButton.HandleLMouseDown(X, Y: integer; ShiftState: TShiftState); +begin + inherited; + if (csDesigning in ComponentState) then + Exit; + CaptureMouse; + DoPush; +end; + +procedure TfpgBaseButton.HandleLMouseUp(x, y: integer; shiftstate: TShiftState); +begin +// inherited; + if (csDesigning in ComponentState) then + Exit; + ReleaseMouse; + DoRelease(x, y); +end; + +procedure TfpgBaseButton.HandleMouseExit; +begin + inherited HandleMouseExit; + if (csDesigning in ComponentState) then + Exit; + if Enabled then + FState := 0; + if FDown and (not AllowDown) then + begin + FDown := False; + Repaint; + end + else if FFlat then + begin + if Enabled then + Repaint; + end; +end; + +procedure TfpgBaseButton.HandleMouseEnter; +begin + inherited HandleMouseEnter; + if (csDesigning in ComponentState) then + Exit; + if Enabled then + FState := 1; + if FClicked and (not AllowDown) then + begin + FDown := True; + Repaint; + end + else if FFlat then + begin + if Enabled then + Repaint; + end; +end; + +procedure TfpgBaseButton.Click; +var + pform: TfpgForm; +begin + if (not AllowDown) then + begin + FDown := False; + FClicked := False; + end; + + pform := WidgetParentForm(self); + if pform <> nil then + pform.ModalResult := ModalResult; + + if Assigned(OnClick) then + OnClick(self); +end; + +function TfpgBaseButton.GetCommand: ICommand; +begin + Result := FCommand; +end; + +procedure TfpgBaseButton.SetCommand(ACommand: ICommand); +begin + FCommand := ACommand; +end; + +procedure TfpgBaseButton.SetImageMargin(const Value: integer); +begin + FImageMargin := Value; + Repaint; +end; + +procedure TfpgBaseButton.SetImageSpacing(const Value: integer); +begin + FImageSpacing := Value; + Repaint; +end; + +procedure TfpgBaseButton.SetImageLayout(const AValue: TImageLayout); +begin + if FImageLayout <> AValue then + begin + FImageLayout := AValue; + Repaint; //Isn't Invalidate better ? + end; +end; + +function TfpgBaseButton.GetAllowDown: Boolean; +begin + Result := GroupIndex > 0; +end; + +procedure TfpgBaseButton.SetAllowDown(const Value: Boolean); +begin + GroupIndex := 1; +end; + +procedure TfpgBaseButton.SetAllowAllUp(const Value: boolean); +begin + FAllowAllUp := Value; +end; + +end. + diff --git a/src/gui/fpg_checkbox.pas b/src/gui/fpg_checkbox.pas new file mode 100644 index 00000000..c185272c --- /dev/null +++ b/src/gui/fpg_checkbox.pas @@ -0,0 +1,216 @@ +{ + fpGUI - Free Pascal GUI Toolkit + + Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this + distribution, for details of the copyright. + + See the file COPYING.modifiedLGPL, included in this distribution, + for details about redistributing fpGUI. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + Description: + Defines a CheckBox control. Also known as a Check Button control. +} + +unit fpg_checkbox; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, + SysUtils, + fpg_base, + fpg_main, + fpg_widget; + +type + + TfpgCheckBox = class(TfpgWidget) + private + FChecked: boolean; + FOnChange: TNotifyEvent; + FText: string; + FFont: TfpgFont; + FBoxSize: integer; + FIsPressed: boolean; + function GetFontDesc: string; + procedure SetChecked(const AValue: boolean); + procedure SetFontDesc(const AValue: string); + procedure SetText(const AValue: string); + protected + procedure HandlePaint; override; + procedure HandleLMouseDown(x, y: integer; shiftstate: TShiftState); override; + procedure HandleLMouseUp(x, y: integer; shiftstate: TShiftState); override; + procedure HandleKeyRelease(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + property Font: TfpgFont read FFont; + published + property BackgroundColor; + property Checked: boolean read FChecked write SetChecked default False; + property FontDesc: string read GetFontDesc write SetFontDesc; + property ParentShowHint; + property ShowHint; + property TabOrder; + property Text: string read FText write SetText; + property TextColor; + property OnChange: TNotifyEvent read FOnChange write FOnChange; + end; + + +function CreateCheckBox(AOwner: TComponent; x, y: TfpgCoord; AText: string): TfpgCheckBox; + +implementation + +function CreateCheckBox(AOwner: TComponent; x, y: TfpgCoord; AText: string): TfpgCheckBox; +begin + Result := TfpgCheckBox.Create(AOwner); + Result.Top := y; + Result.Left := x; + Result.Text := AText; + Result.Width := Result.Font.TextWidth(Result.Text) + 24; +end; + +{ TfpgCheckBox } + +procedure TfpgCheckBox.SetChecked(const AValue: boolean); +begin + if FChecked = AValue then + Exit; //==> + FChecked := AValue; + RePaint; +end; + +function TfpgCheckBox.GetFontDesc: string; +begin + Result := FFont.FontDesc; +end; + +procedure TfpgCheckBox.SetFontDesc(const AValue: string); +begin + FFont.Free; + FFont := fpgGetFont(AValue); + RePaint; +end; + +procedure TfpgCheckBox.SetText(const AValue: string); +begin + if FText = AValue then + Exit; //==> + FText := AValue; + RePaint; +end; + +procedure TfpgCheckBox.HandlePaint; +var + r: TfpgRect; + ty: integer; + tx: integer; + ix: integer; + img: TfpgImage; +begin + inherited HandlePaint; + + Canvas.SetColor(FBackgroundColor); + Canvas.FillRectangle(0, 0, Width, Height); + Canvas.SetFont(Font); + + if FFocused then + begin + Canvas.SetColor(clText1); + Canvas.SetLineStyle(1, lsDot); + Canvas.DrawRectangle(1, 1, Width-2, Height-2); + end; + Canvas.SetLineStyle(1, lsSolid); + + r.SetRect(2, (Height div 2) - (FBoxSize div 2), FBoxSize, FBoxSize); + if r.top < 0 then + r.top := 0; + + // calculate which image to paint. + if Enabled then + begin + ix := Ord(FChecked); + if FIsPressed then + Inc(ix, 2); + end + else + ix := (2 + (Ord(FChecked) * 2)) - Ord(FChecked); + + // paint the check (in this case a X) + tx := r.right + 8; + inc(r.left, 2); + inc(r.top, 1); + img := fpgImages.GetImage('sys.checkboxes'); // Do NOT localize + Canvas.DrawImagePart(r.Left, r.Top, img, ix*13, 0, 13, 13); + + ty := (Height div 2) - (Font.Height div 2); + if ty < 0 then + ty := 0; + Canvas.SetTextColor(FTextColor); + fpgStyle.DrawString(Canvas, tx, ty, FText, Enabled); +end; + +procedure TfpgCheckBox.HandleLMouseDown(x, y: integer; shiftstate: TShiftState); +begin + inherited HandleLMouseDown(x, y, shiftstate); + FIsPressed := True; + Repaint; +end; + +procedure TfpgCheckBox.HandleLMouseUp(x, y: integer; shiftstate: TShiftState); +begin + inherited HandleLMouseUp(x, y, shiftstate); + FIsPressed := False; + Checked := not FChecked; + if Assigned(FOnChange) then + FOnChange(self); +end; + +procedure TfpgCheckBox.HandleKeyRelease(var keycode: word; + var shiftstate: TShiftState; var consumed: boolean); +begin + if (keycode = keySpace) or (keycode = keyReturn) or (keycode = keyPEnter) then + begin + consumed := True; + Checked := not FChecked; + if Assigned(FOnChange) then + FOnChange(self); + end; + + if consumed then + Exit; //==> + + inherited HandleKeyRelease(keycode, shiftstate, consumed); +end; + +constructor TfpgCheckBox.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FText := 'CheckBox'; + FFont := fpgGetFont('#Label1'); + FHeight := FFont.Height + 4; + FWidth := 120; + FTextColor := Parent.TextColor; + FBackgroundColor := Parent.BackgroundColor; + FFocusable := True; + FBoxSize := 14; + FChecked := False; + FIsPressed := False; + FOnChange := nil; +end; + +destructor TfpgCheckBox.Destroy; +begin + FFont.Free; + inherited Destroy; +end; + +end. + diff --git a/src/gui/fpg_combobox.pas b/src/gui/fpg_combobox.pas new file mode 100644 index 00000000..799708c1 --- /dev/null +++ b/src/gui/fpg_combobox.pas @@ -0,0 +1,676 @@ +{ + fpGUI - Free Pascal GUI Toolkit + + Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this + distribution, for details of the copyright. + + See the file COPYING.modifiedLGPL, included in this distribution, + for details about redistributing fpGUI. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + Description: + Defines a ComboBox control. Also known as a Choice List control. +} + +unit fpg_combobox; + +{$mode objfpc}{$H+} + +{.$Define DEBUG} + +{ TODO: When combobox Items changes, the combobox needs to refresh. We need a + custom StringItems class to notify us of changes. See TfpgListBox for + an example. } + +{ TODO: Implement .BeginUpdate and .EndUpdate methods so we know when to refresh + the items list. } + +{ +This is an example of what we can aim for: +You need a mono font to see the correct layout. + + + TfpgBaseComboBox + _________|______________ + | | + TfpgBaseStaticCombo TfpgBaseEditCombo + ______|_________ | + | | TfpgEditCombo + | | + TfpgComboBox TfpgBaseColorCombo + | + TfpgColorComboBox +} + +interface + +uses + Classes, + SysUtils, + fpg_base, + fpg_main, + fpg_widget, + fpg_popupwindow; + +type + // widget options + TfpgComboOption = (wo_FocusItemTriggersOnChange, wo_AllowUserBlank); + TfpgComboOptions = set of TfpgComboOption; + + + TfpgBaseComboBox = class(TfpgWidget) + private + FDropDownCount: integer; + FFont: TfpgFont; + FOnChange: TNotifyEvent; + FOnCloseUp: TNotifyEvent; + FOnDropDown: TNotifyEvent; + FOptions: TfpgComboOptions; + function GetFontDesc: string; + procedure SetDropDownCount(const AValue: integer); + procedure SetFocusItem(const AValue: integer); + procedure SetFontDesc(const AValue: string); + protected + FInternalBtnRect: TfpgRect; + FFocusItem: integer; + FItems: TStringList; + FBtnPressed: Boolean; + procedure CalculateInternalButtonRect; virtual; + procedure InternalOnClose(Sender: TObject); + procedure InternalItemsChanged(Sender: TObject); virtual; + procedure HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override; + procedure DoOnChange; virtual; + procedure DoOnDropDown; virtual; + procedure DoDropDown; virtual; abstract; + procedure DoOnCloseUp; virtual; + procedure PaintInternalButton; virtual; + function GetDropDownPos(AParent, AComboBox, ADropDown: TfpgWidget): TfpgRect; virtual; + property DropDownCount: integer read FDropDownCount write SetDropDownCount default 8; + property FocusItem: integer read FFocusItem write SetFocusItem; + property FontDesc: string read GetFontDesc write SetFontDesc; + property Items: TStringList read FItems; {$Note Make this read/write } + property Options: TfpgComboOptions read FOptions write FOptions; + property OnChange: TNotifyEvent read FOnChange write FOnChange; + property OnCloseUp: TNotifyEvent read FOnCloseUp write FOnCloseUp; + property OnDropDown: TNotifyEvent read FOnDropDown write FOnDropDown; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + property Font: TfpgFont read FFont; + end; + + + { TfpgBaseStaticCombo } + + TfpgBaseStaticCombo = class(TfpgBaseComboBox) + private + procedure InternalBtnClick(Sender: TObject); + protected + FMargin: integer; + FDropDown: TfpgPopupWindow; + procedure DoDropDown; override; + function GetText: string; virtual; + function HasText: boolean; virtual; + procedure SetText(const AValue: string); virtual; + procedure HandleResize(AWidth, AHeight: TfpgCoord); override; + procedure HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override; + procedure HandleLMouseDown(x, y: integer; shiftstate: TShiftState); override; + procedure HandleLMouseUp(x, y: integer; shiftstate: TShiftState); override; + procedure HandleMouseScroll(x, y: integer; shiftstate: TShiftState; delta: smallint); override; + procedure HandlePaint; override; + property Text: string read GetText write SetText; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure Update; + end; + + + TfpgComboBox = class(TfpgBaseStaticCombo) + published + property BackgroundColor default clBoxColor; + property DropDownCount; + property FocusItem; + property FontDesc; + property Height; + property Items; + property Options; + property ParentShowHint; + property ShowHint; + property TabOrder; + property Text; + property TextColor; + property Width; + property OnChange; + property OnCloseUp; + property OnDropDown; + property OnEnter; + property OnExit; + end; + + +function CreateComboBox(AOwner: TComponent; x, y, w: TfpgCoord; AList: TStringList; + h: TfpgCoord = 0): TfpgComboBox; + + +implementation + +uses + fpg_listbox, + math; + +var + OriginalFocusRoot: TfpgWidget; + +type + { This is the class representing the dropdown window of the combo box. } + TComboboxDropdownWindow = class(TfpgPopupWindow) + private + FCallerWidget: TfpgBaseStaticCombo; + FListBox: TfpgListBox; + procedure SetFirstItem; + protected + procedure ListBoxSelect(Sender: TObject); + procedure HandleShow; override; + procedure HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override; + public + constructor Create(AOwner: TComponent; ACallerWidget: TfpgBaseStaticCombo); reintroduce; + property ListBox: TfpgListBox read FListBox; + end; + + +{ TfpgBaseComboBox } + +procedure TfpgBaseComboBox.SetDropDownCount(const AValue: integer); +begin + if FDropDownCount = AValue then + Exit; + FDropDownCount := AValue; +end; + +function TfpgBaseComboBox.GetFontDesc: string; +begin + Result := FFont.FontDesc; +end; + +{ Focusitem is 0 based like the Delphi ItemIndex property. + So at startup, FocusItem = -1 which means nothing is selected. If + FocusItem = 0 it means the first item is selected etc. } +procedure TfpgBaseComboBox.SetFocusItem(const AValue: integer); +begin + if FFocusItem = AValue then + Exit; //==> + FFocusItem := AValue; + + // do some limit check corrections + if FFocusItem < -1 then + FFocusItem := -1 // nothing is selected + else if FFocusItem > FItems.Count-1 then + FFocusItem := FItems.Count-1; + + RePaint; + if wo_FocusItemTriggersOnChange in FOptions then + DoOnChange; +end; + +procedure TfpgBaseComboBox.SetFontDesc(const AValue: string); +begin + FFont.Free; + FFont := fpgGetFont(AValue); + if Height < FFont.Height + 6 then + Height := FFont.Height + 6; + RePaint; +end; + +procedure TfpgBaseComboBox.CalculateInternalButtonRect; +begin + FInternalBtnRect.SetRect(Width - Min(Height, 20), 2, Min(Height, 20)-2, Height-4); +end; + +procedure TfpgBaseComboBox.InternalOnClose(Sender: TObject); +begin + DoOnCloseUp; +end; + +procedure TfpgBaseComboBox.InternalItemsChanged(Sender: TObject); +begin + if FItems.Count = 0 then + FocusItem := -1; + Repaint; +end; + +procedure TfpgBaseComboBox.HandleKeyPress(var keycode: word; + var shiftstate: TShiftState; var consumed: boolean); +var + old: integer; +begin + inherited HandleKeyPress(keycode, shiftstate, consumed); + if not consumed then + begin + old := FocusItem; + case keycode of + keyDown: + begin + if (shiftstate = [ssAlt]) then + DoDropDown + else + begin + FocusItem := FocusItem + 1; + if old <> FocusItem then + DoOnChange; + consumed := True; + end; + end; + + keyUp: + begin + if (FocusItem = 0) and (wo_AllowUserBlank in FOptions) then + FocusItem := FocusItem - 1 + else if FocusItem > 0 then + FocusItem := FocusItem - 1; + if old <> FocusItem then + DoOnChange; + consumed := True; + end; + end; { case } + end; { if } +end; + +procedure TfpgBaseComboBox.DoOnChange; +begin + if Assigned(OnChange) then + FOnChange(self); +end; + +procedure TfpgBaseComboBox.DoOnDropDown; +begin + if Assigned(OnDropDown) then + FOnDropDown(self); +end; + +procedure TfpgBaseComboBox.DoOnCloseUp; +begin + if Assigned(OnCloseUp) then + OnCloseUp(self); +end; + +procedure TfpgBaseComboBox.PaintInternalButton; +var + ar: TfpgRect; + btnflags: TFButtonFlags; +begin + Canvas.BeginDraw; + btnflags := []; + ar := FInternalBtnRect; + InflateRect(ar, -2, -2); + if FBtnPressed then + begin + Include(btnflags, btfIsPressed); + OffsetRect(ar, 1, 1); + end; + // paint button face + fpgStyle.DrawButtonFace(Canvas, + FInternalBtnRect.Left, + FInternalBtnRect.Top, + FInternalBtnRect.Width, + FInternalBtnRect.Height, btnflags); + if Enabled then + Canvas.SetColor(clText1) + else + Canvas.SetColor(clShadow1); + + // paint arrow + fpgStyle.DrawDirectionArrow(Canvas, ar.Left, ar.Top, ar.Width, ar.Height, adDown); + Canvas.EndDraw(FInternalBtnRect); +end; + +function TfpgBaseComboBox.GetDropDownPos(AParent, AComboBox, ADropDown: TfpgWidget): TfpgRect; +var + pt: TPoint; +begin + // translate ComboBox coordinates + pt := WindowToScreen(AParent, Point(AComboBox.Left, AComboBox.Bottom)); + + // dropdown will not fit below combobox so we place it above + if (pt.y + ADropDown.Height) > fpgApplication.ScreenHeight then + Result.Top := AComboBox.Top - ADropDown.Height + else + Result.Top := AComboBox.Bottom; + + // dropdown height doesn't fit in screen height so shrink it + if (ADropDown.Height > fpgApplication.ScreenHeight) then + begin + // 50 is just some spacing for taskbars (top or bottom aligned) + Result.Top := AComboBox.Top - pt.y + 50; + Result.Height := fpgApplication.ScreenHeight - 50; + end + else + Result.Height := ADropDown.Height; + + Result.Left := AComboBox.Left; + Result.Width := ADropDown.Width; +end; + +constructor TfpgBaseComboBox.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FDropDownCount := 8; + FFocusItem := -1; // nothing is selected + FItems := TStringList.Create; + FItems.OnChange := @InternalItemsChanged; + FFont := fpgGetFont('#List'); + FOptions := []; + FBtnPressed := False; + FOnChange := nil; +end; + +destructor TfpgBaseComboBox.Destroy; +begin + FFont.Free; + FItems.Free; + inherited Destroy; +end; + +{ TComboboxDropdownWindow } + +procedure TComboboxDropdownWindow.SetFirstItem; +var + i: integer; +begin + // If FocusItem is less than DropDownCount FirsItem = 0 + if ListBox.FocusItem+1 <= FCallerWidget.DropDownCount then + ListBox.SetFirstItem(0) + // If FocusItem is in the last DropDownCount of items + else if (ListBox.ItemCount - (ListBox.FocusItem+1)) < FCallerWidget.DropDownCount then + ListBox.SetFirstItem(ListBox.ItemCount - FCallerWidget.DropDownCount) + else + // Try and centre FocusItem in the drow down window + ListBox.SetFirstItem(ListBox.FocusItem - (FCallerWidget.DropDownCount div 2)); +end; + +procedure TComboboxDropdownWindow.ListBoxSelect(Sender: TObject); +begin + FCallerWidget.FocusItem := ListBox.FocusItem; + if not (wo_FocusItemTriggersOnChange in FCallerWidget.FOptions) then + FCallerWidget.DoOnChange; + Close; +end; + +procedure TComboboxDropdownWindow.HandleShow; +begin + ListBox.SetPosition(0, 0, Width, Height); + inherited HandleShow; + SetFirstItem; + ListBox.SetFocus; +end; + +procedure TComboboxDropdownWindow.HandleKeyPress(var keycode: word; + var shiftstate: TShiftState; var consumed: boolean); +begin + inherited HandleKeyPress(keycode, shiftstate, consumed); + if KeyCode = keyEscape then + begin + Close; + end +end; + +constructor TComboboxDropdownWindow.Create(AOwner: TComponent; ACallerWidget: TfpgBaseStaticCombo); +begin + inherited Create(nil); + Name := '_ComboboxDropdownWindow'; + if not Assigned(ACallerWidget) then + raise Exception.Create('ACallerWidget may not be '); + FCallerWidget := ACallerWidget; + + FListBox := CreateListBox(self, 0, 0, 80, 100); + FListBox.PopupFrame := True; + FListBox.Items.Assign(FCallerWidget.Items); + FListBox.FocusItem := FCallerWidget.FocusItem; + FListBox.OnSelect := @ListBoxSelect; +end; + + + +function CreateComboBox(AOwner: TComponent; x, y, w: TfpgCoord; AList: TStringList; + h: TfpgCoord = 0): TfpgComboBox; +begin + Result := TfpgComboBox.Create(AOwner); + Result.Left := x; + Result.Top := y; + Result.Width := w; + Result.Focusable := True; + + if h < TfpgComboBox(Result).FFont.Height + 6 then + Result.Height:= TfpgComboBox(Result).FFont.Height + 6 + else + Result.Height:= h; + + if Assigned(AList) then + Result.Items.Assign(AList); +end; + +{ TfpgBaseStaticCombo } + +function TfpgBaseStaticCombo.GetText: string; +begin + if (FocusItem >= 0) and (FocusItem < FItems.Count) then + Result := Items.Strings[FocusItem] + else + Result := ''; +end; + +function TfpgBaseStaticCombo.HasText: boolean; +begin + Result := FocusItem >= 0; +end; + +procedure TfpgBaseStaticCombo.DoDropDown; +var + ddw: TComboboxDropdownWindow; + rowcount: integer; + r: TfpgRect; +begin + {$IFDEF DEBUG} + write('DoDropDown'); + {$ENDIF} + if (not Assigned(FDropDown)) or (not FDropDown.HasHandle) then + begin + {$IFDEF DEBUG} + writeln('.... creating'); + {$ENDIF} + FreeAndNil(FDropDown); + OriginalFocusRoot := FocusRootWidget; + + FDropDown := TComboboxDropdownWindow.Create(nil, self); + ddw := TComboboxDropdownWindow(FDropDown); + + // adjust the height of the dropdown + rowcount := FItems.Count; + if rowcount > FDropDownCount then + rowcount := FDropDownCount; + if rowcount < 1 then + rowcount := 1; // Even if empty at least show one line dropdown + + ddw.Width := Width; + ddw.Height := (ddw.ListBox.RowHeight * rowcount) + 4; + ddw.DontCloseWidget := self; // now we can control when the popup window closes + r := GetDropDownPos(Parent, self, ddw); // find suitable position + ddw.Height := r.Height; // in case GetDropDownPos resized us + + if (FItems.Count > 0) then + DoOnDropDown; + ddw.OnClose := @InternalOnClose; + + ddw.ShowAt(Parent, r.Left, r.Top); + end + else + begin + {$IFDEF DEBUG} + writeln('.... destroying'); + {$ENDIF} + FBtnPressed := False; + ddw := TComboboxDropdownWindow(FDropDown); + ddw.Close; + FreeAndNil(FDropDown); + end; +end; + +procedure TfpgBaseStaticCombo.InternalBtnClick(Sender: TObject); +begin + DoDropDown; +end; + +procedure TfpgBaseStaticCombo.SetText(const AValue: string); +var + i: integer; +begin + if AValue = '' then + SetFocusItem(-1) // nothing selected + else + begin + for i := 0 to FItems.Count-1 do + begin + if SameText(Items.Strings[i], AValue) then + begin + SetFocusItem(i); + Exit; //==> + end; + end; + // if we get here, we didn't find a match + SetFocusItem(-1); + end; +end; + +procedure TfpgBaseStaticCombo.HandleResize( AWidth, AHeight: TfpgCoord); +begin + inherited HandleResize(AWidth, AHeight); + if FSizeIsDirty then + CalculateInternalButtonRect; +end; + +procedure TfpgBaseStaticCombo.HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); +begin + inherited HandleKeyPress(keycode, shiftstate, consumed); + if consumed then + RePaint +end; + +procedure TfpgBaseStaticCombo.HandleLMouseDown(x, y: integer; shiftstate: TShiftState); +begin + inherited HandleLMouseDown(x, y, shiftstate); + // button state is down only if user clicked in the button rectangle. + FBtnPressed := PtInRect(FInternalBtnRect, Point(x, y)); + PaintInternalButton; + DoDropDown; +end; + +procedure TfpgBaseStaticCombo.HandleLMouseUp(x, y: integer; shiftstate: TShiftState); +begin + inherited HandleLMouseUp(x, y, shiftstate); + FBtnPressed := False; + PaintInternalButton; +end; + +procedure TfpgBaseStaticCombo.HandleMouseScroll(x, y: integer; + shiftstate: TShiftState; delta: smallint); +var + NewIndex: Integer; +begin + if (FDropDown <> nil) and FDropDown.Visible then + Exit; //==> + if Items.Count < 1 then + Exit; //==> + + NewIndex := FocusItem + Delta; + + if NewIndex > Items.Count-1 then + NewIndex := Items.Count-1; + + if NewIndex < 0 then + NewIndex := 0; + + if NewIndex <> FocusItem then + begin + FocusItem := NewIndex; + RePaint; + end; +end; + +procedure TfpgBaseStaticCombo.HandlePaint; +var + r: TfpgRect; +begin +// inherited HandlePaint; + Canvas.ClearClipRect; + r.SetRect(0, 0, Width, Height); + Canvas.DrawControlFrame(r); + + // internal background rectangle (without frame) + InflateRect(r, -2, -2); + Canvas.SetClipRect(r); + + if Enabled then + Canvas.SetColor(FBackgroundColor) + else + Canvas.SetColor(clWindowBackground); + + Canvas.FillRectangle(r); + + // paint the fake dropdown button + PaintInternalButton; + + Dec(r.Width, FInternalBtnRect.Width); + Canvas.SetClipRect(r); + Canvas.SetFont(Font); + + if Focused then + begin + Canvas.SetColor(clSelection); + Canvas.SetTextColor(clSelectionText); + InflateRect(r, -1, -1); + end + else + begin + if Enabled then + Canvas.SetColor(FBackgroundColor) + else + Canvas.SetColor(clWindowBackground); + Canvas.SetTextColor(FTextColor); + end; + Canvas.FillRectangle(r); + + // Draw select item's text + if HasText then + fpgStyle.DrawString(Canvas, FMargin+1, FMargin, Text, Enabled); +end; + +constructor TfpgBaseStaticCombo.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FBackgroundColor := clBoxColor; + FTextColor := Parent.TextColor; + FWidth := 120; + FMargin := 3; + FHeight := Font.Height + (2*FMargin); + FFocusable := True; + + CalculateInternalButtonRect; +end; + +destructor TfpgBaseStaticCombo.Destroy; +begin + FDropDown.Free; + inherited Destroy; +end; + +procedure TfpgBaseStaticCombo.Update; +begin + FFocusItem := -1; + Repaint; +end; + +end. + diff --git a/src/gui/fpg_customgrid.pas b/src/gui/fpg_customgrid.pas new file mode 100644 index 00000000..7b042799 --- /dev/null +++ b/src/gui/fpg_customgrid.pas @@ -0,0 +1,362 @@ +{ + fpGUI - Free Pascal GUI Toolkit + + Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this + distribution, for details of the copyright. + + See the file COPYING.modifiedLGPL, included in this distribution, + for details about redistributing fpGUI. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + Description: + Defines a Custom Grid control and basic Column class. +} + +unit fpg_customgrid; + +{$mode objfpc}{$H+} + +{ + TODO: + * Column text alignment needs to be implemented. Currently always Centre. + * AlternateColor for rows need to be implemented. +} + +{.$Define DEBUG} + +interface + +uses + Classes, + SysUtils, + fpg_base, + fpg_main, + fpg_basegrid; + +type + + // data object for grid columns + TfpgGridColumn = class(TObject) + private + FAlignment: TAlignment; + FLayout: TLayout; + FHMargin: Integer; + FTitle: string; + FWidth: integer; + FBackgroundColor: TfpgColor; + FTextColor: TfpgColor; + public + constructor Create; virtual; + property Width: integer read FWidth write FWidth; + property Title: string read FTitle write FTitle; + property Alignment: TAlignment read FAlignment write FAlignment; + property Layout: TLayout read FLayout write FLayout; + property BackgroundColor: TfpgColor read FBackgroundColor write FBackgroundColor; + property HMargin: Integer read FHMargin write FHMargin; + property TextColor: TfpgColor read FTextColor write FTextColor; + end; + + + TfpgCustomGrid = class(TfpgBaseGrid) + protected + FRowCount: Integer; + FColumns: TList; + procedure HandleSetFocus; override; + procedure SetTextColor(const AValue: TfpgColor); override; + function GetColumns(AIndex: integer): TfpgGridColumn; virtual; + procedure DoDeleteColumn(ACol: integer); virtual; + procedure DoSetRowCount(AValue: integer); virtual; + procedure DoAfterAddColumn(ACol: integer); virtual; + function DoCreateColumnClass: TfpgGridColumn; virtual; + function GetColumnCount: Integer; override; + procedure SetColumnCount(const AValue: Integer); virtual; + function GetRowCount: Integer; override; + procedure SetRowCount(const AValue: Integer); virtual; + function GetColumnWidth(ACol: Integer): integer; override; + procedure SetColumnWidth(ACol: Integer; const AValue: integer); override; + function GetColumnBackgroundColor(ACol: Integer): TfpgColor; override; + procedure SetColumnBackgroundColor(ACol: Integer; const AValue: TfpgColor); override; + function GetColumnTextColor(ACol: Integer): TfpgColor; override; + procedure SetColumnTextColor(ACol: Integer; const AValue: TfpgColor); override; + function GetHeaderText(ACol: Integer): string; override; + property RowCount: Integer read GetRowCount write SetRowCount; + property ColumnCount: Integer read GetColumnCount write SetColumnCount; + property Columns[AIndex: integer]: TfpgGridColumn read GetColumns; +// property AlternateColor: TColor read FAlternateColor write SetAlternateColor stored IsAltColorStored; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + function AddColumn(ATitle: string; AWidth: integer): TfpgGridColumn; virtual; + procedure DeleteColumn(AIndex: integer); virtual; + procedure MoveColumn(oldindex, newindex: integer); virtual; + end; + + +implementation + +{ TfpgGridColumn } + +constructor TfpgGridColumn.Create; +begin + Width := 65; + Title := ''; + Alignment := taLeftJustify; + Layout := tlCenter; + HMargin := 2; +end; + +{ TfpgCustomGrid } + +function TfpgCustomGrid.GetRowCount: Integer; +begin + Result := FRowCount; +end; + +procedure TfpgCustomGrid.HandleSetFocus; +begin + inherited HandleSetFocus; + if (GetRowCount > 0) and (FocusRow = -1) then + begin + FocusRow := 0; + FocusCol := 0; + Repaint; + end; +end; + +procedure TfpgCustomGrid.SetTextColor(const AValue: TfpgColor); +var + i: integer; +begin + inherited SetTextColor(AValue); + for i := 0 to ColumnCount-1 do + begin + TfpgGridColumn(FColumns.Items[i]).TextColor := AValue; + end; + Repaint; +end; + +function TfpgCustomGrid.GetColumns(AIndex: integer): TfpgGridColumn; +begin + if (AIndex < 0) or (AIndex > FColumns.Count-1) then + Result := nil + else + Result := TfpgGridColumn(FColumns[AIndex]); +end; + +procedure TfpgCustomGrid.DoDeleteColumn(ACol: integer); +begin + TfpgGridColumn(FColumns.Items[ACol]).Free; + FColumns.Delete(ACol); +end; + +procedure TfpgCustomGrid.DoSetRowCount(AValue: integer); +begin + // do nothing yet +end; + +procedure TfpgCustomGrid.DoAfterAddColumn(ACol: integer); +begin + // do nothing yet + // update empty cells in descendants +end; + +function TfpgCustomGrid.DoCreateColumnClass: TfpgGridColumn; +begin + Result := TfpgGridColumn.Create; +end; + +function TfpgCustomGrid.GetColumnCount: Integer; +begin + Result := FColumns.Count; +end; + +procedure TfpgCustomGrid.SetColumnCount(const AValue: Integer); +var + n: Integer; +begin + n := FColumns.Count; + if (n = AValue) or (AValue < 0) then + Exit; //==> + + if n < AValue then + begin + // adding columns + while n < AValue do + begin + AddColumn('', DefaultColWidth); + inc(n); + end; + end + else + begin + // removing columns + while n > AValue do + begin + DoDeleteColumn(n-1); + dec(n); + end; + end; + + // graemeg 2008-07-18: I believe after all the repaint and event fixes + // this check is not required anymore. +// if csUpdating in ComponentState then +// Exit; + UpdateScrollBars; + RePaint; +end; + +procedure TfpgCustomGrid.SetRowCount(const AValue: Integer); +begin + if FRowCount = AValue then + Exit; //==> + FRowCount := AValue; + if FocusRow > FRowCount-1 then + FocusRow := FRowCount-1; + DoSetRowCount(AValue); // could be implemented by descendants + + // graemeg 2008-07-18: I believe after all the repaint and event fixes + // this check is not required anymore. +// if csUpdating in ComponentState then +// Exit; + UpdateScrollBars; + RePaint; +end; + +function TfpgCustomGrid.GetColumnWidth(ACol: Integer): integer; +begin + if (ACol >= 0) and (ACol < ColumnCount) then + Result := TfpgGridColumn(FColumns[ACol]).Width + else + result := DefaultColWidth; +end; + +procedure TfpgCustomGrid.SetColumnWidth(ACol: Integer; const AValue: integer); +var + lCol: TfpgGridColumn; +begin + lCol := TfpgGridColumn(FColumns[ACol]); + + if lCol.Width <> AValue then + begin + if AValue < 1 then + lCol.Width := 1 + else + lCol.Width := AValue; + UpdateScrollBars; + Repaint; + end; +end; + +function TfpgCustomGrid.GetColumnBackgroundColor(ACol: Integer): TfpgColor; +begin + if (ACol >= 0) and (ACol < ColumnCount) then + Result := TfpgGridColumn(FColumns[ACol]).FBackgroundColor + else + result := BackgroundColor; +end; + +procedure TfpgCustomGrid.SetColumnBackgroundColor(ACol: Integer; const AValue: TfpgColor); +var + lCol: TfpgGridColumn; +begin + lCol := TfpgGridColumn(FColumns[ACol]); + + if lCol.FBackgroundColor <> AValue then + begin + lCol.FBackgroundColor := AValue; +// UpdateScrollBars; + Repaint; + end; +end; + +function TfpgCustomGrid.GetColumnTextColor(ACol: Integer): TfpgColor; +begin + if (ACol >= 0) and (ACol < ColumnCount) then + Result := TfpgGridColumn(FColumns[ACol]).FTextColor + else + result := TextColor; +end; + +procedure TfpgCustomGrid.SetColumnTextColor(ACol: Integer; const AValue: TfpgColor); +var + lCol: TfpgGridColumn; +begin + lCol := TfpgGridColumn(FColumns[ACol]); + + if lCol.FTextColor <> AValue then + begin + lCol.FTextColor := AValue; +// UpdateScrollBars; + Repaint; + end; +end; + +function TfpgCustomGrid.GetHeaderText(ACol: Integer): string; +begin + Result := TfpgGridColumn(FColumns[ACol]).Title; +end; + +constructor TfpgCustomGrid.Create(AOwner: TComponent); +begin + FColumns := TList.Create; + inherited Create(AOwner); + ColumnCount := 0; + RowCount := 0; +end; + +destructor TfpgCustomGrid.Destroy; +begin + while FColumns.Count > 0 do + begin + TfpgGridColumn(FColumns.Items[0]).Free; + FColumns.Delete(0); + end; + + FColumns.Free; + inherited Destroy; +end; + +function TfpgCustomGrid.AddColumn(ATitle: string; AWidth: integer): TfpgGridColumn; +var + i: integer; +begin + Result := DoCreateColumnClass; + Result.Title := ATitle; + Result.Width := AWidth; + Result.Backgroundcolor := clBoxcolor; + Result.TextColor := TextColor; + i := FColumns.Add(Result); + DoAfterAddColumn(i); // update empty cells in descendants + + if csUpdating in ComponentState then + Exit; //==> + + UpdateScrollBars; + RePaint; +end; + +procedure TfpgCustomGrid.DeleteColumn(AIndex: integer); +var + c: TfpgGridColumn; +begin + c := Columns[AIndex]; + if c <> nil then + begin + DoDeleteColumn(AIndex); + if HasHandle then + Update; + end; +end; + +procedure TfpgCustomGrid.MoveColumn(oldindex, newindex: integer); +begin + FColumns.Move(oldindex, newindex); + if HasHandle then + Update; +end; + +end. + diff --git a/src/gui/fpg_dialogs.pas b/src/gui/fpg_dialogs.pas new file mode 100644 index 00000000..10267f4a --- /dev/null +++ b/src/gui/fpg_dialogs.pas @@ -0,0 +1,1387 @@ +{ + fpGUI - Free Pascal GUI Toolkit + + Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this + distribution, for details of the copyright. + + See the file COPYING.modifiedLGPL, included in this distribution, + for details about redistributing fpGUI. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + Description: + Standard dialogs used by fpGUI based applications. +} + +unit fpg_dialogs; + +{$mode objfpc}{$H+} + +{ + TODO: + * Try and refactor the code to remove all IFDEF's + * Implement MessageDlg with icons and buttons [Work-In-Progress] + * Select Directory dialog (treeview style) +} + +{.$Define DEBUG} + +interface + +uses + Classes, + SysUtils, + fpg_base, + fpg_main, + fpg_imgfmt_bmp, + fpg_constants, + fpg_form, + fpg_button, + fpg_label, + fpg_listbox, + fpg_checkbox, + fpg_edit, + fpg_grid, + fpg_combobox, + fpg_panel, + fpg_memo; + +type + TfpgMsgDlgType = (mtAbout, mtWarning, mtError, mtInformation, mtConfirmation, + mtCustom); + + TfpgMsgDlgBtn = (mbNoButton, mbOK, mbCancel, mbYes, mbNo, mbAbort, + mbRetry, mbIgnore, mbAll, mbNoToAll, mbYesToAll, mbHelp, mbClose); + + TfpgMsgDlgButtons = set of TfpgMsgDlgBtn; + +const + mbYesNoCancel = [mbYes, mbNo, mbCancel]; + mbYesNo = [mbYes, mbNo]; + mbOKCancel = [mbOK, mbCancel]; + mbAbortRetryIgnore = [mbAbort, mbRetry, mbIgnore]; + + // make Select File Dialog calls more readable + sfdOpen = True; + sfdSave = False; + + cMsgDlgBtnText: array[TfpgMsgDlgBtn] of string = + ( '', rsOK, rsCancel, rsYes, rsNo, rsAbort, rsRetry, rsIgnore, + rsAll, rsNoToAll, rsYesToAll, rsHelp, rsClose ); + +type + + TfpgMessageBox = class(TfpgForm) + private + FLines: TStringList; + FFont: TfpgFont; + FTextY: integer; + FLineHeight: integer; + FMaxLineWidth: integer; + FButton: TfpgButton; + FCentreText: Boolean; + protected + procedure HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override; + procedure HandlePaint; override; + procedure HandleShow; override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure SetMessage(AMessage: string); + property CentreText: Boolean read FCentreText write FCentreText default False; + end; + + + TfpgBaseDialog = class(TfpgForm) + protected + FSpacing: integer; + FDefaultButtonWidth: integer; + btnOK: TfpgButton; + btnCancel: TfpgButton; + procedure btnOKClick(Sender: TObject); virtual; + procedure btnCancelClick(Sender: TObject); virtual; + procedure HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override; + procedure SetupCaptions; virtual; + public + constructor Create(AOwner: TComponent); override; + end; + + + TfpgFontSelectDialog = class(TfpgBaseDialog) + private + FSampleText: string; + FMode: Byte; // 1 - Normal Fonts; 2 - Alias Fonts + lblLabel1: TfpgLabel; + lblTypeface: TfpgLabel; + lblSize: TfpgLabel; + lblLabel4: TfpgLabel; + lblLabel5: TfpgLabel; + lbCollection: TfpgListBox; + lbFaces: TfpgListBox; + lbSize: TfpgListBox; + cbBold: TfpgCheckBox; + cbItalic: TfpgCheckBox; + cbUnderline: TfpgCheckBox; + cbAntiAlias: TfpgCheckBox; + memSample: TfpgMemo; + procedure OnCollectionChanged(Sender: TObject); + procedure OnParamChange(Sender: TObject); + procedure OnSameTextChanged(Sender: TObject); + procedure CreateFontList; + procedure CreateFontAliasList; + procedure SetupUI(AMode: Byte); + protected + function GetFontDesc: string; + procedure SetFontDesc(Desc: string); + procedure SetupCaptions; override; + public + constructor Create(AOwner: TComponent); override; + procedure SetSampleText(AText: string); + end; + + + TfpgFileDialog = class(TfpgBaseDialog) + private + chlDir: TfpgComboBox; + grid: TfpgFileGrid; + btnUpDir: TfpgButton; + btnDirNew: TfpgButton; + btnShowHidden: TfpgButton; + pnlFileInfo: TfpgPanel; + edFilename: TfpgEdit; + chlFilter: TfpgComboBox; + lb1: TfpgLabel; + lb2: TfpgLabel; + FOpenMode: boolean; + FFilterList: TStringList; + FFilter: string; + procedure SetFilter(const Value: string); + function GetShowHidden: boolean; + procedure SetShowHidden(const Value: boolean); + procedure ListChanged(Sender: TObject; ARow: Integer); + procedure GridDblClicked(Sender: TObject; AButton: TMouseButton; AShift: TShiftState; const AMousePos: TPoint); + procedure InitializeComponents; + procedure ProcessFilterString; + function GetFileFilter: string; + procedure FilterChange(Sender: TObject); + procedure DirChange(Sender: TObject); + procedure UpDirClick(Sender: TObject); + procedure btnDirNewClicked(Sender: TObject); + procedure edFilenameChanged(Sender: TObject); + procedure UpdateButtonState; + function HighlightFile(const AFilename: string): boolean; + protected + procedure HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override; + procedure btnOKClick(Sender: TObject); override; + procedure SetCurrentDirectory(const ADir: string); + public + FileName: string; + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + function RunOpenFile: boolean; + function RunSaveFile: boolean; + property Filter: string read FFilter write SetFilter; + property ShowHidden: boolean read GetShowHidden write SetShowHidden; + end; + + +{ This lets us use a single include file for both the Interface and + Implementation sections. } +{$define read_interface} +{$undef read_implementation} + +{$I logo.inc} +{$I messagedialog.inc} +{$I newdirdialog.inc} +{$I promptuserdialog.inc} + + + +procedure ShowMessage(AMessage, ATitle: string; ACentreText: Boolean = False); overload; +procedure ShowMessage(AMessage: string; ACentreText: Boolean = False); overload; + +function SelectFontDialog(var FontDesc: string): boolean; + +function SelectFileDialog(aDialogType: boolean = sfdOpen; + const aFilter: TfpgString = ''): TfpgString; + +implementation + +uses + fpg_widget, + fpg_utils, + fpg_stringutils + {$IFDEF MSWINDOWS} + ,Windows // used by File Dialog + {$ENDIF} + ,DateUtils + ; + + +procedure WrapText(const AText: String; ALines: TStrings; AFont: TfpgFont; + const ALineWidth: Integer; out AWidth: Integer); +var + maxw: integer; + n: integer; + s, s2: string; + c: char; + + // ----------------- + procedure AddLine(all: boolean); + var + w: integer; + m: integer; + begin + s2 := s; + w := AFont.TextWidth(s2); + if w > ALineWidth then + begin + while w > ALineWidth do + begin + m := UTF8Length(s); + repeat + Dec(m); + s2 := UTF8Copy(s,1,m); + w := AFont.TextWidth(s2); + until w <= ALineWidth; + if w > maxw then + maxw := w; + + // are we in the middle of a word. If so find the beginning of word. + while UTF8Copy(s2, m, m+1) <> ' ' do + begin + Dec(m); + s2 := UTF8Copy(s,1,m); + end; + + ALines.Add(s2); + s := UTF8Copy(s, m+1, UTF8length(s)); + s2 := s; + w := AFont.TextWidth(s2); + end; { while } + if all then + begin + ALines.Add(s2); + s := ''; + end; + end + else + begin + ALines.Add(s2); + s := ''; + end; { if/else } + + if w > maxw then + maxw := w; + end; + +begin + s := ''; + ALines.Clear; + n := 1; + maxw := 0; + while n <= Length(AText) do + begin + c := AText[n]; + if (c = #13) or (c = #10) then + begin + // True indicates that if the text is split over multiple lines the last + // line must also be pocessed before continuing. If False then double CR + // can get ignored. + AddLine(true); + if (c = #13) and (n < Length(AText)) and (AText[n+1] = #10) then + Inc(n); + end + else + s := s + c; + Inc(n); + end; { while } + + AddLine(true); + + // set out variable + AWidth := maxw; +end; + +procedure ShowMessage(AMessage, ATitle: string; ACentreText: Boolean); +var + frm: TfpgMessageBox; +begin + frm := TfpgMessageBox.Create(nil); + try + frm.WindowTitle := ATitle; + frm.CentreText := ACentreText; + frm.SetMessage(AMessage); + frm.ShowModal; + finally + frm.Free; + end; +end; + +procedure ShowMessage(AMessage: string; ACentreText: Boolean); +begin + ShowMessage(AMessage, rsMessage, ACentreText); +end; + +function SelectFontDialog(var FontDesc: string): boolean; +var + frm: TfpgFontSelectDialog; +begin + Result := False; + frm := TfpgFontSelectDialog.Create(nil); + frm.SetFontDesc(FontDesc); + if frm.ShowModal = 1 then + begin + FontDesc := frm.GetFontDesc; + Result := True; + end; + frm.Free; +end; + +function SelectFileDialog(aDialogType: boolean = sfdOpen; + const aFilter: TfpgString = ''): TfpgString; +var + dlg: TfpgFileDialog; + dres: boolean; + DefaultFilter: TfpgString; +begin + DefaultFilter := rsAllFiles+' ('+AllFilesMask+')'+'|'+AllFilesMask; + dlg := TfpgFileDialog.Create(nil); + try + if aFilter = '' then + dlg.Filter := DefaultFilter + else + dlg.Filter := aFilter+'|'+DefaultFilter; + + if aDialogType = sfdOpen then + dres := dlg.RunOpenFile + else + dres := dlg.RunSaveFile; + + if dres then + Result := dlg.FileName + else + Result := ''; + finally + dlg.Free; + end; +end; + +{ TfpgMessageBox } + +procedure TfpgMessageBox.HandleKeyPress(var keycode: word; + var shiftstate: TShiftState; var consumed: boolean); +begin + inherited HandleKeyPress(keycode, shiftstate, consumed); + if keycode = keyEscape then + Close; +end; + +procedure TfpgMessageBox.HandlePaint; +var + n, y: integer; + tw: integer; +begin + inherited HandlePaint; + + Canvas.SetFont(FFont); + y := FTextY; + for n := 0 to FLines.Count-1 do + begin + tw := FFont.TextWidth(FLines[n]); + if CentreText then + Canvas.DrawString(Width div 2 - tw div 2, y, FLines[n]) + else + Canvas.DrawString(10, y, FLines[n]); + Inc(y, FLineHeight); + end; +end; + +procedure TfpgMessageBox.HandleShow; +begin + inherited HandleShow; + FButton.SetFocus; +end; + +constructor TfpgMessageBox.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + WindowPosition := wpScreenCenter; + Sizeable := False; + + FLines := TStringList.Create; + FFont := fpgGetFont('#Label1'); + FTextY := 10; + FLineHeight := FFont.Height + 4; + MinWidth := 200; + FMaxLineWidth := 500; + FCentreText := False; + + FButton := TfpgButton.Create(self); + FButton.Text := cMsgDlgBtnText[mbOK]; + FButton.Width := 75; + FButton.ModalResult := mrOK; +end; + +destructor TfpgMessageBox.Destroy; +begin + FFont.Free; + FLines.Free; + inherited Destroy; +end; + +procedure TfpgMessageBox.SetMessage(AMessage: string); +var + outw: integer; +begin + WrapText(AMessage, FLines, FFont, FMaxLineWidth, outw); + + // dialog width with 10 pixel border on both sides + Width := outw + 2*10; + + if Width < FMinWidth then + Width := FMinWidth; + + // center button + FButton.Top := FTextY + FLineHeight*FLines.Count + FTextY; + FButton.Left := (Width div 2) - (FButton.Width div 2); + + // adjust dialog's height + Height := FButton.Top + FButton.Height + FTextY; +end; + +{ TfpgBaseDialog } + +procedure TfpgBaseDialog.btnOKClick(Sender: TObject); +begin + ModalResult := mrOK; +end; + +procedure TfpgBaseDialog.btnCancelClick(Sender: TObject); +begin + ModalResult := mrCancel; + Close; +end; + +procedure TfpgBaseDialog.HandleKeyPress(var keycode: word; + var shiftstate: TShiftState; var consumed: boolean); +begin + if keycode = keyEscape then // Esc cancels the dialog + btnCancelClick(nil) + else + inherited HandleKeyPress(keycode, shiftstate, consumed); +end; + +procedure TfpgBaseDialog.SetupCaptions; +begin + btnCancel.Text := rsCancel; + btnOK.Text := rsOK; +end; + +constructor TfpgBaseDialog.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + Width := 500; + Height := 400; + MinWidth := 300; + MinHeight := 300; + WindowPosition := wpScreenCenter; + FSpacing := 6; + FDefaultButtonWidth := 80; + + btnCancel := CreateButton(self, Width-FDefaultButtonWidth-FSpacing, 370, FDefaultButtonWidth, rsCancel, @btnCancelClick); + btnCancel.Name := 'btnCancel'; + btnCancel.ImageName := 'stdimg.Cancel'; // Do NOT localize + btnCancel.ShowImage := True; + btnCancel.Anchors := [anRight, anBottom]; + btnCancel.TabOrder := 2; + + btnOK := CreateButton(self, btnCancel.Left-FDefaultButtonWidth-FSpacing, 370, FDefaultButtonWidth, rsOK, @btnOKClick); + btnOK.Name := 'btnOK'; + btnOK.ImageName := 'stdimg.OK'; // Do NOT localize + btnOK.ShowImage := True; + btnOK.Anchors := [anRight, anBottom]; + btnOK.TabOrder := 1; +end; + + +{ TfpgFontSelectDialog } + +procedure TfpgFontSelectDialog.OnCollectionChanged(Sender: TObject); +begin + if lbCollection.Text = rsCollectionFontAliases then + begin + CreateFontAliasList; + SetupUI(2); + end + else + begin + CreateFontList; + SetupUI(1); + end; + OnParamChange(nil); +end; + +procedure TfpgFontSelectDialog.OnParamChange(Sender: TObject); +var + fdesc: string; +begin + fdesc := GetFontDesc; + {$IFDEF DEBUG} Writeln(fdesc); {$ENDIF} + memSample.FontDesc := fdesc; + memSample.Text := FSampleText; + if FMode = 2 then + memSample.Lines.Add(fpgGetNamedFontDesc(UTF8Copy(fdesc, 2, UTF8Length(fdesc)-1))); +end; + +procedure TfpgFontSelectDialog.OnSameTextChanged(Sender: TObject); +begin + FSampleText := memSample.Text; +end; + +procedure TfpgFontSelectDialog.CreateFontList; +var + fl: TStringList; +begin + lbFaces.BeginUpdate; + fl := fpgApplication.GetFontFaceList; + lbFaces.Items.Assign(fl); + fl.Free; + lbFaces.FocusItem := 0; + lbFaces.EndUpdate; +end; + +procedure TfpgFontSelectDialog.CreateFontAliasList; +var + fl: TStringList; + i: integer; +begin + lbFaces.BeginUpdate; + fl := fpgGetNamedFontList; + lbFaces.Items.Clear; + for i := 0 to fl.Count-1 do + lbFaces.Items.Add(fl.Names[i]); + fl.Free; + lbFaces.FocusItem := 0; + lbFaces.EndUpdate; +end; + +procedure TfpgFontSelectDialog.SetupUI(AMode: Byte); +begin + FMode := AMode; + case FMode of + 1: // Normal Fonts + begin + lblSize.Enabled := True; + lblTypeFace.Enabled := True; + lbSize.Enabled := True; + cbBold.Enabled := True; + cbItalic.Enabled := True; + cbUnderline.Enabled := True; + cbAntiAlias.Enabled := True; + end; + 2: // Font Aliases + begin + lblSize.Enabled := False; + lblTypeFace.Enabled := False; + lbSize.Enabled := False; + cbBold.Enabled := False; + cbItalic.Enabled := False; + cbUnderline.Enabled := False; + cbAntiAlias.Enabled := False; + end; + end; +end; + +function TfpgFontSelectDialog.GetFontDesc: string; +var + s: string; +begin + if FMode = 2 then + s := lbFaces.Text + else + begin + s := lbFaces.Text + '-' + lbSize.Text; + // Do NOT localize these! + if cbBold.Checked then + s := s + ':bold'; + + if cbItalic.Checked then + s := s + ':italic'; + + if cbAntiAlias.Checked then + s := s + ':antialias=true' + else + s := s + ':antialias=false'; + + if cbUnderline.Checked then + s := s + ':underline'; + end; + result := s; +end; + +procedure TfpgFontSelectDialog.SetFontDesc(Desc: string); +var + cp: integer; + c: char; + token: string; + prop: string; + propval: string; + + function NextC: char; + begin + inc(cp); + if cp > length(Desc) then + c := #0 + else + c := Desc[cp]; + result := c; + end; + + procedure NextToken; + begin + token := ''; + while (c <> #0) and (c in [' ','a'..'z','A'..'Z','_','0'..'9']) do + begin + token := token + c; + NextC; + end; + end; + + procedure ProcessAliasFont; + var + i: integer; + begin + lbCollection.FocusItem := lbCollection.ItemCount; + for i := 0 to lbFaces.ItemCount-1 do + begin + if SameText(lbFaces.Items[i], Desc) then + begin + lbFaces.FocusItem := i; + Exit; //==> + end; + end; + end; + +begin + cp := 1; + c := Desc[1]; + + if Desc[1] = '#' then + FMode := 2 + else + FMode := 1; + SetupUI(FMode); + + if FMode = 2 then + begin + ProcessAliasFont; + Exit; //==> + end; + + cbBold.Checked := False; + cbItalic.Checked := False; + cbUnderline.Checked := False; + cbAntiAlias.Checked := True; + + NextToken; + lbFaces.FocusItem := lbFaces.Items.IndexOf(token); + + if c = '-' then + begin + NextC; + NextToken; + lbSize.FocusItem := lbSize.Items.IndexOf(token); + end; + + while c = ':' do + begin + NextC; + NextToken; + + prop := UpperCase(token); + propval := ''; + + if c = '=' then + begin + NextC; + NextToken; + propval := UpperCase(token); + end; + + // Do NOT localize these! + if prop = 'BOLD' then + begin + cbBold.Checked := True; + end + else if prop = 'ITALIC' then + begin + cbItalic.Checked := True; + end + else if prop = 'ANTIALIAS' then + begin + if propval = 'FALSE' then + cbAntialias.Checked := False; + end + else if prop = 'UNDERLINE' then + begin + cbUnderline.Checked := True; + end; + + end; + + OnParamChange(self); +end; + +procedure TfpgFontSelectDialog.SetupCaptions; +begin + inherited SetupCaptions; +end; + +constructor TfpgFontSelectDialog.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + WindowTitle := rsSelectAFont; + Width := 600; + MinWidth := Width; + MinHeight := Height; + FSampleText := 'The quick brown fox jumps over the lazy dog. 0123456789 [oO0,ilLI]'; + FMode := 1; // normal fonts + + btnCancel.Left := Width - FDefaultButtonWidth - FSpacing; + btnOK.Left := btnCancel.Left - FDefaultButtonWidth - FSpacing; + + lblLabel5 := TfpgLabel.Create(self); + with lblLabel5 do + begin + SetPosition(8, 8, 73, 16); + AutoSize := True; + Text := fpgAddColon(rsCollection); + end; + + { TODO : This need to be fully implemented at some stage. } + lbCollection := TfpgListBox.Create(self); + with lbCollection do + begin + Name := 'lbCollection'; + SetPosition(8, 28, 145, 236); + Items.Add(rsCollectionAllFonts); + // These should be stored in /fpgui directory + Items.Add(rsCollectionRecentlyUsed); + Items.Add(rsCollectionFavourites); + // From here onwards, these should be created automatically. + Items.Add(rsCollectionFixedWidth); + Items.Add(rsCollectionSans); + Items.Add(rsCollectionSerif); + Items.Add(rsCollectionFontAliases); + FocusItem := 0; + OnChange := @OnCollectionChanged; +// Enabled := False; + end; + + lblLabel1 := TfpgLabel.Create(self); + with lblLabel1 do + begin + SetPosition(161, 8, 73, 16); + AutoSize := True; + Text := fpgAddColon(rsName); + end; + + lbFaces := TfpgListBox.Create(self); + with lbFaces do + begin + Name := 'lbFaces'; + SetPosition(161, 28, 232, 236); + Items.Add(' '); + OnChange := @OnParamChange; + end; + + lblSize := TfpgLabel.Create(self); + with lblSize do + begin + Name := 'lblSize'; + SetPosition(401, 8, 54, 16); + AutoSize := True; + Text := fpgAddColon(rsSize); + end; + + lbSize := TfpgListBox.Create(self); + with lbSize do + begin + Name := 'lbSize'; + SetPosition(401, 28, 52, 236); + Items.Add('6'); + Items.Add('7'); + Items.Add('8'); + Items.Add('9'); + Items.Add('10'); + Items.Add('11'); + Items.Add('12'); + Items.Add('13'); + Items.Add('14'); + Items.Add('15'); + Items.Add('16'); + Items.Add('18'); + Items.Add('20'); + Items.Add('24'); + Items.Add('28'); + Items.Add('32'); + Items.Add('48'); + Items.Add('64'); + Items.Add('72'); + OnChange := @OnParamChange; + end; + + lblTypeface := TfpgLabel.Create(self); + with lblTypeface do + begin + Name := 'lblTypeface'; + SetPosition(461, 8, 54, 16); + AutoSize := True; + Text := fpgAddColon(rsTypeface); + end; + + cbBold := TfpgCheckBox.Create(self); + with cbBold do + begin + SetPosition(461, 32, 110, 20); + Text := rsBold; + OnChange := @OnParamChange; + end; + + cbItalic := TfpgCheckBox.Create(self); + with cbItalic do + begin + SetPosition(461, 56, 110, 20); + Text := rsItalic; + OnChange := @OnParamChange; + end; + + cbUnderline := TfpgCheckBox.Create(self); + with cbUnderline do + begin + SetPosition(461, 80, 110, 20); + Text := rsUnderScore; + OnChange := @OnParamChange; + end; + + cbAntiAlias := TfpgCheckBox.Create(self); + with cbAntiAlias do + begin + SetPosition(461, 124, 110, 20); + Text := rsAntiAliasing; + OnChange := @OnParamChange; + Checked := True; + end; + + lblLabel4 := TfpgLabel.Create(self); + with lblLabel4 do + begin + SetPosition(8, 268, 584, 16); + AutoSize := True; + Text := fpgAddColon(rsExampleText); + end; + + memSample := TfpgMemo.Create(self); + with memSample do + begin + SetPosition(8, 288, 584, 65); + Text := FSampleText; + Anchors := [anLeft, anTop, anRight, anBottom]; + OnChange := @OnSameTextChanged; + end; + + CreateFontList; +end; + +procedure TfpgFontSelectDialog.SetSampleText(AText: string); +begin + if FSampleText = AText then + Exit; //==> + if AText = '' then + Exit; //==> + + FSampleText := AText; + memSample.Text := FSampleText; +end; + + +{ TfpgFileDialog } + +procedure TfpgFileDialog.ListChanged(Sender: TObject; ARow: Integer); +var + s: string; +begin + if grid.CurrentEntry = nil then + Exit; //==> + s := grid.CurrentEntry.Name; + + if grid.CurrentEntry.IsLink then + s := s + ' -> ' + grid.CurrentEntry.LinkTarget; + + if grid.CurrentEntry.EntryType <> etDir then + edFileName.Text := grid.CurrentEntry.Name; + + UpdateButtonState; + pnlFileInfo.Text := s; +end; + +procedure TfpgFileDialog.GridDblClicked(Sender: TObject; AButton: TMouseButton; + AShift: TShiftState; const AMousePos: TPoint); +var + e: TFileEntry; +begin + e := grid.CurrentEntry; + if (e = nil) then + Exit; //==> + + if (e.EntryType = etDir) then + SetCurrentDirectory(e.Name) + else if (e.EntryType = etFile) then + btnOKClick(Sender); +end; + +procedure TfpgFileDialog.SetFilter(const Value: string); +begin + FFilter := Value; + ProcessFilterString; +end; + +function TfpgFileDialog.GetShowHidden: boolean; +begin + Result := btnShowHidden.Down; +end; + +procedure TfpgFileDialog.SetShowHidden(const Value: boolean); +begin + btnShowHidden.Down := Value; +end; + +procedure TfpgFileDialog.InitializeComponents; +begin + chlDir := TfpgComboBox.Create(self); + with chlDir do + begin + SetPosition(8, 12, 526, 22); + Anchors := [anLeft, anRight, anTop]; + FontDesc := '#List'; + OnChange := @DirChange; + end; + + grid := TfpgFileGrid.Create(self); + with grid do + begin + SetPosition(8, 44, 622, 203); + Anchors := [anLeft, anRight, anTop, anBottom]; + OnRowChange := @ListChanged; + OnDoubleClick := @GridDblClicked; + end; + + btnUpDir := TfpgButton.Create(self); + with btnUpDir do + begin + SetPosition(540, 11, 26, 24); + Anchors := [anRight, anTop]; + Text := ''; + FontDesc := '#Label1'; + ImageName := 'stdimg.folderup'; // Do NOT localize + ModalResult := mrNone; + Focusable := False; + OnClick := @UpDirClick; + end; + + btnDirNew := TfpgButton.Create(self); + with btnDirNew do + begin + SetPosition(572, 11, 26, 24); + Anchors := [anRight, anTop]; + Text := ''; + FontDesc := '#Label1'; + ImageName := 'stdimg.foldernew'; // Do NOT localize + ModalResult := mrNone; + Focusable := False; + OnClick := @btnDirNewClicked; + end; + + btnShowHidden := TfpgButton.Create(self); + with btnShowHidden do + begin + SetPosition(604, 11, 26, 24); + Anchors := [anRight, anTop]; + Text := ''; + FontDesc := '#Label1'; + ImageName := 'stdimg.hidden'; // Do NOT localize + ModalResult := mrNone; + Focusable := False; + GroupIndex := 1; + AllowAllUp := True; + OnClick := @DirChange; + end; + + { Create lower Panel details } + + pnlFileInfo := TfpgPanel.Create(self); + with pnlFileInfo do + begin + Name := 'pnlFileInfo'; + SetPosition(8, 253, 622, 25); + Anchors := [anLeft, anRight, anBottom]; + Alignment := taLeftJustify; + Margin := 4; + Style := bsLowered; + Text := ''; + end; + + edFilename := TfpgEdit.Create(self); + with edFilename do + begin + SetPosition(8, 301, 622, 22); + Anchors := [anLeft, anRight, anBottom]; + Text := ''; + FontDesc := '#Edit1'; + OnChange := @edFilenameChanged; + end; + + { Filter section } + + chlFilter := TfpgComboBox.Create(self); + with chlFilter do + begin + SetPosition(8, 345, 622, 22); + Anchors := [anLeft, anRight, anBottom]; + FontDesc := '#List'; + OnChange := @FilterChange; + end; + + lb1 := TfpgLabel.Create(self); + with lb1 do + begin + SetPosition(8, 283, 80, 16); + Anchors := [anLeft, anBottom]; + Text := fpgAddColon(rsFileName); + FontDesc := '#Label1'; + end; + + lb2 := TfpgLabel.Create(self); + with lb2 do + begin + SetPosition(8, 327, 64, 16); + Anchors := [anLeft, anBottom]; + Text := fpgAddColon(rsFileType); + FontDesc := '#Label1'; + end; + + ActiveWidget := grid; + FileName := ''; + SetFilter(rsAllFiles + ' (*)|*'); + chlFilter.FocusItem := 0; +end; + +procedure TfpgFileDialog.HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); +var + e: TFileEntry; +begin + if not consumed then + begin + if (ActiveWidget = grid) then + begin + case keycode of + keyReturn: + begin + e := grid.CurrentEntry; + if (e <> nil) then + begin + if (e.EntryType = etDir) then + SetCurrentDirectory(e.Name) + else if (e.EntryType = etFile) then + btnOKClick(btnOK); + consumed := True; + end; + end; + keyBackSpace: + begin + SetCurrentDirectory('..'); + consumed := True; + end; + end; + end; + end; + if not consumed then + inherited HandleKeyPress(keycode, shiftstate, consumed); +end; + +procedure TfpgFileDialog.btnOKClick(Sender: TObject); +var + e: TFileEntry; +begin + if FOpenMode then + begin + e := grid.CurrentEntry; + if e.EntryType = etDir then + begin + SetCurrentDirectory(e.Name); + Exit; //==> + end; + end; + + if not FOpenMode or fpgFileExists(edFileName.Text) then + begin + ModalResult := mrOK; + end; + + if ModalResult = mrOK then + // FileName := fpgExpandFileName(edFileName.Text); + FileName := grid.FileList.DirectoryName + edFileName.Text; +end; + +constructor TfpgFileDialog.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + WindowTitle := rsFileSelection; + Width := 640; + Height := 410; + WindowPosition := wpScreenCenter; + FSpacing := 10; + + FFilterList := TStringList.Create; + + InitializeComponents; + + // position standard dialog buttons + btnCancel.Left := Width - FDefaultButtonWidth - FSpacing; + btnCancel.Top := Height - btnCancel.Height - FSpacing; + btnOK.Left := btnCancel.Left - FDefaultButtonWidth - 6; + btnOK.Top := btnCancel.Top; +end; + +destructor TfpgFileDialog.Destroy; +begin + FFilterList.Free; + inherited Destroy; +end; + +procedure TfpgFileDialog.DirChange(Sender: TObject); +begin + SetCurrentDirectory(chlDir.Text); +end; + +procedure TfpgFileDialog.FilterChange(Sender: TObject); +begin + SetCurrentDirectory('.'); +end; + +procedure TfpgFileDialog.UpDirClick(Sender: TObject); +begin + SetCurrentDirectory('..'); +end; + +procedure TfpgFileDialog.btnDirNewClicked(Sender: TObject); +var + dlg: TfpgNewDirDialog; +begin + dlg := TfpgNewDirDialog.Create(nil); + try + if dlg.ShowModal = 1 then + begin + if dlg.Directory <> '' then + begin + mkdir(dlg.Directory); + grid.FileList.FileMask := GetFileFilter; + grid.FileList.ShowHidden := ShowHidden; + grid.FileList.ReadDirectory(); + grid.FileList.Sort(soFileName); + grid.Invalidate; + end; + end; + finally + dlg.Free; + end; +end; + +procedure TfpgFileDialog.edFilenameChanged(Sender: TObject); +begin + UpdateButtonState; +end; + +procedure TfpgFileDialog.UpdateButtonState; +begin + if FOpenMode then + btnOK.Enabled := True + else + btnOK.Enabled := edFileName.Text <> ''; +end; + +procedure TfpgFileDialog.SetCurrentDirectory(const ADir: string); +var + fsel: string; +begin + if ADir = '..' then + fsel := ExtractFileName( + ExcludeTrailingPathDelimiter(grid.FileList.DirectoryName)) + else + fsel := ''; + + grid.FileList.FileMask := GetFileFilter; + grid.FileList.ShowHidden := ShowHidden; + + if not grid.FileList.ReadDirectory(ADir) then + begin + ShowMessage(Format(rsErrCouldNotOpenDir, [ADir]), rsError); + Exit; //==> + end; + + grid.FileList.Sort(soFileName); + + // we don't want chlDir to call DirChange while populating items + chlDir.OnChange := nil; + chlDir.Items.Assign(grid.FileList.SpecialDirs); + chlDir.FocusItem := grid.FileList.CurrentSpecialDir; + chlDir.OnChange := @DirChange; // restore event handler + + if fsel <> '' then + HighlightFile(fsel) + else + grid.FocusRow := 0; + + grid.Update; + grid.SetFocus; +end; + +function TfpgFileDialog.HighlightFile(const AFilename: string): boolean; +var + n: integer; +begin + for n := 0 to grid.FileList.Count-1 do + begin + if grid.FileList.Entry[n].Name = AFilename then + begin + grid.FocusRow := n; + Result := True; + Exit; //==> + end; + end; + Result := False; +end; + +procedure TfpgFileDialog.ProcessFilterString; +var + p: integer; + s: string; + fs: string; + fm: string; +begin + // we don't want chlFilter to call FilterChange while populating items + chlFilter.OnChange := nil; + s := FFilter; + FFilterList.Clear; + chlFilter.Items.Clear; + repeat + fs := ''; + fm := ''; + p := pos('|', s); + if p > 0 then + begin + fs := Copy(s, 1, p-1); + Delete(s, 1, p); + p := pos('|', s); + if p > 0 then + begin + fm := Copy(s, 1, p-1); + Delete(s, 1, p); + end + else + begin + fm := s; + s := ''; + end; + end; + + if (fs <> '') and (fm <> '') then + begin + chlFilter.Items.Add(fs); + FFilterList.Add(fm); + end; + until (fs = '') or (fm = ''); { repeat/until } + chlFilter.FocusItem := 0; // first filter + // restore event handler + chlFilter.OnChange := @FilterChange; +end; + +function TfpgFileDialog.GetFileFilter: string; +var + i: integer; +begin + i := chlFilter.FocusItem; + if (i >= 0) and (i < FFilterList.Count) then + Result := FFilterList[i] + else + Result := '*'; +end; + +function TfpgFileDialog.RunOpenFile: boolean; +var + sdir: string; + fname: string; +begin + FOpenMode := True; + sdir := ExtractFileDir(FileName); + if sdir = '' then + sdir := '.'; + + SetCurrentDirectory(sdir); + fname := ExtractFileName(FileName); + + if not HighlightFile(fname) then + edFilename.Text := fname; + + WindowTitle := rsOpenAFile; + btnOK.ImageName := 'stdimg.open'; // Do NOT localize + btnOK.Text := rsOpen; + + if ShowModal = 1 then + Result := True + else + Result := False; +end; + +function TfpgFileDialog.RunSaveFile: boolean; +var + sdir: string; + fname: string; +begin + FOpenMode := False; + sdir := ExtractFileDir(FileName); + if sdir = '' then + sdir := '.'; + SetCurrentDirectory(sdir); + fname := ExtractFileName(FileName); + if not HighlightFile(fname) then + edFilename.Text := fname; + + WindowTitle := rsSaveAFile; + btnOK.ImageName := 'stdimg.save'; // Do NOT localize + btnOK.Text := rsSave; + + if ShowModal = 1 then + Result := True + else + Result := False; +end; + + +{ This lets us use a single include file for both the Interface and + Implementation sections. } +{$undef read_interface} +{$define read_implementation} + + +{$I messagedialog.inc} +{$I newdirdialog.inc} +{$I promptuserdialog.inc} + + + +end. + diff --git a/src/gui/fpg_edit.pas b/src/gui/fpg_edit.pas new file mode 100644 index 00000000..342718c2 --- /dev/null +++ b/src/gui/fpg_edit.pas @@ -0,0 +1,1865 @@ +{ + fpGUI - Free Pascal GUI Toolkit + + Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this + distribution, for details of the copyright. + + See the file COPYING.modifiedLGPL, included in this distribution, + for details about redistributing fpGUI. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + Description: + Defines a Text Edit control. Also known a Text Entry control. +} + +unit fpg_edit; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, + SysUtils, + fpg_base, + fpg_main, + fpg_widget, + fpg_menu; + +type + TfpgEditBorderStyle = (ebsNone, ebsDefault, ebsSingle); + + + TfpgBaseEdit = class(TfpgWidget) + private + FAutoSelect: Boolean; + FHideSelection: Boolean; + FPopupMenu: TfpgPopupMenu; + FDefaultPopupMenu: TfpgPopupMenu; + FText: string; + FFont: TfpgFont; + FPasswordMode: Boolean; + FBorderStyle: TfpgEditBorderStyle; + FOnChange: TNotifyEvent; + FMaxLength: integer; + FSelecting: Boolean; + procedure Adjust(UsePxCursorPos: boolean = false); + procedure AdjustTextOffset(UsePxCursorPos: boolean); + procedure AdjustDrawingInfo; + // function PointToCharPos(x, y: integer): integer; + procedure DeleteSelection; + procedure DoCopy; + procedure DoPaste; + procedure SetAutoSelect(const AValue: Boolean); + procedure SetBorderStyle(const AValue: TfpgEditBorderStyle); + procedure SetHideSelection(const AValue: Boolean); + procedure SetPasswordMode(const AValue: boolean); + function GetFontDesc: string; + procedure SetFontDesc(const AValue: string); + procedure SetText(const AValue: string); + procedure DefaultPopupCut(Sender: TObject); + procedure DefaultPopupCopy(Sender: TObject); + procedure DefaultPopupPaste(Sender: TObject); + procedure DefaultPopupClearAll(Sender: TObject); + procedure SetDefaultPopupMenuItemsState; + protected + FSideMargin: integer; + FMouseDragPos: integer; + FSelStart: integer; + FSelOffset: integer; + FCursorPos: integer; // Caret position (characters) + FCursorPx: integer; // Caret position (pixels) + FTextOffset: integer; + FDrawOffset: integer; + FVisibleText: TfpgString; + FVisSelStartPx: integer; + FVisSelEndPx: integer; + procedure DoOnChange; virtual; + procedure ShowDefaultPopupMenu(const x, y: integer; const shiftstate: TShiftState); virtual; + procedure HandlePaint; override; + procedure HandleResize(awidth, aheight: TfpgCoord); override; + procedure HandleKeyChar(var AText: TfpgChar; var shiftstate: TShiftState; var consumed: Boolean); override; + procedure HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: Boolean); override; + procedure HandleLMouseDown(x, y: integer; shiftstate: TShiftState); override; + procedure HandleRMouseUp(x, y: integer; shiftstate: TShiftState); override; + procedure HandleMouseMove(x, y: integer; btnstate: word; shiftstate: TShiftState); override; + procedure HandleDoubleClick(x, y: integer; button: word; shiftstate: TShiftState); override; + procedure HandleMouseEnter; override; + procedure HandleMouseExit; override; + procedure HandleSetFocus; override; + procedure HandleKillFocus; override; + function GetDrawText: String; + property AutoSelect: Boolean read FAutoSelect write SetAutoSelect default True; + property BorderStyle: TfpgEditBorderStyle read FBorderStyle write SetBorderStyle default ebsDefault; + property Font: TfpgFont read FFont; + property FontDesc: String read GetFontDesc write SetFontDesc; + property HideSelection: Boolean read FHideSelection write SetHideSelection default True; + property MaxLength: Integer read FMaxLength write FMaxLength; + property PasswordMode: Boolean read FPasswordMode write SetPasswordMode default False; + property PopupMenu: TfpgPopupMenu read FPopupMenu write FPopupMenu; + property Text: String read FText write SetText; + property OnChange: TNotifyEvent read FOnChange write FOnChange; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + function SelectionText: string; + procedure SelectAll; + procedure Clear; + procedure ClearSelection; + procedure CopyToClipboard; + procedure CutToClipboard; + procedure PasteFromClipboard; + end; + + + TfpgEdit = class(TfpgBaseEdit) + public + property Font; + property PopupMenu; // UI Designer doesn't fully support it yet + published + property AutoSelect; + property BackgroundColor default clBoxColor; + property BorderStyle; + property FontDesc; + property HideSelection; + property MaxLength; + property PasswordMode; + property ParentShowHint; + property ShowHint; + property TabOrder; + property Text; + property TextColor; + property OnChange; + property OnEnter; + property OnExit; + property OnKeyPress; + property OnMouseEnter; + property OnMouseExit; + property OnPaint; + end; + + + TfpgBaseNumericEdit = class(TfpgBaseEdit) + private + fOldColor: TfpgColor; + fAlignment: TAlignment; + fDecimalSeparator: char; + fNegativeColor: TfpgColor; + fThousandSeparator: char; + fShowThousand: boolean; + procedure SetOldColor(const AValue: TfpgColor); + procedure SetAlignment(const AValue: TAlignment); + procedure SetDecimalSeparator(const AValue: char); + procedure SetNegativeColor(const AValue: TfpgColor); + procedure SetThousandSeparator(const AValue: char); + protected + procedure HandleKeyChar(var AText: TfpgChar; var shiftstate: TShiftState; var consumed: Boolean); override; + procedure HandlePaint; override; + procedure Format; virtual; + procedure Justify; virtual; // to implement in derived classes + property OldColor: TfpgColor read fOldColor write SetOldColor; + property Alignment: TAlignment read fAlignment write SetAlignment default taRightJustify; + property AutoSelect; + property BackgroundColor default clBoxColor; + property BorderStyle; + {Someone likes to use English operating system but localized decimal and thousand separators + Still to implement !!} + property DecimalSeparator: char read fDecimalSeparator write SetDecimalSeparator; + property ThousandSeparator: char read fThousandSeparator write SetThousandSeparator; + property NegativeColor: TfpgColor read fNegativeColor write SetNegativeColor; + property HideSelection; +// property MaxLength; { probably MaxValue and MinValue } + property TabOrder; + property TextColor; + property ShowThousand: boolean read fShowThousand write fShowThousand default False; + property OnChange; + property OnEnter; + property OnExit; + property OnKeyPress; + property OnMouseEnter; + property OnMouseExit; + property OnPaint; + property Text; { this should become Value } + public + constructor Create(AOwner: TComponent); override; + published + property FontDesc; + end; + + + TfpgEditInteger = class(TfpgBaseNumericEdit) + protected + function GetValue: integer; virtual; + procedure SetValue(const AValue: integer); virtual; + procedure SetShowThousand; + procedure Format; override; + procedure HandleKeyChar(var AText: TfpgChar; var shiftstate: TShiftState; var consumed: Boolean); override; + public + constructor Create(AOwner: TComponent); override; + property Text; + published + property Alignment; + property NegativeColor; + property Value: integer read GetValue write SetValue; + property ShowThousand; + property TabOrder; + property TextColor; + property ThousandSeparator; + property OnChange; + property OnEnter; + property OnExit; + property OnKeyPress; + property OnMouseEnter; + property OnMouseExit; + end; + + + TfpgEditFloat = class(TfpgBaseNumericEdit) + private + fDecimals: integer; + protected + function GetValue: extended; virtual; + procedure SetValue(const AValue: extended); virtual; + procedure SetShowThousand; + procedure SetDecimals(AValue: integer); + procedure Format; override; + procedure HandleKeyChar(var AText: TfpgChar; var shiftstate: TShiftState; var consumed: Boolean); override; + public + constructor Create(AOwner: TComponent); override; + property Text; + published + property Alignment; + property Decimals: integer read fDecimals write SetDecimals; + property NegativeColor; + property DecimalSeparator; + property Value: extended read GetValue write SetValue; + property ShowThousand; + property TabOrder; + property TextColor; + property ThousandSeparator; + property OnChange; + property OnEnter; + property OnExit; + property OnKeyPress; + property OnMouseEnter; + property OnMouseExit; + end; + + + TfpgEditCurrency = class(TfpgBaseNumericEdit) + private + fDecimals: integer; + protected + function GetValue: Currency; virtual; + procedure SetValue(const AValue: Currency); virtual; + procedure SetShowThousand; + procedure SetDecimals(AValue: integer); + procedure Format; override; + procedure HandleKeyChar(var AText: TfpgChar; var shiftstate: TShiftState; var consumed: Boolean); override; + procedure HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: Boolean); override; + public + constructor Create(AOwner: TComponent); override; + property Text; + published + property Alignment; + property Decimals: integer read fDecimals write SetDecimals; + property NegativeColor; + property OldColor; + property DecimalSeparator; + property ThousandSeparator; + property ShowThousand; + property Value: Currency read GetValue write SetValue; + property OnChange; + property OnEnter; + property OnExit; + property OnKeyPress; + property OnMouseEnter; + property OnMouseExit; + end; + + +function CreateEdit(AOwner: TComponent; x, y, w, h: TfpgCoord): TfpgEdit; + +function CreateEditInteger(AOwner: TComponent; x, y, w, h: TfpgCoord; + AShowThousand: boolean= True): TfpgEditInteger; + +function CreateEditFloat(AOwner: TComponent; x, y, w, h: TfpgCoord; + AShowThousand: boolean= True; ADecimals: Integer= -1): TfpgEditFloat; + +function CreateEditCurrency(AOwner: TComponent; x, y, w, h: TfpgCoord; + AShowThousand: boolean= True; ADecimals: Integer= 2): TfpgEditCurrency; + + +implementation + +uses + fpg_stringutils, + fpg_constants, + fpg_hint; + +const + // internal popupmenu item names + ipmCut = 'miDefaultCut'; + ipmCopy = 'miDefaultCopy'; + ipmPaste = 'miDefaultPaste'; + ipmClearAll = 'miDefaultClearAll'; + + +function CreateEdit(AOwner: TComponent; x, y, w, h: TfpgCoord): TfpgEdit; +begin + Result := TfpgEdit.Create(AOwner); + Result.Left := x; + Result.Top := y; + if w > 0 then + Result.Width := w; + if h < TfpgEdit(Result).FFont.Height + 6 then + Result.Height:= TfpgEdit(Result).FFont.Height + 6 + else + Result.Height:= h; +end; + +function CreateEditInteger(AOwner: TComponent; x, y, w, h: TfpgCoord; AShowThousand: boolean= True): TfpgEditInteger; +begin + Result := TfpgEditInteger.Create(AOwner); + Result.Left := x; + Result.Top := y; + Result.Width := w; + Result.ShowThousand:= AShowThousand; + if h < TfpgEditInteger(Result).FFont.Height + 6 then + Result.Height:= TfpgEditInteger(Result).FFont.Height + 6 + else + Result.Height:= h; +end; + +function CreateEditFloat(AOwner: TComponent; x, y, w, h: TfpgCoord; AShowThousand: boolean= True; + ADecimals: Integer= -1): TfpgEditFloat; +begin + Result := TfpgEditFloat.Create(AOwner); + Result.Left := x; + Result.Top := y; + Result.Width := w; + Result.ShowThousand:= AShowThousand; + Result.Decimals := ADecimals; + if h < TfpgEditFloat(Result).FFont.Height + 6 then + Result.Height:= TfpgEditFloat(Result).FFont.Height + 6 + else + Result.Height:= h; +end; + +function CreateEditCurrency(AOwner: TComponent; x, y, w, h: TfpgCoord; AShowThousand: boolean= True; + ADecimals: Integer= 2): TfpgEditCurrency; +begin + Result := TfpgEditCurrency.Create(AOwner); + Result.Left := x; + Result.Top := y; + Result.Width := w; + Result.ShowThousand:= AShowThousand; + Result.Decimals := ADecimals; + if h < TfpgEditCurrency(Result).FFont.Height + 6 then + Result.Height:= TfpgEditCurrency(Result).FFont.Height + 6 + else + Result.Height:= h; +end; + + +{ TfpgBaseEdit } + +procedure TfpgBaseEdit.Adjust(UsePxCursorPos: boolean = false); +begin + AdjustTextOffset(False); + AdjustDrawingInfo; +end; + +procedure TfpgBaseEdit.AdjustTextOffset(UsePxCursorPos: boolean); +{If UsePxCursorPos then determines FCursorPos from FCursorPx (that holds mouse pointer coordinates) + Calculates exact FCursorPx (relative to the widget bounding box) from FCursorPos + Calculates FTextOffset based on FCursorPx} +var + dtext: string; + ch: string; // current character + chnum: integer; // its ordinal number + chx: integer; // its X position relative to widget + bestchx: integer; // chx, nearest to the mouse position (indicated by FCursorPx if UsePxCursorPos = True) + tw: integer; // total characters width, that becomes FCursorPx relative to the beginning of the text + ptw: integer; + dpos: integer; // helps to pass through an utf-8 string quickly + VisibleWidth: integer; // width of the edit field minus side margins +begin + if UsePxCursorPos then + begin + if FCursorPx > 0 then // bestchx < chx minimum + bestchx := Low(chx) + 1 + FCursorPx + else // bestchx > chx maximum + bestchx := High(chx) - 1 + FCursorPx; + end else + FCursorPx := 0; + + dtext := GetDrawText; + ch := ''; + chnum := 0; + tw := 0; + dpos := 0; + + while dpos <= Length(dtext) do + begin + dpos := UTF8CharAtByte(dtext, dpos, ch); + ptw := tw; + tw := tw + FFont.TextWidth(ch); + chx := tw - FTextOffset + FSideMargin; + if UsePxCursorPos then + begin + if abs(chx - FCursorPx) < abs(bestchx - FCursorPx) then + begin + bestchx := chx; + FCursorPos := chnum; + end else + begin + tw := ptw; + break; + end; + end else + begin + if chnum >= FCursorPos then + break; + end; + Inc(chnum); + end; + + VisibleWidth := (FWidth - 2 * FSideMargin); + if tw - FTextOffset > VisibleWidth - 2 then + FTextOffset := tw - VisibleWidth + 2 + else if tw - FTextOffset < 0 then + begin + FTextOffset := tw; + if tw <> 0 then + Dec(FTextOffset, 2); + end; + + FCursorPx := tw - FTextOffset + FSideMargin; +end; + +procedure TfpgBaseEdit.AdjustDrawingInfo; +// Calculates FVisSelStartPx, FVisSelEndPx, FVisibleText, FDrawOffset +var + // fvc, lvc: integer; // first/last visible characters + vtstartbyte, vtendbyte: integer; // visible characters' start/end in utf-8 string, bytes + bestfx, bestlx: integer; + dtext: string; + ch: string; // current character + chnum: integer; // its ordinal number + chx: integer; // its X position relative to widget + tw: integer; // total characters width, that becomes FCursorPx relative to the beginning of the text + ptw: integer; // total width on the previous step + dpos: integer; // helps to pass through an utf-8 string quickly + pdp: integer; // dpos on the previous step + vstart, vend: integer; // visible area start and end, pixels + slstart, slend: integer; // selection start and end, pixels +begin + vstart := FSideMargin; + vend := FWidth - FSideMargin; + if FSelOffset > 0 then + begin + slstart := FSelStart; + slend := FSelStart + FSelOffset; + end else + begin + slstart := FSelStart + FSelOffset; + slend := FSelStart; + end; + FVisSelStartPx := vend; // because we stop the search + FVisSelEndPx := vend; // after last visible character is found + bestfx := High(chx) - 1 + vstart; + bestlx := Low(chx) + 1 + vend; + + dtext := GetDrawText; + ch := ''; + chnum := 0; + tw := 0; + dpos := 0; + {fvc := 0; + lvc := 0;} + FDrawOffset := 0; + while dpos <= Length(dtext) do + begin + pdp := dpos; + dpos := UTF8CharAtByte(dtext, dpos, ch); + ptw := tw; + tw := tw + FFont.TextWidth(ch); + chx := tw - FTextOffset + FSideMargin; + + // calculate selection-related fields + if chnum = slstart then + FVisSelStartPx := chx; + if chnum = slend then + FVisSelEndPx := chx; + + // search for the first/last visible characters + if abs(chx - vstart) < abs(bestfx - vstart) then + begin + bestfx := chx; + // fvc := chnum; + vtstartbyte := pdp; + FDrawOffset := ptw; + end; + // in small edit field the same character can be both the first and the last, so no 'else' allowed + if abs(chx - vend) < abs(bestlx - vend) then + begin + bestlx := chx; + // lvc := chnum; + vtendbyte := UTF8CharAtByte(dtext, dpos, ch); // plus one more character + end else + break; // we can safely break after last visible character is found + Inc(chnum); + end; + + if FVisSelStartPx < vstart then + FVisSelStartPx := vstart; + if FVisSelEndPx > vend then + FVisSelEndPx := vend; + + // FVisibleText := UTF8Copy(dtext, fvc, lvc - fvc + 2); + FVisibleText := Copy(dtext, vtstartbyte, vtendbyte - vtstartbyte); + FDrawOffset := FTextOffset - FDrawOffset; +end; + +{function TfpgBaseEdit.PointToCharPos(x, y: integer): integer; +var + n: integer; + cx: integer; // character X position + bestcx: integer; + dtext: string; + tw, dpos: integer; + ch: string; +begin + ch := ''; + dtext := GetDrawText; + if x > 0 then // bestcx < cx minimum + bestcx := Low(cx) + 1 + x + else // bestcx > cx maximum + bestcx := High(cx) - 1 + x; + + tw := 0; + dpos := 0; + n := 0; + Result := n; + // searching the appropriate character position + while dpos <= Length(dtext) do + begin + dpos := UTF8CharAtByte(dtext, dpos, ch); + tw := tw + FFont.TextWidth(ch); + cx := tw - FTextOffset + FSideMargin; + if abs(cx - x) < abs(bestcx - x) then + begin + bestcx := cx; + Result := n; + end else + Exit; //==> + Inc(n); + end; +end;} + +procedure TfpgBaseEdit.SetBorderStyle(const AValue: TfpgEditBorderStyle); +begin + if FBorderStyle = AValue then + Exit; //==> + FBorderStyle := AValue; + RePaint; +end; + +procedure TfpgBaseEdit.SetHideSelection(const AValue: Boolean); +begin + if FHideSelection = AValue then + Exit; + FHideSelection := AValue; +end; + +procedure TfpgBaseEdit.HandlePaint; +var + r: TfpgRect; + + // paint selection rectangle + procedure DrawSelection; + var + lcolor: TfpgColor; + r: TfpgRect; + begin + if Focused then + begin + lcolor := clSelection; + Canvas.SetTextColor(clSelectionText); + end + else + begin + lcolor := clInactiveSel; + Canvas.SetTextColor(clText1); + end; + + r.SetRect(FVisSelStartPx, 3, FVisSelEndPx - FVisSelStartPx, FFont.Height); + Canvas.SetColor(lcolor); + Canvas.FillRectangle(r); + Canvas.SetTextColor(clWhite); + Canvas.AddClipRect(r); + fpgStyle.DrawString(Canvas, -FDrawOffset + FSideMargin, 3, FVisibleText, Enabled); + Canvas.ClearClipRect; + end; + +begin + Canvas.ClearClipRect; + r.SetRect(0, 0, Width, Height); + case BorderStyle of + ebsNone: + begin + // do nothing + end; + ebsDefault: + begin + Canvas.DrawControlFrame(r); + InflateRect(r, -2, -2); + end; + ebsSingle: + begin + Canvas.SetColor(clShadow2); + Canvas.DrawRectangle(r); + InflateRect(r, -1, -1); + end; + end; + Canvas.SetClipRect(r); + + if Enabled then + Canvas.SetColor(FBackgroundColor) + else + Canvas.SetColor(clWindowBackground); + + Canvas.FillRectangle(r); + + Canvas.SetFont(FFont); + Canvas.SetTextColor(FTextColor); + fpgStyle.DrawString(Canvas, -FDrawOffset + FSideMargin, 3, FVisibleText, Enabled); + + if Focused then + begin + // drawing selection + if FSelOffset <> 0 then + DrawSelection; + + // drawing cursor + fpgCaret.SetCaret(Canvas, FCursorPx, 3, fpgCaret.Width, FFont.Height); + end + else + begin + // drawing selection + if (AutoSelect = False) and (FSelOffset <> 0) and (HideSelection = False) then + DrawSelection; + fpgCaret.UnSetCaret(Canvas); + end; +end; + +procedure TfpgBaseEdit.HandleResize(awidth, aheight: TfpgCoord); +begin + inherited HandleResize(awidth, aheight); + AdjustDrawingInfo; +end; + +procedure TfpgBaseEdit.HandleKeyChar(var AText: TfpgChar; + var shiftstate: TShiftState; var consumed: Boolean); +var + s: TfpgChar; + prevval: string; +begin + prevval := Text; + s := AText; + + if not consumed then + begin + // Handle only printable characters + // UTF-8 characters beyond ANSI range are supposed to be printable + if ((Ord(AText[1]) > 31) and (Ord(AText[1]) < 127)) or (Length(AText) > 1) then + begin + if (FMaxLength <= 0) or (UTF8Length(FText) < FMaxLength) then + begin + DeleteSelection; + UTF8Insert(s, FText, FCursorPos + 1); + Inc(FCursorPos); + FSelStart := FCursorPos; + Adjust; + end; + consumed := True; + end; + + if prevval <> Text then + DoOnChange; + end; + + if consumed then + RePaint; + + inherited HandleKeyChar(AText, shiftstate, consumed); +end; + +procedure TfpgBaseEdit.HandleKeyPress(var keycode: word; + var shiftstate: TShiftState; var consumed: boolean); +var + hasChanged: boolean; + + procedure StopSelection; + begin + FSelStart := FCursorPos; + FSelOffset := 0; + end; + +begin + hasChanged := False; + fpgApplication.HideHint; + + + Consumed := True; + case CheckClipBoardKey(keycode, shiftstate) of + ckCopy: + begin + DoCopy; + end; + ckPaste: + begin + DoPaste; + hasChanged := True; + end; + ckCut: + begin + DoCopy; + DeleteSelection; + Adjust; + hasChanged := True; + end; + else + Consumed := False; + end; + + + if not Consumed then + begin + // checking for movement keys: + case keycode of + keyLeft: + if FCursorPos > 0 then + begin + consumed := True; + Dec(FCursorPos); + + if (ssCtrl in shiftstate) then + // word search... + // while (FCursorPos > 0) and not ptkIsAlphaNum(copy(FText,FCursorPos,1)) + // do Dec(FCursorPos); + // while (FCursorPos > 0) and ptkIsAlphaNum(copy(FText,FCursorPos,1)) + // do Dec(FCursorPos); + ; + + end; + + keyRight: + if FCursorPos < UTF8Length(FText) then + begin + consumed := True; + Inc(FCursorPos); + + if (ssCtrl in shiftstate) then + // word search... + // while (FCursorPos < Length(FText)) and ptkIsAlphaNum(copy(FText,FCursorPos+1,1)) + // do Inc(FCursorPos); + // while (FCursorPos < Length(FText)) and not ptkIsAlphaNum(copy(FText,FCursorPos+1,1)) + // do Inc(FCursorPos); + ; + end; + + keyHome: + begin + consumed := True; + FCursorPos := 0; + end; + + keyEnd: + begin + consumed := True; + FCursorPos := UTF8Length(FText); + end; + end; + + if Consumed then + begin + FSelecting := (ssShift in shiftstate); + + if FSelecting then + FSelOffset := FCursorPos - FSelStart + else + StopSelection; + + Adjust; + end; + end; // movement key checking + + if not Consumed then + begin + consumed := True; + + case keycode of + keyBackSpace: + begin + if FCursorPos > 0 then + begin + UTF8Delete(FText, FCursorPos, 1); + Dec(FCursorPos); + hasChanged := True; + end;// backspace + end; + + + keyDelete: + begin + if FSelOffset <> 0 then + DeleteSelection + else if FCursorPos < UTF8Length(FText) then + UTF8Delete(FText, FCursorPos + 1, 1); + hasChanged := True; + end; + else + Consumed := False; + end; + + if Consumed then + begin + StopSelection; + Adjust; + end; + end; { if } + + if consumed then + RePaint + else + inherited; + + if hasChanged then + if Assigned(FOnChange) then + FOnChange(self); +end; + +procedure TfpgBaseEdit.HandleLMouseDown(x, y: integer; shiftstate: TShiftState); +begin + fpgApplication.HideHint; + inherited HandleLMouseDown(x, y, shiftstate); + + FCursorPx := x; + AdjustTextOffset(True); + FMouseDragPos := FCursorPos; + if (ssShift in shiftstate) then + FSelOffset := FCursorPos - FSelStart + else + begin + FSelStart := FCursorPos; + FSelOffset := 0; + end; + AdjustDrawingInfo; + RePaint; +end; + +procedure TfpgBaseEdit.HandleRMouseUp(x, y: integer; shiftstate: TShiftState); +begin + inherited HandleRMouseUp(x, y, shiftstate); + if Assigned(PopupMenu) then + PopupMenu.ShowAt(self, x, y) + else + ShowDefaultPopupMenu(x, y, ShiftState); +end; + +procedure TfpgBaseEdit.HandleMouseMove(x, y: integer; btnstate: word; shiftstate: TShiftState); +var + cp: integer; +begin + if (btnstate and MOUSE_LEFT) = 0 then // Left button not down + begin + inherited HandleMouseMove(x, y, btnstate, shiftstate); + Exit; //==> + end; + + cp := FCursorPos; + FCursorPx := x; + AdjustTextOffset(True); + if FCursorPos <> cp then + begin + FSelOffset := FCursorPos - FSelStart; + AdjustDrawingInfo; + Repaint; + end; +end; + +procedure TfpgBaseEdit.HandleDoubleClick(x, y: integer; button: word; shiftstate: TShiftState); +begin + // button is always Mouse_Left, but lets leave this test here for good measure + if button = MOUSE_LEFT then + SelectAll + else + inherited; +end; + +procedure TfpgBaseEdit.HandleMouseEnter; +begin + inherited HandleMouseEnter; + if (csDesigning in ComponentState) then + Exit; + if Enabled then + MouseCursor := mcIBeam; +end; + +procedure TfpgBaseEdit.HandleMouseExit; +begin + inherited HandleMouseExit; + if (csDesigning in ComponentState) then + Exit; + MouseCursor := mcDefault; +end; + +procedure TfpgBaseEdit.HandleSetFocus; +begin + inherited HandleSetFocus; + if AutoSelect then + SelectAll; +end; + +procedure TfpgBaseEdit.HandleKillFocus; +begin + inherited HandleKillFocus; + if AutoSelect then + FSelOffset := 0; +end; + +function TfpgBaseEdit.GetDrawText: string; +begin + if not PassWordMode then + Result := FText + else + Result := StringOfChar('*', UTF8Length(FText)); +end; + +constructor TfpgBaseEdit.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FFont := fpgGetFont('#Edit1'); // owned object ! + Focusable := True; + FHeight := FFont.Height + 6; + FWidth := 120; + FTextColor := Parent.TextColor; + FBackgroundColor := clBoxColor; + FAutoSelect := True; + FSelecting := False; + FHideSelection := True; + FSideMargin := 3; + FMaxLength := 0; // no limit + FText := ''; + FCursorPos := UTF8Length(FText); + FSelStart := FCursorPos; + FSelOffset := 0; + FTextOffset := 0; + FPasswordMode := False; + FBorderStyle := ebsDefault; + FPopupMenu := nil; + FDefaultPopupMenu := nil; + FOnChange := nil; + +end; + +destructor TfpgBaseEdit.Destroy; +begin + if Assigned(FDefaultPopupMenu) then + FDefaultPopupMenu.Free; + FFont.Free; + inherited Destroy; +end; + +function TfpgBaseEdit.SelectionText: string; +begin + if FSelOffset <> 0 then + begin + if FSelOffset < 0 then + Result := UTF8Copy(FText, 1 + FSelStart + FSelOffset, -FSelOffset) + else + begin + Result := UTF8Copy(FText, 1 + FSelStart, FSelOffset); + end; + end + else + Result := ''; +end; + +procedure TfpgBaseEdit.SetPasswordMode (const AValue: boolean ); +begin + if FPasswordMode = AValue then + Exit; //==> + FPasswordMode := AValue; + Adjust; + RePaint; +end; + +function TfpgBaseEdit.GetFontDesc: string; +begin + Result := FFont.FontDesc; +end; + +procedure TfpgBaseEdit.SetFontDesc(const AValue: string); +begin + FFont.Free; + FFont := fpgGetFont(AValue); + if Height < FFont.Height + 6 then + Height:= FFont.Height + 6; + Adjust; + RePaint; +end; + +procedure TfpgBaseEdit.SetText(const AValue: string); +var + s: string; + prevval: TfpgString; +begin + if FText = AValue then + Exit; + prevval := FText; + + if FMaxLength <> 0 then + begin + if UTF8Length(FText) > FMaxLength then + s := UTF8Copy(AValue, 1, FMaxLength) + else + s := AValue; + end + else + s := AValue; + + FText := s; + FCursorPos := UTF8Length(FText); + FSelStart := FCursorPos; + FSelOffset := 0; + FTextOffset := 0; + + Adjust; + RePaint; + + if prevval <> Text then + DoOnChange; +end; + +procedure TfpgBaseEdit.DefaultPopupCut(Sender: TObject); +begin + CutToClipboard; +end; + +procedure TfpgBaseEdit.DefaultPopupCopy(Sender: TObject); +begin + CopyToClipboard; +end; + +procedure TfpgBaseEdit.DefaultPopupPaste(Sender: TObject); +begin + PasteFromClipboard +end; + +procedure TfpgBaseEdit.DefaultPopupClearAll(Sender: TObject); +begin + Clear; +end; + +procedure TfpgBaseEdit.SetDefaultPopupMenuItemsState; +var + i: integer; + itm: TfpgMenuItem; +begin + for i := 0 to FDefaultPopupMenu.ComponentCount-1 do + begin + if FDefaultPopupMenu.Components[i] is TfpgMenuItem then + begin + itm := TfpgMenuItem(FDefaultPopupMenu.Components[i]); + // enabled/disable menu items + if itm.Name = ipmCut then + itm.Enabled := FSelOffset <> 0 + else if itm.Name = ipmCopy then + itm.Enabled := FSelOffset <> 0 + else if itm.Name = ipmPaste then + itm.Enabled := fpgClipboard.Text <> '' + else if itm.Name = ipmClearAll then + itm.Enabled := Text <> ''; + end; + end; +end; + +procedure TfpgBaseEdit.DoOnChange; +begin + if Assigned(FOnChange) then + FOnChange(self); +end; + +procedure TfpgBaseEdit.ShowDefaultPopupMenu(const x, y: integer; + const shiftstate: TShiftState); +var + itm: TfpgMenuItem; +begin + if not Assigned(FDefaultPopupMenu) then + begin + { todo: This text needs to be localized } + FDefaultPopupMenu := TfpgPopupMenu.Create(nil); + itm := FDefaultPopupMenu.AddMenuItem(rsCut, '', @DefaultPopupCut); + itm.Name := ipmCut; + itm := FDefaultPopupMenu.AddMenuItem(rsCopy, '', @DefaultPopupCopy); + itm.Name := ipmCopy; + itm := FDefaultPopupMenu.AddMenuItem(rsPaste, '', @DefaultPopupPaste); + itm.Name := ipmPaste; + itm := FDefaultPopupMenu.AddMenuItem(rsDelete, '', @DefaultPopupClearAll); + itm.Name := ipmClearAll; + end; + + SetDefaultPopupMenuItemsState; + FDefaultPopupMenu.ShowAt(self, x, y); +end; + +procedure TfpgBaseEdit.DeleteSelection; +var + prevval: TfpgString; +begin + prevval := FText; + if FSelOffset <> 0 then + begin + if FSelOffset < 0 then + begin + UTF8Delete(FText, 1 + FSelStart + FSelOffset, -FSelOffset); + FCurSorPos := FSelStart + FSelOffset; + end + else + begin + UTF8Delete(FText, 1 + FSelStart, FSelOffset); + FCurSorPos := FSelStart; + end; + FSelOffset := 0; + FSelStart := FCursorPos; + end; + if prevval <> Text then + DoOnChange; +end; + +procedure TfpgBaseEdit.DoCopy; +begin + if FSelOffset = 0 then + Exit; //==> + fpgClipboard.Text := SelectionText; +end; + +procedure TfpgBaseEdit.DoPaste; +var + s: string; + prevval: TfpgString; +begin + prevval := FText; + DeleteSelection; + s := fpgClipboard.Text; + + if (FMaxLength > 0) then + if UTF8Length(FText) + UTF8Length(s) > FMaxLength then + s := UTF8Copy(s, 1, FMaxLength - UTF8Length(FText)); // trim the clipboard text if needed + + if UTF8Length(s) < 1 then + Exit; //==> + + UTF8Insert(s, FText, FCursorPos + 1); + FCursorPos := FCursorPos + UTF8Length(s); + FSelStart := FCursorPos; + Adjust; + Repaint; + if prevval <> Text then + DoOnChange; +end; + +procedure TfpgBaseEdit.SetAutoSelect(const AValue: Boolean); +begin + if FAutoSelect = AValue then + Exit; //==> + FAutoSelect := AValue; +end; + +procedure TfpgBaseEdit.SelectAll; +begin + FSelecting := True; + FSelStart := 0; + FSelOffset := UTF8Length(FText); + FCursorPos := FSelOffset; + Adjust; + Repaint; +end; + +procedure TfpgBaseEdit.Clear; +begin + Text := ''; +end; + +procedure TfpgBaseEdit.ClearSelection; +begin + DeleteSelection; + Adjust; + RePaint; +end; + +procedure TfpgBaseEdit.CopyToClipboard; +begin + DoCopy; +end; + +procedure TfpgBaseEdit.CutToClipboard; +begin + DoCopy; + DeleteSelection; + Adjust; + RePaint; +end; + +procedure TfpgBaseEdit.PasteFromClipboard; +begin + DoPaste; +end; + +{ TfpgBaseNumericEdit } + +procedure TfpgBaseNumericEdit.SetOldColor(const AValue: TfpgColor); +begin + if fOldColor=AValue then exit; + fOldColor:=AValue; +end; + +procedure TfpgBaseNumericEdit.SetAlignment(const AValue: TAlignment); +begin + if fAlignment=AValue then exit; + fAlignment:=AValue; +end; + +procedure TfpgBaseNumericEdit.SetDecimalSeparator(const AValue: char); +begin + if fDecimalSeparator=AValue then exit; + fDecimalSeparator:=AValue; +end; + +procedure TfpgBaseNumericEdit.SetNegativeColor(const AValue: TfpgColor); +begin + if fNegativeColor=AValue then exit; + fNegativeColor:=AValue; +end; + +procedure TfpgBaseNumericEdit.SetThousandSeparator(const AValue: char); +begin + if fThousandSeparator=AValue then exit; + fThousandSeparator:=AValue; +end; + +procedure TfpgBaseNumericEdit.Justify; +begin + //based on Alignment property this method will align the derived edit correctly. +end; + +procedure TfpgBaseNumericEdit.HandleKeyChar(var AText: TfpgChar; + var shiftstate: TShiftState; var consumed: Boolean); +begin + inherited HandleKeyChar(AText, shiftstate, consumed); + Format; // just call format virtual procedure to have a simple way to manage polymorphism here +end; + +procedure TfpgBaseNumericEdit.HandlePaint; +var + x: TfpgCoord; + r: TfpgRect; +begin + if Alignment = taRightJustify then + begin + Canvas.BeginDraw; + inherited HandlePaint; + // Canvas.ClearClipRect; + // r.SetRect(0, 0, Width, Height); + r.SetRect(2, 2, Width - 4, Height - 4); + Canvas.SetClipRect(r); + Canvas.Clear(BackgroundColor); + Canvas.SetFont(Font); + Canvas.SetTextColor(TextColor); + x := Width - Font.TextWidth(Text) - 3; + Canvas.DrawString(x,3,Text); + Canvas.EndDraw; + if Focused then + fpgCaret.SetCaret(Canvas, x + Font.TextWidth(Text) - 1, 3, fpgCaret.Width, Font.Height); + end + else + inherited; +end; + +procedure TfpgBaseNumericEdit.Format; +begin + // Colour negative number + if LeftStr(Text,1) = '-' then + TextColor := NegativeColor + else + TextColor := OldColor; +end; + +constructor TfpgBaseNumericEdit.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + fAlignment := taRightJustify; + DecimalSeparator := SysUtils.DecimalSeparator; + ThousandSeparator := SysUtils.ThousandSeparator; + NegativeColor := clRed; + OldColor := TextColor; +end; + +{ TfpgEditInteger } + +function TfpgEditInteger.GetValue: integer; +var + txt: string; +begin + if ShowThousand then + begin + if Copy(fText, 1, 1) = '-' then + txt := Copy(ftext, 2, Length(fText) - 1) + else + txt := fText; + while Pos(ThousandSeparator, txt) > 0 do + txt := Copy(txt, 1, Pred(Pos(ThousandSeparator, txt))) + +Copy(txt, Succ(Pos(ThousandSeparator, txt)), Length(txt) - Pos(ThousandSeparator, txt)); + if Copy(fText, 1, 1) = '-' then + fText := '-' + txt + else + fText := txt; + end; + if fText = '-' then + begin + Result := 0; + Text:= fText; + end + else + if Text > '' then + try + Result := StrToInt(fText); + except + on E: EConvertError do + begin + Result := 0; + Text := ''; + Invalidate; + end; + end + else + Result := 0; +end; + +procedure TfpgEditInteger.SetValue(const AValue: integer); +begin + try + Text := IntToStr(AValue); + except + on E: EConvertError do + Text := ''; + end; +end; + +procedure TfpgEditInteger.SetShowThousand; +var + i,long: integer; + txt, texte: string; +begin + if ShowThousand then + begin + if fText > '' then + if fText[1] = '-' then + txt:= UTF8Copy(fText, 2, UTF8Length(fText)-1) + else + txt:= fText; + long := UTF8Length(txt); + if long = 0 then + texte := '' + else + begin + for i := 1 to UTF8Length(txt) do + if txt[i] = ThousandSeparator then + Exit; // avoids additional separators when pressing return + i := 0; + texte := ''; + repeat + if i > 0 then + if ((i mod 3) = 0) and (txt[UTF8Length(txt)-UTF8Length(texte)] <> ThousandSeparator) then + begin + texte := ThousandSeparator + texte; + UTF8Insert(texte, txt, FCursorPos + 1); + if fText[1] = '-' then + begin + if Pred(FCursorPos) <= UTF8Length(texte) then + Inc(FCursorPos); + end + else + if FCursorPos <= UTF8Length(texte) then + Inc(FCursorPos); + end; + texte := Copy(txt, long - i, 1) + texte; + inc(i); + until i = long; + end; + if fText > '' then + if fText[1] = '-' then + fText:= '-' + texte + else + fText := texte; + end; +end; + +procedure TfpgEditInteger.Format; +begin + SetShowThousand; + inherited Format; +end; + +procedure TfpgEditInteger.HandleKeyChar(var AText: TfpgChar; + var shiftstate: TShiftState; var consumed: Boolean); +var + n: integer; +begin + n := Ord(AText[1]); + if ((n >= 48) and (n <= 57) or (n = Ord('-')) and (Pos(AText[1], Self.Text) <= 0)) then + consumed := False + else + consumed := True; + inherited HandleKeyChar(AText, shiftstate, consumed); +end; + +constructor TfpgEditInteger.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + fShowThousand := True; +end; + +{ TfpgEditFloat } + +function TfpgEditFloat.GetValue: extended; +var + txt: string; +begin + if fDecimals > 0 then + begin + if Pos(DecimalSeparator, fText) > 0 then + if UTF8Length(fText)-Pos(DecimalSeparator, fText) > fDecimals then + fText := Copy(fText, 1, UTF8Length(fText) - 1); + end + else + if fDecimals = 0 then + if Pos(DecimalSeparator, fText) > 0 then + fText := Copy(fText, 1, UTF8Length(fText) - 1); + if ShowThousand then + begin + if Copy(fText, 1, 1) = '-' then + txt := Copy(ftext, 2, Length(fText) - 1) + else + txt := fText; + while Pos(ThousandSeparator, txt) > 0 do + txt := Copy(txt, 1, Pred(Pos(ThousandSeparator, txt))) + +Copy(txt, Succ(Pos(ThousandSeparator, txt)), Length(txt) - Pos(ThousandSeparator, txt)); + if Copy(fText, 1, 1) = '-' then + fText := '-' + txt + else + fText := txt; + end; + if fText = '-' then + begin + Result := 0; + Text:= fText; + end + else + if fText > '' then + try + Result := StrToFloat(fText); + except + on E: EConvertError do + begin + Result := 0; + Text := ''; + Invalidate; + end; + end + else + Result := 0; +end; + +procedure TfpgEditFloat.SetValue(const AValue: extended); +begin + try + Text := FloatToStr(AValue); + except + on E: EConvertError do + Text := ''; + end; +end; + +procedure TfpgEditFloat.SetShowThousand; +var + i,long: integer; + txt, texte, decimal: string; +begin + if fDecimals > 0 then + if Pos(DecimalSeparator, fText) > 0 then + begin + txt := UTF8Copy(fText, 1, Pred(Pos(DecimalSeparator, fText))); + if UTF8Length(fText)-Pos(DecimalSeparator, fText) > fDecimals then + decimal := UTF8Copy(fText, Succ(Pos(DecimalSeparator, fText)), fDecimals) + else + decimal := UTF8Copy(fText, Succ(Pos(DecimalSeparator, fText)), UTF8Length(fText)-Pos(DecimalSeparator, fText)); + end + else + txt := fText + else + if fDecimals = 0 then + if Pos(DecimalSeparator, fText) > 0 then + txt := UTF8Copy(fText, 1, Pred(Pos(DecimalSeparator, fText))) + else + txt := fText + else + if Pos(DecimalSeparator, fText) > 0 then + begin + txt := UTF8Copy(fText, 1, Pred(Pos(DecimalSeparator, fText))); + decimal := UTF8Copy(fText, Succ(Pos(DecimalSeparator, fText)), UTF8Length(fText)-Pos(DecimalSeparator, fText)); + end + else + txt := fText; + if ShowThousand then + begin + if fText > '' then + if fText[1] = '-' then + txt:= UTF8Copy(txt, 2, UTF8Length(txt)-1); + long := UTF8Length(txt); + if long = 0 then + texte := '' + else + begin + for i := 1 to UTF8Length(txt) do + if txt[i] = ThousandSeparator then + Exit; // avoids additional separators when pressing return + i := 0; + texte := ''; + repeat + if i > 0 then + if ((i mod 3) = 0) and (txt[UTF8Length(txt)-UTF8Length(texte)] <> ThousandSeparator) then + begin + texte := ThousandSeparator + texte; + UTF8Insert(texte, txt, FCursorPos + 1); + if fText[1] = '-' then + begin + if Pred(FCursorPos) <= UTF8Length(texte) then + Inc(FCursorPos); + end + else + if FCursorPos <= UTF8Length(texte) then + Inc(FCursorPos); + end; + texte := Copy(txt, long - i, 1) + texte; + inc(i); + until i = long; + end; + if fText > '' then + if fText[1] = '-' then + if Pos(DecimalSeparator, fText) > 0 then + fText := '-' + texte + DecimalSeparator + decimal + else + fText := '-' + texte + else + if Pos(DecimalSeparator, fText) > 0 then + fText := texte + DecimalSeparator + decimal + else + fText := texte + decimal; + end; +end; + +procedure TfpgEditFloat.SetDecimals(AValue: integer); +begin + if AValue < -1 then + Exit; // => + if fDecimals <> AValue then + fDecimals := AValue +end; + +procedure TfpgEditFloat.Format; +begin + SetShowThousand; + inherited Format; +end; + +procedure TfpgEditFloat.HandleKeyChar(var AText: TfpgChar; + var shiftstate: TShiftState; var consumed: Boolean); +var + n: integer; +begin + n := Ord(AText[1]); + if ((n >= 48) and (n <= 57) or (n = Ord('-')) and (Pos(AText[1], Self.Text) <= 0)) + or ((n = Ord(Self.DecimalSeparator)) and (Pos(AText[1], Self.Text) <= 0)) then + consumed := False + else + consumed := True; + inherited HandleKeyChar(AText, shiftstate, consumed); +end; + +constructor TfpgEditFloat.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + fDecimals := -1; + fShowThousand := True; +end; + +{ TfpgEditCurrency } + +function TfpgEditCurrency.GetValue: Currency; +var + txt: string; +begin + if fDecimals > 0 then + if Pos(DecimalSeparator, fText) > 0 then + if UTF8Length(fText)-Pos(DecimalSeparator, fText) > fDecimals then + fText := Copy(fText, 1, UTF8Length(fText) - 1); + if ShowThousand then + begin + if Copy(fText, 1, 1) = '-' then + txt := Copy(ftext, 2, Length(fText) - 1) + else + txt := fText; + while Pos(ThousandSeparator, txt) > 0 do + txt := Copy(txt, 1, Pred(Pos(ThousandSeparator, txt))) + +Copy(txt, Succ(Pos(ThousandSeparator, txt)), Length(txt) - Pos(ThousandSeparator, txt)); + if Copy(fText, 1, 1) = '-' then + fText := '-' + txt + else + fText := txt; + end; + if fText = '-' then + begin + Result := 0; + Text:= fText; + end + else + if fText > '' then + try + Result := StrToCurr(fText); + except + on E: EConvertError do + begin + Result := 0; + Text := ''; + Invalidate; + end; + end + else + Result := 0; +end; + +procedure TfpgEditCurrency.SetValue(const AValue: Currency); +var + i,long: integer; + txt, texte, decimal: string; +begin + try + fText := CurrToStr(AValue); + if ShowThousand then + begin + if Pos(DecimalSeparator, fText) = 0 then + txt := fText + else + begin + txt := UTF8Copy(fText, 1, Pred(Pos(DecimalSeparator, fText))); + decimal := UTF8Copy(fText, Succ(Pos(DecimalSeparator, fText)), UTF8Length(fText) - Pos(DecimalSeparator, fText)); + end; + if AValue < 0 then + txt:= UTF8Copy(txt, 2, UTF8Length(txt)-1); + long := UTF8Length(txt); + i := 0; + texte := ''; + repeat + if i > 0 then + if ((i mod 3) = 0) and (txt[UTF8Length(txt)-UTF8Length(texte)] <> ThousandSeparator) then + begin + texte := ThousandSeparator + texte; + if AValue < 0 then + begin + if Pred(FCursorPos) <= UTF8Length(texte) then + Inc(FCursorPos); + end + else + if FCursorPos <= UTF8Length(texte) then + Inc(FCursorPos); + end; + texte := Copy(txt, long - i, 1) + texte; + inc(i); + until i = long; + if Pos(DecimalSeparator, fText) = 0 then + begin + if AValue < 0 then + begin + fText := '-' + texte; + Inc(FCursorPos); + end + else + fText := texte; + end + else + begin + if AValue < 0 then + begin + fText := '-' + texte + DecimalSeparator + decimal; + Inc(FCursorPos); + end + else + fText := texte + DecimalSeparator + decimal; + FCursorPos := FCursorPos + Succ(Length(decimal)); + end; + end; + if fDecimals > 0 then + begin + if Pos(DecimalSeparator, fText) = 0 then + begin + fText := fText + DecimalSeparator; + Inc(FCursorPos); + end; + if UTF8Length(fText)-Pos(DecimalSeparator, fText) < fDecimals then + while UTF8Length(fText)-Pos(DecimalSeparator, fText) < fDecimals do + begin + fText := fText + '0'; + Inc(FCursorPos); + end; + end; + if AValue < 0 then + TextColor := NegativeColor + else + TextColor := OldColor; + except + on E: EConvertError do + Text := ''; + end; +end; + +procedure TfpgEditCurrency.SetShowThousand; +var + i,long: integer; + txt, texte, decimal: string; +begin + if fDecimals > 0 then + if Pos(DecimalSeparator, fText) > 0 then + begin + txt := UTF8Copy(fText, 1, Pred(Pos(DecimalSeparator, fText))); + if UTF8Length(fText)-Pos(DecimalSeparator, fText) > fDecimals then + decimal := UTF8Copy(fText, Succ(Pos(DecimalSeparator, fText)), fDecimals) + else + decimal := UTF8Copy(fText, Succ(Pos(DecimalSeparator, fText)), UTF8Length(fText)-Pos(DecimalSeparator, fText)); + end + else + txt := fText; + if ShowThousand then + begin + if fText > '' then + if fText[1] = '-' then + txt:= UTF8Copy(txt, 2, UTF8Length(txt)-1); + long := UTF8Length(txt); + if long = 0 then + texte := '' + else + begin + for i := 1 to UTF8Length(txt) do + if txt[i] = ThousandSeparator then + Exit; // avoids additional separators when pressing return + i := 0; + texte := ''; + repeat + if i > 0 then + if ((i mod 3) = 0) and (txt[UTF8Length(txt)-UTF8Length(texte)] <> ThousandSeparator) then + begin + texte := ThousandSeparator + texte; + UTF8Insert(texte, txt, FCursorPos + 1); + if fText[1] = '-' then + begin + if Pred(FCursorPos) <= UTF8Length(texte) then + Inc(FCursorPos); + end + else + if FCursorPos <= UTF8Length(texte) then + Inc(FCursorPos); + end; + texte := Copy(txt, long - i, 1) + texte; + inc(i); + until i = long; + end; + if fText > '' then + if fText[1] = '-' then + if Pos(DecimalSeparator, fText) > 0 then + fText := '-' + texte + DecimalSeparator + decimal + else + fText := '-' + texte + else + if Pos(DecimalSeparator, fText) > 0 then + fText := texte + DecimalSeparator + decimal + else + fText := texte + decimal; + end; +end; + +procedure TfpgEditCurrency.SetDecimals(AValue: integer); +begin + if (AValue < 0) or (AValue > 4) then + Exit; // => + if fDecimals <> AValue then + fDecimals := AValue +end; + +procedure TfpgEditCurrency.Format; +begin + SetShowThousand; + inherited Format; +end; + +procedure TfpgEditCurrency.HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: Boolean); +begin + case keycode of + keyReturn, keyPEnter, keyTab: + if fDecimals > 0 then + begin + if Pos(DecimalSeparator, fText) = 0 then + begin + fText := fText + DecimalSeparator; + Inc(FCursorPos); + end; + if UTF8Length(fText)-Pos(DecimalSeparator, fText) < fDecimals then + while UTF8Length(fText)-Pos(DecimalSeparator, fText) < fDecimals do + begin + fText := fText + '0'; + Inc(FCursorPos); + end; + end; + end; + inherited HandleKeyPress(keycode,shiftstate,consumed); +end; + +procedure TfpgEditCurrency.HandleKeyChar(var AText: TfpgChar; + var shiftstate: TShiftState; var consumed: Boolean); +var + n: integer; +begin + n := Ord(AText[1]); + if ((n >= 48) and (n <= 57) or (n = Ord('-')) and (Pos(AText[1], Self.Text) <= 0)) + or ((n = Ord(Self.DecimalSeparator)) and (Pos(AText[1], Self.Text) <= 0)) then + consumed := False + else + consumed := True; + inherited HandleKeyChar(AText, shiftstate, consumed); +end; + +constructor TfpgEditCurrency.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + fDecimals := 2; + fShowThousand := True; +end; + + +end. + diff --git a/src/gui/fpg_editcombo.pas b/src/gui/fpg_editcombo.pas new file mode 100644 index 00000000..efa97423 --- /dev/null +++ b/src/gui/fpg_editcombo.pas @@ -0,0 +1,776 @@ +{ + fpGUI - Free Pascal GUI Toolkit + + Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this + distribution, for details of the copyright. + + See the file COPYING.modifiedLGPL, included in this distribution, + for details about redistributing fpGUI. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + Description: + Defines a edit ComboBox control with auto-complete feature. +} + +unit fpg_editcombo; + +{$mode objfpc}{$H+} + +{.$Define DEBUG} + +{ + *********************************************************** + ********** This is still under development! *********** + *********************************************************** + + It needs lots of testing and debugging. +} + + +{ TODO: Needs a lot of refactoring to get rid of code duplication. } + +{ +This is an example of what we can aim for: +You need a mono font to see the correct layout. + + + TfpgBaseComboBox + _________|______________ + | | + TfpgBaseStaticCombo TfpgBaseEditCombo + ______|_________ | + | | TfpgEditCombo + | | + TfpgComboBox TfpgBaseColorCombo + | + TfpgColorComboBox +} + +interface + +uses + Classes, + SysUtils, + fpg_base, + fpg_main, + fpg_widget, + fpg_popupwindow, + fpg_combobox; + +type + TAllowNew = (anNo, anYes, anAsk); + + + { TfpgBaseEditCombo } + + TfpgBaseEditCombo = class(TfpgBaseComboBox) + private + FAutoCompletion: Boolean; + FAllowNew: TAllowNew; + FText: string; + FSelectedItem: integer; + FMaxLength: integer; + FNewItem: boolean; + procedure SetAllowNew(const AValue: TAllowNew); + procedure InternalBtnClick(Sender: TObject); + procedure InternalListBoxSelect(Sender: TObject); + procedure InternalListBoxKeyPress(Sender: TObject; var keycode: word; var shiftstate: TShiftState; + var consumed: Boolean); + protected + FMargin: integer; + FDropDown: TfpgPopupWindow; + FDrawOffset: integer; + FSelStart: integer; + FSelOffset: integer; + FCursorPos: integer; + procedure DoDropDown; override; + function GetText: string; virtual; + function HasText: boolean; virtual; + procedure SetText(const AValue: string); virtual; + procedure HandleResize(AWidth, AHeight: TfpgCoord); override; + procedure HandleKeyChar(var AText: TfpgChar; var shiftstate: TShiftState; var consumed: Boolean); override; + procedure HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: Boolean); override; + procedure HandleLMouseDown(x, y: integer; shiftstate: TShiftState); override; + procedure HandleLMouseUp(x, y: integer; shiftstate: TShiftState); override; + procedure HandlePaint; override; + property AutoCompletion: Boolean read FAutocompletion write FAutoCompletion default False; + property AllowNew: TAllowNew read FAllowNew write SetAllowNew default anNo; + property BackgroundColor default clBoxColor; + property TextColor default clText1; + property Text: string read GetText write SetText; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure Update; + property NewText: boolean read FNewItem; + end; + + + TfpgEditCombo = class(TfpgBaseEditCombo) + published + property AutoCompletion; + property AllowNew; + property BackgroundColor; + property DropDownCount; + property FocusItem; + property FontDesc; + property Height; + property Items; + property Text; + property TextColor; + property Width; + property OnChange; + property OnCloseUp; + property OnDropDown; + property OnEnter; + property OnExit; + property OnKeyPress; + end; + + +function CreateEditCombo(AOwner: TComponent; x, y, w: TfpgCoord; AList:TStringList; ACompletion: boolean = False; + ANew: TAllowNew = anNo; h: TfpgCoord = 0): TfpgEditCombo; + + +implementation + +uses + fpg_stringutils, + fpg_constants, + fpg_listbox, + fpg_dialogs, + math; + +var + OriginalFocusRoot: TfpgWidget; + +type + { This is the class representing the dropdown window of the combo box. } + TDropDownWindow = class(TfpgPopupWindow) + private + FCallerWidget: TfpgWidget; + ListBox: TfpgListBox; + protected + procedure HandlePaint; override; + procedure HandleKeyChar(var AText: TfpgChar; var shiftstate: TShiftState; var consumed: Boolean); override; + procedure HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override; + procedure HandleShow; override; + procedure HandleHide; override; + public + constructor Create(AOwner: TComponent); override; + property CallerWidget: TfpgWidget read FCallerWidget write FCallerWidget; + end; + + +{ TDropDownWindow } + +procedure TDropDownWindow.HandlePaint; +begin + Canvas.BeginDraw; +// inherited HandlePaint; + Canvas.Clear(clWhite); + Canvas.EndDraw; +end; + +procedure TDropDownWindow.HandleKeyChar(var AText: TfpgChar; + var shiftstate: TShiftState; var consumed: Boolean); +begin + if TfpgEditCombo(FCallerWidget).FAutoCompletion then + TfpgEditCombo(FCallerWidget).HandleKeyChar(AText,shiftstate,consumed); +end; + +procedure TDropDownWindow.HandleKeyPress(var keycode: word; + var shiftstate: TShiftState; var consumed: boolean); +begin + if TfpgEditCombo(FCallerWidget).FAutoCompletion then + begin + TfpgEditCombo(FCallerWidget).HandleKeyPress(keycode,shiftstate,consumed); +// consumed:= True; + end + else + begin + inherited HandleKeyPress(keycode, shiftstate, consumed); + if keycode = keyEscape then + begin + consumed := True; + Close; + end; + end; +end; + +procedure TDropDownWindow.HandleShow; +begin + ListBox.SetPosition(0, 0, Width, Height); + inherited HandleShow; + ActiveWidget := ListBox; +end; + +procedure TDropDownWindow.HandleHide; +begin + // HandleHide also gets called in TfpgWidget.Destroy so we need a few + // if Assigned() tests here. This should be improved on. +// if Assigned(FocusRootWidget) then +// FocusRootWidget.ReleaseMouse; // for internal ListBox + + if Assigned(CallerWidget) then + CallerWidget.SetFocus; + inherited HandleHide; +end; + +constructor TDropDownWindow.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + ListBox := TfpgListBox.Create(self); + ListBox.PopupFrame := True; +end; + +function CreateEditCombo(AOwner: TComponent; x, y, w: TfpgCoord; AList:TStringList; ACompletion: boolean = False; + ANew: TAllowNew = anNo; h: TfpgCoord = 0): TfpgEditCombo; +begin + Result := TfpgEditCombo.Create(AOwner); + Result.Left := x; + Result.Top := y; + Result.Width := w; + Result.Focusable := True; + Result.AutoCompletion := ACompletion; + Result.AllowNew := ANew; + if h < TfpgEditCombo(Result).Font.Height + 6 then + Result.Height:= TfpgEditCombo(Result).Font.Height + 6 + else + Result.Height:= h; + + if Assigned(AList) then + Result.Items.Assign(AList); +end; + +{ TfpgBaseEditCombo } + +procedure TfpgBaseEditCombo.SetAllowNew(const AValue: TAllowNew); +begin + if FAllowNew <> AValue then + FAllowNew := AValue; +end; + +function TfpgBaseEditCombo.GetText: string; +var + i: integer; +begin + if FAutoCompletion then + Result := FText + else + if (FocusItem >= 0) and (FocusItem <= FItems.Count-1) then + Result := FItems.Strings[FocusItem] + else + Result := ''; +end; + +function TfpgBaseEditCombo.HasText: boolean; +begin + Result := FFocusItem >= 0; +end; + +procedure TfpgBaseEditCombo.DoDropDown; +var + ddw: TDropDownWindow; + rowcount, i: integer; + r: TfpgRect; +begin + if (not Assigned(FDropDown)) or (not FDropDown.HasHandle) then + begin + FreeAndNil(FDropDown); + OriginalFocusRoot := FocusRootWidget; + FDropDown := TDropDownWindow.Create(nil); + ddw := TDropDownWindow(FDropDown); + ddw.Width := Width; + ddw.CallerWidget := self; + ddw.ListBox.OnSelect := @InternalListBoxSelect; + ddw.ListBox.OnKeyPress := @InternalListBoxKeyPress; + + // Assign combobox text items to internal listbox + if FAutoCompletion then + begin + for i := 0 to FItems.Count-1 do + if SameText(UTF8Copy(FItems.Strings[i], 1, UTF8Length(FText)), FText) then + ddw.ListBox.Items.Add(FItems.Strings[i]); + end + else + ddw.ListBox.Items.Assign(FItems); + + // adjust the height of the dropdown + rowcount := ddw.ListBox.Items.Count; + if rowcount > DropDownCount then + rowcount := DropDownCount; + if rowcount < 1 then + rowcount := 1; + ddw.Height := (ddw.ListBox.RowHeight * rowcount) + 4; + ddw.ListBox.Height := ddw.Height; // needed in follow focus, otherwise, the default value (80) is used + + // set default focusitem + ddw.ListBox.FocusItem := FFocusItem; + + ddw.DontCloseWidget := self; // now we can control when the popup window closes + r := GetDropDownPos(Parent, self, ddw); + ddw.Height := r.Height; + + if (FItems.Count > 0) then + DoOnDropDown; + ddw.OnClose := @InternalOnClose; + + ddw.ShowAt(Parent, r.Left, r.Top); + end + else + begin + FBtnPressed := False; + ddw := TDropDownWindow(FDropDown); + ddw.Close; + FreeAndNil(FDropDown); + end; +end; + +procedure TfpgBaseEditCombo.InternalBtnClick(Sender: TObject); +begin + DoDropDown; +end; + +procedure TfpgBaseEditCombo.InternalListBoxSelect(Sender: TObject); +var + i: Integer; +begin + for i := 0 to Items.Count-1 do + begin + if Items[i]= TDropDownWindow(FDropDown).ListBox.Items[TDropDownWindow(FDropDown).ListBox.FocusItem] then + begin + FocusItem := i; + FSelectedItem:= i; + FText:= Items[i]; + Break; + end; + end; + FDropDown.Close; + //Repaint will check if Handle is created + Repaint; +end; + +procedure TfpgBaseEditCombo.InternalListBoxKeyPress(Sender: TObject; var keycode: word; + var shiftstate: TShiftState; var consumed: Boolean); +var + i: Integer; +begin + if ((keycode = keyUp) or (keycode = keyDown)) and (TDropDownWindow(FDropDown).ListBox.FocusItem > -1) then + for i := 0 to Items.Count-1 do + begin + if Items[i]= TDropDownWindow(FDropDown).ListBox.Items[TDropDownWindow(FDropDown).ListBox.FocusItem] then + begin + FSelectedItem:= i; + Break; + end; + end; + + //Repaint will check if Handle is created + Repaint; +end; + +procedure TfpgBaseEditCombo.SetText(const AValue: string); +var + i: integer; +begin + if AValue = '' then + begin + FText:= ''; + FocusItem := -1; // nothing selected + end + else + begin + for i := 0 to Items.Count-1 do + begin + if SameText(UTF8Copy(Items.Strings[i], 1, UTF8Length(AVAlue)), AValue) then + begin + FocusItem := i; + FText:= AValue; + Repaint; + Exit; //==> + end; + end; + // if we get here, we didn't find a match + FocusItem := -1; + end; +end; + +procedure TfpgBaseEditCombo.HandleResize(AWidth, AHeight: TfpgCoord); +begin + inherited HandleResize(AWidth, AHeight); + if FSizeIsDirty then + CalculateInternalButtonRect; +end; + +procedure TfpgBaseEditCombo.HandleKeyChar(var AText: TfpgChar; + var shiftstate: TShiftState; var consumed: Boolean); +var + s: TfpgChar; + prevval: string; + i: integer; +begin + prevval := FText; + s := AText; + consumed := False; + if FText = '' then + FNewItem := False; + + // Handle only printable characters + // Note: This is now UTF-8 compliant! + if Enabled and (Ord(AText[1]) > 31) and (Ord(AText[1]) < 127) or (Length(AText) > 1) then + begin + if (FMaxLength <= 0) or (UTF8Length(FText) < FMaxLength) then + begin + UTF8Insert(s, FText, FCursorPos + UTF8Length(s)); + Inc(FCursorPos); + FSelStart := FCursorPos; + if Assigned(FDropDown) then + FDropDown.Close; + FSelectedItem := -1; + for i := 0 to FItems.Count-1 do + if SameText(UTF8Copy(FItems.Strings[i], 1, UTF8Length(FText)), FText) then + begin + FSelectedItem:= i; + DoDropDown; + Break; + end; + if FSelectedItem = -1 then + if FAllowNew = anNo then + begin + UTF8Delete(FText, FCursorPos, 1); + Dec(FCursorPos); + FSelStart := FCursorPos; + for i := 0 to FItems.Count-1 do + if SameText(UTF8Copy(FItems.Strings[i], 1, UTF8Length(FText)), FText) then + begin + FSelectedItem:= i; + DoDropDown; + Break; + end; + end + else + FNewItem:= True; + end; + consumed := True; + end; + + if prevval <> FText then + DoOnChange; + + if consumed then + RePaint; +// else + inherited HandleKeyChar(AText, shiftstate, consumed); +end; + +procedure TfpgBaseEditCombo.HandleKeyPress(var keycode: word; + var shiftstate: TShiftState; var consumed: boolean); +var + hasChanged: boolean; + i: integer; +begin + hasChanged := False; + + if not Enabled then + consumed := False + else + begin + consumed := True; + + case keycode of + keyBackSpace: + begin + if FCursorPos > 0 then + begin + UTF8Delete(FText, FCursorPos, 1); + Dec(FCursorPos); + FSelStart := FCursorPos; + if Assigned(FDropDown) then + FDropDown.Close; + FSelectedItem := -1; + for i := 0 to FItems.Count-1 do + if SameText(UTF8Copy(FItems.Strings[i], 1, UTF8Length(FText)), FText) then + begin + FSelectedItem:= i; + if FNewItem then + FNewItem:= False; + DoDropDown; + Break; + end; + hasChanged := True; + end; + end; + keyDelete: + begin + if FAllowNew <> anNo then + begin + FocusItem := -1; + FSelectedItem := -1; + FNewItem:= True; + hasChanged := True; + end; + end; + + keyReturn, + keyPEnter: + begin + if FSelectedItem > -1 then + SetText(Items[FSelectedItem]) + else + FocusItem:= -1; + if FNewItem then + case FAllowNew of + anYes: + FItems.Add(FText); + anAsk: + begin + if TfpgMessageDialog.Question(rsNewItemDetected, Format(rsAddNewItem, [FText])) = mbYes then + begin + FItems.Add(FText); + FocusItem := Pred(FItems.Count); + end + else + begin + FNewItem:= False; + FocusItem := -1; + FText:= ''; + end; { if/else } + Parent.ActivateWindow; + end; + end; + hasChanged := True; + if Assigned(FDropDown) then + FDropDown.Close; + end; + else + begin + Consumed := False; + end; + end; + end; + + if Consumed then + begin + FSelStart := FCursorPos; + FSelOffset := 0; + end; + + if consumed and hasChanged then + RePaint; + + if hasChanged then + DoOnChange; + inherited HandleKeyPress(keycode, shiftstate, consumed); +end; + +procedure TfpgBaseEditCombo.HandleLMouseDown(x, y: integer; + shiftstate: TShiftState); +begin + inherited HandleLMouseDown(x, y, shiftstate); + // button state is down only if user clicked in the button rectangle. + FBtnPressed := PtInRect(FInternalBtnRect, Point(x, y)); + if not FAutoCompletion then + begin + PaintInternalButton; + DoDropDown; + end + else if FBtnPressed then + begin + PaintInternalButton; + DoDropDown; + end; +end; + +procedure TfpgBaseEditCombo.HandleLMouseUp(x, y: integer; + shiftstate: TShiftState); +begin + inherited HandleLMouseUp(x, y, shiftstate); + FBtnPressed := False; + PaintInternalButton; +end; + +procedure TfpgBaseEditCombo.HandlePaint; +var + r: TfpgRect; + tw, tw2, st, len: integer; + Texte: string; + + // paint selection rectangle + procedure DrawSelection; + var + lcolor: TfpgColor; + begin + if Focused then + begin + lcolor := clSelection; + Canvas.SetTextColor(clSelectionText); + end + else + begin + lcolor := clInactiveSel; + Canvas.SetTextColor(clText1); + end; + + len := FSelOffset; + st := FSelStart; + if len < 0 then + begin + st := st + len; + len := -len; + end; + tw := Font.TextWidth(UTF8Copy(Items[FSelectedItem], 1, st)); + tw2 := Font.TextWidth(UTF8Copy(Items[FSelectedItem], 1, st + len)); + + // XOR on Anti-aliased text doesn't look to good. Lets try standard + // Blue & White like what was doen in TfpgEdit. +{ Canvas.SetColor(lcolor); + Canvas.FillRectangle(-FDrawOffset + FMargin + tw, 3, tw2 - tw, Font.Height); + r.SetRect(-FDrawOffset + FMargin + tw, 3, tw2 - tw, Font.Height); + Canvas.AddClipRect(r); + Canvas.SetTextColor(clWhite); + fpgStyle.DrawString(Canvas, -FDrawOffset + FMargin, 3, Text, Enabled); + Canvas.ClearClipRect; +} + Canvas.XORFillRectangle(fpgColorToRGB(lcolor) xor $FFFFFF, + -FDrawOffset + FMargin + tw, 3, tw2 - tw, Font.Height); + end; + +begin + Canvas.BeginDraw; +// inherited HandlePaint; + Canvas.ClearClipRect; + r.SetRect(0, 0, Width, Height); + Canvas.DrawControlFrame(r); + + // internal background rectangle (without frame) + InflateRect(r, -2, -2); + Canvas.SetClipRect(r); + + if Enabled then + Canvas.SetColor(FBackgroundColor) + else + Canvas.SetColor(clWindowBackground); + + Canvas.FillRectangle(r); + + // paint the fake dropdown button + PaintInternalButton; + + Dec(r.Width, FInternalBtnRect.Width); + Canvas.SetClipRect(r); + Canvas.SetFont(Font); + + if not AutoCompletion then + if Focused then + begin + Canvas.SetColor(clSelection); + Canvas.SetTextColor(clSelectionText); + InflateRect(r, -1, -1); + end + else + begin + if Enabled then + Canvas.SetColor(FBackgroundColor) + else + Canvas.SetColor(clWindowBackground); + Canvas.SetTextColor(FTextColor); + end + else + begin + if Enabled then + Canvas.SetColor(FBackgroundColor) + else + Canvas.SetColor(clWindowBackground); + Canvas.SetTextColor(FTextColor); + end; + Canvas.FillRectangle(r); + + // Draw select item's text + if not AutoCompletion then + begin + if HasText then + fpgStyle.DrawString(Canvas, FMargin+1, FMargin, Text, Enabled); + end + else + begin + if HasText then + begin + FSelOffset := 0; + fpgStyle.DrawString(Canvas, FMargin+1, FMargin, Text, Enabled); + end + else + begin + Texte := Text; + if Texte <> '' then + if FSelectedItem > -1 then + begin + FSelOffset := Font.TextWidth(UTF8Copy(Items[FSelectedItem], UTF8Length(FText) + 1, + UTF8Length(Items[FSelectedItem]) - UTF8Length(FText))); + fpgStyle.DrawString(Canvas, FMargin+1, FMargin, FText + UTF8Copy(Items[FSelectedItem], + UTF8Length(FText) + 1, UTF8Length(Items[FSelectedItem]) - UTF8Length(FText)), Enabled); + end + else + begin + FSelOffset := 0; + fpgStyle.DrawString(Canvas, FMargin+1, FMargin, FText, Enabled); + end; + end; + + if Focused then + begin + // drawing selection + if FSelOffset <> 0 then + DrawSelection; + + // drawing cursor + FCursorPos:= UTF8Length(FText); + tw := Font.TextWidth(UTF8Copy(FText, 1, FCursorPos)); + fpgCaret.SetCaret(Canvas, -FDrawOffset + FMargin + tw, 3, fpgCaret.Width, Font.Height); + end + else + fpgCaret.UnSetCaret(Canvas); + end; + + Canvas.EndDraw; +end; + +constructor TfpgBaseEditCombo.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FBackgroundColor := clBoxColor; + FTextColor := Parent.TextColor; + FWidth := 120; + FHeight := Font.Height + 6; + FMargin := 3; + FFocusable := True; + FAutocompletion := False; + FAllowNew := anNo; + + FText := ''; + FCursorPos := UTF8Length(FText); + FSelStart := FCursorPos; + FSelOffset := 0; + FDrawOffset := 0; + FSelectedItem := -1; // to allow typing if list is empty + FNewItem := False; + + CalculateInternalButtonRect; +end; + +destructor TfpgBaseEditCombo.Destroy; +begin + FDropDown.Free; + inherited Destroy; +end; + +procedure TfpgBaseEditCombo.Update; +begin + FFocusItem := -1; + Repaint; +end; + +end. diff --git a/src/gui/fpg_form.pas b/src/gui/fpg_form.pas new file mode 100644 index 00000000..f9740a36 --- /dev/null +++ b/src/gui/fpg_form.pas @@ -0,0 +1,429 @@ +{ + fpGUI - Free Pascal GUI Toolkit + + Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this + distribution, for details of the copyright. + + See the file COPYING.modifiedLGPL, included in this distribution, + for details about redistributing fpGUI. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + Description: + Defines a Form control. Also known as a Window which holds other + controls. +} + +unit fpg_form; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, + SysUtils, + fpg_base, + fpg_widget; + +type + TWindowPosition = (wpUser, wpAuto, wpScreenCenter); + TCloseAction = (caNone, caHide, caFree{, caMinimize}); + + TFormCloseEvent = procedure(Sender: TObject; var CloseAction: TCloseAction) of object; + TFormCloseQueryEvent = procedure(Sender: TObject; var CanClose: boolean) of object; + + TfpgBaseForm = class(TfpgWidget) + private + FFullScreen: boolean; + FOnActivate: TNotifyEvent; + FOnClose: TFormCloseEvent; + FOnCloseQuery: TFormCloseQueryEvent; + FOnCreate: TNotifyEvent; + FOnDeactivate: TNotifyEvent; + FOnDestroy: TNotifyEvent; + FOnHide: TNotifyEvent; + FOnShow: TNotifyEvent; + protected + FModalResult: TfpgModalResult; + FParentForm: TfpgBaseForm; + FWindowPosition: TWindowPosition; + FWindowTitle: string; + FSizeable: boolean; + procedure AdjustWindowStyle; override; + procedure SetWindowParameters; override; + procedure SetWindowTitle(const ATitle: string); override; + procedure MsgActivate(var msg: TfpgMessageRec); message FPGM_ACTIVATE; + procedure MsgDeActivate(var msg: TfpgMessageRec); message FPGM_DEACTIVATE; + procedure MsgClose(var msg: TfpgMessageRec); message FPGM_CLOSE; + procedure HandlePaint; override; + procedure HandleClose; virtual; + procedure HandleHide; override; + procedure HandleShow; override; + procedure HandleMove(x, y: TfpgCoord); override; + procedure HandleResize(awidth, aheight: TfpgCoord); override; + procedure HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override; + procedure DoOnClose(var CloseAction: TCloseAction); virtual; + // properties + property Sizeable: boolean read FSizeable write FSizeable; + property ModalResult: TfpgModalResult read FModalResult write FModalResult; + property FullScreen: boolean read FFullScreen write FFullScreen default False; + property WindowPosition: TWindowPosition read FWindowPosition write FWindowPosition default wpAuto; + property WindowTitle: string read FWindowTitle write SetWindowTitle; + // events + property OnActivate: TNotifyEvent read FOnActivate write FOnActivate; + property OnClose: TFormCloseEvent read FOnClose write FOnClose; + property OnCloseQuery: TFormCloseQueryEvent read FOnCloseQuery write FOnCloseQuery; + property OnCreate: TNotifyEvent read FOnCreate write FOnCreate; + property OnDeactivate: TNotifyEvent read FOnDeactivate write FOnDeactivate; + property OnDestroy: TNotifyEvent read FOnDestroy write FOnDestroy; + property OnHide: TNotifyEvent read FOnHide write FOnHide; + property OnShow: TNotifyEvent read FOnShow write FOnShow; + public + constructor Create(AOwner: TComponent); override; + procedure AfterConstruction; override; + procedure BeforeDestruction; override; + procedure AfterCreate; virtual; + procedure Show; + procedure Hide; + function ShowModal: integer; + procedure Close; + function CloseQuery: boolean; virtual; + end; + + + TfpgForm = class(TfpgBaseForm) + published + property BackgroundColor; + property FullScreen; + property ModalResult; + property Sizeable; + property ShowHint; + property TextColor; + property WindowPosition; + property WindowTitle; + property OnActivate; + property OnClose; + property OnCloseQuery; + property OnCreate; + property OnDeactivate; + property OnDestroy; + property OnHide; + property OnPaint; + property OnResize; + property OnShow; + end; + + +function WidgetParentForm(wg: TfpgWidget): TfpgForm; + + +implementation + +uses + fpg_main, + fpg_popupwindow, + fpg_menu; + +type + // to access protected methods + TfpgMenuBarFriend = class(TfpgMenuBar) + end; + + +function WidgetParentForm(wg: TfpgWidget): TfpgForm; +var + w: TfpgWidget; +begin + w := wg; + while w <> nil do + begin + if w is TfpgForm then + begin + Result := TfpgForm(w); + Exit; //==> + end; + w := w.Parent; + end; + Result := nil; +end; + +{ TfpgBaseForm } + +procedure TfpgBaseForm.SetWindowTitle(const ATitle: string); +begin + FWindowTitle := ATitle; + inherited SetWindowTitle(ATitle); +end; + +procedure TfpgBaseForm.MsgActivate(var msg: TfpgMessageRec); +begin +// writeln('BaseForm - MsgActivate'); + if (fpgApplication.TopModalForm = nil) or (fpgApplication.TopModalForm = self) then + begin + FocusRootWidget := self; + + if FFormDesigner <> nil then + begin + FFormDesigner.Dispatch(msg); + Exit; + end; + + if ActiveWidget = nil then + ActiveWidget := FindFocusWidget(nil, fsdFirst) + else + ActiveWidget.SetFocus; + end; + + if Assigned(FOnActivate) then + FOnActivate(self); +end; + +procedure TfpgBaseForm.MsgDeActivate(var msg: TfpgMessageRec); +begin + ClosePopups; + if ActiveWidget <> nil then + ActiveWidget.KillFocus; + if Assigned(FOnDeactivate) then + FOnDeactivate(self); +end; + +procedure TfpgBaseForm.HandlePaint; +begin + inherited HandlePaint; + Canvas.Clear(FBackgroundColor); +end; + +procedure TfpgBaseForm.AdjustWindowStyle; +begin + if fpgApplication.MainForm = nil then + fpgApplication.MainForm := self; + + if FWindowPosition = wpAuto then + Include(FWindowAttributes, waAutoPos) + else + Exclude(FWindowAttributes, waAutoPos); + + if FWindowPosition = wpScreenCenter then + Include(FWindowAttributes, waScreenCenterPos) + else + Exclude(FWindowAttributes, waScreenCenterPos); + + if FSizeable then + Include(FWindowAttributes, waSizeable) + else + Exclude(FWindowAttributes, waSizeable); + + if FFullScreen then + Include(FWindowAttributes, waFullScreen) + else + Exclude(FWindowAttributes, waFullScreen); +end; + +procedure TfpgBaseForm.SetWindowParameters; +begin + inherited; + DoSetWindowTitle(FWindowTitle); +end; + +constructor TfpgBaseForm.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FWindowPosition := wpAuto; + FWindowTitle := ''; + FSizeable := True; + FParentForm := nil; + FBackgroundColor := clWindowBackground; + FTextColor := clText1; + FMinWidth := 32; + FMinHeight := 32; + FModalResult := mrNone; + FFullScreen := False; + FIsContainer := True; +end; + +procedure TfpgBaseForm.AfterCreate; +begin + // for the user +end; + +procedure TfpgBaseForm.Show; +begin + FVisible := True; + HandleShow; +end; + +function TfpgBaseForm.ShowModal: integer; +var + lCloseAction: TCloseAction; +begin + FWindowType := wtModalForm; + fpgApplication.PushModalForm(self); + ModalResult := mrNone; + + Show; + + // processing messages until this form ends. + // delivering the remaining messages + fpgApplication.ProcessMessages; + try + repeat + fpgWaitWindowMessage; + until (ModalResult <> mrNone) or (not Visible); + except + on E: Exception do + begin + ModalResult := -1; + Visible := False; + fpgApplication.HandleException(self); + end; + end; + + fpgApplication.PopModalForm; + Result := ModalResult; + + if ModalResult <> mrNone then + begin + lCloseAction := caFree; // Dummy variable - we do nothing with it + DoOnClose(lCloseAction); // Simply so the OnClose event fires. + end; +end; + +procedure TfpgBaseForm.MsgClose(var msg: TfpgMessageRec); +begin + HandleClose; +end; + +procedure TfpgBaseForm.HandleClose; +begin + Close; +end; + +procedure TfpgBaseForm.HandleHide; +begin + if Assigned(FOnHide) then + FOnHide(self); + inherited HandleHide; +end; + +procedure TfpgBaseForm.HandleShow; +begin + inherited HandleShow; + HandleAlignments(0, 0); + if Assigned(FOnShow) then + FOnShow(self); +end; + +procedure TfpgBaseForm.HandleMove(x, y: TfpgCoord); +begin + ClosePopups; + inherited HandleMove(x, y); +end; + +procedure TfpgBaseForm.HandleResize(awidth, aheight: TfpgCoord); +begin + ClosePopups; + inherited HandleResize(awidth, aheight); +end; + +procedure TfpgBaseForm.HandleKeyPress(var keycode: word; + var shiftstate: TShiftState; var consumed: boolean); +var + i: integer; + wg: TfpgWidget; +begin +// writeln(Classname, '.Keypress'); + // find the TfpgMenuBar + if not consumed then + begin + for i := 0 to ComponentCount-1 do + begin + wg := TfpgWidget(Components[i]); + if (wg <> nil) and (wg <> self) and (wg is TfpgMenuBar) then + begin + TfpgMenuBarFriend(wg).HandleKeyPress(keycode, shiftstate, consumed); + Break; //==> + end; + end; + end; { if } + + inherited HandleKeyPress(keycode, shiftstate, consumed); +end; + +procedure TfpgBaseForm.AfterConstruction; +begin + inherited AfterConstruction; + AfterCreate; + if Assigned(FOnCreate) then + FOnCreate(self); +end; + +procedure TfpgBaseForm.BeforeDestruction; +begin + inherited BeforeDestruction; + if Assigned(FOnDestroy) then + FOnDestroy(self); +end; + +procedure TfpgBaseForm.DoOnClose(var CloseAction: TCloseAction); +begin + if Assigned(FOnClose) then + OnClose(self, CloseAction); +end; + +procedure TfpgBaseForm.Hide; +begin + Visible := False; +// HandleHide; + if ModalResult = mrNone then + ModalResult := -1; +end; + +procedure TfpgBaseForm.Close; +var + CloseAction: TCloseAction; + IsMainForm: Boolean; +begin + if CloseQuery then // May we close the form? User could override decision + begin + IsMainForm := fpgApplication.MainForm = self; + if IsMainForm then + CloseAction := caFree + else + CloseAction := caHide; + + // execute event handler - maybe user wants to modify it. + DoOnClose(CloseAction); + // execute action according to close action + case CloseAction of + caHide: + begin + Hide; + end; + // fpGUI Forms don't have a WindowState property yet! +// caMinimize: WindowState := wsMinimized; + caFree: + begin + HandleHide; + if IsMainForm then + fpgApplication.Terminate + else + // We can't free ourselves, somebody else needs to do it + fpgPostMessage(Self, fpgApplication, FPGM_CLOSE); + end; + end; { case CloseAction } + end; { if CloseQuery } +end; + +function TfpgBaseForm.CloseQuery: boolean; +begin + Result := True; + if Assigned(FOnCloseQuery) then + FOnCloseQuery(self, Result); +end; + + +end. + diff --git a/src/gui/fpg_gauge.pas b/src/gui/fpg_gauge.pas new file mode 100644 index 00000000..b8678828 --- /dev/null +++ b/src/gui/fpg_gauge.pas @@ -0,0 +1,572 @@ +{ + fpGUI - Free Pascal GUI Toolkit + + Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this + distribution, for details of the copyright. + + See the file COPYING.modifiedLGPL, included in this distribution, + for details about redistributing fpGUI. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + Description: + A Gauge component that supports different display styles. eg: Needle, + Dial, Pie etc. +} + +unit fpg_gauge; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, math, + fpg_base, + fpg_main, + fpg_widget; + +type + + TGaugeKind = (gkText, gkHorizontalBar, gkVerticalBar, gkPie, gkNeedle, gkDial); + + TBorderStyle = (bsNone, bsSingle, bsDouble, bsRaisedPanel, bsSunkenPanel, + bsRaised3D, bsSunken3D, bsEtched, bsEmmbossed); + + + TfpgGauge = class(TfpgWidget) + private + FFont: TfpgFont; + FClientRect: TfpgRect; + FMin: Longint; + FMax: Longint; + FPosition: Longint; + FKind: TGaugeKind; + FShowText: Boolean; + { TODO: Implement Border style } + FBorderStyle: TBorderStyle; + FColor: TfpgColor; // Background color + { Currently little used colors, should be derived from style and possibly + overriden by user TODO - How to deal with gradients? Starting color and compute ending, + or give pair? } + FFirstColor: TfpgColor; // Text and Needle color + FSecondColor: TfpgColor; // Bar, Pie etc. main color + { TODO: Currently unused. Implement Low Watermark and High Watermark } +// FLWMColor: TfpgColor; // Low Watermark Color +// FLWMValue: Longint; // Low Watermark Value +// FHWMColor: TfpgColor; // High Watermark Color +// FHWMValue: Longint; // High Watermark Color + procedure BackgroundDraw; + procedure TextDraw; + procedure BarDraw; + procedure PieDraw; + procedure NeedleDraw; + procedure DialDraw; + procedure SetGaugeKind(AValue: TGaugeKind); + procedure SetShowText(AValue: Boolean); + procedure SetBorderStyle(AValue: TBorderStyle); + procedure SetFirstColor(AValue: TfpgColor); + procedure SetSecondColor(AValue: TfpgColor); + procedure SetMin(AValue: Longint); + procedure SetMax(AValue: Longint); + procedure SetProgress(AValue: Longint); + function GetPercentage: Longint; + protected + procedure HandlePaint; override; + public + constructor Create(AOwner: TComponent); override; + procedure AddProgress(AValue: Longint); + property Percentage: Longint read GetPercentage; + property Font: TfpgFont read FFont; + published + property Align; + property Anchors; + property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle; + property Color: TfpgColor read FColor write FColor default clButtonFace; + property Enabled; + property FirstColor: TfpgColor read FFirstColor write SetFirstColor default clBlack; + property Kind: TGaugeKind read FKind write SetGaugeKind default gkHorizontalBar; + property MaxValue: Longint read FMax write SetMax default 100; + property MinValue: Longint read FMin write SetMin default 0; + property ParentShowHint; + property Progress: Longint read FPosition write SetProgress; + property SecondColor: TfpgColor read FSecondColor write SetSecondColor default clWhite; + property ShowHint; + property ShowText: Boolean read FShowText write SetShowText default True; + property Visible; + end; + + +// A convenience function to quickly create a gauge from code +function CreateGauge (AOwner: TComponent; ALeft, ATop, AWidth, + AHeight: TfpgCoord; AKind: TGaugeKind ): TfpgGauge; + + +implementation + +uses + fpg_wuline; + +{ This procedure draws a filled arc with a color gradient - + to be moved in CanvasBase? } +procedure FillArcGradient(canvas: TfpgCanvas; X,Y,W,H: TfpgCoord; a1,a2: double; Astart,Astop: TfpgColor); +var + RGBStart: TRGBTriple; + RGBStop: TRGBTriple; + RDiff, GDiff, BDiff: Integer; + count: Integer; + i: Integer; + newcolor: TRGBTriple; +begin + if Astart = Astop then + begin { No gradient, just solid color} + canvas.SetColor(Astart); + canvas.FillArc(X, Y, W, H, a1, a2); + Exit; //==> + end; + + RGBStart := fpgColorToRGBTriple(fpgColorToRGB(AStart)); + RGBStop := fpgColorToRGBTriple(fpgColorToRGB(AStop)); + + count := min(H,W); + count := count div 2; + count := count -2 ; + + RDiff := RGBStop.Red - RGBStart.Red; + GDiff := RGBStop.Green - RGBStart.Green; + BDiff := RGBStop.Blue - RGBStart.Blue; + + + { X11 draws arcs at one pixel distance without leaving out pixels, so Line Width + of 1 would be appropriate, but GDI doesn't, and therefore Line Width 2 is + required to make both work} + + //canvas.SetLineStyle(1,lsSolid); + canvas.SetLineStyle(2,lsSolid); + for i := 0 to count do + begin + X := X + 1; + Y := Y + 1; + W := W - 2; + H := H - 2; + newcolor.Red := RGBStart.Red + (i * RDiff) div count; + newcolor.Green := RGBStart.Green + (i * GDiff) div count; + newcolor.Blue := RGBStart.Blue + (i * BDiff) div count; + canvas.SetColor(RGBTripleTofpgColor(newcolor)); + canvas.DrawArc(X, Y, W, H, a1, a2); + end; +end; + +function CreateGauge(AOwner: TComponent; ALeft, ATop, AWidth, AHeight: TfpgCoord; + AKind: TGaugeKind): TfpgGauge; +begin + Result := TfpgGauge.Create(AOwner); + Result.Left := ALeft; + Result.Top := ATop; + Result.Width := AWidth; + Result.Height := AHeight; + Result.Kind := AKind; +end; + +{ TfpgGauge } + +{ Drawing procedures - they're called from HandlePaint, which takes care of + Canvas.BeginDraw and Canvas.EndDraw - Shouldn't be used otherwise. } +procedure TfpgGauge.BackgroundDraw; +begin + {common Background for all kinds } + + {Client area is Widget area, to start with} + FClientRect.SetRect(0, 0, Width, Height); + Canvas.ClearClipRect; + Canvas.Clear(Color); + { This must be adjusted according the selected style } + Canvas.SetColor(TfpgColor($999999)); + Canvas.SetLineStyle(1, lsSolid); + Canvas.DrawRectangle(FClientRect); + { This must be completed and adjusted with border style } + InflateRect(FClientRect, -1, -1); + with FClientRect do + begin + { Kind specific Bacground } + case FKind of + { Currently Text doesn't require additional Bacground } + { And so horizontal and vertical bar - Unless style requires it} + gkHorizontalBar, + gkVerticalBar: + begin + Canvas.SetLineStyle(1, lsSolid); // just in case background changed that + end; + gkPie: + begin + { Round frame for the Pie } + Canvas.SetLineStyle(2, lsSolid); + Canvas.SetColor(TfpgColor($98b2ed)); + Canvas.DrawArc(Left, Top, Width, Height, 0, 360); + end; + gkNeedle: + begin + { Half a filled circle background for needle } + FillArcGradient(Canvas,Left, Top, Width, Height * 2 -1, 0, 180,TfpgColor($425d9b),TfpgColor($98b2ed)); + Canvas.SetLineStyle(2, lsSolid); + //Canvas.SetColor(TfpgColor($3b4c71)); + Canvas.SetColor(TfpgColor($98b2ed)); + Canvas.DrawArc(Left, Top, Width, Height * 2 - 1, 0, 180); + Canvas.SetLineStyle(1, lsSolid); + Canvas.SetColor(TfpgColor($3b4c71)); + Canvas.DrawLine(Left, Bottom,Left + Width, Bottom); + end; + gkDial: + begin + { 270° pie shaped background for Dial } + FillArcGradient (Canvas,Left, Top, Width, Height , 225, -270 ,TfpgColor($425d9b),TfpgColor($98b2ed)); + Canvas.SetLineStyle(2, lsSolid); + //Canvas.SetColor(TfpgColor($3b4c71)); + Canvas.SetColor(TfpgColor($98b2ed)); + Canvas.DrawArc(Left,Top,Width,Height,225,-270); + end; + end; + end; { with } +end; + +procedure TfpgGauge.TextDraw; +var + S: string; + X, Y: Integer; +begin + S := Format('%d%%', [Percentage]); + with FClientRect do + begin + X := (Width - FFont.TextWidth(S)) div 2; + Y := (Height - FFont.Height) div 2; + if Kind = gkDial then + Y := Y + (Y div 2); + end; +{ If contrast is poor we might use a Xor function } + Canvas.SetTextColor(FirstColor); + Canvas.Font := FFont; + Canvas.DrawString(x, y, S); +end; + +procedure TfpgGauge.BarDraw; +var + BarLength: Longint; + SavedRect: TfpgRect; +begin + SavedRect := FClientRect; // save client rect for text !! + with FClientRect do + begin + case FKind of + gkHorizontalBar: + begin + BarLength := Longint(Trunc( (Width * Percentage) / 100.0 ) ); + if BarLength > 0 then + begin + if BarLength > Width then + BarLength := Width; + Width := BarLength; + // left top + Canvas.SetColor(TfpgColor($98b2ed)); + Canvas.DrawLine(Left, Bottom, Left, Top); // left + Canvas.DrawLine(Left, Top, Right, Top); // top + // right bottom + Canvas.SetColor(TfpgColor($3b4c71)); + Canvas.DrawLine(Right, Top, Right, Bottom); // right + Canvas.DrawLine(Right, Bottom, Left, Bottom); // bottom + // inside gradient fill + InflateRect(FClientRect, -1, -1); + Canvas.GradientFill(FClientRect, TfpgColor($425d9b), TfpgColor($97b0e8), gdVertical); + end; { if } + end; + gkVerticalBar: + begin + BarLength := Longint(Trunc( (Height * Percentage) / 100.0 ) ); + if BarLength > 0 then + begin + if BarLength > Height then + BarLength := Height; + Top := Height - BarLength+1; + Height := BarLength; + // left top + Canvas.SetColor(TfpgColor($98b2ed)); + Canvas.DrawLine(Left, Bottom, Left, Top); // left + Canvas.DrawLine(Left, Top, Right, Top); // top + // right bottom + Canvas.SetColor(TfpgColor($3b4c71)); + Canvas.DrawLine(Right, Top, Right, Bottom); // right + Canvas.DrawLine(Right, Bottom, Left, Bottom); // bottom + // inside gradient fill + InflateRect(FClientRect, -1, -1); + Canvas.GradientFill(FClientRect, TfpgColor($425d9b), TfpgColor($97b0e8), gdHorizontal); + end; + end; { if } + end; { case } + end; { with } + FClientRect := SavedRect; +end; + +procedure TfpgGauge.PieDraw; +var + Angle: Double; +begin + with FClientRect do + begin + Angle := Percentage; + Angle := Angle * 3.6; // Percentage to degrees + Canvas.SetColor(TfpgColor($425d9b)); + FillArcGradient (Canvas,Left, Top, Width, Height , 90, -Angle,TfpgColor($425d9b),TfpgColor($98b2ed)); + end; +end; + +procedure TfpgGauge.NeedleDraw; +var + Center: TPoint; + Radius: TPoint; + Angle: Double; +begin + with FClientRect do + begin + if Percentage > 0 then + begin + { Compute the center } + Center := CenterPoint(Rect(Left,Top,Width,Height)); + { Make needle 4 pixel shorter than gauge radius to accomodate border } + Radius.X := Center.X - 4; + Radius.Y := (Bottom - 4); + Canvas.SetLineStyle(2,lsSolid); + Angle := (Pi * ((Percentage / 100.0))); // percentage to radiants + Canvas.SetColor(TfpgColor($3b4c71)); + Canvas.SetLineStyle(2,lsSolid); + //Canvas.DrawLine(Center.X, FClientRect.Bottom, + //Integer(round(Center.X - (Radius.X * Cos(Angle)))), + //Integer(round((FClientRect.Bottom) - (Radius.Y * Sin(Angle))))); + + { *** Experimental *** } + WuLine(Canvas, + Point(Center.X, FClientRect.Bottom), + Point(Integer(round(Center.X - (Radius.X * Cos(Angle)))), + Integer(round((FClientRect.Bottom) - (Radius.Y * Sin(Angle))))), + Canvas.Color); + WuLine(Canvas, + Point(Center.X+1, FClientRect.Bottom), + Point(Integer(round(Center.X+1 - (Radius.X * Cos(Angle)))), + Integer(round((FClientRect.Bottom) - (Radius.Y * Sin(Angle))))), + Canvas.Color); + end; + end; +end; + +procedure TfpgGauge.DialDraw; +var + Center: TPoint; + Radius: TPoint; + Angle: Double; + CenterDot: Integer; +begin + with FClientRect do + begin + if Percentage >= 0 then + begin + { Compute the center } + Center := CenterPoint(Rect(Left,Top,Width,Height)); + { Make needle 3 pixel shorter than gauge radius } + Radius.X := Center.X -3; + Radius.Y := Center.Y -3; + {compute centre circle size} + CenterDot := (Width + Height) div 40; // approx. scaled to 1/10 of widget size: + if CenterDot < 2 then + CenterDot := 2; + { draw needle centre circle } + Canvas.SetColor(TfpgColor($3b4c71)); + Canvas.FillArc(Center.X - CenterDot, Center.Y - CenterDot,CenterDot * 2, CenterDot * 2,0,360); + { draw needle } + Angle := (Pi * ((Percentage / (100 * 2 / 3)) + -0.25)); + Canvas.SetLineStyle(2,lsSolid); + //Canvas.DrawLine(Center.X, Center.Y, + //Integer(round(Center.X - ( Radius.X * cos(Angle)))), + //Integer(round((Center.Y) - (Radius.Y * Sin(Angle))))); + + { *** Experimental *** } + WuLine(Canvas, + Point(Center.X, Center.Y), + Point(Integer(round(Center.X - ( Radius.X * cos(Angle)))), + Integer(round((Center.Y) - (Radius.Y * Sin(Angle))))), + Canvas.Color); + WuLine(Canvas, + Point(Center.X+1, Center.Y), + Point(Integer(round(Center.X+1 - ( Radius.X * cos(Angle)))), + Integer(round((Center.Y) - (Radius.Y * Sin(Angle))))), + Canvas.Color); + end; { if } + end; { with } +end; + +procedure TfpgGauge.HandlePaint; +begin + inherited HandlePaint; +// Canvas.BeginDraw(True); + {Paint Background and adjust FClientRect according style and BorderStyle} + BackgroundDraw; + {Paint foreground according selected Kind} + case FKind of + gkHorizontalBar, + gkVerticalBar: + BarDraw; + gkPie: + PieDraw; + gkNeedle: + NeedleDraw; + gkDial: + DialDraw; + end; + {Add Text if required} + if ShowText then + TextDraw; +// Canvas.EndDraw; +end; + +procedure TfpgGauge.SetGaugeKind(AValue: TGaugeKind); +begin + if AValue <> FKind then + begin + FKind := AValue; + RePaint; + end; +end; + +procedure TfpgGauge.SetShowText(AValue: Boolean); +begin + if AValue <> FShowText then + begin + FShowText := AValue; + RePaint; + end; +end; + +procedure TfpgGauge.SetBorderStyle(AValue: TBorderStyle); +begin + if AValue <> FBorderStyle then + begin + FBorderStyle := AValue; + { TODO: Implement Border style } + // Graeme: Wouldn't descending from TfpgBevel give you this functionality already? + // It could be a option. + //RePaint; + end; +end; + +procedure TfpgGauge.SetFirstColor(AValue: TfpgColor); +begin + if AValue <> FFirstColor then + begin + FFirstColor := AValue; + { TODO: allow user colors} + //RePaint; + end; +end; + +procedure TfpgGauge.SetSecondColor(AValue: TfpgColor); +begin + if AValue <> FSecondColor then + begin + FSecondColor := AValue; + { TODO: allow user colors} + //RePaint; + end; +end; + +procedure TfpgGauge.SetMin(AValue: Longint); +begin + if AValue <> FMin then + begin + // correct input errors + if AValue > FMax then + if not (csLoading in ComponentState) then + FMax := AValue + 1; + if FPosition < AValue then + FPosition := AValue; + // then update + FMin := AValue; + RePaint; + end; +end; + +procedure TfpgGauge.SetMax(AValue: Longint); +begin + if AValue <> FMax then + begin + // correct input errors + if AValue < FMin then + if not (csLoading in ComponentState) then + FMin := AValue - 1; + if FPosition > AValue then + FPosition := AValue; + // then update + FMax := AValue; + RePaint; + end; +end; + +procedure TfpgGauge.SetProgress(AValue: Longint); +var + CurrPercentage: Longint; + MustRepaint: Boolean; +begin + CurrPercentage := GetPercentage; + MustRepaint := False; + + if AValue < FMin then + AValue := FMin + else if AValue > FMax then + AValue := FMax; + + if FPosition <> AValue then + begin // Value has changed + FPosition := AValue; + if CurrPercentage <> Percentage then // Visible value has changed + MustRepaint := True; + { TODO: Check against low and high watermarks } + end; + if MustRepaint then + RePaint; +end; + +function TfpgGauge.GetPercentage: Longint; +Var + V,T: Longint; +begin + T := FMax - FMin; + V := FPosition - FMin; + if T = 0 then + Result := 0 + else + Result := Longint(Trunc( (V * 100.0) / T )); +end; + +constructor TfpgGauge.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + Focusable := False; + FWidth := 100; + FHeight := 25; + FKind := gkHorizontalBar; + FSecondColor := clWhite; + FFirstColor := clBlack; + FColor := TfpgColor($c4c4c4); //clInactiveWgFrame; + FMax := 100; + FMin := 0; + FPosition := 0; + FShowText := True; + FBorderStyle := bsNone; + FFont := fpgStyle.DefaultFont; +end; + +procedure TfpgGauge.AddProgress(AValue: Longint); +begin + Progress := FPosition + AValue; +end; + +end. + diff --git a/src/gui/fpg_grid.pas b/src/gui/fpg_grid.pas new file mode 100644 index 00000000..72fd29bf --- /dev/null +++ b/src/gui/fpg_grid.pas @@ -0,0 +1,517 @@ +{ + fpGUI - Free Pascal GUI Toolkit + + Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this + distribution, for details of the copyright. + + See the file COPYING.modifiedLGPL, included in this distribution, + for details about redistributing fpGUI. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + Description: + Defines a File Grid and String Grid. Both are decendants of Custom Grid. +} + +unit fpg_grid; + +{$mode objfpc}{$H+} + +{ + TODO: + * TCustomStringGrid: Col[] and Row[] properties need to be implemented, + returning a TStrings with all related text inserted. + * File Grid: Introduce support for images based on file types. User must + be able to override the default images with their own. + * Remove the usage of libc unit. libc is linux/x86 specific. +} + +interface + +uses + Classes, + SysUtils, + fpg_base, + fpg_main, + fpg_basegrid, + fpg_customgrid; + +type + + TfpgFileGrid = class(TfpgCustomGrid) + private + FFileList: TfpgFileList; + FFixedFont: TfpgFont; + protected + function GetRowCount: Integer; override; + procedure DrawCell(ARow, ACol: Integer; ARect: TfpgRect; AFlags: TfpgGridDrawState); override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + function CurrentEntry: TFileEntry; + property FixedFont: TfpgFont read FFixedFont; + property FileList: TfpgFileList read FFileList; + property DefaultRowHeight; + property Font; + property HeaderFont; + published + property FontDesc; + property HeaderFontDesc; + property RowCount; + property ColumnCount; + property Columns; + property FocusRow; + property ScrollBarStyle; + property TabOrder; + property OnRowChange; + property OnDoubleClick; + end; + + + TfpgStringColumn = class(TfpgGridColumn) + private + FCells: TStringList; + public + constructor Create; override; + destructor Destroy; override; + property Cells: TStringList read FCells write FCells; + end; + + + { TfpgCustomStringGrid } + + TfpgCustomStringGrid = class(TfpgCustomGrid) + private + function GetCell(ACol, ARow: Integer): string; + function GetColumnAlignment(ACol: Integer): TAlignment; + function GetColumnTitle(ACol: Integer): string; + function GetObjects(ACol, ARow: Integer): TObject; + procedure SetCell(ACol, ARow: Integer; const AValue: string); + procedure SetColumnAlignment(ACol: Integer; const AValue: TAlignment); + procedure SetColumnTitle(ACol: Integer; const AValue: string); + procedure SetObjects(ACol, ARow: Integer; const AValue: TObject); + protected + function GetColumnWidth(ACol: Integer): integer; override; + procedure SetColumnWidth(ACol: Integer; const AValue: integer); override; + function GetColumns(AIndex: Integer): TfpgStringColumn; reintroduce; + procedure DoDeleteColumn(ACol: integer); override; + procedure DoSetRowCount(AValue: integer); override; + procedure DoAfterAddColumn(ACol: integer); override; + function DoCreateColumnClass: TfpgStringColumn; reintroduce; override; + procedure DrawCell(ARow, ACol: Integer; ARect: TfpgRect; AFlags: TfpgGridDrawState); override; + property Columns[AIndex: Integer]: TfpgStringColumn read GetColumns; + public + constructor Create(AOwner: TComponent); override; + function AddColumn(ATitle: string; AWidth: integer; AAlignment: TAlignment = taLeftJustify; + AbackgroundColor: TfpgColor = clDefault; ATextColor: TfpgColor = clDefault): TfpgStringColumn; overload; + property Cells[ACol, ARow: Integer]: string read GetCell write SetCell; + property Objects[ACol, ARow: Integer]: TObject read GetObjects write SetObjects; + property ColumnTitle[ACol: Integer]: string read GetColumnTitle write SetColumnTitle; + property ColumnWidth[ACol: Integer]: integer read GetColumnWidth write SetColumnWidth; + property ColumnAlignment[ACol: Integer]: TAlignment read GetColumnAlignment write SetColumnAlignment; + property ColumnBackgroundColor; + property ColumnTextColor; +// property Cols[index: Integer]: TStrings read GetCols write SetCols; +// property Rows[index: Integer]: TStrings read GetRows write SetRows; + end; + + + TfpgStringGrid = class(TfpgCustomStringGrid) + published + property BackgroundColor; +// property ColResizing; + property ColumnCount; + property Columns; + property ColumnWidth; + property DefaultColWidth; + property DefaultRowHeight; + property FocusCol; + property FocusRow; + property FontDesc; + property HeaderFontDesc; + property HeaderHeight; + property Options; + property ParentShowHint; + property RowCount; + property RowSelect; + property ScrollBarStyle; + property ShowGrid; + property ShowHeader; + property ShowHint; + property TabOrder; + property TopRow; + property VisibleRows; + property OnCanSelectCell; + property OnDrawCell; + property OnDoubleClick; + property OnFocusChange; + property OnKeyPress; + property OnRowChange; + end; + +function CreateStringGrid(AOwner: TComponent; x, y, w, h: TfpgCoord; AColumnCount: integer = 0): TfpgStringGrid; + + +implementation + +uses + fpg_constants; + +function CreateStringGrid(AOwner: TComponent; x, y, w, h: TfpgCoord; AColumnCount: integer = 0): TfpgStringGrid; +begin + Result := TfpgStringGrid.Create(AOwner); + Result.Left := x; + Result.Top := y; + Result.Width := w; + Result.Height := h; + Result.ColumnCount := AColumnCount; +end; + +{ TfpgFileGrid } + +function TfpgFileGrid.GetRowCount: Integer; +begin + Result := FFileList.Count; +end; + +procedure TfpgFileGrid.DrawCell(ARow, ACol: Integer; ARect: TfpgRect; AFlags: TfpgGridDrawState); +const + picture_width = 20; +var + e: TFileEntry; + x: integer; + y: integer; + s: string; + img: TfpgImage; +begin + e := FFileList.Entry[ARow]; + if e = nil then + Exit; //==> + + x := ARect.Left + 2; + y := ARect.Top;// + 1; + s := ''; + + if (e.EntryType = etDir) and (ACol = 0) then + Canvas.SetFont(HeaderFont) + else + Canvas.SetFont(Font); + + case ACol of + 0: begin + if e.EntryType = etDir then + img := fpgImages.GetImage('stdimg.folder') // Do NOT localize + else if e.IsExecutable then + img := fpgImages.GetImage('stdimg.executable') // Do NOT localize + else + img := fpgImages.GetImage('stdimg.document'); // Do NOT localize + + if img <> nil then + Canvas.DrawImage(ARect.Left + (picture_width - img.Width) div 2, + y + (ARect.Height - img.Height) div 2, img); + if e.IsLink then // paint shortcut link symbol over existing image + Canvas.DrawImage(ARect.Left+1, ARect.Top+1, fpgImages.GetImage('stdimg.link')); + x := ARect.Left + picture_width; + s := e.Name; + end; + + 1: begin + if e.EntryType = etDir then + s := '' + else + s := FormatFloat('###,###,###,##0', e.Size); + x := ARect.Right - Font.TextWidth(s) - 1; + if x < (ARect.Left + 2) then + x := ARect.Left + 2; + end; + + 2: s := FormatDateTime('yyyy-mm-dd hh:nn', e.ModTime); + + 3: begin + if FFileList.HasFileMode then // on unix + s := e.Mode + else // on windows + s := e.Attributes; + + Canvas.SetFont(FixedFont); + end; + end; + + if FFileList.HasFileMode then // unix + case ACol of + 4: s := e.Owner; + 5: s := e.Group; + end; + + // centre text in row height + y := y + ((DefaultRowHeight - Canvas.Font.Height) div 2); + Canvas.DrawString(x, y, s); +end; + +constructor TfpgFileGrid.Create(AOwner: TComponent); +begin + FFileList := TfpgFileList.Create; + inherited Create(AOwner); + ColumnCount := 0; + RowCount := 0; + FFixedFont := fpgGetFont('Courier New-9'); + + if FFileList.HasFileMode then + AddColumn(rsName, 220) // save space for file mode, owner and group + else + AddColumn(rsName, 320); // more space to filename + + AddColumn(rsSize, 80); + AddColumn(rsFileModifiedTime, 108); + + if FFileList.HasFileMode then + begin + AddColumn(rsFileRights, 78); + AddColumn(rsFileOwner, 54); + AddColumn(rsFileGroup, 54); + end + else + AddColumn(rsFileAttributes, 78); + + RowSelect := True; + DefaultRowHeight := fpgImages.GetImage('stdimg.document').Height + 2; +end; + +destructor TfpgFileGrid.Destroy; +begin + OnRowChange := nil; + FFixedFont.Free; + FFileList.Free; + inherited Destroy; +end; + +function TfpgFileGrid.CurrentEntry: TFileEntry; +begin + Result := FFileList.Entry[FocusRow]; +end; + +{ TfpgStringColumn } + +constructor TfpgStringColumn.Create; +begin + inherited Create; + FCells := TStringList.Create; +end; + +destructor TfpgStringColumn.Destroy; +begin + FCells.Free; + inherited Destroy; +end; + +{ TfpgCustomStringGrid } + +function TfpgCustomStringGrid.GetCell(ACol, ARow: Integer): string; +begin + if ACol > ColumnCount-1 then + Exit; //==> + if ARow > RowCount-1 then + Exit; //==> + Result := TfpgStringColumn(FColumns.Items[ACol]).Cells[ARow]; +end; + +function TfpgCustomStringGrid.GetColumnAlignment(ACol: Integer): TAlignment; +begin + if ACol > ColumnCount-1 then + Exit; //==> + Result := TfpgStringColumn(FColumns.Items[ACol]).Alignment; +end; + +function TfpgCustomStringGrid.GetColumnTitle(ACol: Integer): string; +begin + if ACol > ColumnCount-1 then + Exit; //==> + Result := TfpgStringColumn(FColumns.Items[ACol]).Title; +end; + +function TfpgCustomStringGrid.GetObjects(ACol, ARow: Integer): TObject; +begin + if ACol > ColumnCount-1 then + Exit; //==> + if ARow > RowCount-1 then + Exit; //==> + Result := TfpgStringColumn(FColumns.Items[ACol]).Cells.Objects[ARow]; +end; + +function TfpgCustomStringGrid.GetColumnWidth(ACol: Integer): integer; +begin + if ACol > ColumnCount-1 then + Exit; //==> + Result := TfpgStringColumn(FColumns.Items[ACol]).Width; +end; + +procedure TfpgCustomStringGrid.SetCell(ACol, ARow: Integer; + const AValue: string); +begin + if ACol > ColumnCount-1 then + Exit; //==> + if ARow > RowCount-1 then + Exit; //==> + if TfpgStringColumn(FColumns.Items[ACol]).Cells[ARow] <> AValue then + begin + BeginUpdate; + TfpgStringColumn(FColumns.Items[ACol]).Cells[ARow] := AValue; + EndUpdate; + end; +end; + +procedure TfpgCustomStringGrid.SetColumnAlignment(ACol: Integer; + const AValue: TAlignment); +begin + if ACol > ColumnCount-1 then + Exit; //==> + BeginUpdate; + TfpgStringColumn(FColumns.Items[ACol]).Alignment := AValue; + EndUpdate; +end; + +procedure TfpgCustomStringGrid.SetColumnTitle(ACol: Integer; const AValue: string); +begin + if ACol > ColumnCount-1 then + Exit; //==> + BeginUpdate; + TfpgStringColumn(FColumns.Items[ACol]).Title := AValue; + EndUpdate; +end; + +procedure TfpgCustomStringGrid.SetObjects(ACol, ARow: Integer; + const AValue: TObject); +begin + if ACol > ColumnCount-1 then + Exit; //==> + if ARow > RowCount-1 then + Exit; //==> + TfpgStringColumn(FColumns.Items[ACol]).Cells.Objects[ARow] := AValue; +end; + +procedure TfpgCustomStringGrid.SetColumnWidth(ACol: Integer; const AValue: integer); +begin + if ACol > ColumnCount-1 then + Exit; //==> + BeginUpdate; + TfpgStringColumn(FColumns.Items[ACol]).Width := AValue; + EndUpdate; +end; + +function TfpgCustomStringGrid.GetColumns(AIndex: Integer): TfpgStringColumn; +begin + if (AIndex < 0) or (AIndex > ColumnCount-1) then + Result := nil + else + Result := TfpgStringColumn(FColumns.Items[AIndex]); +end; + +procedure TfpgCustomStringGrid.DoDeleteColumn(ACol: integer); +begin + TfpgStringColumn(FColumns.Items[ACol]).Free; + FColumns.Delete(ACol); +end; + +procedure TfpgCustomStringGrid.DoSetRowCount(AValue: integer); +var + diff: integer; + c: integer; +begin + inherited DoSetRowCount(AValue); + if FColumns.Count = 0 then + Exit; //==> + + diff := AValue - TfpgStringColumn(FColumns.Items[0]).Cells.Count; + if diff > 0 then // We need to add rows + begin + for c := 0 to FColumns.Count - 1 do + begin + while TfpgStringColumn(FColumns[c]).Cells.Count <> AValue do + TfpgStringColumn(FColumns[c]).Cells.Append(''); + end; + end; +end; + +procedure TfpgCustomStringGrid.DoAfterAddColumn(ACol: integer); +var + r: integer; +begin + inherited DoAfterAddColumn(ACol); + // initialize cells for existing rows + for r := 0 to RowCount-1 do + TfpgStringColumn(FColumns.Items[ACol]).Cells.Append(''); +end; + +function TfpgCustomStringGrid.DoCreateColumnClass: TfpgStringColumn; +begin + Result := TfpgStringColumn.Create; +end; + +procedure TfpgCustomStringGrid.DrawCell(ARow, ACol: Integer; ARect: TfpgRect; + AFlags: TfpgGridDrawState); +var + Flags: TFTextFlags; + txt: string; +begin + if Cells[ACol, ARow] <> '' then + begin + txt := Cells[ACol, ARow]; + Flags:= []; + if not Enabled then + Include(Flags,txtDisabled); + + case Columns[ACol].Alignment of + taLeftJustify: + Include(Flags,txtLeft); + taCenter: + Include(Flags,txtHCenter); + taRightJustify: + Include(Flags,txtRight); + end; { case } + + case Columns[ACol].Layout of + tlTop: + Include(Flags,txtTop); + tlCenter: + Include(Flags,txtVCenter); + tlBottom: + Include(Flags,txtBottom); + end; { case } + + with ARect,Columns[ACol] do + Canvas.DrawText(Left+HMargin,Top,Right-Left-HMargin,Bottom-Top, txt, Flags); + end; +end; + +constructor TfpgCustomStringGrid.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + ColumnCount := 0; + RowCount := 0; +end; + +function TfpgCustomStringGrid.AddColumn(ATitle: string; AWidth: integer; + AAlignment: TAlignment; ABackgroundColor: TfpgColor; ATextColor: TfpgColor): TfpgStringColumn; +begin + Updating; + Result := TfpgStringColumn(inherited AddColumn(ATitle, AWidth)); + Result.Alignment := AAlignment; + + if ABackgroundColor = clDefault then + Result.BackgroundColor := clBoxColor + else + Result.BackgroundColor:= ABackgroundColor; + + if ATextColor = clDefault then + Result.TextColor := TextColor + else + Result.TextColor:= ATextColor; + + if UpdateCount = 0 then + Updated; // if we called .BeginUpdate then don't clear csUpdating here +end; + +end. + diff --git a/src/gui/fpg_hint.pas b/src/gui/fpg_hint.pas new file mode 100644 index 00000000..a59c1636 --- /dev/null +++ b/src/gui/fpg_hint.pas @@ -0,0 +1,226 @@ +{ + fpGUI - Free Pascal GUI Toolkit + + Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this + distribution, for details of the copyright. + + See the file COPYING.modifiedLGPL, included in this distribution, + for details about redistributing fpGUI. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + Description: + Defines a window that gets used to display help hints (aka a HintWindow) +} + +unit fpg_hint; + +{$mode objfpc}{$H+} + +{.$Define Debug} + +interface + +uses + Classes, + SysUtils, + fpg_base, + fpg_main, + fpg_form, + fpg_label; + +type + TfpgHintWindow = class(TfpgForm) + private + FFont: TfpgFont; + FTime: Integer; + FShadow: Integer; + FBorder: Integer; + FMargin: Integer; + L_Hint: TfpgLabel; + T_Chrono: TfpgTimer; + procedure FormShow(Sender: TObject); + procedure FormHide(Sender: TObject); + function GetText: TfpgString; + procedure SetText(const AValue: TfpgString); + procedure T_ChronoFini(Sender: TObject); + procedure SetShadow(AValue: Integer); + procedure SetBorder(AValue: Integer); + procedure SetTime(AValue: Integer); + procedure SetLTextColor(AValue: Tfpgcolor); + procedure SetLBackgroundColor(AValue: Tfpgcolor); + procedure SetShadowColor(AValue: TfpgColor); + protected + procedure HandleShow; override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure SetPosition(aleft, atop, awidth, aheight: TfpgCoord); override; + property Font: TfpgFont read FFont; + property Text: TfpgString read GetText write SetText; + property Shadow: Integer read FShadow write SetShadow default 5; + property Border: Integer read FBorder write SetBorder default 1; + property Margin: Integer read FMargin write FMargin default 3; + property LTextColor: TfpgColor write SetLTextColor default clBlack; + property LBackgroundColor: TfpgColor write SetLBackgroundColor default clHintWindow; + property ShadowColor: TfpgColor write SetShadowColor default clGray; + property Time: Integer write SetTime default 5000; + end; + + + TfpgHintWindowClass = class of TfpgHintWindow; + + +var + HintWindowClass: TfpgHintWindowClass = TfpgHintWindow; + + +implementation + +type + TfpgHintShadow = class(TfpgForm) + public + constructor Create(AOwner: TComponent); override; + end; + + +var + uShadowForm: TfpgHintShadow; + + +{ TfpgHintWindow } + +procedure TfpgHintWindow.FormShow(Sender: TObject); +begin + T_Chrono.Enabled:= True; +end; + +procedure TfpgHintWindow.FormHide(Sender: TObject); +begin + T_Chrono.Enabled := False; + if Assigned(uShadowForm) then + uShadowForm.Hide; +end; + +function TfpgHintWindow.GetText: TfpgString; +begin + Result := L_Hint.Text; +end; + +procedure TfpgHintWindow.SetText(const AValue: TfpgString); +begin + L_Hint.Text := AValue; +end; + +procedure TfpgHintWindow.T_ChronoFini(Sender: TObject); +begin + {$IFDEF DEBUG} + writeln('TF_Hint.T_ChronoFini timer fired'); + {$ENDIF} + Hide; +end; + +procedure TfpgHintWindow.SetShadow(AValue: Integer); +begin + if FShadow <> AValue then + FShadow := AValue; +end; + +procedure TfpgHintWindow.SetBorder(AValue: Integer); +begin + if FBorder <> AValue then + FBorder := AValue; +end; + +procedure TfpgHintWindow.SetTime(AValue: Integer); +begin + if FTime <> AValue then + begin + FTime := AValue; + T_Chrono.Interval := FTime; + end; +end; + +procedure TfpgHintWindow.SetLTextColor(AValue: Tfpgcolor); +begin + if L_Hint.TextColor <> AValue then + L_Hint.TextColor := AValue +end; + +procedure TfpgHintWindow.SetLBackgroundColor(AValue: Tfpgcolor); +begin + if L_Hint.BackgroundColor <> AValue then + L_Hint.BackgroundColor := AValue +end; + +procedure TfpgHintWindow.SetShadowColor(AValue: Tfpgcolor); +begin + if uShadowForm.BackgroundColor <> AValue then + uShadowForm.BackgroundColor := AValue; +end; + +procedure TfpgHintWindow.HandleShow; +begin + // This is so the Shadow Window is below the Hint Window. + if Shadow > 0 then + begin + uShadowForm.SetPosition(Left+Shadow, Top+Shadow, Width, Height); + uShadowForm.Show; + end; + inherited HandleShow; +end; + +constructor TfpgHintWindow.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + Name := 'F_Hint'; + WindowPosition := wpUser; + WindowType := wtPopup; + Sizeable := False; + BackgroundColor:= clBlack; + FFont := fpgGetFont('#Label1'); + FMargin := 3; + FBorder := 1; + FShadow := 5; + FTime := 5000; + L_Hint := CreateLabel(Self, FBorder, FBorder, '', Width - FBorder * 2, Height - FBorder * 2, taCenter, tlCenter); + L_Hint.BackgroundColor := clHintWindow; + L_Hint.OnClick := @T_ChronoFini; + T_Chrono := TfpgTimer.Create(FTime); + T_Chrono.OnTimer := @T_ChronoFini; + uShadowForm:= TfpgHintShadow.Create(nil); + OnShow := @FormShow; + OnHide := @FormHide; +end; + +destructor TfpgHintWindow.Destroy; +begin + T_Chrono.Free; + FFont.Free; + inherited Destroy; +end; + +procedure TfpgHintWindow.SetPosition(aleft, atop, awidth, aheight: TfpgCoord); +begin + inherited SetPosition(aleft, atop, awidth, aheight); + L_Hint.SetPosition(Border, Border, Width - (Border * 2), Height - (Border * 2)); +end; + +constructor TfpgHintShadow.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + Name := 'F_Shadow'; + WindowPosition := wpUser; + WindowType := wtPopup; + Sizeable := False; + BackgroundColor := clGray; +end; + +initialization +finalization + FreeAndNil(uShadowForm); + +end. + diff --git a/src/gui/fpg_hyperlink.pas b/src/gui/fpg_hyperlink.pas new file mode 100644 index 00000000..ffed0bfb --- /dev/null +++ b/src/gui/fpg_hyperlink.pas @@ -0,0 +1,138 @@ +{ + fpGUI - Free Pascal GUI Toolkit + + Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this + distribution, for details of the copyright. + + See the file COPYING.modifiedLGPL, included in this distribution, + for details about redistributing fpGUI. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + Description: + A hyperlink label component. When the user clicks the label, a + web browser is opened with the URL specified. +} + + +unit fpg_hyperlink; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, + Sysutils, + fpg_base, + fpg_main, + fpg_label; + +type + + TfpgHyperlink = class(TfpgCustomLabel) + private + fHotTrackColor: TfpgColor; + fOldColor: TfpgColor; + fOldFont: TfpgString; + fHTFont: TfpgString; + fUrl: TfpgString; + procedure SetHotTrackColor(const AValue: TfpgColor); + procedure SetHotTrackFont(const AValue: TfpgString); + procedure SetURL(const Value: TfpgString); + protected + procedure HandleMouseEnter; override; + procedure HandleMouseExit; override; + procedure HandleLMouseDown(x, y: integer; shiftstate: TShiftState); override; + public + constructor Create(AOwner: TComponent); override; + procedure GoHyperLink; + published + property Autosize; + property FontDesc; + property HotTrackColor: TfpgColor read fHotTrackColor write SetHotTrackColor; + property HotTrackFont: TfpgString read fHTFont write SetHotTrackFont; + property Text; + property TextColor; + property URL: TfpgString read FUrl write SetURL; + property OnClick; +end; + + + +implementation + +uses + fpg_utils; + + +{ TfpgHyperlink } + +constructor TfpgHyperlink.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + fHotTrackColor := clBlue; + TextColor := clBlue; + fUrl := 'http://opensoft.homeip.net/fpgui/'; + Text := 'fpGUI website'; + fHTFont := 'Arial-8:antialias=true:underline:bold'; + FontDesc := 'Arial-8:antialias=true:underline'; + AutoSize := True; +end; + +procedure TfpgHyperlink.SetURL(const Value: TfpgString); +begin + if fUrl <> Value then + fUrl := Value; +end; + +procedure TfpgHyperlink.SetHotTrackFont(const AValue: TfpgString); +begin + if fHTFont = AValue then + Exit; + fHTFont := AValue; +end; + +procedure TfpgHyperlink.SetHotTrackColor(const AValue: TfpgColor); +begin + if fHotTrackColor = AValue then + Exit; + fHotTrackColor := AValue; +end; + +procedure TfpgHyperlink.GoHyperLink; +begin + if URL <> '' then + fpgOpenURL(URL); +end; + +procedure TfpgHyperlink.HandleMouseEnter; +begin + inherited HandleMouseEnter; + fOldColor := TextColor; + TextColor := fHotTrackColor; + fOldFont := FontDesc; + FontDesc := fHTFont; + MouseCursor := mcHand; +end; + +procedure TfpgHyperlink.HandleMouseExit; +begin + inherited HandleMouseExit; + TextColor := fOldColor; + MouseCursor := mcDefault; + FontDesc := fOldFont; +end; + +procedure TfpgHyperlink.HandleLMouseDown(x, y: integer; shiftstate: TShiftState); +begin + inherited HandleLMouseDown(x, y, shiftstate); + if not Assigned(OnClick) then + GoHyperlink; +end; + + +end. + diff --git a/src/gui/fpg_iniutils.pas b/src/gui/fpg_iniutils.pas new file mode 100644 index 00000000..3fefc1d4 --- /dev/null +++ b/src/gui/fpg_iniutils.pas @@ -0,0 +1,245 @@ +{ + fpGUI - Free Pascal GUI Toolkit + + Copyright (C) 2006 - 2007 See the file AUTHORS.txt, included in this + distribution, for details of the copyright. + + See the file COPYING.modifiedLGPL, included in this distribution, + for details about redistributing fpGUI. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + Description: + This descendant adds ReadOnly support and can read/write Form state + information. +} + +unit fpg_iniutils; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, + SysUtils, + IniFiles, + fpg_form; + +type + + TfpgINIFile = class(TINIFile) + private + FReadOnly: Boolean; + public + constructor CreateExt(const AFileName: string = ''; AReadOnly: Boolean = False); + function ReadString(const ASection, AIdent, ADefault: string): string; override; + function ReadInteger(const ASection, AIdent: string; ADefault: longint): longint; override; + function ReadBool(const ASection, AIdent: string; ADefault: Boolean): Boolean; override; + function ReadDate(const ASection, AName: string; ADefault: TDateTime): TDateTime; override; + function ReadDateTime(const ASection, AName: string; ADefault: TDateTime): TDateTime; override; + function ReadFloat(const ASection, AName: string; ADefault: double): double; override; + function ReadTime(const ASection, AName: string; ADefault: TDateTime): TDateTime; override; + procedure ReadFormState(AForm: TfpgForm; AHeight: integer = -1; AWidth: integer = -1); + procedure WriteFormState(AForm: TfpgForm); + end; + +// singleton +function gINI(const AFileName: string = ''): TfpgINIFile; + +implementation + +uses + fpg_main, + fpg_constants; + +var + uINI: TfpgINIFile; + + +function gINI(const AFileName: string): TfpgINIFile; +begin + if uINI = nil then + uINI := TfpgINIFile.CreateExt(AFileName); + Result := uINI; +end; + +{ TfpgINIFile } + +constructor TfpgINIFile.CreateExt(const AFileName: string; AReadOnly: Boolean); +var + lDir: string; + lFileName: string; +begin + FReadOnly := AReadOnly; + lDir := ExtractFileDir(AFileName); + lFileName := ExtractFileName(AFileName); + + if lDir = '' then + lDir := GetAppConfigDir(False); + if not (lDir[Length(lDir)] = PathDelim) then + lDir := lDir + PathDelim; + + { We used a non-Global config dir, so should be able to create the dir } + if not ForceDirectories(lDir) then + raise Exception.CreateFmt(rsErrFailedToCreateDir, [lDir]); + + + if lFileName = '' then + lFileName := ApplicationName + '.ini' + else if ExtractFileExt(lFileName) = '' then + lFileName := lFileName + '.ini'; + + lFileName := lDir + lFileName; + Create(lFileName); +end; + +function TfpgINIFile.ReadString(const ASection, AIdent, ADefault: string): string; +begin + Result := inherited ReadString(ASection, AIdent, ADefault); + if (not ValueExists(ASection, AIdent)) and + (not FReadOnly) then + WriteString(ASection, AIdent, ADefault); +end; + +function TfpgINIFile.ReadInteger(const ASection, AIdent: string; ADefault: longint): longint; +begin + if (not ValueExists(ASection, AIdent)) and + (not FReadOnly) then + WriteInteger(ASection, AIdent, ADefault); + Result := inherited ReadInteger(ASection, AIdent, ADefault); +end; + +function TfpgINIFile.ReadBool(const ASection, AIdent: string; ADefault: Boolean): Boolean; +var + lValueExists: Boolean; +begin + lValueExists := ValueExists(ASection, AIdent); + if (not lValueExists) and + (not FReadOnly) then + WriteBool(ASection, AIdent, ADefault); + Result := inherited ReadBool(ASection, AIdent, ADefault); +end; + +function TfpgINIFile.ReadDate(const ASection, AName: string; ADefault: TDateTime): TDateTime; +begin + if (not ValueExists(ASection, AName)) and + (not FReadOnly) then + WriteDate(ASection, AName, ADefault); + Result := inherited ReadDate(ASection, AName, ADefault); +end; + +function TfpgINIFile.ReadDateTime(const ASection, AName: string; ADefault: TDateTime): TDateTime; +begin + if (not ValueExists(ASection, AName)) and + (not FReadOnly) then + WriteDateTime(ASection, AName, ADefault); + Result := inherited ReadDateTime(ASection, AName, ADefault); +end; + +function TfpgINIFile.ReadFloat(const ASection, AName: string; ADefault: double): double; +begin + if (not ValueExists(ASection, AName)) and + (not FReadOnly) then + WriteFloat(ASection, AName, ADefault); + Result := inherited ReadFloat(ASection, AName, ADefault); +end; + +function TfpgINIFile.ReadTime(const ASection, AName: string; ADefault: TDateTime): TDateTime; +begin + if (not ValueExists(ASection, AName)) and + (not FReadOnly) then + WriteTime(ASection, AName, ADefault); + Result := inherited ReadTime(ASection, AName, ADefault); +end; + +// Do NOT localize +procedure TfpgINIFile.ReadFormState(AForm: TfpgForm; AHeight: integer; AWidth: integer); +var + LINISection: string; + LTop: integer; + LLeft: integer; + LHeight: integer; + LWidth: integer; +begin + Assert(AForm <> nil, Format(rsErrNotAssigned, ['pForm'])); + LINISection := AForm.Name + 'State'; + // Read form position, -1 if not stored in registry + LTop := readInteger(LINISection, 'Top', -1); + LLeft := readInteger(LINISection, 'Left', -1); + // The form pos was found in the registr + if (LTop <> -1) and (LLeft <> -1) then + begin + AForm.Top := readInteger(LINISection, 'Top', AForm.Top); + AForm.Left := readInteger(LINISection, 'Left', AForm.Left); + AForm.WindowPosition := wpUser; + // No form pos in the registry, so default to screen center + end + else if Assigned(fpgApplication.MainForm) and (fpgApplication.MainForm <> AForm) then + AForm.WindowPosition := wpAuto + else + AForm.WindowPosition := wpScreenCenter; + // Only set the form size if a bsSizable window + if AForm.Sizeable then + begin + if AHeight = -1 then + LHeight := AForm.Height + else + LHeight := AHeight; + if AWidth = -1 then + LWidth := AForm.Width + else + LWidth := AWidth; + AForm.Height := readInteger(LINISection, 'Height', LHeight); + AForm.Width := readInteger(LINISection, 'Width', LWidth); + end; + // AForm.WindowState := TWindowState(ReadInteger(LINISection, 'WindowState', ord(wsNormal))); + + // If the form is off screen (positioned outside all monitor screens) then + // center the form on screen. + //{$IFDEF MSWINDOWS} + //if (AForm.FormStyle <> fsMDIChild) {$IFNDEF FPC} and tiFormOffScreen(AForm) {$ENDIF} then + //begin + //if Assigned(Application.MainForm) and (Application.MainForm <> AForm) then + //AForm.Position := poMainFormCenter + //else + //AForm.Position:= poScreenCenter; + //end; + //{$ENDIF MSWINDOWS} +end; + +// Do NOT localize +procedure TfpgINIFile.WriteFormState(AForm: TfpgForm); +var + LINISection: string; +begin + LINISection := AForm.Name + 'State'; + // writeInteger(LINISection, 'WindowState', ord(AForm.WindowState)); + // if AForm.WindowState = wsNormal then + // begin + + // A work-around while WindowState is not implemented + if (AForm.Top >= 0) or (AForm.Left >= 0) then + begin + writeInteger(LINISection, 'Top', AForm.Top); + writeInteger(LINISection, 'Left', AForm.Left); + end; + if AForm.Sizeable then + begin + writeInteger(LINISection, 'Height', AForm.Height); + WriteInteger(LINISection, 'Width', AForm.Width); + end; + // end; +end; + + +initialization + uINI := nil; + +finalization + uINI.Free; + +end. + diff --git a/src/gui/fpg_label.pas b/src/gui/fpg_label.pas new file mode 100644 index 00000000..94a0df4c --- /dev/null +++ b/src/gui/fpg_label.pas @@ -0,0 +1,255 @@ +{ + fpGUI - Free Pascal GUI Toolkit + + Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this + distribution, for details of the copyright. + + See the file COPYING.modifiedLGPL, included in this distribution, + for details about redistributing fpGUI. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + Description: + Defines a basic Label control. Also known as a Caption component. +} + +unit fpg_label; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, + SysUtils, + fpg_base, + fpg_main, + fpg_widget; + +type + + + TfpgCustomLabel = class(TfpgWidget) + private + FAutoSize: boolean; + FAlignment: TAlignment; + FLayout: TLayout; + FWrapText: boolean; + FLineSpace: integer; + procedure SetWrapText(const AValue: boolean); + procedure SetAlignment(const AValue: TAlignment); + procedure SetLayout(const AValue: TLayout); + function GetFontDesc: string; + procedure SetAutoSize(const AValue: boolean); + procedure SetFontDesc(const AValue: string); + procedure SetText(const AValue: TfpgString); + procedure ResizeLabel; + protected + FText: TfpgString; + FFont: TfpgFont; + FTextHeight: integer; + procedure HandlePaint; override; + property WrapText: boolean read FWrapText write SetWrapText default False; + property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify; + property AutoSize: boolean read FAutoSize write SetAutoSize default False; + property Layout: TLayout read FLayout write SetLayout default tlTop; + property FontDesc: string read GetFontDesc write SetFontDesc; + property Text: TfpgString read FText write SetText; + property LineSpace: integer read FLineSpace write FLineSpace default 2; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + property Font: TfpgFont read FFont; + property TextHeight: integer read FTextHeight; + end; + + + TfpgLabel = class(TfpgCustomLabel) + published + property Alignment; + property AutoSize; + property BackgroundColor; + property FontDesc; + property Hint; + property Layout; + property LineSpace; + property ParentShowHint; + property ShowHint; + property Text; + property TextColor; + property Width; + property WrapText; + property OnClick; + property OnDoubleClick; + property OnMouseDown; + property OnMouseEnter; + property OnMouseExit; + property OnMouseMove; + property OnMouseUp; + end; + + +// A convenience function to create a TfpgLabel instance +function CreateLabel(AOwner: TComponent; x, y: TfpgCoord; AText: string; w: TfpgCoord= 0; h: TfpgCoord= 0; + HAlign: TAlignment= taLeftJustify; VAlign: TLayout= tlTop; ALineSpace: integer= 2): TfpgLabel; overload; + +implementation + + +function CreateLabel(AOwner: TComponent; x, y: TfpgCoord; AText: string; w: TfpgCoord; h: TfpgCoord; + HAlign: TAlignment; VAlign: TLayout; ALineSpace: integer): TfpgLabel; +begin + Result := TfpgLabel.Create(AOwner); + Result.Left := x; + Result.Top := y; + Result.Text := AText; + Result.LineSpace := ALineSpace; + if w = 0 then + begin + Result.Width := Result.Font.TextWidth(Result.Text); + Result.FAutoSize := True; + end + else + Result.Width := w; + if h < Result.Font.Height then + Result.Height:= Result.Font.Height + else + Result.Height:= h; + Result.Alignment:= HAlign; + Result.Layout:= VAlign; +end; + +{ TfpgCustomLabel } + +procedure TfpgCustomLabel.SetWrapText(const AValue: boolean); +begin + if FWrapText <> AValue then + begin + FWrapText := AValue; + ResizeLabel; + end; +end; + +procedure TfpgCustomLabel.SetAlignment(const AValue: TAlignment); +begin + if FAlignment <> AValue then + begin + FAlignment := AValue; + ResizeLabel; + end; +end; + +procedure TfpgCustomLabel.SetLayout(const AValue: TLayout); +begin + if FLayout <> AValue then + begin + FLayout := AValue; + ResizeLabel; + end; +end; + +function TfpgCustomLabel.GetFontDesc: string; +begin + Result := FFont.FontDesc; +end; + +procedure TfpgCustomLabel.SetAutoSize(const AValue: boolean); +begin + if FAutoSize <> AValue then + begin + FAutoSize := AValue; + ResizeLabel; + end; +end; + +procedure TfpgCustomLabel.SetFontDesc(const AValue: string); +begin + FFont.Free; + FFont := fpgGetFont(AValue); + ResizeLabel; +end; + +procedure TfpgCustomLabel.SetText(const AValue: TfpgString); +begin + if FText <> AValue then + begin + FText := AValue; + ResizeLabel; + end; +end; + +procedure TfpgCustomLabel.ResizeLabel; +begin + if FAutoSize and not FWrapText then + Width:= FFont.TextWidth(FText); + UpdateWindowPosition; + RePaint; +end; + +constructor TfpgCustomLabel.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FText := 'Label'; + FFont := fpgGetFont('#Label1'); + FHeight := FFont.Height; + FWidth := 80; + FTextColor := Parent.TextColor; + FBackgroundColor := Parent.BackgroundColor; + FAutoSize := False; + FLayout := tlTop; + FAlignment := taLeftJustify; + FWrapText := False; + FLineSpace := 2; +end; + +destructor TfpgCustomLabel.Destroy; +begin + FText := ''; + FFont.Free; + inherited Destroy; +end; + +procedure TfpgCustomLabel.HandlePaint; +var + r: TfpgRect; + lTxtFlags: TFTextFlags; +begin + inherited HandlePaint; + Canvas.ClearClipRect; + r.SetRect(0, 0, Width, Height); + Canvas.Clear(FBackgroundColor); + Canvas.SetFont(Font); + if Enabled then + Canvas.SetTextColor(FTextColor) + else + Canvas.SetTextColor(clShadow1); + + lTxtFlags:= []; + if not Enabled then + Include(lTxtFlags, txtDisabled); + + if FWrapText then + Include(lTxtFlags, txtWrap); + case FAlignment of + taLeftJustify: + Include(lTxtFlags, txtLeft); + taRightJustify: + Include(lTxtFlags, txtRight); + taCenter: + Include(lTxtFlags, txtHCenter); + end; + case FLayout of + tlTop: + Include(lTxtFlags, txtTop); + tlBottom: + Include(lTxtFlags, txtBottom); + tlCenter: + Include(lTxtFlags, txtVCenter); + end; + FTextHeight := Canvas.DrawText(0, 0, Width, Height, FText, lTxtFlags); +end; + +end. + diff --git a/src/gui/fpg_listbox.pas b/src/gui/fpg_listbox.pas new file mode 100644 index 00000000..98633295 --- /dev/null +++ b/src/gui/fpg_listbox.pas @@ -0,0 +1,1142 @@ +{ + fpGUI - Free Pascal GUI Toolkit + + Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this + distribution, for details of the copyright. + + See the file COPYING.modifiedLGPL, included in this distribution, + for details about redistributing fpGUI. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + Description: + Defines various ListBox controls. A basic text (string) listbox + control has been implemented. +} + +unit fpg_listbox; + +{$mode objfpc}{$H+} + +{ + TODO: + * Refactor these to have a better hierarchy + * Only surface properties as published in TfpgListBox + * Implement .BeginUpdate and .EndUpdate methods so we know when to refresh + the items list. + * Color Listbox: User Defined color palette support. +} + +interface + +uses + Classes, + SysUtils, + fpg_base, + fpg_main, + fpg_widget, + fpg_scrollbar; + +type + + // My thinking was that we could use this class as the base class for anything + // that contains a list and needs to be presented like a normal listBox. + // Not sure if it is actually going to work. + TfpgBaseListBox = class(TfpgWidget) + private + FHotTrack: boolean; + FOnChange: TNotifyEvent; + FOnScroll: TNotifyEvent; + FOnSelect: TNotifyEvent; + FPopupFrame: boolean; + FAutoHeight: boolean; + FUpdateCount: Integer; + function GetFontDesc: string; + procedure SetFocusItem(const AValue: integer); + procedure SetFontDesc(const AValue: string); + procedure SetPopupFrame(const AValue: boolean); + procedure UpdateScrollbarCoords; + procedure SetAutoHeight(const AValue: boolean); + protected + FFont: TfpgFont; + FScrollBar: TfpgScrollBar; + FFocusItem: integer; + FMouseDragging: boolean; + FFirstItem: integer; + FMargin: integer; + procedure MsgPaint(var msg: TfpgMessageRec); message FPGM_PAINT; + procedure UpdateScrollBar; + procedure FollowFocus; + function ListHeight: TfpgCoord; + function ScrollBarWidth: TfpgCoord; + function PageLength: integer; + procedure ScrollBarMove(Sender: TObject; APosition: integer); + procedure DrawItem(num: integer; rect: TfpgRect; flags: integer); virtual; + procedure DoChange; + procedure DoSelect; + procedure HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed : boolean); override; + procedure HandleLMouseDown(x, y: integer; shiftstate: TShiftState); override; + procedure HandleLMouseUp(x, y: integer; shiftstate: TShiftState); override; + procedure HandleMouseMove(x, y: integer; btnstate: word; shiftstate: TShiftState); override; + procedure HandleMouseScroll(x, y: integer; shiftstate: TShiftState; delta: smallint); override; + procedure HandleResize(awidth, aheight: TfpgCoord); override; + procedure HandleShow; override; + procedure HandlePaint; override; + property AutoHeight: boolean read FAutoHeight write SetAutoHeight default False; + property FocusItem: integer read FFocusItem write SetFocusItem; + property FontDesc: string read GetFontDesc write SetFontDesc; + property HotTrack: boolean read FHotTrack write FHotTrack; + property PopupFrame: boolean read FPopupFrame write SetPopupFrame; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure BeginUpdate; + procedure EndUpdate; + procedure Update; + function ItemCount: integer; virtual; + function RowHeight: integer; virtual; + procedure SetFirstItem(item: integer); + property Font: TfpgFont read FFont; + property OnChange: TNotifyEvent read FOnChange write FOnChange; + property OnKeyPress; // to allow to detect return or tab key has been pressed + property OnScroll: TNotifyEvent read FOnScroll write FOnScroll; + property OnSelect: TNotifyEvent read FOnSelect write FOnSelect; + end; + + + // Listbox containg strings - the normal listbox as we know it. Used by + // component developers. + TfpgTextListBox = class(TfpgBaseListBox) + protected + FItems: TStringList; + procedure DrawItem(num: integer; rect: TfpgRect; flags: integer); override; + procedure HandleKeyChar(var AText: TfpgChar; var shiftstate: TShiftState; var consumed: boolean); override; + property Items: TStringList read FItems; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + function ItemCount: integer; override; + function Text: string; + end; + + + // The standard strings listbox we will actually use in a GUI. + TfpgListBox = class(TfpgTextListBox) + published + property AutoHeight; + property BackgroundColor default clListBox; + property FocusItem; + property FontDesc; + property HotTrack; + property Items; + property ParentShowHint; + property PopupFrame; + property ShowHint; + property TabOrder; + property TextColor; + end; + + + // simple data class containing color information + TColorItem = class(TObject) + public + constructor Create(const AColorName: string; const AColorValue: TfpgColor); + ColorName: string; + ColorValue: TfpgColor; + end; + + + TfpgColorPalette = (cpStandardColors, cpSystemColors, cpWebColors, cpUserDefined); + + + TfpgBaseColorListBox = class(TfpgBaseListBox) + private + FColorBoxWidth: TfpgCoord; + FColorBoxHeight: TfpgCoord; + FColorPalette: TfpgColorPalette; + FShowColorNames: Boolean; + function GetColor: TfpgColor; + procedure SetColor(const AValue: TfpgColor); + procedure SetColorPalette(const AValue: TfpgColorPalette); + procedure SetShowColorNames (const AValue: Boolean ); + procedure SetupColorPalette; + procedure FreeAndClearColors; + protected + FItems: TList; + procedure DrawItem(num: integer; rect: TfpgRect; flags: integer); override; +// procedure HandleKeyChar(var AText: TfpgChar; var shiftstate: TShiftState; var consumed: boolean); override; + property Items: TList read FItems; + property Color: TfpgColor read GetColor write SetColor; + property ColorPalette: TfpgColorPalette read FColorPalette write SetColorPalette; + property ShowColorNames: Boolean read FShowColorNames write SetShowColorNames default True; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + function ItemCount: integer; override; + + end; + + + TfpgColorListBox = class(TfpgBaseColorListBox) + published + property AutoHeight; + property BackgroundColor default clListBox; + property Color; + property ColorPalette; + property FocusItem; + property FontDesc; + property HotTrack; + property Items; + property PopupFrame; + property ShowColorNames; + property TabOrder; + property TextColor; + end; + + +function CreateListBox(AOwner: TComponent; x, y, w, h: TfpgCoord): TfpgListBox; + + +implementation + + +type + // custom stringlist that will notify listbox of item changes + TfpgListBoxStrings = class(TStringList) + protected + ListBox: TfpgTextListBox; + procedure SetUpdateState(Updating: Boolean); override; + public + constructor Create(AListBox: TfpgTextListBox); + destructor Destroy; override; + function Add(const s: String): Integer; override; + procedure Delete(Index: Integer); override; + procedure Clear; override; + end; + + +function CreateListBox(AOwner: TComponent; x, y, w, h: TfpgCoord): TfpgListBox; +begin + Result := TfpgListBox.Create(AOwner); + Result.Left := x; + Result.Top := y; + Result.Width := w; + if h > 0 then + Result.Height := h; +end; + + +{ TfpgListBoxStrings } + +procedure TfpgListBoxStrings.SetUpdateState(Updating: Boolean); +begin + inherited SetUpdateState(Updating); + // do nothing extra for now +end; + +constructor TfpgListBoxStrings.Create(AListBox: TfpgTextListBox); +begin + inherited Create; + ListBox := AListBox; +end; + +destructor TfpgListBoxStrings.Destroy; +begin + ListBox := nil; + inherited Destroy; +end; + +function TfpgListBoxStrings.Add(const s: String): Integer; +begin + Result := inherited Add(s); + if Assigned(ListBox) and (ListBox.HasHandle) then + begin + ListBox.UpdateScrollBar; + ListBox.Invalidate; + end; +end; + +procedure TfpgListBoxStrings.Delete(Index: Integer); +begin + inherited Delete(Index); + if Assigned(ListBox) and (ListBox.HasHandle) then + begin + ListBox.UpdateScrollBar; + ListBox.Invalidate; + end; +end; + +procedure TfpgListBoxStrings.Clear; +begin + inherited Clear; + ListBox.FocusItem := -1; + ListBox.UpdateScrollBar; + ListBox.Invalidate; +end; + + +{ TfpgBaseListBox } + +function TfpgBaseListBox.GetFontDesc: string; +begin + result := FFont.FontDesc; +end; + +procedure TfpgBaseListBox.SetFocusItem(const AValue: integer); +var + old: integer; +begin + if FFocusItem = AValue then + Exit; //==> + + old := FFocusItem; + // do some sanity checks + if AValue < -1 then // -1 is a valid focusitem (no selection) + FFocusItem := -1 + else if AValue > ItemCount-1 then + FFocusItem := ItemCount-1 + else + FFocusItem := AValue; + + if FFocusItem = old then + Exit; //==> + + if FFocusItem <= 0 then + FFirstItem := 0; + + FollowFocus; + UpdateScrollbar; + RePaint; + DoChange; +end; + +procedure TfpgBaseListBox.SetFontDesc(const AValue: string); +begin + FFont.Free; + FFont := fpgGetFont(AValue); + if FAutoHeight then + Height:= ((Height - 6) div RowHeight) * RowHeight + 6; + RePaint; +end; + +procedure TfpgBaseListBox.SetPopupFrame(const AValue: boolean); +begin + if FPopupFrame = AValue then + Exit; //==> + FPopupFrame := AValue; + RePaint; +end; + +procedure TfpgBaseListBox.UpdateScrollbarCoords; +var + HWidth: integer; + VHeight: integer; +begin + VHeight := Height - 4; + HWidth := Width - 4; + + if FScrollBar.Visible then + Dec(HWidth, FScrollBar.Width); + + FScrollBar.Top := 2; + FScrollBar.Left := Width - FScrollBar.Width - 2; + FScrollBar.Height := VHeight; + FScrollBar.UpdateWindowPosition; +end; + +procedure TfpgBaseListBox.SetAutoHeight(const AValue: boolean); +begin + if FAutoHeight= AValue then + Exit; //==> + FAutoHeight := AValue; + Height := (PageLength * RowHeight) + (2 * FMargin); +end; + +procedure TfpgBaseListBox.MsgPaint(var msg: TfpgMessageRec); +begin + // Optimising painting and preventing OnPaint from firing if not needed + if FUpdateCount = 0 then + inherited MsgPaint(msg); +end; + +procedure TfpgBaseListBox.SetFirstItem(item: integer); +begin + FFirstItem := item; + UpdateScrollBar; +end; + +procedure TfpgBaseListBox.UpdateScrollBar; +var + pn : integer; +begin + if not HasHandle then + Exit; //==> + pn := PageLength; + FScrollBar.Visible := PageLength < ItemCount-1; + + if FScrollBar.Visible then + begin + FScrollBar.Min := 0; + if ItemCount <> 0 then + FScrollBar.SliderSize := pn / ItemCount + else + FScrollBar.SliderSize := 1; + FScrollBar.Max := ItemCount-1-pn; + FScrollBar.Position := FFirstItem; + FScrollBar.RepaintSlider; + end; +end; + +procedure TfpgBaseListBox.FollowFocus; +var + n: integer; + h: TfpgCoord; +begin + if FFocusItem < FFirstItem then + FFirstItem := FFocusItem + else + begin + h := 0; + for n := FFocusItem downto FFirstItem do + begin + h := h + RowHeight; + if h > ListHeight then + begin + FFirstItem := n+1; + Break; + end; + end; + end; + + if FFirstItem < 0 then + FFirstItem := 0; + UpdateScrollBar; +end; + +function TfpgBaseListBox.ListHeight: TfpgCoord; +begin + result := height - (2*FMargin); +end; + +function TfpgBaseListBox.ScrollBarWidth: TfpgCoord; +begin + if FScrollBar.Visible then + result := FScrollBar.Width + else + result := 0; +end; + +function TfpgBaseListBox.PageLength: integer; +begin + result := (ListHeight div RowHeight)-1; // component height minus 1 line +end; + +procedure TfpgBaseListBox.ScrollBarMove(Sender: TObject; APosition: integer); +begin + FFirstItem := APosition; + Repaint; + if Assigned(FOnScroll) then + FOnScroll(self); +end; + +procedure TfpgBaseListBox.DoChange; +begin + if Assigned(OnChange) then + FOnChange(self); +end; + +procedure TfpgBaseListBox.DoSelect; +begin + if Assigned(OnSelect) then + FOnSelect(self); +end; + +procedure TfpgBaseListBox.HandleKeyPress(var keycode: word; + var shiftstate: TShiftState; var consumed: boolean); +begin + consumed := true; + + case keycode of + keyUp: + begin + if FFocusItem > 0 then + FocusItem := FFocusItem - 1; + end; + + keyDown: + begin + if FFocusItem < (ItemCount-1) then + FocusItem := FFocusItem + 1; + end; + + keyPageUp: + begin + if ItemCount > 0 then + begin + if ((FFocusItem - PageLength) < 0) then + FocusItem := 0 + else + FocusItem := FFocusItem - PageLength; + end; + end; + + keyPageDown: + begin + if ItemCount > 0 then + begin + if (FFocusItem + PageLength) > ItemCount-1 then + FocusItem := ItemCount - 1 + else + FocusItem := FFocusItem + PageLength; + end; + end; + + keyHome: + begin + FocusItem := 0; + end; + + keyEnd: + begin + FocusItem := ItemCount-1; + end; + + keyReturn, keyPEnter: + begin + if FocusItem > -1 then + DoSelect; + consumed := false; // to allow the forms to detect it + end; + else + consumed := false; + end; + inherited HandleKeyPress(keycode, shiftstate, consumed); +end; + +procedure TfpgBaseListBox.HandleLMouseDown(x, y: integer; shiftstate: TShiftState); +begin + inherited HandleLMouseDown(x, y, shiftstate); + + if ItemCount < 1 then + Exit; //==> + + FocusItem := FFirstItem + Trunc((y - FMargin) / RowHeight); + FMouseDragging := True; +end; + +procedure TfpgBaseListBox.HandleLMouseUp(x, y: integer; shiftstate: TShiftState); +begin + inherited HandleLMouseUp(x, y, shiftstate); + if ItemCount < 1 then + Exit; //==> + + FMouseDragging := False; + DoSelect; +end; + +procedure TfpgBaseListBox.HandleMouseMove(x, y: integer; btnstate: word; shiftstate: TShiftState); +var + NewFocus: Integer; +begin + inherited HandleMouseMove(x, y, btnstate, shiftstate); + + if ItemCount < 1 then + Exit; //==> + + if ((not FMouseDragging) or (btnstate and 1 = 0)) and (not HotTrack) then + Exit; //==> + + NewFocus := FFirstItem + Trunc((y - FMargin) / RowHeight); + if NewFocus < 0 then + NewFocus := 0; + + FocusItem := NewFocus; +end; + +procedure TfpgBaseListBox.HandleMouseScroll(x, y: integer; shiftstate: TShiftState; delta: smallint); +var + pfi: integer; +begin + pfi := FFirstItem; + if delta > 0 then // scroll down + FFirstItem := FFirstItem + abs(delta) + else // scroll up + FFirstItem := FFirstItem - abs(delta); + + if FFirstItem + PageLength > (ItemCount-1) then + FFirstItem := ItemCount - 1 - PageLength; + if FFirstItem < 0 then + FFirstItem := 0; + if pfi <> FFirstItem then + begin + UpdateScrollBar; + Repaint; + end; +end; + +procedure TfpgBaseListBox.HandleResize(awidth, aheight: TfpgCoord); +begin + inherited HandleResize(awidth, aheight); + if (csLoading in ComponentState) then + Exit; + UpdateScrollbarCoords; + UpdateScrollBar; +end; + +procedure TfpgBaseListBox.HandleShow; +begin + inherited HandleShow; + if (csLoading in ComponentState) then + Exit; + UpdateScrollBarCoords; + UpdateScrollBar; +end; + +procedure TfpgBaseListBox.HandlePaint; +var + n: integer; + r: TfpgRect; +begin + //if FUpdateCount > 0 then + //Exit; //==> + + inherited HandlePaint; + Canvas.ClearClipRect; + + r.SetRect(0, 0, Width, Height); + + if popupframe then + begin + Canvas.SetLineStyle(1, lsSolid); + Canvas.SetColor(clWidgetFrame); + Canvas.DrawRectangle(r); + InflateRect(r, -1, -1); + end + else + begin + Canvas.DrawControlFrame(r); + InflateRect(r, -2, -2); + end; + + Canvas.SetClipRect(r); + Canvas.SetColor(FBackgroundColor); + Canvas.FillRectangle(r); + Canvas.SetFont(FFont); + + r.SetRect(0, 0, Width-ScrollBarWidth, Height); + InflateRect(r, -FMargin, -FMargin); +// r.SetRect(FMargin, FMargin, Width-ScrollBarWidth-(FMargin*2), Height - (FMargin*2)); + Canvas.SetClipRect(r); + + r.Height := RowHeight; + + if ItemCount = 0 then + Exit; //==> + if FFirstItem = -1 then + FFirstItem := 0; + for n := FFirstItem to ItemCount-1 do + begin + if n = FFocusItem then + begin + if FFocused then + begin + Canvas.SetColor(clSelection); + Canvas.SetTextColor(clSelectionText); + end + else + begin + Canvas.SetColor(clInactiveSel); + Canvas.SetTextColor(clInactiveSelText); + end; + end + else + begin + Canvas.SetColor(FBackgroundColor); + Canvas.SetTextColor(FTextColor); + end; { if/else } + Canvas.FillRectangle(r); + + // This is just a test. + // Bluecurve theme :) + if (n = FFocusItem) and FFocused then + begin + // outer dark border + Canvas.SetColor(TfpgColor($3b4c71)); + Canvas.SetLineStyle(1, lsSolid); + Canvas.DrawRectangle(r); + InflateRect(r, -1, -1); + // left top + Canvas.SetColor(TfpgColor($98b2ed)); + Canvas.DrawLine(r.Left, r.Bottom, r.Left, r.Top); // left + Canvas.DrawLine(r.Left, r.Top, r.Right, r.Top); // top + // right bottom + Canvas.SetColor(TfpgColor($4468b8)); + Canvas.DrawLine(r.Right, r.Top, r.Right, r.Bottom); // right + Canvas.DrawLine(r.Right, r.Bottom, r.Left-1, r.Bottom); // bottom + // inside gradient fill + InflateRect(r, -1, -1); + Canvas.GradientFill(r, TfpgColor($435e9a), TfpgColor($5476c4), gdVertical); + // reset rectangle + InflateRect(r, 2, 2); + end; + + DrawItem(n, r, 0); + inc(r.Top, RowHeight); + + if r.Top >= Height then + Break; + end; { for } + + // clearing after the last row + if r.Top <= Height then + begin + Canvas.SetColor(FBackgroundColor); + r.SetBottom(Height - FMargin); + Canvas.FillRectangle(r); + end; +end; + +constructor TfpgBaseListBox.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FFont := fpgGetFont('#List'); + FBackgroundColor := clListBox; + FTextColor := Parent.TextColor; + + FFocusable := True; + FFocusItem := -1; + FFirstItem := 0; + FWidth := 80; + FHeight := 80; + FMargin := 2; + FUpdateCount := 0; + FMouseDragging := False; + FPopupFrame := False; + FHotTrack := False; + FAutoHeight := False; + + FScrollBar := TfpgScrollBar.Create(self); + FScrollBar.OnScroll := @ScrollBarMove; + + FOnChange := nil; + FOnSelect := nil; + FOnScroll := nil; +end; + +destructor TfpgBaseListBox.Destroy; +begin + FFont.Free; + inherited Destroy; +end; + +procedure TfpgBaseListBox.BeginUpdate; +begin + Inc(FUpdateCount); +end; + +procedure TfpgBaseListBox.EndUpdate; +begin + if FUpdateCount = 0 then + Exit; //==> + Dec(FUpdateCount); + if FUpdateCount = 0 then + Repaint; +end; + +procedure TfpgBaseListBox.Update; +begin + FFirstItem := -1; + FFocusItem := -1; + UpdateScrollBar; + Repaint; +end; + +function TfpgBaseListBox.ItemCount: integer; +begin + // This must be overridden in descendant classes! + result := 17; +end; + +function TfpgBaseListBox.RowHeight: integer; +begin + result := FFont.Height+2; +end; + +procedure TfpgBaseListBox.DrawItem(num: integer; rect: TfpgRect; flags: integer); +var + s: string; +begin + // This must be overridden in descendant classes! + s := 'Item' + IntToStr(num); + Canvas.DrawString(rect.left+2, rect.top+1, s); +end; + +{ TfpgTextListBox } + +procedure TfpgTextListBox.DrawItem(num: integer; rect: TfpgRect; flags: integer); +begin + //if num < 0 then + //Exit; //==> + fpgStyle.DrawString(Canvas, rect.left+2, rect.top+1, FItems.Strings[num], Enabled); +end; + +procedure TfpgTextListBox.HandleKeyChar(var AText: TfpgChar; + var shiftstate: TShiftState; var consumed: boolean); +var + i: integer; +begin + // If the user pressed a key then it will search the stringlist for a word + // beginning with that letter + if (Ord(AText[1]) > 31) and (Ord(AText[1]) < 127) or (Length(AText) > 1 ) then + if FFocusItem > -1 then + for i := FFocusItem to FItems.Count-1 do + begin + if SameText(LeftStr(FItems.Strings[i], Length(AText)), AText) then + begin + FocusItem := i; + break; + end; + end; { for } + inherited HandleKeyChar(AText, shiftstate, consumed); +end; + +constructor TfpgTextListBox.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FItems := TfpgListBoxStrings.Create(self); + FFocusItem := -1; +end; + +destructor TfpgTextListBox.Destroy; +begin + TfpgListBoxStrings(FItems).Free; + inherited Destroy; +end; + +function TfpgTextListBox.ItemCount: integer; +begin + result := FItems.Count; +end; + +function TfpgTextListBox.Text: string; +begin + if (ItemCount > 0) and (FocusItem <> -1) then + result := FItems[FocusItem] + else + result := ''; +end; + +{ TColorItem } + +constructor TColorItem.Create (const AColorName: string; const AColorValue: TfpgColor); +begin + inherited Create; + ColorName := AColorName; + ColorValue := AColorValue; +end; + +{ TfpgBaseColorListBox } + +procedure TfpgBaseColorListBox.SetColorPalette (const AValue: TfpgColorPalette ); +begin + if FColorPalette = AValue then + Exit; + FColorPalette := AValue; + SetupColorPalette; + RePaint; +end; + +procedure TfpgBaseColorListBox.SetShowColorNames (const AValue: Boolean ); +begin + if FShowColorNames = AValue then + Exit; + FShowColorNames := AValue; + Repaint; +end; + +function TfpgBaseColorListBox.GetColor: TfpgColor; +begin + Result := TColorItem(FItems.Items[FocusItem]).ColorValue; +end; + +procedure TfpgBaseColorListBox.SetColor(const AValue: TfpgColor); +var + i: integer; +begin + if GetColor = AValue then + Exit; //==> + for i := 0 to FItems.Count-1 do + begin + if TColorItem(FItems.Items[i]).ColorValue = AValue then + begin + FocusItem := i; + Exit; + end; + end; +end; + +procedure TfpgBaseColorListBox.SetupColorPalette; +begin + FreeAndClearColors; + + case FColorPalette of + cpStandardColors: + begin + FItems.Add(TColorItem.Create('clAqua', clAqua)); + FItems.Add(TColorItem.Create('clBlack', clBlack)); + FItems.Add(TColorItem.Create('clBlue', clBlue)); + FItems.Add(TColorItem.Create('clCream', clCream)); + FItems.Add(TColorItem.Create('clDkGray', clDkGray)); + FItems.Add(TColorItem.Create('clFuchsia', clFuchsia)); + FItems.Add(TColorItem.Create('clGray', clGray)); + FItems.Add(TColorItem.Create('clGreen', clGreen)); + FItems.Add(TColorItem.Create('clLime', clLime)); + FItems.Add(TColorItem.Create('clLtGray', clLtGray)); + FItems.Add(TColorItem.Create('clMaroon', clMaroon)); + FItems.Add(TColorItem.Create('clNavy', clNavy)); + FItems.Add(TColorItem.Create('clOlive', clOlive)); + FItems.Add(TColorItem.Create('clPurple', clPurple)); + FItems.Add(TColorItem.Create('clRed', clRed)); + FItems.Add(TColorItem.Create('clSilver', clSilver)); + FItems.Add(TColorItem.Create('clTeal', clTeal)); + FItems.Add(TColorItem.Create('clWhite', clWhite)); + FItems.Add(TColorItem.Create('clYellow', clYellow)); + FItems.Add(TColorItem.Create('clMoneyGreen', clMoneyGreen)); + FItems.Add(TColorItem.Create('clSkyBlue', clSkyBlue)); + FItems.Add(TColorItem.Create('clMedGray', clMedGray)); + end; + cpSystemColors: + begin + FItems.Add(TColorItem.Create('clWindowBackground', clWindowBackground)); + FItems.Add(TColorItem.Create('clBoxColor', clBoxColor)); + FItems.Add(TColorItem.Create('clButtonFace', clButtonFace)); + FItems.Add(TColorItem.Create('clShadow1', clShadow1)); + FItems.Add(TColorItem.Create('clShadow2', clShadow2)); + FItems.Add(TColorItem.Create('clHilite1', clHilite1)); + FItems.Add(TColorItem.Create('clHilite2', clHilite2)); + FItems.Add(TColorItem.Create('clText1', clText1)); + FItems.Add(TColorItem.Create('clText2', clText2)); + FItems.Add(TColorItem.Create('clText3', clText3)); + FItems.Add(TColorItem.Create('clText4', clText4)); + FItems.Add(TColorItem.Create('clSelection', clSelection)); + FItems.Add(TColorItem.Create('clSelectionText', clSelectionText)); + FItems.Add(TColorItem.Create('clInactiveSel', clInactiveSel)); + FItems.Add(TColorItem.Create('clInactiveSelText', clInactiveSelText)); + FItems.Add(TColorItem.Create('clScrollBar', clScrollBar)); + FItems.Add(TColorItem.Create('clListBox', clListBox)); + FItems.Add(TColorItem.Create('clGridLines', clGridLines)); + FItems.Add(TColorItem.Create('clGridHeader', clGridHeader)); + FItems.Add(TColorItem.Create('clWidgetFrame', clWidgetFrame)); + FItems.Add(TColorItem.Create('clInactiveWgFrame', clInactiveWgFrame)); + FItems.Add(TColorItem.Create('clTextCursor', clTextCursor)); + FItems.Add(TColorItem.Create('clChoiceListBox', clChoiceListBox)); + FItems.Add(TColorItem.Create('clUnset', clUnset)); + FItems.Add(TColorItem.Create('clMenuText', clMenuText)); + FItems.Add(TColorItem.Create('clMenuDisabled', clMenuDisabled)); + end; + cpWebColors: + begin + { TODO : Need to add the web colors } + FItems.Add(TColorItem.Create('clAliceBlue', clAliceBlue)); + FItems.Add(TColorItem.Create('clAntiqueWhite', clAntiqueWhite)); + FItems.Add(TColorItem.Create('clAqua', clAqua)); + FItems.Add(TColorItem.Create('clAquamarine', clAquamarine)); + FItems.Add(TColorItem.Create('clAzure', clAzure)); + FItems.Add(TColorItem.Create('clBeige', clBeige)); + FItems.Add(TColorItem.Create('clBisque', clBisque)); + FItems.Add(TColorItem.Create('clBlack', clBlack)); + FItems.Add(TColorItem.Create('clBlanchedAlmond', clBlanchedAlmond)); + FItems.Add(TColorItem.Create('clBlue', clBlue)); + FItems.Add(TColorItem.Create('clBlueViolet', clBlueViolet)); + FItems.Add(TColorItem.Create('clBrown', clBrown)); + FItems.Add(TColorItem.Create('clBurlyWood', clBurlyWood)); + FItems.Add(TColorItem.Create('clCadetBlue', clCadetBlue)); + FItems.Add(TColorItem.Create('clChartreuse', clChartreuse)); + FItems.Add(TColorItem.Create('clChocolate', clChocolate)); + FItems.Add(TColorItem.Create('clCoral', clCoral)); + FItems.Add(TColorItem.Create('clCornflowerBlue', clCornflowerBlue)); + FItems.Add(TColorItem.Create('clCornsilk', clCornsilk)); + FItems.Add(TColorItem.Create('clCrimson', clCrimson)); + FItems.Add(TColorItem.Create('clCyan', clCyan)); + FItems.Add(TColorItem.Create('clDarkBlue', clDarkBlue)); + FItems.Add(TColorItem.Create('clDarkCyan', clDarkCyan)); + FItems.Add(TColorItem.Create('clDarkGoldenrod', clDarkGoldenrod)); + FItems.Add(TColorItem.Create('clDarkGray', clDarkGray)); + FItems.Add(TColorItem.Create('clDarkGreen', clDarkGreen)); + FItems.Add(TColorItem.Create('clDarkKhaki', clDarkKhaki)); + FItems.Add(TColorItem.Create('clDarkMagenta', clDarkMagenta)); + FItems.Add(TColorItem.Create('clDarkOliveGreen', clDarkOliveGreen)); + FItems.Add(TColorItem.Create('clDarkOrange', clDarkOrange)); + FItems.Add(TColorItem.Create('clDarkOrchid', clDarkOrchid)); + FItems.Add(TColorItem.Create('clDarkRed', clDarkRed)); + FItems.Add(TColorItem.Create('clDarkSalmon', clDarkSalmon)); + FItems.Add(TColorItem.Create('clDarkSeaGreen', clDarkSeaGreen)); + FItems.Add(TColorItem.Create('clDarkSlateBlue', clDarkSlateBlue)); + FItems.Add(TColorItem.Create('clDarkSlateGray', clDarkSlateGray)); + FItems.Add(TColorItem.Create('clDarkTurquoise', clDarkTurquoise)); + FItems.Add(TColorItem.Create('clDarkViolet', clDarkViolet)); + FItems.Add(TColorItem.Create('clDeepPink', clDeepPink)); + FItems.Add(TColorItem.Create('clDeepSkyBlue', clDeepSkyBlue)); + FItems.Add(TColorItem.Create('clDimGray',clDimGray )); + FItems.Add(TColorItem.Create('clDodgerBlue', clDodgerBlue)); + FItems.Add(TColorItem.Create('clFireBrick', clFireBrick)); + FItems.Add(TColorItem.Create('clFloralWhite', clFloralWhite)); + FItems.Add(TColorItem.Create('clForestGreen', clForestGreen)); + FItems.Add(TColorItem.Create('clFuchsia', clFuchsia)); + FItems.Add(TColorItem.Create('clGainsboro', clGainsboro)); + FItems.Add(TColorItem.Create('clGhostWhite', clGhostWhite)); + FItems.Add(TColorItem.Create('clGold', clGold)); + FItems.Add(TColorItem.Create('clGoldenrod', clGoldenrod)); + FItems.Add(TColorItem.Create('clGray', clGray)); + FItems.Add(TColorItem.Create('clGreen', clGreen)); + FItems.Add(TColorItem.Create('clGreenYellow', clGreenYellow)); + FItems.Add(TColorItem.Create('clHoneydew', clHoneydew)); + FItems.Add(TColorItem.Create('clHotPink', clHotPink)); + FItems.Add(TColorItem.Create('clIndianRed', clIndianRed)); + FItems.Add(TColorItem.Create('clIndigo', clIndigo)); + FItems.Add(TColorItem.Create('clIvory', clIvory)); + FItems.Add(TColorItem.Create('clKhaki', clKhaki)); + FItems.Add(TColorItem.Create('clLavender', clLavender)); + FItems.Add(TColorItem.Create('clLavenderBlush', clLavenderBlush)); + FItems.Add(TColorItem.Create('clLawnGreen', clLawnGreen)); + FItems.Add(TColorItem.Create('clLemonChiffon', clLemonChiffon)); + FItems.Add(TColorItem.Create('clLightBlue', clLightBlue)); + FItems.Add(TColorItem.Create('clLightCoral', clLightCoral)); + FItems.Add(TColorItem.Create('clLightCyan', clLightCyan)); + FItems.Add(TColorItem.Create('clLightGoldenrodYellow', clLightGoldenrodYellow)); + FItems.Add(TColorItem.Create('clLightGreen', clLightGreen)); + FItems.Add(TColorItem.Create('clLightGray', clLightGray)); + FItems.Add(TColorItem.Create('clLightPink', clLightPink)); + FItems.Add(TColorItem.Create('clLightSalmon', clLightSalmon)); + FItems.Add(TColorItem.Create('clLightSeaGreen', clLightSeaGreen)); + FItems.Add(TColorItem.Create('clLightSkyBlue', clLightSkyBlue)); + FItems.Add(TColorItem.Create('clLightSlateGray', clLightSlateGray)); + FItems.Add(TColorItem.Create('clLightSteelBlue', clLightSteelBlue)); + FItems.Add(TColorItem.Create('clLightYellow', clLightYellow)); + FItems.Add(TColorItem.Create('clLime', clLime)); + FItems.Add(TColorItem.Create('clLimeGreen', clLimeGreen)); + FItems.Add(TColorItem.Create('clLinen', clLinen)); + FItems.Add(TColorItem.Create('clMagenta', clMagenta)); + FItems.Add(TColorItem.Create('clMaroon', clMaroon)); + FItems.Add(TColorItem.Create('clMediumAquamarine', clMediumAquamarine)); + FItems.Add(TColorItem.Create('clMediumBlue', clMediumBlue)); + FItems.Add(TColorItem.Create('clMediumOrchid', clMediumOrchid)); + FItems.Add(TColorItem.Create('clMediumPurple', clMediumPurple)); + FItems.Add(TColorItem.Create('clMediumSeaGreen', clMediumSeaGreen)); + FItems.Add(TColorItem.Create('clMediumSlateBlue', clMediumSlateBlue)); + FItems.Add(TColorItem.Create('clMediumSpringGreen', clMediumSpringGreen)); + FItems.Add(TColorItem.Create('clMediumTurquoise', clMediumTurquoise)); + FItems.Add(TColorItem.Create('clMediumVioletRed', clMediumVioletRed)); + FItems.Add(TColorItem.Create('clMidnightBlue', clMidnightBlue)); + FItems.Add(TColorItem.Create('clMintCream', clMintCream)); + FItems.Add(TColorItem.Create('clMistyRose', clMistyRose)); + FItems.Add(TColorItem.Create('clMoccasin', clMoccasin)); + FItems.Add(TColorItem.Create('clNavajoWhite', clNavajoWhite)); + FItems.Add(TColorItem.Create('clNavy', clNavy)); + FItems.Add(TColorItem.Create('clOldLace', clOldLace)); + FItems.Add(TColorItem.Create('clOlive', clOlive)); + FItems.Add(TColorItem.Create('clOliveDrab', clOliveDrab)); + FItems.Add(TColorItem.Create('clOrange', clOrange)); + FItems.Add(TColorItem.Create('clOrangeRed', clOrangeRed)); + FItems.Add(TColorItem.Create('clOrchid', clOrchid)); + FItems.Add(TColorItem.Create('clPaleGoldenrod', clPaleGoldenrod)); + FItems.Add(TColorItem.Create('clPaleGreen', clPaleGreen)); + FItems.Add(TColorItem.Create('clPaleTurquoise', clPaleTurquoise)); + FItems.Add(TColorItem.Create('clPaleVioletRed', clPaleVioletRed)); + FItems.Add(TColorItem.Create('clPaleBlue',clPaleBlue )); + FItems.Add(TColorItem.Create('clPapayaWhip', clPapayaWhip)); + FItems.Add(TColorItem.Create('clPeachPuff',clPeachPuff )); + FItems.Add(TColorItem.Create('clPeru', clPeru)); + FItems.Add(TColorItem.Create('clPink', clPink)); + FItems.Add(TColorItem.Create('clPlum', clPlum)); + FItems.Add(TColorItem.Create('clPowderBlue', clPowderBlue)); + FItems.Add(TColorItem.Create('clPurple', clPurple)); + FItems.Add(TColorItem.Create('clRed', clRed)); + FItems.Add(TColorItem.Create('clRosyBrown', clRosyBrown)); + FItems.Add(TColorItem.Create('clRoyalBlue', clRoyalBlue)); + FItems.Add(TColorItem.Create('clSaddleBrown', clSaddleBrown)); + FItems.Add(TColorItem.Create('clSalmon', clSalmon)); + FItems.Add(TColorItem.Create('clSandyBrown', clSandyBrown)); + FItems.Add(TColorItem.Create('clSeaGreen', clSeaGreen)); + FItems.Add(TColorItem.Create('clSeashell', clSeashell)); + FItems.Add(TColorItem.Create('clSienna', clSienna)); + FItems.Add(TColorItem.Create('clSilver', clSilver)); + FItems.Add(TColorItem.Create('clSkyBlue2', clSkyBlue2)); + FItems.Add(TColorItem.Create('clSlateBlue', clSlateBlue)); + FItems.Add(TColorItem.Create('clSlateGray', clSlateGray)); + FItems.Add(TColorItem.Create('clSnow', clSnow)); + FItems.Add(TColorItem.Create('clSpringGreen', clSpringGreen)); + FItems.Add(TColorItem.Create('clSteelBlue', clSteelBlue)); + FItems.Add(TColorItem.Create('clTan', clTan)); + FItems.Add(TColorItem.Create('clTeal', clTeal)); + FItems.Add(TColorItem.Create('clThistle', clThistle)); + FItems.Add(TColorItem.Create('clTomato', clTomato)); + FItems.Add(TColorItem.Create('clTurquoise', clTurquoise)); + FItems.Add(TColorItem.Create('clViolet', clViolet)); + FItems.Add(TColorItem.Create('clWheat', clWheat)); + FItems.Add(TColorItem.Create('clWhite', clWhite)); + FItems.Add(TColorItem.Create('clWhiteSmoke', clWhiteSmoke)); + FItems.Add(TColorItem.Create('clYellow', clYellow)); + FItems.Add(TColorItem.Create('clYellowGreen', clYellowGreen)); + end; + end; + FocusItem := 0; + FollowFocus; + UpdateScrollbar; +end; + +procedure TfpgBaseColorListBox.FreeAndClearColors; +var + i: integer; +begin + for i := 0 to FItems.Count-1 do + TColorItem(FItems.Items[i]).Free; + FItems.Clear; +end; + +procedure TfpgBaseColorListBox.DrawItem(num: integer; rect: TfpgRect; flags: integer); +var + itm: TColorItem; +begin + if num < 0 then + Exit; //==> + itm := TColorItem(FItems.Items[num]); + // color box + Canvas.SetColor(itm.ColorValue); + Canvas.FillRectangle(rect.Left + 2, rect.Top + 4, FColorBoxWidth, FColorboxHeight); + Canvas.SetColor(clBlack); + Canvas.DrawRectangle(rect.Left + 2, rect.Top + 4, FColorBoxWidth, FColorboxHeight); + // color text + if FShowColorNames then + fpgStyle.DrawString(Canvas, FColorboxWidth + 8 + rect.left, rect.top+1, itm.ColorName, Enabled); +end; + +constructor TfpgBaseColorListBox.Create(AOwner: TComponent); +begin + inherited Create (AOwner ); + FColorBoxWidth := 35; + FColorBoxHeight := 10; + FShowColorNames := True; + + FItems := TList.Create; + // default Delphi colors + FColorPalette := cpStandardColors; + SetupColorPalette; +end; + +destructor TfpgBaseColorListBox.Destroy; +begin + FreeAndClearColors; + FItems.Free; + inherited Destroy; +end; + +function TfpgBaseColorListBox.ItemCount: integer; +begin + result := FItems.Count; +end; + +end. + diff --git a/src/gui/fpg_listview.pas b/src/gui/fpg_listview.pas new file mode 100644 index 00000000..acb4e337 --- /dev/null +++ b/src/gui/fpg_listview.pas @@ -0,0 +1,1753 @@ +{ + fpGUI - Free Pascal GUI Toolkit + + Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this + distribution, for details of the copyright. + + See the file COPYING.modifiedLGPL, included in this distribution, + for details about redistributing fpGUI. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + Description: + Defines a Listview control. +} + +unit fpg_listview; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, + SysUtils, + fpg_base, + fpg_main, + fpg_widget, + fpg_scrollbar; + +type + TfpgListView = class; + TfpgLVItem = class; + TfpgLVColumns = class; + TfpgLVColumn = class; + + TfpgLVColumnClickEvent = procedure(Listview: TfpgListView; Column: TfpgLVColumn; Button: Integer) of object; + + + TfpgLVColumn = class(TComponent) + private + FAlignment: TAlignment; + FCaptionAlignment: TAlignment; + FDown: Boolean; + FAutoSize: Boolean; + FCaption: String; + FClickable: Boolean; + FColumnIndex: Integer; + FColumns: TfpgLVColumns; + FHeight: Integer; + FResizable: Boolean; + FVisible: Boolean; + FWidth: Integer; + procedure SetAlignment(const AValue: TAlignment); + procedure SetAutoSize(const AValue: Boolean); + procedure SetCaption(const AValue: String); + procedure SetCaptionAlignment(const AValue: TAlignment); + procedure SetColumnIndex(const AValue: Integer); + procedure SetHeight(const AValue: Integer); + procedure SetResizable(const AValue: Boolean); + procedure SetVisible(const AValue: Boolean); + procedure SetWidth(const AValue: Integer); + public + constructor Create(AColumns: TfpgLVColumns); reintroduce; + destructor Destroy; override; + property Caption: String read FCaption write SetCaption; + property CaptionAlignment: TAlignment read FCaptionAlignment write SetCaptionAlignment; + property Alignment: TAlignment read FAlignment write SetAlignment; + property AutoSize: Boolean read FAutoSize write SetAutoSize; + property Width: Integer read FWidth write SetWidth; + property Height: Integer read FHeight write SetHeight; + property Visible: Boolean read FVisible write SetVisible; + property ColumnIndex: Integer read FColumnIndex write SetColumnIndex; + property Clickable: Boolean read FClickable write FClickable; + property Resizable: Boolean read FResizable write SetResizable; + end; + + + TfpgLVColumns = class(TPersistent) + private + FListView: TfpgListView; + FColumns: TList; + function GetColumn(AIndex: Integer): TfpgLVColumn; + procedure SetColumn(AIndex: Integer; const AValue: TfpgLVColumn); + public + constructor Create(AListView: TfpgListView); + destructor Destroy; override; + function Add(AColumn: TfpgLVColumn): Integer; + procedure Clear; + procedure Delete(AIndex: Integer); + procedure Insert(AColumn: TfpgLVColumn; AIndex: Integer); + function Count: Integer; + property Column[AIndex: Integer]: TfpgLVColumn read GetColumn write SetColumn; + end; + + + TfpgLVItemState = set of (lisFocused, lisSelected, lisHotTrack); + + TfpgLVItemPaintPart = set of (lvppBackground, lvppIcon, lvppText, lvppFocused); + + TfpgLVPaintColumnEvent = procedure(ListView: TfpgListView; Canvas: TfpgCanvas; Column: TfpgLVColumn; + ColumnIndex: Integer; Area: TfpgRect; var PaintPart: TfpgLVItemPaintPart) of object; + TfpgLVPaintItemEvent = procedure(ListView: TfpgListView; Canvas: TfpgCanvas; Item: TfpgLVItem; + ItemIndex: Integer; Area:TfpgRect; var PaintPart: TfpgLVItemPaintPart) of object; + TfpgLVItemSelectEvent = procedure(ListView: TfpgListView; Item: TfpgLVItem; + ItemIndex: Integer; Selected: Boolean) of object; + + + IfpgLVItemViewer = interface + procedure ItemDeleted(AIndex: Integer); + procedure ItemAdded(AIndex: Integer); + procedure ItemChanged(AIndex: Integer); + procedure ItemsUpdated; + end; + + + TfpgLVItems = class(TObject) + private + FUpdateCount: Integer; + FColumns: TfpgLVColumns; + FCurrentIndexOf: Integer; + FViewers: TList; + FItems: TList; + function GetCapacity: Integer; + function GetItem(AIndex: Integer): TfpgLVItem; + procedure SetCapacity(const AValue: Integer); + procedure SetItem(AIndex: Integer; const AValue: TfpgLVItem); + procedure AddViewer(AValue: IfpgLVItemViewer); + procedure DeleteViewer(AValue: IfpgLVItemViewer); + // interface method triggers + procedure DoChange(AItem: TfpgLVItem); + procedure DoAdd(AItem: TfpgLVItem); + procedure DoDelete(AItem: TfpgLVItem); + procedure DoEndUpdate; + public + constructor Create(AViewer: IfpgLVItemViewer); + destructor Destroy; override; + function Add(AItem: TfpgLVItem): Integer; + function Count: Integer; + procedure Clear; + procedure Delete(AIndex: Integer); + function IndexOf(AItem: TfpgLVItem): Integer; + procedure InsertItem(AItem: TfpgLVItem; AIndex: Integer); + procedure BeginUpdate; + procedure EndUpdate; + property Capacity: Integer read GetCapacity write SetCapacity; + property Columns: TfpgLVColumns read FColumns; + property Item[AIndex: Integer]: TfpgLVItem read GetItem write SetItem; + end; + + + TfpgLVItem = class(TObject) + private + FCaption: String; + FItems: TfpgLVItems; + FSubItems: TStrings; + FUserData: Pointer; + function GetSelected(ListView: TfpgListView): Boolean; + procedure SetCaption(const AValue: String); + procedure SetSelected(ListView: TfpgListView; const AValue: Boolean); + procedure SubItemsChanged(Sender: TObject); + public + constructor Create(Items: TfpgLVItems); virtual; + destructor Destroy; override; + property Caption: String read FCaption write SetCaption; + property UserData: Pointer read FUserData write FUserData; + property SubItems: TStrings read FSubItems; + property Selected[ListView: TfpgListView]: Boolean read GetSelected write SetSelected; + end; + + + TfpgListView = class(TfpgWidget, IfpgLVItemViewer) + private + FItemIndex: Integer; + FMultiSelect: Boolean; + FOnPaintColumn: TfpgLVPaintColumnEvent; + FOnSelectionChanged: TfpgLVItemSelectEvent; + FShiftCount: Integer; + FSelectionFollowsFocus: Boolean; + FSelectionShiftStart: Integer; + FOnColumnClick: TfpgLVColumnClickEvent; + FSelected: TList; + FOldSelected: TList; + FUpdateCount: Integer; + FVScrollBar: TfpgScrollBar; + FHScrollBar: TfpgScrollBar; + FColumns: TfpgLVColumns; + FItems: TfpgLVItems; + FOnPaintItem: TfpgLVPaintItemEvent; + FShowHeaders: Boolean; + FResizingColumn: TfpgLVColumn; + FMouseDownPoint: TPoint; + FScrollBarNeedsUpdate: Boolean; + function GetItemHeight: Integer; + procedure SetItemIndex(const AValue: Integer); + procedure SetItems(const AValue: TfpgLVItems); + procedure SetMultiSelect(const AValue: Boolean); + procedure SetOnColumnClick(const AValue: TfpgLVColumnClickEvent); + procedure SetShowHeaders(const AValue: Boolean); + procedure VScrollChange(Sender: TObject; Position: Integer); + procedure HScrollChange(Sender: TObject; Position: Integer); + // interface methods + procedure ItemDeleted(AIndex: Integer); + procedure ItemAdded(AIndex: Integer); + procedure ItemChanged(AIndex: Integer); + procedure ItemsUpdated; + // + function GetVisibleColumnsWidth: Integer; + function GetItemAreaHeight: Integer; + procedure StartShiftSelection; + procedure EndShiftSelection; + procedure SelectionSetRangeEnabled(AStart, AEnd: Integer; AValue: Boolean); + procedure SelectionToggleRange(AStart, AEnd: Integer; const ShiftState: TShiftState; IgnoreStartIndex: Boolean); + procedure SelectionClear; + function ItemGetSelected(const AItem: TfpgLVItem): Boolean; + procedure ItemSetSelected(const AItem: TfpgLVItem; const AValue: Boolean); + function ItemGetFromPoint(const X, Y: Integer): TfpgLVItem; + function ItemGetRect(AIndex: Integer): TfpgRect; + function ItemIndexFromY(Y: Integer): Integer; + function HeaderHeight: Integer; + procedure DoRepaint; + procedure DoColumnClick(Column: TfpgLVColumn; Button: Integer); + procedure HandleHeaderMouseMove(x, y: Integer; btnstate: word; Shiftstate: TShiftState); + protected + procedure MsgPaint(var msg: TfpgMessageRec); message FPGM_PAINT; + procedure HandleMouseScroll(x, y: integer; shiftstate: TShiftState; delta: smallint); override; + procedure HandleLMouseDown(x, y: integer; shiftstate: TShiftState); override; + procedure HandleRMouseDown(x, y: integer; shiftstate: TShiftState); override; + procedure HandleLMouseUp(x, y: integer; shiftstate: TShiftState); override; + procedure HandleRMouseUp(x, y: integer; shiftstate: TShiftState); override; + procedure HandleMouseMove(x, y: integer; btnstate: word; shiftstate: TShiftState); override; + procedure HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override; + procedure HandleKeyRelease(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override; + procedure HandlePaint; override; + procedure HandleResize(awidth, aheight: TfpgCoord); override; + procedure PaintHeaders; virtual; + procedure PaintItems; virtual; + procedure UpdateScrollBarPositions; virtual; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + function GetClientRect: TfpgRect; override; + procedure BeginUpdate; + procedure EndUpdate; + procedure MakeItemVisible(AIndex: Integer; PartialOK: Boolean = False); + function ItemAdd: TfpgLVItem; + published + property Columns: TfpgLVColumns read FColumns; + property HScrollBar: TfpgScrollBar read FHScrollBar; + property ItemHeight: Integer read GetItemHeight; + property ItemIndex: Integer read FItemIndex write SetItemIndex; + property Items: TfpgLVItems read FItems write SetItems; + property MultiSelect: Boolean read FMultiSelect write SetMultiSelect; + property ParentShowHint; + property SelectionFollowsFocus: Boolean read FSelectionFollowsFocus write FSelectionFollowsFocus; + property ShowHeaders: Boolean read FShowHeaders write SetShowHeaders; + property ShowHint; + property TabOrder; + property VScrollBar: TfpgScrollBar read FVScrollBar; + property OnColumnClick: TfpgLVColumnClickEvent read FOnColumnClick write SetOnColumnClick; + property OnPaintColumn: TfpgLVPaintColumnEvent read FOnPaintColumn write FOnPaintColumn; + property OnPaintItem: TfpgLVPaintItemEvent read FOnPaintItem write FOnPaintItem; + property OnSelectionChanged: TfpgLVItemSelectEvent read FOnSelectionChanged write FOnSelectionChanged; + end; + + +implementation + +uses + fpg_constants; + + +type + // used to access protected methods + TfpgScrollbarFriend = class(TfpgScrollbar) + end; + +{ TfpgLVItems } + +function Min(AInt, BInt: Integer): Integer; +begin + if AInt < Bint then + Result := AInt + else Result := BInt; +end; + +function Max(AInt, BInt: Integer): INteger; +begin + if AInt > Bint then + Result := AInt + else Result := BInt; +end; + +function TfpgLVItems.GetItem(AIndex: Integer): TfpgLVItem; +begin + Result := TfpgLVItem(FItems.Items[AIndex]); +end; + +function TfpgLVItems.GetCapacity: Integer; +begin + Result := FItems.Capacity; +end; + +procedure TfpgLVItems.SetCapacity(const AValue: Integer); +begin + FItems.Capacity := AValue; +end; + +procedure TfpgLVItems.SetItem(AIndex: Integer; const AValue: TfpgLVItem); +begin + FItems.Items[AIndex] := AValue; +end; + +procedure TfpgLVItems.AddViewer(AValue: IfpgLVItemViewer); +begin + if AValue <> nil then + FViewers.Add(AValue); +end; + +procedure TfpgLVItems.DeleteViewer(AValue: IfpgLVItemViewer); +var + AIndex: Integer; +begin + AIndex := FViewers.IndexOf(AValue); + if AIndex > -1 then + begin + FViewers.Delete(AIndex); + end; + if FViewers.Count = 0 then + Free; +end; + +procedure TfpgLVItems.DoChange(AItem: TfpgLVItem); +var + I: Integer; + AIndex: Integer; +begin + if FUpdateCount > 0 then + Exit; + AIndex := IndexOf(AItem); + for I := 0 to FViewers.Count -1 do + begin + IfpgLVItemViewer(FViewers.Items[I]).ItemChanged(AIndex); + end; +end; + +procedure TfpgLVItems.DoAdd(AItem: TfpgLVItem); +var + I: Integer; + AIndex: Integer; +begin + if FUpdateCount > 0 then + Exit; + AIndex := IndexOf(AItem); + for I := 0 to FViewers.Count -1 do + begin + IfpgLVItemViewer(FViewers.Items[I]).ItemAdded(AIndex); + end; +end; + +procedure TfpgLVItems.DoDelete(AItem: TfpgLVItem); +var + I: Integer; + AIndex: Integer; +begin + if FUpdateCount > 0 then + Exit; + AIndex := IndexOf(AItem); + for I := 0 to FViewers.Count -1 do + begin + IfpgLVItemViewer(FViewers.Items[I]).ItemDeleted(AIndex); + end; +end; + +procedure TfpgLVItems.DoEndUpdate; +var + I: Integer; +begin + if FUpdateCount > 0 then + Exit; + for I := 0 to FViewers.Count -1 do + begin + IfpgLVItemViewer(FViewers.Items[I]).ItemsUpdated; + end; +end; + +constructor TfpgLVItems.Create(AViewer: IfpgLVItemViewer); +begin + FItems := TList.Create; + FViewers := TList.Create; + AddViewer(AViewer); +end; + +destructor TfpgLVItems.Destroy; +begin + FItems.Free; + FViewers.Free; + inherited Destroy; +end; + +function TfpgLVItems.Add(AItem: TfpgLVItem): Integer; +begin + Result := Count; + InsertItem(AItem, Count); + DoAdd(AItem); +end; + +function TfpgLVItems.Count: Integer; +begin + Result := FItems.Count; +end; + +procedure TfpgLVItems.Clear; +var + i: integer; +begin + for i := FItems.Count-1 downto 0 do + Delete(i); + FItems.Clear; +end; + +procedure TfpgLVItems.Delete(AIndex: Integer); +begin + DoDelete(GetItem(AIndex)); + FItems.Delete(AIndex); +end; + +function TfpgLVItems.IndexOf(AItem: TfpgLVItem): Integer; +begin + Result := -1; + // this checks for a index close to the old one whic can speed up + // search significantly when we are using indexof in a for loop + if (FCurrentIndexOf > 100) and (FCurrentIndexOf < Count-2) then + begin + if FItems.Items[FCurrentIndexOf] = Pointer(AItem) then + Result := FCurrentIndexOf + else if FItems.Items[FCurrentIndexOf+1] = Pointer(AItem) then + Result := FCurrentIndexOf+1 + else if FItems.Items[FCurrentIndexOf-1] = Pointer(AItem) then + Result := FCurrentIndexOf-1 + end; + if Result = -1 then + Result := FItems.IndexOf(AItem); + FCurrentIndexOf := Result; +end; + +procedure TfpgLVItems.InsertItem(AItem: TfpgLVItem; AIndex: Integer); +begin + if AItem.InheritsFrom(TfpgLVItem) then + FItems.Insert(AIndex, AItem) + else + raise Exception.CreateFmt(rsErrItemOfWrongType, ['TfpgLVItem']); +end; + +procedure TfpgLVItems.BeginUpdate; +begin + Inc(FUpdateCount); +end; + +procedure TfpgLVItems.EndUpdate; +begin + Dec(FUpdateCount); + if FUpdateCount < 0 then + FUpdateCount := 0; + if FUpdateCount = 0 then + DoEndUpdate; +end; + +{ TfpgLVItem } + +procedure TfpgLVItem.SetCaption(const AValue: String); +begin + if FCaption=AValue then + Exit; + FCaption:=AValue; + if Assigned(FItems) then + FItems.DoChange(Self); +end; + +function TfpgLVItem.GetSelected(ListView: TfpgListView): Boolean; +begin + Result := ListView.ItemGetSelected(Self); +end; + +procedure TfpgLVItem.SetSelected(ListView: TfpgListView; const AValue: Boolean); +begin + ListView.ItemSetSelected(Self, AValue); +end; + +procedure TfpgLVItem.SubItemsChanged(Sender: TObject); +begin + if Assigned(FItems) then + FItems.DoChange(Self); +end; + +constructor TfpgLVItem.Create(Items: TfpgLVItems); +begin + FItems := Items; + FSubItems := TStringList.Create; + TStringList(FSubItems).OnChange := @SubItemsChanged; +end; + +destructor TfpgLVItem.Destroy; +begin + FSubItems.Free; + inherited Destroy; +end; + +{ TfpgListView } + + +procedure TfpgListView.SetShowHeaders(const AValue: Boolean); +begin + if FShowHeaders=AValue then + Exit; + FShowHeaders:=AValue; + DoRePaint; +end; + + +procedure TfpgListView.VScrollChange(Sender: TObject; Position: Integer); +begin + DoRepaint; +end; + +procedure TfpgListView.HScrollChange(Sender: TObject; Position: Integer); +begin + DoRepaint; +end; + +procedure TfpgListView.SetItems(const AValue: TfpgLVItems); +begin + if AValue = FItems then + Exit; + AValue.AddViewer(Self); + FItems.DeleteViewer(Self); + Fitems := AValue; +end; + +procedure TfpgListView.SetMultiSelect(const AValue: Boolean); +begin + if FMultiSelect=AValue then + Exit; + FMultiSelect:=AValue; +end; + +procedure TfpgListView.SetOnColumnClick(const AValue: TfpgLVColumnClickEvent); +begin + if FOnColumnClick=AValue then + Exit; + FOnColumnClick:=AValue; +end; + +function TfpgListView.GetItemHeight: Integer; +begin + Result := Canvas.Font.Height + 4; +end; + +procedure TfpgListView.SetItemIndex(const AValue: Integer); +begin + if FItemIndex=AValue then + Exit; + if (AValue >= -1) and (AValue < FItems.Count) then + FItemIndex:=AValue; +end; + +procedure TfpgListView.ItemDeleted(AIndex: Integer); +begin + if FUpdateCount = 0 then + DoRePaint; +end; + +procedure TfpgListView.ItemAdded(AIndex: Integer); +begin + if FUpdateCount = 0 then + DoRePaint; +end; + +procedure TfpgListView.ItemChanged(AIndex: Integer); +begin + if FUpdateCount = 0 then + DoRePaint; +end; + +procedure TfpgListView.ItemsUpdated; +begin + DoRepaint; +end; + +function TfpgListView.GetClientRect: TfpgRect; +begin + Result.Top := 2; + Result.Left := 2; + Result.SetRight(Width - 2); + Result.SetBottom(Height - 2); +end; + +function TfpgListView.GetVisibleColumnsWidth: Integer; +var + I: Integer; +begin + Result := 0; + for I := 0 to FColumns.Count-1 do + if FColumns.Column[I].Visible then + Inc(Result, FColumns.Column[I].Width); +end; + +function TfpgListView.GetItemAreaHeight: Integer; +begin + Result := Height - 4; + if ShowHeaders then + Dec(Result, HeaderHeight); + if FHScrollBar.Visible then + Dec(Result,FHScrollBar.Height); +end; + +procedure TfpgListView.StartShiftSelection; +var + I: Integer; +begin + Inc(FShiftCount); + if FItems.Count = 0 then + Exit; + if FShiftCount> 1 then + Exit; + FSelectionShiftStart := FItemIndex; + if FSelectionShiftStart = -1 then + Inc(FSelectionShiftStart); + FOldSelected.Clear; + FOldSelected.Capacity := FSelected.Capacity; + for I := 0 to FSelected.Count-1 do + begin + FOldSelected.Add(FSelected.Items[I]); + end; +end; + +procedure TfpgListView.EndShiftSelection; +begin + Dec(FShiftCount); + if FShiftCount > 0 then + Exit; + FSelectionShiftStart := -1; + FOldSelected.Clear; +end; + +procedure TfpgListView.SelectionSetRangeEnabled(AStart, AEnd: Integer; AValue: Boolean); +var + TmpI: LongInt; + I: LongInt; + ShouldShow: Boolean; +begin + if AStart > AEnd then + begin + TmpI := AStart; + AStart := AEnd; + AEnd := TmpI; + end; + FSelected.Clear; + FSelected.Capacity := FOldSelected.Capacity; + for I := 0 to FOldSelected.Count-1 do + begin + FSelected.Add(FOldSelected.Items[I]); + end; + if (AStart < 0) or (AEnd > FItems.Count-1) then + Exit; + for I := AStart to AEnd do + begin + ShouldShow := AValue; + if FOldSelected.IndexOf(FItems.Item[I]) > -1 then + ShouldShow := not AValue; + + if I <> FSelectionShiftStart then + ItemSetSelected(FItems.Item[I], ShouldShow); + end; +end; + +procedure TfpgListView.SelectionToggleRange(AStart, AEnd: Integer; + const ShiftState: TShiftState; IgnoreStartIndex: Boolean); +var + TmpI: Integer; + I: LongInt; +begin + TmpI := AStart; + if AStart > AEnd then + begin + AStart := AEnd; + AEnd := TmpI; + end; + if not FMultiSelect then + begin + SelectionClear; + ItemSetSelected(FItems.Item[TmpI], True); + Exit; + end; + if ssShift in ShiftState then + for I := AStart to AEnd do + begin + if not(IgnoreStartIndex and (I = TmpI)) + then ItemSetSelected(FItems.Item[I], not ItemGetSelected(FItems.Item[I])); + end; +end; + +procedure TfpgListView.SelectionClear; +var + Item: TfpgLVItem; + I: Integer; +begin + for I := FSelected.Count-1 downto 0 do + begin + Item := TfpgLVItem(FSelected.Items[I]); + FSelected.Delete(I); + if Assigned(FOnSelectionChanged) then + FOnSelectionChanged(Self, Item, Items.IndexOf(Item), False); + end; + +end; + + +function TfpgListView.ItemGetSelected(const AItem: TfpgLVItem): Boolean; +begin + Result := FSelected.IndexOf(AItem) > -1; +end; + +procedure TfpgListView.ItemSetSelected(const AItem: TfpgLVItem; const AValue: Boolean); +var + Index: Integer; +begin + Index := FSelected.IndexOf(AItem); + + if AValue and (Index = -1) then + FSelected.Add(AItem); + if (AValue = False) and (Index <> -1) then + FSelected.Delete(Index); + if Assigned(FOnSelectionChanged) then + FOnSelectionChanged(Self, AItem, Items.IndexOf(AItem), AValue); +end; + +function TfpgListView.ItemGetFromPoint(const X, Y: Integer): TfpgLVItem; +var + Index: Integer; + ItemTop: Integer; +begin + Result := nil; + ItemTop := (FVScrollBar.Position + Y) -2; + if ShowHeaders then + Dec(ItemTop, HeaderHeight); + Index := ItemTop div ItemHeight; + if Index < 0 then + Exit; + if Index >= FItems.Count then + Exit; + if FHScrollBar.Position - 2 + X > GetVisibleColumnsWidth then + Exit; + + Result := FItems.Item[Index]; +end; + +function TfpgListView.ItemGetRect(AIndex: Integer): TfpgRect; +begin + Result.Top := 2 + (AIndex * ItemHeight) - FVScrollBar.Position; + if ShowHeaders then + Inc(Result.Top, HeaderHeight); + Result.Height := ItemHeight; + Result.Left := 2 - FHScrollBar.Position; + Result.Width := GetVisibleColumnsWidth; +end; + +function TfpgListView.ItemIndexFromY(Y: Integer): Integer; +var + TopPos: Integer; +begin + if ShowHeaders and (Y < HeaderHeight) then + Exit(-1); + + TopPos := (FVScrollBar.Position + Y) - 2; + if ShowHeaders then + Dec(TopPos, HeaderHeight); + Result := TopPos div ItemHeight; + if Result > Fitems.Count-1 then + Result := -1; +end; + +function TfpgListView.HeaderHeight: Integer; +begin + Result := Canvas.Font.Height + 10; +end; + +procedure TfpgListView.DoRepaint; +begin + if FUpdateCount = 0 then + RePaint; +end; + +procedure TfpgListView.DoColumnClick(Column: TfpgLVColumn; Button: Integer); +begin + if not Column.Clickable then + Exit; + if Assigned(FOnColumnClick) then + FOnColumnClick(Self, Column, Button); + + Column.FDown := True; + + if FUpdateCount = 0 then + begin + Canvas.BeginDraw(False); + PaintHeaders; + Canvas.EndDraw;//(2,2, width-4, Height-4); + end; +end; + +procedure TfpgListView.HandleHeaderMouseMove(x, y: Integer; btnstate: word; + Shiftstate: TShiftState); +var + I: Integer; + curLeft: Integer; + curRight: Integer; + Column: TfpgLVColumn; + LastColumn: TfpgLVColumn; + HeaderX: Integer; // this is X from the headers point of view + NewMouseCursor: TMouseCursor; +begin + curLeft := 0; + + HeaderX := FHScrollBar.Position - 2 + X; + NewMouseCursor := MouseCursor; + LastColumn := nil; + for I := 0 to FColumns.Count-1 do + begin + Column := FColumns.Column[I]; + if not Column.Visible then + Continue; + curRight := curLeft + Column.Width-1; + if Column.Resizable or (Assigned(LastColumn) and LastColumn.Resizable) then + begin + if (FResizingColumn <> nil) and (FResizingColumn = Column) then + begin + FResizingColumn.Width := (x + FHScrollBar.Position)- curLeft; + DoRepaint; + Break; + end + else begin + if (HeaderX >= curLeft) and (HeaderX <= curRight) then // we are within this columns space + begin + if ((LastColumn <> nil) and (LastColumn.Resizable) and (HeaderX - curLeft < 5)) + or (Column.Resizable) and (curRight - HeaderX < 5) + then + begin + NewMouseCursor := mcSizeEW; + Break; + end; + end + else + NewMouseCursor := mcDefault; + end; + end; + LastColumn := Column; + Inc(curLeft, Column.Width); + end; + if not Assigned(FResizingColumn) and Assigned(LastColumn) and LastColumn.Resizable then + if (HeaderX - curLeft < 5) and (HeaderX - curLeft >= 0) then + NewMouseCursor := mcSizeEW; + + if FResizingColumn <> nil then + NewMouseCursor := mcSizeEW; + + if NewMouseCursor <> MouseCursor then + MouseCursor := NewMouseCursor; + +end; + +procedure TfpgListView.MsgPaint(var msg: TfpgMessageRec); +begin + // Optimises painting and prevents Begin[End]Draw and OnPaint event firing + // in not needed. + if FUpdateCount = 0 then + inherited MsgPaint(msg); +end; + +procedure TfpgListView.HandleMouseScroll(x, y: integer; + shiftstate: TShiftState; delta: smallint); +var + cRect: TfpgRect; +begin + cRect := GetClientRect; + if FShowHeaders then + Inc(cRect.Top, HeaderHeight); + if FHScrollBar.Visible then + Dec(cRect.Height, FHScrollBar.Height); + if FVScrollBar.Visible then + Dec(cRect.Width, FVScrollBar.Width); + + + if not PtInRect(cRect, Point(X,Y)) then + Exit; + + TfpgScrollbarFriend(FVScrollBar).HandleMouseScroll(x, y, shiftstate, delta); +end; + +procedure TfpgListView.HandleLMouseDown(x, y: integer; shiftstate: TShiftState); +var + Item: TfpgLVItem; + cRect: TfpgRect; + curLeft, curRight: Integer; + I: Integer; + Column: TfpgLVColumn; + LastColumn: TfpgLVColumn; + HeaderX: Integer; +begin + inherited HandleLMouseDown(x, y, shiftstate); + + cRect := GetClientRect; + + FMouseDownPoint := Point(X,Y); + + if not PtInRect(cRect, Point(X,Y)) then + Exit; + + if FShowHeaders then + begin + if (Y < HeaderHeight + cRect.Top) then + begin + LastColumn := nil; + HeaderX := FHScrollBar.Position - 2 + x; + + curLeft := 0; + for I := 0 to FColumns.Count-1 do + begin + Column := FColumns.Column[I]; + if Column.Visible then + begin + curRight := curLeft + Column.Width-1; + if (HeaderX <= curRight) and (HeaderX >= curLeft) then + begin + if (MouseCursor = mcSizeEW) then + begin + if Column.Resizable and (curRight - HeaderX < 5) then + FResizingColumn := Column + else + if Assigned(LastColumn) and LastColumn.Resizable and (HeaderX - curLeft < 5) then + FResizingColumn := LastColumn + end + else // only perform a mouse click if we aren't resizing + DoColumnClick(Column, 1); + end; + Inc(curLeft, Column.Width); + end; + LastColumn := Column; + end; + if not Assigned(FResizingColumn) and Assigned(LastColumn) and LastColumn.Resizable then + if (HeaderX - curLeft < 5) and (HeaderX - curLeft >= 0) then + FResizingColumn := LastColumn; + end; + + Inc(cRect.Top, HeaderHeight); + end; + + if FHScrollBar.Visible then + Dec(cRect.Height, FHScrollBar.Height); + if FVScrollBar.Visible then + Dec(cRect.Width, FVScrollBar.Width); + + if not PtInRect(cRect, Point(X,Y)) then + Exit; + + Item := ItemGetFromPoint(X, Y); + if not FMultiSelect then + SelectionClear; + if Item <> nil then + begin + FItemIndex := ItemIndexFromY(Y); + MakeItemVisible(FItemIndex); + if FMultiSelect then + begin + if not ((ssCtrl in shiftstate) or (ssShift in shiftstate)) then + begin + SelectionClear; + ItemSetSelected(Item, True); + end + else begin + if ssCtrl in shiftstate then + ItemSetSelected(Item, not ItemGetSelected(Item)); + if ssShift in shiftstate then + SelectionSetRangeEnabled(FSelectionShiftStart, FItemIndex, True); + end + end + else ItemSetSelected(Item, True); + end; + DoRepaint; +end; + +procedure TfpgListView.HandleRMouseDown(x, y: integer; shiftstate: TShiftState); +var + I: Integer; + cLeft, cRight: Integer; + cRect: TfpgRect; + Column: TfpgLVColumn; +begin + inherited HandleRMouseDown(x, y, shiftstate); + + cRect := GetClientRect; + + if not PtInRect(cRect, Point(X,Y)) then + Exit; + + if FShowHeaders then + begin + if (Y < HeaderHeight + cRect.Top) then + begin + cLeft := cRect.Left - FHScrollBar.Position; + for I := 0 to FColumns.Count-1 do + begin + Column := FColumns.Column[I]; + if Column.Visible then + begin + cRight := cLeft + Column.Width-1; + if (X <= cRight) and (X >= cLeft) then + DoColumnClick(Column, 3); + Inc(cLeft, Column.Width); + end; + end; + end; + Inc(cRect.Top, HeaderHeight); + end; + + if FVScrollBar.Visible then + Dec(cRect.Width, FVScrollBar.Width); + if FHScrollBar.Visible then + Dec(cRect.Height, FHScrollBar.Height); +end; + +procedure TfpgListView.HandleLMouseUp(x, y: integer; shiftstate: TShiftState); +var + I: Integer; +begin + inherited HandleLMouseUp(x, y, shiftstate); + for I := 0 to FColumns.Count-1 do + begin + FColumns.Column[I].FDown := False; + end; + + FResizingColumn := nil; + DoRepaint; +end; + +procedure TfpgListView.HandleRMouseUp(x, y: integer; shiftstate: TShiftState); +var + I: Integer; +begin + inherited HandleRMouseUp(x, y, shiftstate); + for I := 0 to FColumns.Count-1 do + begin + FColumns.Column[I].FDown := False; + end; + DoRepaint; +end; + +procedure TfpgListView.HandleMouseMove(x, y: integer; btnstate: word; + shiftstate: TShiftState); +var + cRect: TfpgRect; +begin + inherited HandleMouseMove(x, y, btnstate, shiftstate); + + cRect := GetClientRect; + + if not PtInRect(cRect, Point(X,Y)) and (FResizingColumn = nil) then + Exit; + + if ((Y < (cRect.Top + HeaderHeight)) and ShowHeaders) or (FResizingColumn <> nil) then + begin + HandleHeaderMouseMove(x, y, btnstate, shiftstate); + end + else + if (MouseCursor <> mcDefault) and (FResizingColumn = nil) then + MouseCursor := mcDefault; + + //if FVScrollBar.Visible then Dec(cRect.Width, FVScrollBar.Width); + //if FHScrollBar.Visible then Dec(cRect.Height, FHScrollBar.Height); +end; + +procedure TfpgListView.HandleKeyPress(var keycode: word; + var shiftstate: TShiftState; var consumed: boolean); +var + iIndex: Integer; + OldIndex: Integer; + procedure CheckMultiSelect; + begin + if FMultiSelect then begin + if (ssShift in shiftstate) or (FSelectionShiftStart > -1) then + begin + SelectionSetRangeEnabled(FSelectionShiftStart, FItemIndex, True); + end + else if ssCtrl in shiftstate then + begin + SelectionToggleRange(FItemIndex, FItemIndex, shiftstate, False); + end; + end; + end; + procedure CheckSelectionFocus; + begin + if ((ssShift in shiftstate) or (ssCtrl in shiftstate)) then + Exit; + SelectionClear; + if FSelectionFollowsFocus and (FItemIndex > -1) then + ItemSetSelected(FItems.Item[FItemIndex], True); + end; +begin + consumed := True; + OldIndex := FItemIndex; + //WriteLn('Got key: ',IntToHex(keycode, 4)); + case keycode of + keyShift, keyShiftR: + begin + if FMultiSelect then + StartShiftSelection; + end; + keyUp: + begin + if ItemIndex > 0 then + ItemIndex := ItemIndex-1; + MakeItemVisible(ItemIndex); + if OldIndex <> ItemIndex then + CheckSelectionFocus; + CheckMultiSelect; + end; + keyDown: + begin + ItemIndex := ItemIndex+1; + MakeItemVisible(ItemIndex); + if OldIndex <> ItemIndex then + CheckSelectionFocus; + CheckMultiSelect; + end; + keyLeft: + begin + FHScrollBar.Position := FHScrollBar.Position - FHScrollBar.ScrollStep; + end; + keyRight: + begin + FHScrollBar.Position := FHScrollBar.Position + FHScrollBar.ScrollStep; + end; + keyHome: + begin + ItemIndex := 0; + MakeItemVisible(ItemIndex); + if OldIndex <> ItemIndex then + CheckSelectionFocus; + CheckMultiSelect; + end; + keyEnd: + begin + ItemIndex := FItems.Count-1; + MakeItemVisible(ItemIndex); + if OldIndex <> ItemIndex then + CheckSelectionFocus; + CheckMultiSelect; + end; + keyPageUp: + begin + iIndex := ItemIndex - (GetItemAreaHeight div ItemHeight); + if iIndex < 0 then + iIndex := 0; + ItemIndex := iIndex; + MakeItemVisible(ItemIndex); + if OldIndex <> ItemIndex then + CheckSelectionFocus; + CheckMultiSelect; + end; + keyPageDown: + begin + iIndex := ItemIndex + (GetItemAreaHeight div ItemHeight); + if iIndex > FItems.Count-1 then + iIndex := FItems.Count-1; + ItemIndex := iIndex; + MakeItemVisible(ItemIndex); + if OldIndex <> ItemIndex then + CheckSelectionFocus; + CheckMultiSelect + end; + else + consumed := False; + inherited HandleKeyPress(keycode, shiftstate, consumed); + Exit; + end; + DoRepaint; + +end; + +procedure TfpgListView.HandleKeyRelease(var keycode: word; + var shiftstate: TShiftState; var consumed: boolean); +begin + consumed := True; + case keycode of + keyShift, keyShiftR: + begin + EndShiftSelection; + end; + else + consumed := False; + inherited HandleKeyRelease(keycode, shiftstate, consumed); + end; + +end; + +procedure TfpgListView.HandlePaint; +var + ClipRect: TfpgRect; +begin + //if FScrollBarNeedsUpdate then + UpdateScrollBarPositions; + fpgStyle.DrawControlFrame(Canvas, 0, 0, Width, Height); + + ClipRect.Top := 2; + ClipRect.Left := 2; + ClipRect.Width := Width -4; + ClipRect.Height := Height -4; + + if ShowHeaders then + begin + PaintHeaders; + Inc(ClipRect.Top, HeaderHeight); + Dec(ClipRect.Height, HeaderHeight); + end; + + Canvas.SetClipRect(ClipRect); + + // this paints the small square remaining below the vscrollbar and to the right of the hscrollbar + if FVScrollBar.Visible and FHScrollBar.Visible then + begin + Canvas.Color := clButtonFace; + Canvas.FillRectangle(Width - 2 - FVScrollBar.Width, + Height - 2 - FHScrollBar.Height, + Width - 2, + Height - 2); + end; + + if FVScrollBar.Visible then + Dec(ClipRect.Width, FVScrollBar.Width); + if FHScrollBar.Visible then + Dec(ClipRect.Height, FhScrollBar.Height); + + Canvas.SetClipRect(ClipRect); + PaintItems; +end; + +procedure TfpgListView.HandleResize(awidth, aheight: TfpgCoord); +begin + inherited HandleResize(awidth, aheight); + FScrollBarNeedsUpdate := FScrollBarNeedsUpdate or FSizeIsDirty; +end; + +procedure TfpgListView.PaintHeaders; +var + I: Integer; + cLeft, + cTop: Integer; + Column: TfpgLVColumn; + Flags: TFButtonFlags; + ClipRect: TfpgRect; + cRect: TfpgRect; + PaintPart: TfpgLVItemPaintPart; + tWidth, + tLeft: Integer; +begin + cLeft := 2; + ClipRect.Top := 2; + ClipRect.Left := 2; + ClipRect.Height := HeaderHeight; + ClipRect.Width := Width -4; + Canvas.SetClipRect(ClipRect); + + if FHScrollBar.Visible then Dec(cLeft, FHScrollBar.Position); + cTop := 2; + for I := 0 to Columns.Count-1 do + begin + Column := Columns.Column[I]; + if Column.Visible then + begin + Flags := [btfIsEmbedded]; + if Column.FDown then Flags := Flags + [btfIsPressed]; + cRect.Top := cTop; + cRect.Left := cLeft; + cRect.Width := Column.Width; + cRect.Height := HeaderHeight; + fpgStyle.DrawButtonFace(Canvas,cLeft, cRect.Top, cRect.Width, cRect.Height, Flags); + PaintPart := [lvppText]; + + if Assigned(FOnPaintColumn) then + FOnPaintColumn(Self, Canvas, Column, I, cRect, PaintPart); + + if lvppText in PaintPart then + begin + tLeft := cLeft; + tWidth := Canvas.Font.TextWidth(Column.Caption); + case Column.CaptionAlignment of + taRightJustify: Inc(tLeft, Column.Width - tWidth - 5); + taCenter: Inc(tLeft, (Column.Width - tWidth - 5) div 2); + taLeftJustify: Inc(tLeft, 5); + end; + fpgStyle.DrawString(Canvas, tLeft, cTop+5, Column.Caption, Enabled); + end; + Inc(cLeft, Column.Width); + end; + end; + if cLeft < FWidth-2 then + begin + Canvas.SetColor(clButtonFace); + Canvas.FillRectangle(cLeft, cTop, cLeft+(Width-3-cLeft), Canvas.Font.Height+10); + end; +end; + +procedure TfpgListView.PaintItems; +var + FirstIndex, + LastIndex: Integer; + I, J : Integer; + PaintPart: TfpgLVItemPaintPart; + ItemRect: TfpgRect; + ItemState: TfpgLVItemState; + Item: TfpgLVItem; + TheText: String; + TheTextColor: TfpgColor; + oClipRect: TfpgRect; + iColumnClipRect: TfpgRect; + ColumnIndex: Integer; + cBottom: Integer; + vBottom: Integer; + tLeft, + tWidth: Integer; +begin + FirstIndex := (FVScrollBar.Position) div ItemHeight; + LastIndex := (FVScrollBar.Position+GetItemAreaHeight) div ItemHeight; + + if LastIndex > FItems.Count-1 then + LastIndex := FItems.Count-1; + + cBottom := 2 + ((LastIndex+1 - FirstIndex) * ItemHeight); + + if ShowHeaders then + Inc(cBottom, HeaderHeight); + + oClipRect := Canvas.GetClipRect; + + for I := FirstIndex to LastIndex do + begin + ItemState := []; + PaintPart := [lvppBackground, lvppIcon, lvppText]; + ItemRect := ItemGetRect(I); + + if (I = FirstIndex) + and (ShowHeaders) + and (ItemRect.Top < 2 + HeaderHeight) then + Dec(cBottom, (2 + HeaderHeight) - ItemRect.Top); + + Item := FItems.Item[I]; + if Item.Selected[Self] then + Include(ItemState, lisSelected); + if FItemIndex = I then + begin + Include(ItemState, lisFocused); + Include(PaintPart, lvppFocused); + end; + + if lisSelected in (ItemState) then + begin + if Focused then + Canvas.Color := clSelection + else + Canvas.Color := clInactiveSel; + end + else Canvas.Color := clListBox; + + Canvas.FillRectangle(ItemRect); + Exclude(PaintPart, lvppBackground); + TheTextColor := Canvas.TextColor; + if Assigned(FOnPaintItem) then + FOnPaintItem(Self, Canvas, Item, I, ItemRect, PaintPart); + + if lvppIcon in PaintPart then + begin + { TODO: paint icon } + end; + + if lvppFocused in PaintPart then + begin + Canvas.Color := clBlack; + Canvas.SetLineStyle(1, lsDot); + Canvas.DrawRectangle(ItemRect); + end; + + if lvppText in PaintPart then + begin + if lisSelected in ItemState then + Canvas.TextColor := clSelectionText; + for J := 0 to FColumns.Count-1 do + begin + if FColumns.Column[J].Visible then + begin + iColumnClipRect.Left := Max(ItemRect.Left, oClipRect.Left); + iColumnClipRect.Top := Max(ItemRect.Top, oClipRect.Top); + iColumnClipRect.SetRight(Min(ItemRect.Left+FColumns.Column[J].Width, oClipRect.Right)); + iColumnClipRect.SetBottom(Min(ItemRect.Bottom, oClipRect.Bottom)); + Canvas.SetClipRect(iColumnClipRect); + if FColumns.Column[J].ColumnIndex <> -1 then + ColumnIndex := FColumns.Column[J].ColumnIndex + else + ColumnIndex := J; + if ColumnIndex = 0 then + TheText := Item.Caption + else if Item.SubItems.Count >= ColumnIndex then + TheText := Item.SubItems.Strings[ColumnIndex-1] + else + TheText := ''; + + tLeft := ItemRect.Left; + tWidth := Canvas.Font.TextWidth(TheText); + case FColumns.Column[J].Alignment of + taRightJustify: Inc(tLeft, FColumns.Column[J].Width - tWidth - 5); + taCenter: Inc(tLeft, (FColumns.Column[J].Width - tWidth - 5) div 2); + taLeftJustify: Inc(tLeft, 5); + end; + + fpgStyle.DrawString(Canvas, tLeft, ItemRect.Top+2, TheText, Enabled); + Inc(ItemRect.Left, FColumns.Column[J].Width); + //WriteLn(ItemRect.Left,' ', ItemRect.Top, ' ', ItemRect.Right, ' ', ItemRect.Bottom); + end; + end; + end; + + Canvas.SetClipRect(oClipRect); + + Canvas.TextColor := TheTextColor; + end; + + vBottom := Height - 2; + if FHScrollBar.Visible then + Dec(vBottom, FHScrollBar.Height); + + // the painted items haven't fully covered the visible area + if vBottom > cBottom then begin + ItemRect.Left := 2; + ItemRect.Top := cBottom; + ItemRect.SetBottom(vBottom); + ItemRect.Width := Width - 4; + Canvas.SetColor(clListBox); + Canvas.FillRectangle(ItemRect); + end; + if GetVisibleColumnsWidth < oClipRect.Width then + begin + ItemRect.Left := GetVisibleColumnsWidth+2; + ItemRect.SetRight(oClipRect.Right); + ItemRect.Top := oClipRect.Top; + ItemRect.Height := oClipRect.Height; + Canvas.SetColor(clListBox); + Canvas.FillRectangle(ItemRect); + end; +end; + +procedure TfpgListView.UpdateScrollBarPositions; +var + BevelSize: Integer; + I: Integer; + MaxH, + MaxV: Integer; +begin + MaxH := 0; + MaxV := 0; + BevelSize := 2; + + for I := 0 to Columns.Count -1 do + begin + if Columns.Column[I].Visible then + Inc(MaxH, Columns.Column[I].Width); + end; + + MaxV := (FItems.Count+2) * ItemHeight - (Height); + if ShowHeaders then + Inc(MaxV, HeaderHeight); + if FVScrollBar.Visible then + Inc(MaxH, FVScrollBar.Width); + + FHScrollBar.Top := Height - FHScrollBar.Height - (BevelSize ); + FHScrollBar.Left := BevelSize; + FHScrollBar.Width := Width - (BevelSize * 2); + + + FVScrollBar.Top := BevelSize; + FVScrollBar.Left := Width - FVScrollBar.Width - (BevelSize ); + FVScrollBar.Height := Height - FVScrollBar.Top - BevelSize; + + if FVScrollBar.Visible and FHScrollBar.Visible then + begin + FHScrollBar.Width := FHScrollBar.Width - FVScrollBar.Width; + FVScrollBar.Height := FVScrollBar.Height - FHScrollBar.Height; + end; + + FHScrollBar.Max := MaxH-(Width-(BevelSize * 2)); + FVScrollBar.Max := MaxV; + + if FVScrollBar.Max = 0 then + FVScrollBar.SliderSize := 1 + else + begin + if (FVScrollBar.Max + FVScrollBar.Height) > 0 then + FVScrollBar.SliderSize := FVScrollBar.Height / (FVScrollBar.Max + FVScrollBar.Height) + else + FVScrollBar.SliderSize := 0.5; + end; + FVScrollBar.RepaintSlider; + + if FHScrollBar.Max = 0 then + FHScrollBar.SliderSize := 1 + else + begin + if (FHScrollBar.Max + FHScrollBar.Width) > 0 then + FHScrollBar.SliderSize := FHScrollBar.Width / (FHScrollBar.Max + FHScrollBar.Width) + else + FHScrollBar.SliderSize := 0.5; + end; + FHScrollBar.RepaintSlider; + + + if FHScrollBar.Visible then + FHScrollBar.UpdateWindowPosition; + if FVScrollBar.Visible then + FVScrollBar.UpdateWindowPosition; + + FScrollBarNeedsUpdate := False; +end; + +constructor TfpgListView.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FWidth := 120; + FHeight := 80; + Focusable := True; + FShowHeaders := True; + + FVScrollBar := TfpgScrollBar.Create(Self); + FVScrollBar.Orientation := orVertical; + FVScrollBar.OnScroll := @VScrollChange; + FVScrollBar.ScrollStep := 18; + FVScrollBar.Position := 0; + + FHScrollBar := TfpgScrollBar.Create(Self); + FHScrollBar.Orientation := orHorizontal; + FHScrollBar.OnScroll := @HScrollChange; + FHScrollBar.ScrollStep := 18; + FHScrollBar.Position := 0; + + FColumns := TfpgLVColumns.Create(Self); + + FItems := TfpgLVItems.Create(Self); + FSelected := TList.Create; + FOldSelected := TList.Create;; + FSelectionShiftStart := -1; + FSelectionFollowsFocus := True; + FItemIndex := -1; + FScrollBarNeedsUpdate := True; +end; + +destructor TfpgListView.Destroy; +begin + FItems.DeleteViewer(Self); + FSelected.Free; + FOldSelected.Free; + inherited Destroy; +end; + +procedure TfpgListView.BeginUpdate; +begin + Inc(FUpdateCount); + FItems.BeginUpdate; +end; + +procedure TfpgListView.EndUpdate; +begin + FItems.EndUpdate; + Dec(FUpdateCount); + if FUpdateCount < 0 then + FUpdateCount := 0; + if FUpdateCount = 0 then + DoRePaint; +end; + +procedure TfpgListView.MakeItemVisible(AIndex: Integer; PartialOK: Boolean); +var + iTop, + iBottom: integer; + tVisible, bVisible: Boolean; +begin + if AIndex = -1 then + Exit; + iTop := AIndex * ItemHeight; + iBottom := iTop + ItemHeight; + + tVisible := (iTop >= FVScrollBar.Position) and (iTop < FVScrollBar.Position + GetItemAreaHeight); + bVisible := (iBottom >= FVScrollBar.Position) and (iBottom < FVScrollBar.Position + GetItemAreaHeight); + + if PartialOK and (bVisible or tVisible) then + Exit; + + if bVisible and tVisible then + Exit; + + if (iBottom >= FVScrollBar.Position + GetItemAreaHeight) then + FVScrollBar.Position := iBottom - GetItemAreaHeight + else + FVScrollBar.Position := iTop; +end; + +function TfpgListView.ItemAdd: TfpgLVItem; +begin + Result := TfpgLVItem.Create(FItems); + FItems.Add(Result); +end; + +{ TfpgLVColumns } + +function TfpgLVColumns.GetColumn(AIndex: Integer): TfpgLVColumn; +begin + Result := TfpgLVColumn(FColumns.Items[AIndex]); +end; + +procedure TfpgLVColumns.SetColumn(AIndex: Integer; const AValue: TfpgLVColumn); +begin + FColumns.Items[AIndex] := AValue; +end; + +constructor TfpgLVColumns.Create(AListView: TfpgListView); +begin + FListView := AListView; + FColumns := TList.Create; +end; + +destructor TfpgLVColumns.Destroy; +begin + FColumns.Free; + inherited Destroy; +end; + +function TfpgLVColumns.Add(AColumn: TfpgLVColumn): Integer; +begin + Result := Count; + Insert(AColumn, Count); +end; + +procedure TfpgLVColumns.Clear; +var + i: integer; +begin + for i := FColumns.Count-1 downto 0 do + Delete(i); + FColumns.Clear; +end; + +procedure TfpgLVColumns.Delete(AIndex: Integer); +begin + FColumns.Delete(AIndex); +end; + +procedure TfpgLVColumns.Insert(AColumn: TfpgLVColumn; AIndex: Integer); +begin + FColumns.Insert(AIndex, AColumn); +end; + +function TfpgLVColumns.Count: Integer; +begin + Result := FColumns.Count; +end; + +{ TfpgLVColumn } + +procedure TfpgLVColumn.SetCaption(const AValue: String); +begin + if FCaption=AValue then + Exit; + FCaption:=AValue; +end; + +procedure TfpgLVColumn.SetCaptionAlignment(const AValue: TAlignment); +begin + if FCaptionAlignment=AValue then exit; + FCaptionAlignment:=AValue; + if Assigned(FColumns) and Assigned(FColumns.FListView) then + FColumns.FListView.DoRepaint; + +end; + +procedure TfpgLVColumn.SetColumnIndex(const AValue: Integer); +begin + if FColumnIndex=AValue then + Exit; + FColumnIndex:=AValue; +end; + +procedure TfpgLVColumn.SetHeight(const AValue: Integer); +begin + if FHeight=AValue then Exit; + FHeight:=AValue; +end; + +procedure TfpgLVColumn.SetResizable(const AValue: Boolean); +begin + if FResizable=AValue then exit; + FResizable:=AValue; +end; + +procedure TfpgLVColumn.SetVisible(const AValue: Boolean); +begin + if FVisible=AValue then exit; + FVisible:=AValue; +end; + +procedure TfpgLVColumn.SetAutoSize(const AValue: Boolean); +begin + if FAutoSize=AValue then exit; + FAutoSize:=AValue; +end; + +procedure TfpgLVColumn.SetAlignment(const AValue: TAlignment); +begin + if FAlignment=AValue then exit; + FAlignment:=AValue; + if Assigned(FColumns)and Assigned(FColumns.FListView) then + FColumns.FListView.DoRepaint; +end; + +procedure TfpgLVColumn.SetWidth(const AValue: Integer); +begin + if FWidth=AValue then exit; + FWidth:=AValue; + if FWidth < 1 then + FWidth := 1; +end; + +constructor TfpgLVColumn.Create(AColumns: TfpgLVColumns); +begin + FVisible := True; + FColumnIndex := -1; + FColumns := AColumns; + FClickable := True; + FAlignment := taLeftJustify; + FCaptionAlignment := taLeftJustify; +end; + +destructor TfpgLVColumn.Destroy; +begin + inherited Destroy; +end; + +end. diff --git a/src/gui/fpg_memo.pas b/src/gui/fpg_memo.pas new file mode 100644 index 00000000..a93b06d8 --- /dev/null +++ b/src/gui/fpg_memo.pas @@ -0,0 +1,1459 @@ +{ + fpGUI - Free Pascal GUI Toolkit + + Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this + distribution, for details of the copyright. + + See the file COPYING.modifiedLGPL, included in this distribution, + for details about redistributing fpGUI. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + Description: + Defines a Memo control. Also known as a multi-line text edit control. +} + +unit fpg_memo; + +{$mode objfpc}{$H+} + + { TODO : Started a implementation for Tab support. It is still very experimental and should not be used yet. } + +interface + +uses + Classes, + SysUtils, + fpg_base, + fpg_main, + fpg_widget, + fpg_scrollbar, + fpg_menu; + +type + + TfpgMemo = class(TfpgWidget) + private + FLines: TStringList; + FMaxLength: integer; + FCursorPos: integer; + FCursorLine: integer; + FOnChange: TNotifyEvent; + FSideMargin: integer; + FSelStartLine: integer; + FSelEndLine: integer; + FSelStartPos: integer; + FSelEndPos: integer; + FSelecting: boolean; + FMouseDragging: boolean; + FMouseDragPos: integer; + FFont: TfpgFont; + FDrawOffset: integer; + FLineHeight: integer; + FFirstLine: integer; + FTabWidth: integer; + FUseTabs: boolean; + FVScrollBar: TfpgScrollBar; + FHScrollBar: TfpgScrollBar; + FWrapping: boolean; + FLongestLineWidth: TfpgCoord; + FPopupMenu: TfpgPopupMenu; + function GetFontDesc: string; + procedure SetFontDesc(const AValue: string); + procedure RecalcLongestLine; + procedure DeleteSelection; + procedure DoCopy; + procedure DoPaste; + procedure AdjustCursor; + function LineCount: integer; + function GetLineText(linenum: integer): string; + procedure SetLineText(linenum: integer; Value: string); + function GetCursorX: integer; + procedure SetCPByX(x: integer); + function CurrentLine: string; + function VisibleLines: integer; + function VisibleWidth: integer; + procedure VScrollBarMove(Sender: TObject; position: integer); + procedure HScrollBarMove(Sender: TObject; position: integer); + procedure SetText(const AValue: TfpgString); + function GetText: TfpgString; + procedure SetCursorLine(aValue: integer); + procedure UpdateScrollBarCoords; + protected + procedure HandleKeyChar(var AText: TfpgChar; var shiftstate: TShiftState; var consumed: boolean); override; + procedure HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override; + procedure HandleLMouseDown(x, y: integer; shiftstate: TShiftState); override; + procedure HandleRMouseUp(x, y: integer; shiftstate: TShiftState); override; + procedure HandleMouseMove(x, y: integer; btnstate: word; shiftstate: TShiftState); override; + procedure HandleResize(dwidth, dheight: integer); override; + procedure HandleMouseScroll(x, y: integer; shiftstate: TShiftState; delta: smallint); override; + procedure HandlePaint; override; + procedure HandleShow; override; + procedure HandleMouseEnter; override; + procedure HandleMouseExit; override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure UpdateScrollBars; + function SelectionText: string; + property CursorLine: integer read FCursorLine write SetCursorLine; + property Font: TfpgFont read FFont; + property LineHeight: integer read FLineHeight; + property MaxLength: integer read FMaxLength write FMaxLength; + property TabWidth: integer read FTabWidth write FTabWidth; + property Text: TfpgString read GetText write SetText; + property UseTabs: boolean read FUseTabs write FUseTabs default False; + property PopupMenu: TfpgPopupMenu read FPopupMenu write FPopupMenu; + published + property BackgroundColor default clBoxColor; + property FontDesc: string read GetFontDesc write SetFontDesc; + property Lines: TStringList read FLines; + property ParentShowHint; + property ShowHint; + property TabOrder; + property TextColor; + property OnChange: TNotifyEvent read FOnChange write FOnChange; + property OnEnter; + property OnExit; + property OnKeyPress; + end; + + +function CreateMemo(AOwner: TComponent; x, y, w, h: TfpgCoord): TfpgMemo; + + +implementation + +uses + fpg_stringutils; + +type + // custom stringlist that will notify the memo of item changes + TfpgMemoStrings = class(TStringList) + protected + Memo: TfpgMemo; + procedure RefreshMemo; + public + constructor Create(AMemo: TfpgMemo); reintroduce; + destructor Destroy; override; + function Add(const s: String): Integer; override; + procedure Clear; override; + procedure Delete(Index: Integer); override; + procedure Insert(Index: Integer; const S: string); override; + end; + +{ TfpgMemoStrings } + +procedure TfpgMemoStrings.RefreshMemo; +begin + if Assigned(Memo) and (Memo.HasHandle) then + begin + Memo.Invalidate; + Memo.UpdateScrollBars; + end; +end; + +constructor TfpgMemoStrings.Create(AMemo: TfpgMemo); +begin + inherited Create; + Memo := AMemo; +end; + +destructor TfpgMemoStrings.Destroy; +begin + Memo := nil; + inherited Destroy; +end; + +function TfpgMemoStrings.Add(const s: String): Integer; +begin + Result := inherited Add(s); + RefreshMemo; +end; + +procedure TfpgMemoStrings.Delete(Index: Integer); +begin +// writeln('Delete''s Index = ', Index); + inherited Delete(Index); + RefreshMemo; +end; + +procedure TfpgMemoStrings.Insert(Index: Integer; const S: string); +begin +// writeln('Insert''s Index = ', Index); + inherited Insert(Index, S); + RefreshMemo; +end; + +procedure TfpgMemoStrings.Clear; +begin + inherited Clear; + RefreshMemo; +end; + + +{ TfpgMemo } + + +function CreateMemo(AOwner: TComponent; x, y, w, h: TfpgCoord): TfpgMemo; +begin + Result := TfpgMemo.Create(AOwner); + Result.Left := x; + Result.Top := y; + Result.Width := w; + if h > 0 then + Result.Height := h; +end; + + +procedure TfpgMemo.SetCursorLine(aValue: integer); +var + i: integer; + MaxLine: integer; + yp: integer; +begin + if (aValue < 0) or (aValue = FCursorLine) then + Exit; // wrong value + if aValue < FFirstLine then + begin + FFirstLine := aValue; // moves the selected line to the top of the displayed rectangle + FCursorLine := aValue; + FCursorPos := 0; + RePaint; + Exit; + end; + yp := 2; + MaxLine := 0; + for i := FFirstLine to LineCount-1 do + begin + yp := yp + LineHeight; + if yp > Height then + begin + MaxLine := i - 1; + break; + end; + end; + if MaxLine < aValue then + begin + FFirstLine := aValue; + FCursorLine := aValue; + FCursorPos := 0; + RePaint; + Exit; + end + else + begin + FCursorLine := aValue; + FCursorPos := 0; + RePaint; + Exit; + end; +end; + +procedure TfpgMemo.UpdateScrollBarCoords; +var + HWidth: integer; + VHeight: integer; +begin + VHeight := Height - 4; + HWidth := Width - 4; + + if FVScrollBar.Visible then + Dec(HWidth, FVScrollBar.Width); + if FHScrollBar.Visible then + Dec(VHeight, FHScrollBar.Height); + + FHScrollBar.Top := Height -FHScrollBar.Height - 2; + FHScrollBar.Left := 2; + FHScrollBar.Width := HWidth; + + FVScrollBar.Top := 2; + FVScrollBar.Left := Width - FVScrollBar.Width - 2; + FVScrollBar.Height := VHeight; + + FVScrollBar.UpdateWindowPosition; + FHScrollBar.UpdateWindowPosition; +end; + +constructor TfpgMemo.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + Focusable := True; + FFont := fpgGetFont('#Edit1'); + FHeight := FFont.Height * 3 + 4; + FWidth := 120; + FLineHeight := FFont.Height + 2; + FSelecting := False; + FSideMargin := 3; + FMaxLength := 0; + FWrapping := False; + FOnChange := nil; + FTextColor := Parent.TextColor; + FBackgroundColor := clBoxColor; + FUseTabs := False; + FTabWidth := 4; + FMinWidth := 20; + FMinHeight := 30; + + FLines := TfpgMemoStrings.Create(self); + FFirstLine := 0; + FCursorLine := 0; + + FCursorPos := 0; + FSelStartPos := FCursorPos; + FSelEndPos := 0; + FSelStartLine := -1; + FSelEndLine := -1; + + FDrawOffset := 0; + FMouseDragging := False; + + FVScrollBar := TfpgScrollBar.Create(self); + FVScrollBar.Orientation := orVertical; + FVScrollBar.OnScroll := @VScrollBarMove; + FVScrollBar.Visible := False; + + FHScrollBar := TfpgScrollBar.Create(self); + FHScrollBar.Orientation := orHorizontal; + FHScrollBar.OnScroll := @HScrollBarMove; + FHScrollBar.ScrollStep := 5; + FHScrollBar.Visible := False; +end; + +destructor TfpgMemo.Destroy; +begin + TfpgMemoStrings(FLines).Free; + FFont.Free; + inherited Destroy; +end; + +procedure TfpgMemo.RecalcLongestLine; +var + n: integer; + lw: TfpgCoord; +begin + FLongestLineWidth := 0; + for n := 0 to LineCount-1 do + begin + lw := FFont.TextWidth(getlinetext(n)); + if lw > FlongestLineWidth then + FlongestLineWidth := lw; + end; +end; + +function TfpgMemo.GetFontDesc: string; +begin + Result := FFont.FontDesc; +end; + +procedure TfpgMemo.DeleteSelection; +var + n: integer; + selsl: integer; + selsp: integer; + selel: integer; + selep: integer; + ls: string; + len: integer; + st: integer; +begin + if FSelEndLine < 0 then + Exit; + + if (FSelStartLine shl 16) + FSelStartPos <= (FSelEndLine shl 16) + FSelEndPos then + begin + selsl := FSelStartLine; + selsp := FSelStartPos; + selel := FSelEndLine; + selep := FSelEndPos; + end + else + begin + selel := FSelStartLine; + selep := FSelStartPos; + selsl := FSelEndLine; + selsp := FSelEndPos; + end; + + for n := selsl to selel do + begin + ls := GetLineText(n); + + if selsl < n then + st := 0 + else + st := selsp; + if selel > n then + len := UTF8Length(ls) + else + len := selep - st; + + UTF8Delete(ls, st + 1, len); + SetLineText(n, ls); + end; + + if selsl < selel then + begin + ls := GetlineText(selsl); + ls := ls + GetLineText(selel); + SetLineText(selsl, ls); + end; + + for n := selsl to selel do + FLines.Delete(n); + + FCursorPos := selsp; + FCursorLine := selsl; + FSelEndLine := -1; +end; + +procedure TfpgMemo.DoCopy; +var + n: integer; + selsl: integer; + selsp: integer; + selel: integer; + selep: integer; + ls: string; + len: integer; + st: integer; + s: string; +begin + if FSelEndLine < 0 then + Exit; + + if (FSelStartLine shl 16) + FSelStartPos <= (FSelEndLine shl 16) + FSelEndPos then + begin + selsl := FSelStartLine; + selsp := FSelStartPos; + selel := FSelEndLine; + selep := FSelEndPos; + end + else + begin + selel := FSelStartLine; + selep := FSelStartPos; + selsl := FSelEndLine; + selsp := FSelEndPos; + end; + + s := ''; + + for n := selsl to selel do + begin + if n > selsl then + s := s + #13#10; + + ls := GetLineText(n); + + if selsl < n then + st := 0 + else + st := selsp; + + if selel > n then + len := UTF8Length(ls) + else + len := selep - st; + + s := s + UTF8Copy(ls, st + 1, len); + end; + + //SetClipboardText(s); +end; + +procedure TfpgMemo.DoPaste; +{ +var + s: string; + si: string; + si8: string; + lineend: string; + n: integer; + l: integer; + lcnt: integer; +} +begin + Exit; + (* + DeleteSelection; + s := GetClipboardText; + + si := UTF8Copy(CurrentLine,1,FCursorPos); + lineend := UTF8Copy(CurrentLine,FCursorPos+1, UTF8Length(CurrentLine)); + l := FCursorLine; + n := 1; + lcnt := 0; + si8 := ''; + while n <= length(s) do + begin + if (s[n] = #13) or (s[n] = #10) then + begin + if lcnt = 0 then SetLineText(l, si + si8) + else FLines.Insert(l-1, si + si8); + + si := ''; + si8 := ''; + inc(lcnt); + inc(l); + + // skip multibyte line end: + if (s[n]=#13) and (n < length(s)) and (s[n+1]=#10) then inc(n); + end + else + begin + si8 := si8 + s[n]; + end; + inc(n); + end; + + si := si + si8; + + FCursorPos := UTF8Length(si); + si := si + lineend; + + if lcnt = 0 then + begin + SetLineText(l, si) + end + else + begin + FLines.Insert(l-1, si); + FCursorLine := l; + end; + + AdjustCursor; + Repaint; +*) +end; + +procedure TfpgMemo.AdjustCursor; +var + tw: integer; +begin + // horizontal adjust + RecalcLongestLine; + tw := FFont.TextWidth(UTF8Copy(CurrentLine, 1, FCursorPos)); + + if tw - FDrawOffset > VisibleWidth - 2 then + FDrawOffset := tw - VisibleWidth + 2 + else if tw - FDrawOffset < 0 then + begin + FDrawOffset := tw; + if tw <> 0 then + Dec(FDrawOffset, 2); + end; + + // vertical adjust + if FCursorLine < FFirstLine then + FFirstLine := FCursorLine; + if FCursorline - FFirstLine + 1 > VisibleLines then + FFirstLine := FCursorline - VisibleLines + 1; + + if (FFirstLine + VisibleLines) > LineCount then + begin + FFirstLine := LineCount - VisibleLines + 1; + if FFirstline < 0 then + FFirstLine := 0; + end; + + UpdateScrollbars; +end; + +procedure TfpgMemo.UpdateScrollBars; +var + vlines: integer; + vsbw: integer; + hsbwas: boolean; + vsbwas: boolean; + vsbvis: boolean; +begin + hsbwas := FHScrollBar.Visible; + vsbwas := FVScrollBar.Visible; + vlines := (Height - (FSideMargin shl 1)) div Lineheight; + vsbvis := (LineCount > vlines); + + if vsbvis then + vsbw := FVScrollBar.Width + else + vsbw := 0; + + FHScrollBar.Visible := FLongestLineWidth > (Width - vsbw - FSideMargin * 2) - 1; + + if FHScrollBar.Visible and not vsbvis then + begin + // recheck vertical scrollbar + vlines := (Height - (FSideMargin shl 1) - FHScrollBar.Height) div Lineheight; + vsbvis := (LineCount > vlines); + end; + + FVScrollBar.Visible := vsbvis; + + UpdateScrollBarCoords; + + if FHScrollBar.Visible then + begin + FHScrollBar.Min := 0; + FHScrollBar.Max := FLongestLineWidth - VisibleWidth - 1; + if (FLongestLineWidth <= 0) or (FLongestLineWidth <= VisibleWidth) then + FHScrollBar.SliderSize := 1 + else + FHScrollBar.SliderSize := VisibleWidth / FLongestLineWidth; + FHScrollBar.Position := FDrawOffset; + FHScrollBar.RepaintSlider; + end; + + if FVScrollBar.Visible then + begin + FVScrollBar.Min := 0; + // TODO: Look at calculation of vlines value to improve this! + if LineCount > 0 then + begin + FVScrollBar.SliderSize := VisibleLines / LineCount; + FVScrollBar.Max := LineCount - VisibleLines; + end + else + begin + FVScrollBar.SliderSize := 0.5; + FVScrollBar.Max := 10; + end; + FVScrollBar.Position := FFirstLine; + FVScrollBar.RepaintSlider; + end; + + if (hsbwas <> FHScrollBar.Visible) or (vsbwas <> FVScrollBar.Visible) then + AdjustCursor; +end; + +function TfpgMemo.LineCount: integer; +begin + Result := FLines.Count; +end; + +function TfpgMemo.GetLineText(linenum: integer): string; +begin + if LineCount = 0 then + FLines.Add(''); + if (linenum >= 0) and (linenum < LineCount) then + Result := FLines.Strings[linenum] + else + Result := ''; +end; + +procedure TfpgMemo.SetFontDesc(const AValue: string); +begin + FFont.Free; + FFont := fpgGetFont(AValue); + RePaint; +end; + +procedure TfpgMemo.SetLineText(linenum: integer; Value: string); +begin + FLines.Strings[linenum] := Value; +end; + +function TfpgMemo.GetCursorX: integer; +begin + Result := FFont.TextWidth(copy(CurrentLine, 1, FCursorPos)); +end; + +// Set cursor position by X +procedure TfpgMemo.SetCPByX(x: integer); +var + n: integer; + cpx: integer; + cp: integer; + cx: integer; + ls: string; +begin + // searching the appropriate character position + ls := CurrentLine; + cpx := FFont.TextWidth(UTF8Copy(ls, 1, FCursorPos)); // + FDrawOffset + FSideMargin; + cp := FCursorPos; + if cp > UTF8Length(ls) then + cp := UTF8Length(ls); + + for n := 0 to UTF8Length(ls) do + begin + cx := FFont.TextWidth(UTF8Copy(ls, 1, n)); // + FDrawOffset + FSideMargin; + if abs(cx - x) < abs(cpx - x) then + begin + cpx := cx; + cp := n; + end; + end; + + FCursorPos := cp; +end; + +function TfpgMemo.CurrentLine: string; +begin + Result := GetLineText(FCursorLine); +end; + +function TfpgMemo.VisibleLines: integer; +var + sh: integer; +begin + if FHScrollBar.Visible then + sh := 18 + else + sh := 0; + Result := (Height - (FSideMargin shl 1) - sh) div Lineheight; +end; + +function TfpgMemo.VisibleWidth: integer; +var + sw: integer; +begin + if FVScrollBar.Visible then + sw := FVScrollBar.Width + else + sw := 0; + Result := (Width - (FSideMargin shl 1) - sw); +end; + +procedure TfpgMemo.HandleShow; +begin + inherited HandleShow; + if (csLoading in ComponentState) then + Exit; + RecalcLongestLine; + UpdateScrollBars; + UpdateScrollBarCoords; +end; + +procedure TfpgMemo.HandleMouseEnter; +begin + inherited HandleMouseEnter; + MouseCursor := mcIBeam; +end; + +procedure TfpgMemo.HandleMouseExit; +begin + inherited HandleMouseExit; + MouseCursor := mcDefault; +end; + +procedure TfpgMemo.VScrollBarMove(Sender: TObject; position: integer); +begin + if FFirstLine <> position then + begin + FFirstLine := position; + repaint; + end; +end; + +procedure TfpgMemo.HScrollBarMove(Sender: TObject; position: integer); +begin + if position <> FDrawOffset then + begin + FDrawOffset := position; + Repaint; + end; +end; + +procedure TfpgMemo.HandlePaint; +var + n: integer; + tw, tw2, st, len: integer; + yp, xp: integer; + ls: string; + r: TfpgRect; + selsl, selsp, selel, selep: integer; + c: integer; + s: string; +begin + Canvas.ClearClipRect; + r.SetRect(0, 0, Width, Height); + Canvas.DrawControlFrame(r); + + InflateRect(r, -2, -2); + Canvas.SetClipRect(r); + + if Enabled then + Canvas.SetColor(FBackgroundColor) + else + Canvas.SetColor(clWindowBackground); + Canvas.FillRectAngle(r); + + Canvas.SetTextColor(FTextColor); + Canvas.SetFont(FFont); + + if (FSelStartLine shl 16) + FSelStartPos <= (FSelEndLine shl 16) + FSelEndPos then + begin + selsl := FSelStartLine; + selsp := FSelStartPos; + selel := FSelEndLine; + selep := FSelEndPos; + end + else + begin + selel := FSelStartLine; + selep := FSelStartPos; + selsl := FSelEndLine; + selsp := FSelEndPos; + end; + + yp := 3; + for n := FFirstline to LineCount-1 do + begin + ls := GetLineText(n); + if FUseTabs then + begin + xp := 0; + s := ''; + for c := 1 to Length(ls) do + begin + if ls[c] = #9 then + begin + if s <> '' then + Canvas.DrawString(-FDrawOffset + FSideMargin + xp, yp, s); + xp := xp + Canvas.Font.TextWidth(' ') * FTabWidth; + s := ''; + end + else + s := s + ls[c]; + end; + if s <> '' then + Canvas.DrawString(-FDrawOffset + FSideMargin + xp, yp, s); + end + else + Canvas.DrawString(-FDrawOffset + FSideMargin, yp, ls); + + if Focused then + begin + // drawing selection + if (FSelEndLine > -1) and (selsl <= n) and (selel >= n) then + begin + if selsl < n then + st := 0 + else + st := selsp; + if selel > n then + len := UTF8Length(ls) + else + len := selep - st; + + tw := FFont.TextWidth(UTF8Copy(ls, 1, st)); + tw2 := FFont.TextWidth(UTF8Copy(ls, 1, st + len)); + Canvas.XORFillRectangle(fpgColorToRGB(clSelection) xor $FFFFFF, -FDrawOffset + + FSideMargin + tw, yp, tw2 - tw, LineHeight); + end; + + //drawing cursor + if FCursorLine = n then + begin + // drawing cursor + tw := FFont.TextWidth(UTF8Copy(ls, 1, FCursorPos)); + fpgCaret.SetCaret(Canvas, -FDrawOffset + FSideMargin + tw, yp, fpgCaret.Width, FFont.Height); + end; + end; { if } + + yp := yp + LineHeight; + if yp > Height then + Break; + end; { for } + + if not Focused then + fpgCaret.UnSetCaret(Canvas); + + // The little square in the bottom right corner + if FHScrollBar.Visible and FVScrollBar.Visible then + begin + Canvas.SetColor(clButtonFace); + Canvas.FillRectangle(FHScrollBar.Left+FHScrollBar.Width, + FVScrollBar.Top+FVScrollBar.Height, + FVScrollBar.Width, + FHScrollBar.Height); + end; +end; + +procedure TfpgMemo.HandleKeyChar(var AText: TfpgChar; var shiftstate: TShiftState; var consumed: boolean); +var + prevval: string; + s: string; + ls: string; +begin + inherited; + prevval := Text; + s := AText; + + // Printable characters only + // Note: This is now UTF-8 compliant! + if (Ord(AText[1]) > 31) and (Ord(AText[1]) < 127) or (Length(AText) > 1) then + begin + if (FMaxLength <= 0) or (UTF8Length(FLines.Text) < FMaxLength) then + begin + if FCursorLine < 0 then + FCursorLine := 0; + DeleteSelection; + ls := GetLineText(FCursorLine); + UTF8Insert(s, ls, FCursorPos + 1); + SetLineText(FCursorLine, ls); + Inc(FCursorPos); + FSelStartPos := FCursorPos; + FSelStartLine := FCursorLine; + FSelEndLine := -1; + AdjustCursor; + end; + + consumed := True; + end; + + if prevval <> Text then + if Assigned(FOnChange) then + FOnChange(self); + + if consumed then + RePaint; +end; + +procedure TfpgMemo.HandleKeyPress(var keycode: word; + var shiftstate: TShiftState; var consumed: boolean); +var + cx: integer; + ls: string; + ls2: string; + hasChanged: boolean; + + procedure StopSelection; + begin + FSelStartLine := FCursorLine; + FSelStartPos := FCursorPos; + FSelEndLine := -1; + end; + +begin + Consumed := True; + hasChanged := False; + case CheckClipBoardKey(keycode, shiftstate) of + ckCopy: + begin + DoCopy; + end; + ckPaste: + begin + DoPaste; + hasChanged := True; + end; + ckCut: + begin + DoCopy; + DeleteSelection; + hasChanged := True; + end; + else + Consumed := False; + end; + + if not Consumed then + begin + // checking for movement keys: + consumed := True; + FSelecting := (ssShift in shiftstate); + + case keycode of + keyLeft: + if FCursorPos > 0 then + begin + Dec(FCursorPos); + + if (ssCtrl in shiftstate) then + // word search... + (* + while (FCursorPos > 0) and not pgfIsAlphaNum(copy(CurrentLine,FCursorPos,1)) + do Dec(FCursorPos); + + while (FCursorPos > 0) and pgfIsAlphaNum(copy(CurrentLine,FCursorPos,1)) + do Dec(FCursorPos); + *); + + end;// left + + keyRight: + if FCursorPos < UTF8Length(CurrentLine) then + begin + Inc(FCursorPos); + + if (ssCtrl in shiftstate) then + // word search... + (* + while (FCursorPos < length(CurrentLine)) and pgfIsAlphaNum(copy(CurrentLine,FCursorPos+1,1)) + do Inc(FCursorPos); + + while (FCursorPos < length(CurrentLine)) and not pgfIsAlphaNum(copy(CurrentLine,FCursorPos+1,1)) + do Inc(FCursorPos); + *); + + end;// right + + keyUp: + begin // up + cx := GetCursorX; + if FCursorLine > 0 then + begin + Dec(FCursorline); + SetCPByX(cx); + end; + end; + + keyDown: + begin + cx := GetCursorX; + if FCursorLine < (LineCount-1) then + begin + Inc(FCursorline); + SetCPByX(cx); + end; + end; + + keyHome: + begin + if (ssCtrl in shiftstate) then + FCursorLine := 0; + FCursorPos := 0; + end; + + keyEnd: + begin + if (ssCtrl in shiftstate) then + FCursorLine := LineCount-1; + FCursorPos := UTF8Length(CurrentLine); + end; + + keyPageUp: + if FCursorLine > 0 then + begin + cx := GetCursorX; + Dec(FCursorLine, VisibleLines); + if FCursorLine < 0 then + FCursorLine := 0; + SetCPByX(cx); + end; + + keyPageDown: + begin + cx := GetCursorX; + if FCursorLine < (LineCount-1) then + begin + Inc(FCursorline, VisibleLines); + if FCursorLine > (LineCount-1) then + FCursorLine := LineCount-1; + SetCPByX(cx); + end; + end; + + else + Consumed := False; + end; + + if Consumed then + begin + AdjustCursor; + + if FSelecting then + begin + FSelEndPos := FCursorPos; + FSelEndLine := FCursorLine; + end + else + StopSelection; + end; + end; + + if not Consumed then + begin + consumed := True; + + case keycode of + keyReturn, + keyPEnter: + begin + ls := UTF8Copy(FLines[FCursorline], 1, FCursorPos); + ls2 := UTF8Copy(FLines[FCursorline], FCursorPos + 1, UTF8Length(FLines[FCursorline])); + FLines.Insert(FCursorLine, ls); + Inc(FCursorLine); + SetLineText(FCursorLine, ls2); + FCursorPos := 0; + hasChanged := True; + end; + + keyBackSpace: + begin + if FCursorPos > 0 then + begin + ls := GetLineText(FCursorLine); + UTF8Delete(ls, FCursorPos, 1); + SetLineText(FCursorLine, ls); + Dec(FCursorPos); + end + else if FCursorLine > 0 then + begin + ls := CurrentLine; + FLines.Delete(FCursorLine); + Dec(FCursorLine); + FCursorPos := UTF8Length(FLines.Strings[FCursorLine]); + FLines.Strings[FCursorLine] := FLines.Strings[FCursorLine] + ls; + end; + hasChanged := True; + end; + + keyDelete: + begin + ls := GetLineText(FCursorLine); + if FSelEndLine > -1 then + DeleteSelection + else if FCursorPos < UTF8Length(ls) then + begin + UTF8Delete(ls, FCursorPos + 1, 1); + SetLineText(FCursorLine, ls); + end + else if FCursorLine < (LineCount-1) then + begin + ls2 := FLines.Strings[FCursorLine+1]; + FLines.Delete(FCursorLine); + FLines.Strings[FCursorLine] := ls + ls2; + end; + hasChanged := True; + end; + + keyTab: + begin + if FUseTabs then + begin + ls := GetLineText(FCursorLine); +{ if FSelEndLine > 0 then + DeleteSelection + else} if FCursorPos < UTF8Length(ls) then + begin + UTF8Insert(#9, ls, FCursorPos); + SetLineText(FCursorLine, ls); + end; +{ + else if FCursorLine < LineCount then + begin + ls2 := FLines.Strings[FCursorLine]; + FLines.Delete(FCursorLine); + FLines.Strings[FCursorLine - 1] := ls + ls2; + end; +} + hasChanged := True; + end + else + Consumed := False; + end; + else + Consumed := False; + end; + + if Consumed then + begin + StopSelection; + AdjustCursor; + end; + end; + + if Consumed then + RePaint + else + inherited; + + if hasChanged then + if Assigned(FOnChange) then + FOnChange(self); +end; + +procedure TfpgMemo.HandleLMouseDown(x, y: integer; shiftstate: TShiftState); +var + n: integer; + cpx: integer; + cp: integer; + cx: integer; + lnum: integer; + ls: string; +begin + inherited HandleLMouseDown(x, y, shiftstate); + + // searching the appropriate character position + lnum := FFirstLine + (y - FSideMargin) div LineHeight; + if lnum > (LineCount-1) then + lnum := LineCount-1; + + ls := GetLineText(lnum); + cpx := FFont.TextWidth(UTF8Copy(ls, 1, FCursorPos)) - FDrawOffset + FSideMargin; + cp := FCursorPos; + + for n := 0 to UTF8Length(ls) do + begin + cx := FFont.TextWidth(UTF8Copy(ls, 1, n)) - FDrawOffset + FSideMargin; + if abs(cx - x) < abs(cpx - x) then + begin + cpx := cx; + cp := n; + end; + end; + + FMouseDragging := True; + FMouseDragPos := cp; + FCursorPos := cp; + FCursorLine := lnum; + + if (ssShift in shiftstate) then + begin + FSelEndLine := lnum; + FSelEndpos := cp; + end + else + begin + FSelStartLine := lnum; + FSelStartPos := cp; + FSelEndLine := -1; + end; + Repaint; +end; + +procedure TfpgMemo.HandleRMouseUp(x, y: integer; shiftstate: TShiftState); +begin + inherited HandleRMouseUp(x, y, shiftstate); + if Assigned(PopupMenu) then + PopupMenu.ShowAt(self, x, y); +end; + +procedure TfpgMemo.HandleMouseMove(x, y: integer; btnstate: word; shiftstate: TShiftState); +var + n: integer; + cpx: integer; + cp: integer; + cx: integer; + lnum: integer; + ls: string; +begin + if not FMouseDragging or ((btnstate and 1) = 0) then + begin + FMouseDragging := False; + Exit; + end; + + // searching the appropriate character position + lnum := FFirstLine + (y - FSideMargin) div LineHeight; + if lnum > LineCount-1 then + lnum := LineCount-1; + + ls := GetLineText(lnum); + cpx := FFont.TextWidth(UTF8Copy(ls, 1, FCursorPos)) - FDrawOffset + FSideMargin; + cp := FCursorPos; + + for n := 0 to UTF8Length(ls) do + begin + cx := FFont.TextWidth(UTF8Copy(ls, 1, n)) - FDrawOffset + FSideMargin; + if abs(cx - x) < abs(cpx - x) then + begin + cpx := cx; + cp := n; + end; + end; + + if (cp <> FCursorPos) or (lnum <> FCursorLine) then + begin + FCursorLine := lnum; + FSelEndLine := lnum; + FSelEndPos := cp; + FCursorPos := cp; + Repaint; + end; + + + // searching the appropriate character position + { + cpx := FFont.TextWidth16(copy16(FText,1,FCursorPos)) + FDrawOffset + FSideMargin; + cp := FCursorPos; + + s := ''; + + for n := 0 to Length16(Text) do + begin + cx := FFont.TextWidth16(copy16(Text,1,n)) + FDrawOffset + FSideMargin; + if abs(cx - x) < abs(cpx - x) then + begin + cpx := cx; + cp := n; + end; + end; + + //FMouseDragPos := cp; + FSelOffset := cp-FSelStart; + if FCursorPos <> cp then + begin + FCursorPos := cp; + Repaint; + end; +} +end; + +(* +procedure TfpgMemo.HandleWindowScroll(direction, amount: integer); +var + pfl, pdo : integer; +begin + inherited HandleWindowScroll(direction, amount); + + pfl := FFirstLine; + pdo := FDrawOffset; + + if direction = 0 then + begin + dec(FFirstLine, amount); + end; + if direction = 1 then + begin + inc(FFirstLine, amount); + end; + if FFirstLine > LineCount - VisibleLines + 1 then FFirstLine := LineCount - VisibleLines + 1; + if FFirstLine < 1 then FFirstLine := 1; + + if FHScrollBar.Visible then + begin + if Direction = 2 then + begin + dec(FDrawOffset, amount*16); + end; + if Direction = 3 then + begin + inc(FDrawOffset, amount*16); + end; + + if FDrawOffset > FHScrollBar.Max then FDrawOffset := FHScrollBar.Max; + if FDrawOffset < 0 then FDrawOffset := 0; + end; + + if (pfl <> FFirstLine) or (pdo <> FDrawOffset) then + begin + UpdateScrollBars; + Repaint; + end; + +end; +*) + +procedure TfpgMemo.HandleResize(dwidth, dheight: integer); +begin + inherited HandleResize(dwidth, dheight); + if (csLoading in ComponentState) then + Exit; + UpdateScrollBarCoords; + UpdateScrollBars; +end; + +procedure TfpgMemo.HandleMouseScroll(x, y: integer; shiftstate: TShiftState; + delta: smallint); +var + pfl, pdo : integer; +begin + inherited HandleMouseScroll(x, y, shiftstate, delta); + + pfl := FFirstLine; + pdo := FDrawOffset; + + if delta < 0 then + dec(FFirstLine, abs(delta)) // scroll up + else + inc(FFirstLine, abs(delta)); // scroll down + + if FFirstLine > LineCount - VisibleLines{ + 1} then + FFirstLine := LineCount - VisibleLines {+ 1}; + if FFirstLine < 0 then + FFirstLine := 0; + + if FHScrollBar.Visible then + begin + if FDrawOffset > FHScrollBar.Max then + FDrawOffset := FHScrollBar.Max; + if FDrawOffset < 0 then + FDrawOffset := 0; + end; + + if (pfl <> FFirstLine) or (pdo <> FDrawOffset) then + begin + UpdateScrollBars; + Repaint; + end; +end; + +function TfpgMemo.SelectionText: string; +begin + { + if FSelOffset <> 0 then + begin + if FSelOffset < 0 then + begin + Result := Copy(FText,1+FSelStart + FSelOffset,-FSelOffset); + end + else + begin + result := Copy(FText,1+FSelStart,FSelOffset); + end; + end + else +} + Result := ''; +end; + +function TfpgMemo.GetText: TfpgString; +var + n: integer; + s: TfpgString; +begin + s := ''; + for n := 0 to LineCount-1 do + begin + if n > 0 then + s := s + #13#10; + s := s + GetLineText(n); + end; + Result := s; +end; + +procedure TfpgMemo.SetText(const AValue: TfpgString); +var + n: integer; + c: TfpgChar; + s: TfpgString; +begin + FLines.Clear; + s := ''; + n := 1; + while n <= UTF8Length(AValue) do + begin + c := UTF8Copy(AValue, n, 1); + if (c[1] = #13) or (c[1] = #10) then + begin + FLines.Add(s); + s := ''; + c := UTF8Copy(AValue, n + 1, 1); + if c[1] = #10 then + Inc(n); + end + else + s := s + c; + Inc(n); + end; + + if s <> '' then + FLines.Add(s); + + FDrawOffset := 0; + FCursorPos := 0; + FCursorLine := 0; + FSelStartLine := FCursorLine; + FSelStartPos := FCursorPos; + FSelEndLine := -1; + + AdjustCursor; + Repaint; +end; + +end. + diff --git a/src/gui/fpg_menu.pas b/src/gui/fpg_menu.pas new file mode 100644 index 00000000..fa1c8bad --- /dev/null +++ b/src/gui/fpg_menu.pas @@ -0,0 +1,1325 @@ +{ + fpGUI - Free Pascal GUI Toolkit + + Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this + distribution, for details of the copyright. + + See the file COPYING.modifiedLGPL, included in this distribution, + for details about redistributing fpGUI. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + Description: + Defines a MainMenu Bar, Popup Menu and Menu Item controls. +} + +unit fpg_menu; + +{$mode objfpc}{$H+} + +{.$Define DEBUG} + +{ + TODO: + * Refactor the HotKey painting code into Canvas.DrawString so that other + widgets like TfpgButton could also use it. + * Global keyboard activation of menu items are still missing. +} + +interface + +uses + Classes, + SysUtils, + fpg_base, + fpg_main, + fpg_widget, + fpg_popupwindow, + fpg_stringutils, + fpg_command_intf; + +type + TfpgHotKeyDef = string; + + TfpgMenuOption = (mnuo_autoopen, // auto open menus when mouse over menubar + mnuo_nofollowingmouse // don't auto open new menus as mouse moves over menubar + ); + + TfpgMenuOptions = set of TfpgMenuOption; + + // forward declarations + TfpgPopupMenu = class; + TfpgMenuBar = class; + + + TfpgMenuItem = class(TComponent, ICommandHolder) + private + FCommand: ICommand; + FEnabled: boolean; + FHotKeyDef: TfpgHotKeyDef; + FOnClick: TNotifyEvent; + FSeparator: boolean; + FSubMenu: TfpgPopupMenu; + FText: TfpgString; + FVisible: boolean; + procedure SetEnabled(const AValue: boolean); + procedure SetHotKeyDef(const AValue: TfpgHotKeyDef); + procedure SetSeparator(const AValue: boolean); + procedure SetText(const AValue: TfpgString); + procedure SetVisible(const AValue: boolean); + public + constructor Create(AOwner: TComponent); override; + procedure Click; + function Selectable: boolean; + function GetAccelChar: string; + procedure DrawText(ACanvas: TfpgCanvas; x, y: TfpgCoord); + function GetCommand: ICommand; + procedure SetCommand(ACommand: ICommand); + property Text: TfpgString read FText write SetText; + property HotKeyDef: TfpgHotKeyDef read FHotKeyDef write SetHotKeyDef; + property Separator: boolean read FSeparator write SetSeparator; + property Visible: boolean read FVisible write SetVisible; + property Enabled: boolean read FEnabled write SetEnabled; + property SubMenu: TfpgPopupMenu read FSubMenu write FSubMenu; + property OnClick: TNotifyEvent read FOnClick write FOnClick; + end; + + + // Actual Menu Items are stored in TComponent's Components property + // Visible only items are stored in FItems just before a paint + TfpgPopupMenu = class(TfpgPopupWindow) + private + FBeforeShow: TNotifyEvent; + FMargin: TfpgCoord; + FTextMargin: TfpgCoord; + procedure DoSelect; + procedure CloseSubmenus; + function GetItemPosY(index: integer): integer; + function CalcMouseRow(y: integer): integer; + function VisibleCount: integer; + function VisibleItem(ind: integer): TfpgMenuItem; + function MenuFocused: boolean; + function SearchItemByAccel(s: string): integer; + protected + FMenuFont: TfpgFont; + FMenuAccelFont: TfpgFont; + FMenuDisabledFont: TfpgFont; + FSymbolWidth: integer; + FItems: TList; + FFocusItem: integer; + procedure HandleMouseEnter; override; + procedure HandleMouseExit; override; + procedure HandleMouseMove(x, y: integer; btnstate: word; shiftstate: TShiftState); override; + procedure HandleLMouseDown(x, y: integer; shiftstate: TShiftState); override; + procedure HandleLMouseUp(x, y: integer; shiftstate: TShiftState); override; + procedure HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override; + procedure HandlePaint; override; + procedure HandleShow; override; + procedure HandleClose; override; + procedure DrawItem(mi: TfpgMenuItem; rect: TfpgRect); virtual; + procedure DrawRow(line: integer; focus: boolean); virtual; + function ItemHeight(mi: TfpgMenuItem): integer; virtual; + procedure PrepareToShow; + public + OpenerPopup: TfpgPopupMenu; + OpenerMenuBar: TfpgMenuBar; + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure Close; override; + function AddMenuItem(const AMenuName: TfpgString; const hotkeydef: string; HandlerProc: TNotifyEvent): TfpgMenuItem; + function MenuItemByName(const AMenuName: TfpgString): TfpgMenuItem; + function MenuItem(const AMenuPos: integer): TfpgMenuItem; // added to allow for localization + property BeforeShow: TNotifyEvent read FBeforeShow write FBeforeShow; + end; + + + // Actual Menu Items are stored in TComponents Components property + // Visible only items are stored in FItems just before a paint + TfpgMenuBar = class(TfpgWidget) + private + FBeforeShow: TNotifyEvent; + FLightColor: TfpgColor; + FDarkColor: TfpgColor; + FMenuOptions: TfpgMenuOptions; + FPrevFocusItem: integer; + FFocusItem: integer; + procedure SetFocusItem(const AValue: integer); + procedure DoSelect; + procedure CloseSubmenus; + function ItemWidth(mi: TfpgMenuItem): integer; + protected + FItems: TList; // stores visible items only + property FocusItem: integer read FFocusItem write SetFocusItem; + procedure PrepareToShow; + function VisibleCount: integer; + function VisibleItem(ind: integer): TfpgMenuItem; + procedure HandleShow; override; + procedure HandleMouseMove(x, y: integer; btnstate: word; shiftstate: TShiftState); override; + procedure HandleLMouseDown(x, y: integer; shiftstate: TShiftState); override; + procedure HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override; + procedure HandlePaint; override; + function CalcMouseCol(x: integer): integer; + function GetItemPosX(index: integer): integer; + function MenuFocused: boolean; + function SearchItemByAccel(s: string): integer; + procedure ActivateMenu; + procedure DeActivateMenu; + procedure DrawColumn(col: integer; focus: boolean); virtual; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + function AddMenuItem(const AMenuTitle: string; OnClickProc: TNotifyEvent): TfpgMenuItem; + function MenuItem(const AMenuPos: integer): TfpgMenuItem; // added to allow for localization + property MenuOptions: TfpgMenuOptions read FMenuOptions write FMenuOptions; + property BeforeShow: TNotifyEvent read FBeforeShow write FBeforeShow; + end; + + +function CreateMenuBar(AOwner: TfpgWidget; x, y, w, h: TfpgCoord): TfpgMenuBar; overload; +function CreateMenuBar(AOwner: TfpgWidget): TfpgMenuBar; overload; + + +implementation + +var + uFocusedPopupMenu: TfpgPopupMenu; + +function CreateMenuBar(AOwner: TfpgWidget; x, y, w, h: TfpgCoord): TfpgMenuBar; +begin + if AOwner = nil then + raise Exception.Create('MenuBar component must have an Owner assigned'); + Result := TfpgMenuBar.Create(AOwner); + Result.Left := x; + Result.Top := y; + if w = 0 then + Result.Width := AOwner.Width + else + Result.Width := w; + if h > 0 then + Result.Height := h; +end; + +function CreateMenuBar(AOwner: TfpgWidget): TfpgMenuBar; +begin + Result := CreateMenuBar(AOwner, 0, 0, 0, 0); +end; + + +{ TfpgMenuItem } + +procedure TfpgMenuItem.SetText(const AValue: TfpgString); +begin + if FText = AValue then + Exit; //==> + FText := AValue; +end; + +procedure TfpgMenuItem.SetVisible(const AValue: boolean); +begin + if FVisible=AValue then exit; + FVisible:=AValue; +end; + +procedure TfpgMenuItem.SetHotKeyDef(const AValue: TfpgHotKeyDef); +begin + if FHotKeyDef=AValue then exit; + FHotKeyDef:=AValue; +end; + +procedure TfpgMenuItem.SetEnabled(const AValue: boolean); +begin + if FEnabled=AValue then exit; + FEnabled:=AValue; +end; + +procedure TfpgMenuItem.SetSeparator(const AValue: boolean); +begin + if FSeparator=AValue then exit; + FSeparator:=AValue; +end; + +constructor TfpgMenuItem.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + Text := ''; + HotKeyDef := ''; + FSeparator := False; + FVisible := True; + FEnabled := True; + FSubMenu := nil; + FOnClick := nil; +end; + +procedure TfpgMenuItem.Click; +begin + if Assigned(FOnClick) then + FOnClick(self); +end; + +function TfpgMenuItem.Selectable: boolean; +begin + Result := Enabled and Visible and (not Separator); +end; + +function TfpgMenuItem.GetAccelChar: string; +var + p: integer; +begin + p := UTF8Pos('&', Text); + if p > 0 then + begin + Result := UTF8Copy(Text, p+1, 1); + end + else + Result := ''; +end; + +procedure TfpgMenuItem.DrawText(ACanvas: TfpgCanvas; x, y: TfpgCoord); +var + s: string; + p: integer; + achar: string; +begin +// writeln('DrawText x:', x, ' y:', y); + if not Enabled then + ACanvas.SetFont(fpgStyle.MenuDisabledFont) + else + ACanvas.SetFont(fpgStyle.MenuFont); + + achar := '&'; + s := Text; + + repeat + p := UTF8Pos(achar, s); + if p > 0 then + begin + // first part of text before the & sign + ACanvas.DrawString(x, y, UTF8Copy(s, 1, p-1)); + inc(x, fpgStyle.MenuFont.TextWidth(UTF8Copy(s, 1, p-1))); + if UTF8Copy(s, p+1, 1) = achar then + begin + // Do we need to paint a actual & sign (create via && in item text) + ACanvas.DrawString(x, y, achar); + inc(x, fpgStyle.MenuFont.TextWidth(achar)); + end + else + begin + // Draw the HotKey text + if Enabled then + ACanvas.SetFont(fpgStyle.MenuAccelFont); + ACanvas.DrawString(x, y, UTF8Copy(s, p+1, 1)); + inc(x, ACanvas.Font.TextWidth(UTF8Copy(s, p+1, 1))); + if Enabled then + ACanvas.SetFont(fpgStyle.MenuFont); + end; + s := UTF8Copy(s, p+2, UTF8Length(s)); + end; { if } + until p < 1; + + // Draw the remaining text after the & sign + if UTF8Length(s) > 0 then + ACanvas.DrawString(x, y, s); +end; + +function TfpgMenuItem.GetCommand: ICommand; +begin + Result := FCommand; +end; + +procedure TfpgMenuItem.SetCommand(ACommand: ICommand); +begin + FCommand := ACommand; +end; + +{ TfpgMenuBar } + +procedure TfpgMenuBar.SetFocusItem(const AValue: integer); +begin + if FFocusItem = AValue then + Exit; + FPrevFocusItem := FFocusItem; + FFocusItem := AValue; +end; + +procedure TfpgMenuBar.PrepareToShow; +var + n: integer; + mi: TfpgMenuItem; +begin + if Assigned(FBeforeShow) then + FBeforeShow(self); + + FItems.Count := 0; + // Collecting visible items + for n := 0 to ComponentCount-1 do + begin + if Components[n] is TfpgMenuItem then + begin + mi := TfpgMenuItem(Components[n]); + if mi.Visible then + FItems.Add(mi); + end; + end; +end; + +function TfpgMenuBar.VisibleCount: integer; +begin + Result := FItems.Count; +end; + +function TfpgMenuBar.VisibleItem(ind: integer): TfpgMenuItem; +begin + if (ind < 0) or (ind > FItems.Count-1) then + Result := nil + else + Result := TfpgMenuItem(FItems.Items[ind]); +end; + +procedure TfpgMenuBar.HandleShow; +begin + PrepareToShow; + inherited HandleShow; +end; + +procedure TfpgMenuBar.HandleMouseMove(x, y: integer; btnstate: word; shiftstate: TShiftState); +var + newf: integer; +begin + inherited HandleMouseMove(x, y, btnstate, shiftstate); + + // process menu options + if mnuo_nofollowingmouse in FMenuOptions then + begin + if not MenuFocused then + Exit; //==> + end + else if mnuo_autoopen in FMenuOptions then + begin + if not Focused then + ActivateMenu; + end + else + begin + if not Focused then + Exit; + end; + + + newf := CalcMouseCol(x); + if not VisibleItem(newf).Selectable then + Exit; //==> + + if newf = FFocusItem then + Exit; //==> + + FocusItem := newf; + // continue processing menu options + if mnuo_autoopen in FMenuOptions then + DoSelect + else + begin + Repaint; + if not MenuFocused then + DoSelect; + end +end; + +procedure TfpgMenuBar.HandleLMouseDown(x, y: integer; shiftstate: TShiftState); +var + newf: integer; +begin + inherited HandleLMouseDown(x, y, shiftstate); + + if ComponentCount = 0 then + Exit; // We have no menu items in MainMenu. + + if not Focused then + ActivateMenu; + //else + //begin + //CloseSubmenus; + //DeActivateMenu; + //Exit; //==> + //end; + + newf := CalcMouseCol(x); + + if not VisibleItem(newf).Selectable then + Exit; //==> + + if newf <> FFocusItem then + begin +// DrawColumn(FFocusItem, False); + FocusItem := newf; +// DrawColumn(FFocusItem, True); + end; + + DoSelect; +end; + +procedure TfpgMenuBar.HandleKeyPress(var keycode: word; + var shiftstate: TShiftState; var consumed: boolean); +var + s: string; + i: integer; +begin +// writeln(Classname, '.Keypress'); + s := KeycodeToText(keycode, shiftstate); +// writeln('s: ', s); + // handle MenuBar (Alt+?) shortcuts only - for now! + if (length(s) = 5) and (copy(s, 1, 4) = 'Alt+') then + begin + s := KeycodeToText(keycode, []); + i := SearchItemByAccel(s); + if i <> -1 then + begin + consumed := True; +// writeln('Selected ', VisibleItem(i).Text); + FFocusItem := i; + DoSelect; + end; + end; + inherited HandleKeyPress(keycode, shiftstate, consumed); +end; + +procedure TfpgMenuBar.HandlePaint; +var + n: integer; + r: TfpgRect; +begin + Canvas.BeginDraw; + inherited HandlePaint; + r.SetRect(0, 0, Width, Height); + Canvas.Clear(FBackgroundColor); +// Canvas.DrawButtonFace(r, []); + // inner bottom line + Canvas.SetColor(clShadow1); + Canvas.DrawLine(r.Left, r.Bottom-1, r.Right+1, r.Bottom-1); // bottom + // outer bottom line + Canvas.SetColor(clHilite1); + Canvas.DrawLine(r.Left, r.Bottom, r.Right+1, r.Bottom); // bottom + + for n := 0 to VisibleCount-1 do + DrawColumn(n, n = FocusItem); + Canvas.EndDraw; +end; + +constructor TfpgMenuBar.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FItems := TList.Create; + FBeforeShow := nil; + FFocusItem := -1; + FPrevFocusItem := -1; + FFocusable := False; + FBackgroundColor := Parent.BackgroundColor; + FTextColor := Parent.TextColor; + // calculate the best height based on font + FHeight := fpgStyle.MenuFont.Height + 6; // 3px margin top and bottom + + FLightColor := TfpgColor($f0ece3); // color at top of menu bar + FDarkColor := TfpgColor($beb8a4); // color at bottom of menu bar + + FMenuOptions := []; +end; + +destructor TfpgMenuBar.Destroy; +begin + FItems.Free; + inherited Destroy; +end; + +function TfpgMenuBar.ItemWidth(mi: TfpgMenuItem): integer; +begin + Result := fpgStyle.MenuFont.TextWidth(mi.Text) + (2*6); +end; + +procedure TfpgMenuBar.DrawColumn(col: integer; focus: boolean); +var + n: integer; + r: TfpgRect; + mi: TfpgMenuItem; +begin + Canvas.BeginDraw; + r.SetRect(2, 1, 1, fpgStyle.MenuFont.Height+1); + + for n := 0 to VisibleCount-1 do + begin + mi := VisibleItem(n); + r.width := ItemWidth(mi); + if col = n then + begin + if focus and Focused then + begin + if MenuFocused then + begin + Canvas.SetColor(clSelection); + Canvas.SetTextColor(clSelectionText); + end + else + begin +// Canvas.SetColor(clInactiveSel); + Canvas.SetColor(clShadow1); + Canvas.SetTextColor(clInactiveSelText); + end; + end + else + begin + if mi.Enabled then + begin + Canvas.SetColor(BackgroundColor); + Canvas.SetTextColor(clMenuText); + end + else + begin + Canvas.SetColor(BackgroundColor); + Canvas.SetTextColor(clMenuDisabled); + end; + end; { if/else } + Canvas.FillRectangle(r); + // a possible future theme option +// Canvas.GradientFill(r, FLightColor, FDarkColor, gdVertical); + mi.DrawText(Canvas, r.left+4, r.top+1); + Canvas.EndDraw(r.Left, r.Top, r.Width, r.Height); + Exit; //==> + end; { if col=n } + inc(r.Left, ItemWidth(mi)); + end; { for } +end; + +function TfpgMenuBar.CalcMouseCol(x: integer): integer; +var + w: integer; + n: integer; +begin + Result := 0; + w := 0; + n := 0; + while (w <= x) and (n < VisibleCount) do + begin + Result := n; + inc(w, ItemWidth(VisibleItem(n))); + inc(n); + end; +end; + +function TfpgMenuBar.GetItemPosX(index: integer): integer; +var + n: integer; +begin + Result := 0; + if index < 0 then + Exit; //==> + n := 0; + while (n < VisibleCount) and (n < index) do + begin + Inc(result, ItemWidth(VisibleItem(n))); + inc(n); + end; +end; + +procedure TfpgMenuBar.DoSelect; +var + mi: TfpgMenuItem; +begin + mi := VisibleItem(FocusItem); + CloseSubMenus; // deactivates menubar! + + if mi.SubMenu <> nil then + begin + ActivateMenu; + // showing the submenu + mi.SubMenu.ShowAt(self, GetItemPosX(FocusItem)+2, fpgStyle.MenuFont.Height+4); + mi.SubMenu.OpenerPopup := nil; + mi.SubMenu.OpenerMenuBar := self; + mi.SubMenu.DontCloseWidget := self; + uFocusedPopupMenu := mi.SubMenu; + RePaint; + end + else + begin + VisibleItem(FocusItem).Click; + DeActivateMenu; + end; +end; + +procedure TfpgMenuBar.CloseSubmenus; +var + n: integer; +begin + // Close all previous popups + for n := 0 to VisibleCount-1 do + with VisibleItem(n) do + begin + if (SubMenu <> nil) and (SubMenu.HasHandle) then + SubMenu.Close; + end; +end; + +function TfpgMenuBar.MenuFocused: boolean; +var + n: integer; + mi: TfpgMenuItem; +begin + Result := True; + for n := 0 to VisibleCount-1 do + begin + mi := VisibleItem(n); + if (mi.SubMenu <> nil) and (mi.SubMenu.HasHandle) then + begin + Result := False; + Break; + end; + end; +end; + +function TfpgMenuBar.SearchItemByAccel(s: string): integer; +var + n: integer; +begin + Result := -1; + for n := 0 to VisibleCount-1 do + begin + with VisibleItem(n) do + begin + {$Note Should UpperCase take note of UTF-8? } + if Enabled and (UpperCase(s) = UpperCase(GetAccelChar)) then + begin + Result := n; + Exit; //==> + end; + end; + end; +end; + +procedure TfpgMenuBar.DeActivateMenu; +begin + Parent.ActiveWidget := nil; +end; + +procedure TfpgMenuBar.ActivateMenu; +begin + Parent.ActiveWidget := self; +end; + +function TfpgMenuBar.AddMenuItem(const AMenuTitle: string; OnClickProc: TNotifyEvent): TfpgMenuItem; +begin + Result := TfpgMenuItem.Create(self); + Result.Text := AMenuTitle; + Result.HotKeyDef := ''; + Result.OnClick := OnClickProc; + Result.Separator := False; +end; + +function TfpgMenuBar.MenuItem(const AMenuPos: integer): TfpgMenuItem; +begin + Result:= TfpgMenuItem(Components[AMenuPos]); +end; + +{ TfpgPopupMenu } + +procedure TfpgPopupMenu.DoSelect; +var + mi: TfpgMenuItem; + op: TfpgPopupMenu; +begin + mi := VisibleItem(FFocusItem); + if mi.SubMenu <> nil then + begin + CloseSubMenus; + // showing the submenu + mi.SubMenu.ShowAt(self, Width, GetItemPosY(FFocusItem)); + mi.SubMenu.OpenerPopup := self; + mi.SubMenu.OpenerMenuBar := OpenerMenuBar; + uFocusedPopupMenu := mi.SubMenu; + RePaint; + end + else + begin + // Close this popup + Close; + op := OpenerPopup; + while op <> nil do + begin + if op.HasHandle then + op.Close; + op := op.OpenerPopup; + end; + VisibleItem(FFocusItem).Click; + end; { if/else } + +// if OpenerMenuBar <> nil then +// OpenerMenuBar.DeActivateMenu; +end; + +procedure TfpgPopupMenu.CloseSubmenus; +var + n: integer; +begin + // Close all previous popups + for n := 0 to VisibleCount-1 do + with VisibleItem(n) do + begin + if (SubMenu <> nil) and (SubMenu.HasHandle) then + SubMenu.Close; + end; +end; + +function TfpgPopupMenu.GetItemPosY(index: integer): integer; +var + n: integer; +begin + Result := 2; + if index < 0 then + Exit; //==> + n := 0; + while (n < VisibleCount) and (n < index) do + begin + Inc(Result, ItemHeight(VisibleItem(n))); + inc(n); + end; +end; + +procedure TfpgPopupMenu.HandleMouseMove(x, y: integer; btnstate: word; shiftstate: TShiftState); +var + newf: integer; +begin + inherited HandleMouseMove(x, y, btnstate, shiftstate); + + if not MenuFocused then + Exit; //==> + + newf := CalcMouseRow(y); + if newf < 0 then + Exit; //==> + + if newf = FFocusItem then + Exit; //==> + + FFocusItem := newf; + Repaint; +end; + +procedure TfpgPopupMenu.HandleLMouseDown(x, y: integer; shiftstate: TShiftState); +var + r: TfpgRect; +begin + inherited HandleLMouseDown(x, y, shiftstate); + + r.SetRect(0, 0, Width, Height); + if not PtInRect(r, Point(x, y)) then + begin + ClosePopups; + Exit; //==> + end; +end; + +procedure TfpgPopupMenu.HandleLMouseUp(x, y: integer; shiftstate: TShiftState); +var + newf: integer; + mi: TfpgMenuItem; + r: TfpgRect; +begin + inherited HandleLMouseUp(x, y, shiftstate); + + newf := CalcMouseRow(y); + if newf < 0 then + Exit; + + if not VisibleItem(newf).Selectable then + Exit; //==> + + if newf <> FFocusItem then + FFocusItem := newf; + + mi := VisibleItem(FFocusItem); + if (mi <> nil) and (not MenuFocused) and (mi.SubMenu <> nil) + and mi.SubMenu.HasHandle then + mi.SubMenu.Close + else + DoSelect; +end; + +procedure TfpgPopupMenu.HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); +var + oldf: integer; + i: integer; + s: string; + op: TfpgPopupMenu; + trycnt: integer; + + procedure FollowFocus; + begin + if oldf <> FFocusItem then + begin + Repaint; + end; + end; + +begin + inherited HandleKeyPress(keycode, shiftstate, consumed); + + oldf := FFocusItem; + + consumed := true; + case keycode of + keyUp: + begin // up + trycnt := 2; + i := FFocusItem-1; + repeat + while (i >= 0) and not VisibleItem(i).Selectable do + dec(i); + + if i >= 0 then + break; //==> + + i := VisibleCount-1; + dec(trycnt); + until trycnt > 0; + + if i >= 0 then + FFocusItem := i; + end; + + keyDown: + begin // down + trycnt := 2; + i := FFocusItem+1; + repeat + while (i < VisibleCount) and not VisibleItem(i).Selectable do + inc(i); + if i < VisibleCount then + Break; //==> + i := 0; + dec(trycnt); + until trycnt > 0; + + if i < VisibleCount then + FFocusItem := i; + end; + + keyReturn: + begin + DoSelect; + end; + + keyLeft: + begin + if OpenerMenubar <> nil then + OpenerMenubar.HandleKeyPress(keycode, shiftstate, consumed); + end; + + keyRight: + begin + if OpenerMenubar <> nil then + OpenerMenubar.HandleKeyPress(keycode, shiftstate, consumed); + // VisibleItem(FFocusItem).SubMenu <> nil then DoSelect; + end; + + keyBackSpace: + begin + //if self.OpenerPopup <> nil then + Close; + end; + + keyEscape: + begin + Close; + op := OpenerPopup; + while op <> nil do + begin + op.Close; + op := op.OpenerPopup; + end; + end; + else + consumed := false; + end; + + FollowFocus; + + if (not consumed) and ((keycode and $8000) <> $8000) then + begin + // normal char + s := chr(keycode and $00FF) + chr((keycode and $FF00) shr 8); + i := SearchItemByAccel(s); + if i >= 0 then + begin + FFocusItem := i; + FollowFocus; + Consumed := true; + DoSelect; + end; + end; +end; + +procedure TfpgPopupMenu.HandlePaint; +var + n: integer; +begin + Canvas.BeginDraw; +// inherited HandlePaint; + Canvas.Clear(BackgroundColor); + Canvas.SetColor(clWidgetFrame); + Canvas.DrawRectangle(0, 0, Width, Height); // black rectangle border + Canvas.DrawButtonFace(1, 1, Width-1, Height-1, []); // 3d rectangle inside black border + + for n := 0 to VisibleCount-1 do + DrawRow(n, n = FFocusItem); + + Canvas.EndDraw; +end; + +procedure TfpgPopupMenu.HandleShow; +begin + PrepareToShow; + inherited HandleShow; +end; + +procedure TfpgPopupMenu.HandleClose; +begin + {$IFDEF DEBUG} + writeln(Classname, '.HandleClose'); + {$ENDIF} + inherited HandleClose; +end; + +function TfpgPopupMenu.VisibleCount: integer; +begin + Result := FItems.Count; +end; + +function TfpgPopupMenu.VisibleItem(ind: integer): TfpgMenuItem; +begin + if (ind < 0) or (ind > FItems.Count-1) then + Result := nil + else + Result := TfpgMenuItem(FItems.Items[ind]); +end; + +procedure TfpgPopupMenu.DrawItem(mi: TfpgMenuItem; rect: TfpgRect); +var + s: string; + x: integer; + img: TfpgImage; +begin + if mi.Separator then + begin + Canvas.SetColor(clMenuText); + Canvas.DrawLine(rect.Left, rect.Top+2, rect.Right+1, rect.Top+2); + end + else + begin + x := rect.Left + FSymbolWidth + FTextMargin; + + mi.DrawText(Canvas, x, rect.top); + + if mi.HotKeyDef <> '' then + begin + s := mi.HotKeyDef; + Canvas.DrawString(rect.Right-FMenuFont.TextWidth(s)-FTextMargin, rect.Top, s); + end; + + if mi.SubMenu <> nil then + begin + canvas.SetColor(Canvas.TextColor); + x := (rect.height div 2) - 3; + img := fpgImages.GetImage('sys.sb.right'); + Canvas.DrawImage(rect.right-x-2, rect.Top + ((rect.Height-img.Height) div 2), img); +// canvas.FillTriangle(rect.right-x-2, rect.top+2, +// rect.right-2, rect.top+2+x, +// rect.right-x-2, rect.top+2+2*x); + end; + end; +end; + +procedure TfpgPopupMenu.DrawRow(line: integer; focus: boolean); +var + n: integer; + r: TfpgRect; + mi: TfpgMenuItem; +begin + Canvas.BeginDraw; + r.SetRect(FMargin, FMargin, FWidth-(2*FMargin), FHeight-(2*FMargin)); + + for n := 0 to VisibleCount-1 do + begin + mi := VisibleItem(n); + + r.height := ItemHeight(mi); + + if line = n then + begin + if focus and (not mi.Separator) then + begin + if MenuFocused then + begin + Canvas.SetColor(clSelection); + if mi.Selectable then + Canvas.SetTextColor(clSelectionText) + else + Canvas.SetTextColor(clMenuDisabled); + end + else + begin + Canvas.SetColor(clShadow1); + Canvas.SetTextColor(clInactiveSelText); + end; + end + else + begin + if mi.Enabled then + begin + Canvas.SetColor(BackgroundColor); + Canvas.SetTextColor(clMenuText); + end + else + begin + Canvas.SetColor(BackgroundColor); + Canvas.SetTextColor(clMenuDisabled); + end; + end; + Canvas.FillRectangle(r); + DrawItem(mi, r); + Canvas.EndDraw(r.Left, r.Top, r.Width, r.Height); + Exit; //==> + end; + inc(r.Top, ItemHeight(mi) ); + end; { for } +end; + +function TfpgPopupMenu.ItemHeight(mi: TfpgMenuItem): integer; +begin + if mi.Separator then + Result := 5 + else + Result := FMenuFont.Height + 2; +end; + +function TfpgPopupMenu.MenuFocused: boolean; +begin + Result := (uFocusedPopupMenu = self); +end; + +function TfpgPopupMenu.SearchItemByAccel(s: string): integer; +var + n: integer; +begin + result := -1; + for n := 0 to VisibleCount-1 do + begin + with VisibleItem(n) do + begin + {$Note Do we need to use UTF-8 upper case? } + if Enabled and (UpperCase(s) = UpperCase(GetAccelChar)) then + begin + result := n; + Exit; //==> + end; + end; + end; +end; + +procedure TfpgPopupMenu.HandleMouseEnter; +begin + {$IFDEF DEBUG} + writeln(Classname, '.HandleMouseEnter'); + {$ENDIF} + inherited HandleMouseEnter; +end; + +procedure TfpgPopupMenu.HandleMouseExit; +begin + {$IFDEF DEBUG} + writeln(Classname, '.HandleMouseExit'); + {$ENDIF} + inherited HandleMouseExit; + FFocusItem := -1; + Repaint; +end; + +// Collecting visible items and measuring sizes +procedure TfpgPopupMenu.PrepareToShow; +var + n: integer; + h: integer; + tw: integer; + hkw: integer; + x: integer; + mi: TfpgMenuItem; +begin + if Assigned(FBeforeShow) then + BeforeShow(self); + + // Collecting visible items + FItems.Count := 0; + + for n := 0 to ComponentCount-1 do + begin + if Components[n] is TfpgMenuItem then + begin + mi := TfpgMenuItem(Components[n]); + if mi.Visible then + FItems.Add(mi); + end; + end; + + // Measuring sizes + h := 0; // height + tw := 0; // text width + hkw := 0; // hotkey width + FSymbolWidth := 0; + for n := 0 to VisibleCount-1 do + begin + mi := VisibleItem(n); + x := ItemHeight(mi); + inc(h, x); + x := FMenuFont.TextWidth(mi.Text); + if tw < x then + tw := x; + + if mi.SubMenu <> nil then + x := FMenuFont.Height + else + x := FMenuFont.TextWidth(mi.HotKeyDef); + if hkw < x then + hkw := x; + end; + + if hkw > 0 then + hkw := hkw + 10; // spacing between text and hotkey text + + FHeight := FMargin*2 + h; + FWidth := (FMargin+FTextMargin)*2 + FSymbolWidth + tw + hkw; + + uFocusedPopupMenu := self; +end; + +function TfpgPopupMenu.CalcMouseRow(y: integer): integer; +var + h: integer; + n: integer; +begin + h := 2; + n := 0; + Result := n; + + // sanity check + if y < 0 then + Exit + else + n := 0; + + while (h <= y) and (n < VisibleCount) do + begin + Result := n; + inc(h, ItemHeight(VisibleItem(n))); + inc(n); + end; +end; + +constructor TfpgPopupMenu.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FMargin := 3; + FTextMargin := 3; + FItems := TList.Create; + + // fonts + FMenuFont := fpgStyle.MenuFont; + FMenuAccelFont := fpgStyle.MenuAccelFont; + FMenuDisabledFont := fpgStyle.MenuDisabledFont; + FSymbolWidth := FMenuFont.Height+2; + + FBeforeShow := nil; + FFocusItem := -1; + OpenerPopup := nil; + OpenerMenubar := nil; +end; + +destructor TfpgPopupMenu.Destroy; +begin + {$IFDEF DEBUG} + writeln(Classname, '.Destroy'); + {$ENDIF} + FItems.Free; + inherited Destroy; +end; + +{$Note See if we can move this to HandleHide + not make Close virtual! } +procedure TfpgPopupMenu.Close; +var + n: integer; + mi: TfpgMenuItem; +begin + for n := 0 to FItems.Count-1 do + begin + mi := TfpgMenuItem(FItems[n]); + if mi.SubMenu <> nil then + begin + if mi.SubMenu.HasHandle then + mi.SubMenu.Close; + end; + end; + inherited Close; + uFocusedPopupMenu := OpenerPopup; + if (uFocusedPopupMenu <> nil) and uFocusedPopupMenu.HasHandle then + uFocusedPopupMenu.RePaint; + + if (OpenerMenuBar <> nil) and OpenerMenuBar.HasHandle then + begin + if (OpenerPopup = nil) or not OpenerPopup.HasHandle then + begin + OpenerMenuBar.DeActivateMenu; + //OpenerMenuBar.Repaint; + end; + //else + //OpenerMenuBar.RePaint; + end; +end; + +function TfpgPopupMenu.AddMenuItem(const AMenuName: TfpgString; + const hotkeydef: string; HandlerProc: TNotifyEvent): TfpgMenuItem; +begin + result := TfpgMenuItem.Create(self); + if AMenuName <> '-' then + begin + result.Text := AMenuName; + result.hotkeydef := hotkeydef; + result.OnClick := HandlerProc; + end + else + begin + result.Separator := true; + end; +end; + +function TfpgPopupMenu.MenuItemByName(const AMenuName: TfpgString): TfpgMenuItem; +var + i: integer; +begin + Result := nil; + for i := 0 to ComponentCount-1 do + begin + if Components[i] is TfpgMenuItem then + if SameText(TfpgMenuItem(Components[i]).Text, AMenuName) then + begin + Result := TfpgMenuItem(Components[i]); + Exit; //==> + end; + end; +end; + +function TfpgPopupMenu.MenuItem(const AMenuPos: integer): TfpgMenuItem; +begin + Result:= TfpgMenuItem(Components[AMenuPos]); +end; + +initialization + uFocusedPopupMenu := nil; + +end. + diff --git a/src/gui/fpg_mru.pas b/src/gui/fpg_mru.pas new file mode 100644 index 00000000..64feb793 --- /dev/null +++ b/src/gui/fpg_mru.pas @@ -0,0 +1,276 @@ +{ + fpGUI - Free Pascal GUI Toolkit + + Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this + distribution, for details of the copyright. + + See the file COPYING.modifiedLGPL, included in this distribution, + for details about redistributing fpGUI. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + Description: + A component implementing a 'Most Recently Used' feature normally + inserted in the File menu. +} + +unit fpg_mru; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, fpg_menu; + +type + + TMRUClickEvent = procedure(Sender: TObject; const FileName: String) of object; + + TfpgMRU = class(TComponent) + private + FItems: TStringList; + FMaxItems: Integer; + FShowFullPath: boolean; + FParentMenuItem: TfpgPopupMenu; +// FIniFilePath: string; + FOnClick: TMRUClickEvent; + procedure SetMaxItems(const AValue: Integer); +// procedure SetIniFilePath(const AValue: string); + procedure SetParentMenuItem(const AValue: TfpgPopupMenu); + procedure SetShowFullPath(const AValue: boolean); + procedure SaveMRU; + procedure ItemsChange(Sender: TObject); + procedure ClearParentMenu; + protected + // this never gets called without a Form Streaming class, which fpGUI doesn't use + procedure Loaded; override; + procedure Notification(AComponent: TComponent; Operation: TOperation); override; + procedure DoClick(Sender: TObject); + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure AddItem(const FileName: string); + function RemoveItem(const FileName : string) : boolean; + procedure LoadMRU; + published + property MaxItems: Integer read FMaxItems write SetMaxItems default 4; +// property IniFilePath: string read FIniFilePath write SetIniFilePath; + property ShowFullPath: boolean read FShowFullPath write SetShowFullPath default True; + property ParentMenuItem: TfpgPopupMenu read FParentMenuItem write SetParentMenuItem; + property OnClick: TMRUClickEvent read FOnClick write FOnClick; + end; + + +implementation + +uses + fpg_iniutils; + +type + //to be able to recognize MRU menu item when deleting + TMRUMenuItem = class(TfpgMenuItem); + + +{ TfpgMRU } + +procedure TfpgMRU.SetMaxItems(const AValue: Integer); +begin + if AValue <> FMaxItems then + begin + if AValue < 1 then + FMaxItems := 1 + else + begin + if AValue > High(Word) then // 65535 should be enough + FMaxItems := High(Word) + else + begin + FMaxItems := AValue; + FItems.BeginUpdate; + try + while FItems.Count > MaxItems do + FItems.Delete(FItems.Count - 1); + finally + FItems.EndUpdate; + end; + end; + end; { if/else } + end; +end; + +{ +procedure TfpgMRU.SetIniFilePath(const AValue: string); +begin + if FIniFilePath=AValue then exit; + FIniFilePath:=AValue; +end; +} + +procedure TfpgMRU.SetParentMenuItem(const AValue: TfpgPopupMenu); +begin + if AValue = FParentMenuItem then + Exit; + FParentMenuItem := AValue; +end; + +procedure TfpgMRU.SetShowFullPath(const AValue: boolean); +begin + if FShowFullPath <> AValue then + begin + FShowFullPath := AValue; + ItemsChange(Self); + end; +end; + +procedure TfpgMRU.LoadMRU; +var + i: cardinal; +begin + FItems.BeginUpdate; + FItems.Clear; + try + for i := 1 to FMaxItems do + if gINI.ValueExists('MRU', 'MRU'+IntToStr(i)) then + FItems.Add(gINI.ReadString('MRU', 'MRU'+IntToStr(i), '')); + finally + FItems.EndUpdate; + end; +end; + +procedure TfpgMRU.SaveMRU; +var + i: integer; +begin + if FItems.Count = 0 then + Exit; + + //delete old mru + i := 1; + while gINI.ValueExists('MRU', 'MRU'+IntToStr(i)) do + begin + gINI.DeleteKey('MRU', 'MRU'+IntToStr(i)); + Inc(i); + end; + + //write new mru + for i := 0 to FItems.Count-1 do + gINI.WriteString('MRU', 'MRU'+IntToStr(i+1), FItems[i]); +end; + +procedure TfpgMRU.ItemsChange(Sender: TObject); +var + i: Integer; + NewMenuItem: TfpgMenuItem; + FileName: String; +begin +// writeln('TfpgMRU.ItemsChange'); + if ParentMenuItem <> nil then + begin + ClearParentMenu; + if FItems.Count = 0 then + ParentMenuItem.AddMenuItem('-', '', nil); // add something if we have no previous MRU's + for i := 0 to -1 + FItems.Count do + begin + if ShowFullPath then + FileName := StringReplace(FItems[I], '&', '&&', [rfReplaceAll, rfIgnoreCase]) + else + FileName := StringReplace(ExtractFileName(FItems[i]), '&', '&&', [rfReplaceAll, rfIgnoreCase]); + +// NewMenuItem := ParentMenuItem.AddMenuItem(Format('%s', [FileName]), '', @DoClick); +// NewMenuItem.Tag := i; + NewMenuItem := TMRUMenuItem.Create(ParentMenuItem); + NewMenuItem.Text := Format('%s', [FileName]); + NewMenuItem.Tag := i; + NewMenuItem.OnClick := @DoClick; + end; + end; +end; + +procedure TfpgMRU.ClearParentMenu; +//var +// i:integer; +begin + if Assigned(ParentMenuItem) then + ParentMenuItem.DestroyComponents; +{ + for i := ParentMenuItem.ComponentCount-1 downto 0 do + if ParentMenuItem.Components[i] is TMRUMenuItem then + ParentMenuItem.Delete(i); +} +end; + +procedure TfpgMRU.Loaded; +begin + inherited Loaded; + if not (csDesigning in ComponentState) then +// if FIniFilePath <> '' then + LoadMRU; +end; + +procedure TfpgMRU.Notification(AComponent: TComponent; Operation: TOperation); +begin + inherited Notification(AComponent, Operation); + if (Operation = opRemove) and (AComponent = FParentMenuItem) then + FParentMenuItem := nil; +end; + +procedure TfpgMRU.DoClick(Sender: TObject); +begin + if Assigned(FOnClick) and (Sender is TMRUMenuItem) then + FOnClick(Self, FItems[TMRUMenuItem(Sender).Tag]); +end; + +constructor TfpgMRU.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FParentMenuItem := nil; + FItems := TStringList.Create; + FItems.OnChange := @ItemsChange; + FMaxItems := 4; + FShowFullPath := True; +// Loaded; +end; + +destructor TfpgMRU.Destroy; +begin + if not (csDesigning in ComponentState) then + SaveMRU; + FItems.OnChange := nil; + FItems.Free; + inherited Destroy; +end; + +procedure TfpgMRU.AddItem(const FileName: string); +begin + if FileName <> '' then + begin + FItems.BeginUpdate; + try + if FItems.IndexOf(FileName) > -1 then + FItems.Delete(FItems.IndexOf(FileName)); + FItems.Insert(0, FileName); + + while FItems.Count > MaxItems do + FItems.Delete(MaxItems); + finally + FItems.EndUpdate; + end; + end; +end; + +function TfpgMRU.RemoveItem(const FileName: string): boolean; +begin + if FItems.IndexOf(FileName) > -1 then + begin + FItems.Delete(FItems.IndexOf(FileName)); + Result := True; + end + else + Result := False; +end; + +end. + diff --git a/src/gui/fpg_panel.pas b/src/gui/fpg_panel.pas new file mode 100644 index 00000000..6e75dda0 --- /dev/null +++ b/src/gui/fpg_panel.pas @@ -0,0 +1,754 @@ +{ + fpGUI - Free Pascal GUI Toolkit + + Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this + distribution, for details of the copyright. + + See the file COPYING.modifiedLGPL, included in this distribution, + for details about redistributing fpGUI. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + Description: + Defines a Panel control. Also known as a Bevel or Frame control. + This control can also draw itself like a GroupBox component. +} + +unit fpg_panel; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, + SysUtils, + fpg_base, + fpg_main, + fpg_widget; + +type + + TPanelShape = (bsBox, bsFrame, bsTopLine, bsBottomLine, bsLeftLine, + bsRightLine, bsSpacer); + + TPanelStyle = (bsLowered, bsRaised); + + TPanelBorder = (bsSingle, bsDouble); + + + TfpgAbstractPanel = class(TfpgWidget) + private + FPanelShape: TPanelShape; + FPanelStyle: TPanelStyle; + FPanelBorder: TPanelBorder; + function GetClientRect: TfpgRect; override; + procedure SetPanelStyle(const AValue: TPanelStyle); + procedure SetPanelBorder(const AValue: TPanelBorder); + protected + property Style: TPanelStyle read FPanelStyle write SetPanelStyle default bsRaised; + property BorderStyle: TPanelBorder read FPanelBorder write SetPanelBorder default bsSingle; + public + constructor Create(AOwner: TComponent); override; + end; + + + TfpgBevel = class(TfpgAbstractPanel) + private + procedure SetPanelShape(const AValue: TPanelShape); + protected + procedure HandlePaint; override; + published + property BackgroundColor; + property BorderStyle; + property ParentShowHint; + property Shape: TPanelShape read FPanelShape write SetPanelShape default bsBox; + property ShowHint; + property Style; + property OnClick; + property OnDoubleClick; + property OnMouseDown; + property OnMouseUp; + property OnPaint; + end; + + + TfpgPanel = class(TfpgAbstractPanel) + private + FAlignment: TAlignment; + FLayout: TLayout; + FWrapText: boolean; + FLineSpace: integer; + FMargin: integer; + FText: string; + function GetAlignment: TAlignment; + procedure SetAlignment(const AValue: TAlignment); + function GetLayout: TLayout; + procedure SetLayout(const AValue: TLayout); + function GetText: string; + procedure SetText(const AValue: string); + function GetFontDesc: string; + procedure SetFontDesc(const AValue: string); + function GetLineSpace: integer; + procedure SetLineSpace(const AValue: integer); + function GetMargin: integer; + procedure SetMargin(const AValue: integer); + function GetWrapText: boolean; + procedure SetWrapText(const AValue: boolean); + protected + FFont: TfpgFont; + procedure HandlePaint; override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + property Font: TfpgFont read FFont; + published + property Alignment: TAlignment read GetAlignment write SetAlignment default taCenter; + property BackgroundColor; + property BorderStyle; + property FontDesc: string read GetFontDesc write SetFontDesc; + property Layout: TLayout read GetLayout write SetLayout default tlCenter; + property ParentShowHint; + property ShowHint; + property Style; + property Text: string read GetText write SetText; + property TextColor; + property LineSpace: integer read GetLineSpace write SetLineSpace default 2; + property Margin: integer read GetMargin write SetMargin default 2; + property WrapText: boolean read GetWrapText write SetWrapText default False; + property OnClick; + property OnDoubleClick; + end; + + + TfpgGroupBox = class(TfpgAbstractPanel) + private + FAlignment: TAlignment; + FMargin: integer; + FText: string; + function GetAlignment: TAlignment; + procedure SetAlignment(const AValue: TAlignment); + function GetText: string; + procedure SetText(const AValue: string); + function GetFontDesc: string; + procedure SetFontDesc(const AValue: string); + function GetMargin: integer; + procedure SetMargin(const AValue: integer); + protected + FFont: TfpgFont; + function GetClientRect: TfpgRect; override; + procedure HandlePaint; override; + public + constructor Create(AOwner: TComponent); override; + property Font: TfpgFont read FFont; + published + property Alignment: TAlignment read GetAlignment write SetAlignment default taCenter; + property BackgroundColor; + property BorderStyle; + property FontDesc: string read GetFontDesc write SetFontDesc; + property Style; + property Text: string read GetText write SetText; + property TextColor; + property Margin: integer read GetMargin write SetMargin default 2; + property OnClick; + property OnDoubleClick; + end; + + +function CreateBevel(AOwner: TComponent; ALeft, ATop, AWidth, AHeight: TfpgCoord; AShape: TPanelShape; + AStyle: TPanelStyle): TfpgBevel; + +function CreatePanel(AOwner: TComponent; ALeft, ATop, AWidth, AHeight: TfpgCoord; AText: string; + AStyle: TPanelStyle; AALignment: TAlignment= taCenter; ALayout: TLayout= tlCenter; + AMargin: integer= 2; ALineSpace: integer= 2): TfpgPanel; + +function CreateGroupBox(AOwner: TComponent; ALeft, ATop, AWidth, AHeight: TfpgCoord; AText: string; + AStyle: TPanelStyle; AALignment: TAlignment= taCenter; AMargin: integer= 2): TfpgGroupBox; + + +implementation + +function CreateBevel(AOwner: TComponent; ALeft, ATop, AWidth, AHeight: TfpgCoord; AShape: TPanelShape; + AStyle: TPanelStyle): TfpgBevel; +begin + Result := TfpgBevel.Create(AOwner); + Result.Left := ALeft; + Result.Top := ATop; + Result.Width := AWidth; + Result.Height := AHeight; + Result.Shape := AShape; + Result.Style := AStyle; +end; + +function CreatePanel(AOwner: TComponent; ALeft, ATop, AWidth, AHeight: TfpgCoord; AText: string; + AStyle: TPanelStyle; AALignment: TAlignment= taCenter; ALayout: TLayout= tlCenter; + AMargin: integer= 2; ALineSpace: integer= 2): TfpgPanel; +begin + Result := TfpgPanel.Create(AOwner); + Result.Left := ALeft; + Result.Top := ATop; + Result.Width := AWidth; + Result.Height := AHeight; + Result.FText := AText; + Result.Style := AStyle; + Result.FAlignment:= AAlignment; + Result.FLayout := ALayout; + Result.FMargin := AMargin; + Result.FLineSpace:= ALineSpace; +end; + +function CreateGroupBox(AOwner: TComponent; ALeft, ATop, AWidth, AHeight: TfpgCoord; AText: string; + AStyle: TPanelStyle; AALignment: TAlignment= taCenter; AMargin: integer= 2): TfpgGroupBox; +begin + Result := TfpgGroupBox.Create(AOwner); + Result.Left := ALeft; + Result.Top := ATop; + Result.Width := AWidth; + Result.Height := AHeight; + Result.FText := AText; + Result.Style := AStyle; + Result.FAlignment := AAlignment; + Result.FMargin := AMargin; +end; + + +{TfpgAbstractPanel} + +function TfpgAbstractPanel.GetClientRect: TfpgRect; +begin + Result.SetRect(2, 2, Width - 4, Height - 4); +end; + +procedure TfpgAbstractPanel.SetPanelStyle(const AValue: TPanelStyle); +begin + if FPanelStyle <> AValue then + begin + FPanelStyle := AValue; + Repaint; + end; +end; + +procedure TfpgAbstractPanel.SetPanelBorder(const AValue: TPanelBorder); +begin + if FPanelBorder <> AValue then + begin + FPanelBorder := AValue; + Repaint; + end; +end; + +constructor TfpgAbstractPanel.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FPanelShape := bsBox; + FPanelStyle := bsRaised; + FPanelBorder := bsSingle; + FWidth := 80; + FHeight := 80; + FFocusable := True; // otherwise children can't get focus + FBackgroundColor := Parent.BackgroundColor; + FIsContainer := True; +end; + +{TfpgBevel} + +procedure TfpgBevel.SetPanelShape(const AValue: TPanelShape); +begin + if FPanelShape <> AValue then + begin + FPanelShape := AValue; + Repaint; + end; +end; + +procedure TfpgBevel.HandlePaint; +begin + inherited HandlePaint; + + Canvas.Clear(BackgroundColor); + + // Canvas.SetLineStyle(2, lsSolid); + // Canvas.SetColor(clWindowBackground); + // Canvas.DrawRectangle(1, 1, Width - 1, Height - 1); + if FPanelBorder = bsSingle then + Canvas.SetLineStyle(1, lsSolid) + else + Canvas.SetLineStyle(2, lsSolid); + + if Style = bsRaised then + Canvas.SetColor(clHilite2) + else + Canvas.SetColor(clShadow2); + + if Shape in [bsBox] then + if FPanelBorder = bsSingle then + Canvas.DrawLine(0, 0, Width - 1, 0) + else + Canvas.DrawLine(0, 1, Width - 1, 1); + if Shape in [bsFrame, bsTopLine] then + Canvas.DrawLine(0, 0, Width - 1, 0); + if Shape in [bsBox] then + if FPanelBorder = bsSingle then + Canvas.DrawLine(0, 1, 0, Height - 1) + else + Canvas.DrawLine(1, 1, 1, Height - 1); + if Shape in [bsFrame, bsLeftLine] then + Canvas.DrawLine(0, 1, 0, Height - 1); + if Shape in [bsFrame, bsRightLine] then + Canvas.DrawLine(Width - 2, 1, Width - 2, Height - 1); + if Shape in [bsFrame, bsBottomLine] then + Canvas.DrawLine(1, Height - 2, Width - 1, Height - 2); + + if Style = bsRaised then + Canvas.SetColor(clShadow2) + else + Canvas.SetColor(clHilite2); + + if Shape in [bsFrame, bsTopLine] then + Canvas.DrawLine(1, 1, Width - 2, 1); + if Shape in [bsFrame, bsLeftLine] then + Canvas.DrawLine(1, 2, 1, Height - 2); + if Shape in [bsBox, bsFrame, bsRightLine] then + Canvas.DrawLine(Width - 1, 0, Width - 1, Height - 1); + if Shape in [bsBox, bsFrame, bsBottomLine] then + Canvas.DrawLine(0, Height - 1, Width, Height - 1); + + // To make it more visible in the UI Designer + if csDesigning in ComponentState then + begin + if Shape in [bsSpacer] then + begin + Canvas.SetColor(clInactiveWgFrame); + Canvas.SetLineStyle(1, lsDash); + Canvas.DrawRectangle(0, 0, Width, Height); +// Canvas.SetTextColor(clText1); +// Canvas.DrawString(2, 2, Name + ': ' + Classname); + end; + end; +end; + +{TfpgPanel} + +function TfpgPanel.GetAlignment: TAlignment; +begin + Result := FAlignment; +end; + +procedure TfpgPanel.SetAlignment(const AValue: TAlignment); +begin + if FAlignment <> AValue then + begin + FAlignment := AValue; + Repaint; + end; +end; + +function TfpgPanel.GetLayout: TLayout; +begin + Result := FLayout; +end; + +procedure TfpgPanel.SetLayout(const AValue: TLayout); +begin + if FLayout <> AValue then + begin + FLayout := AValue; + Repaint; + end; +end; + +function TfpgPanel.GetText: string; +begin + Result := FText; +end; + +procedure TfpgPanel.SetText(const AValue: string); +begin + if FText <> AValue then + begin + FText := AValue; + Repaint; + end; +end; + +function TfpgPanel.GetFontDesc: string; +begin + Result := FFont.FontDesc; +end; + +procedure TfpgPanel.SetFontDesc(const AValue: string); +begin + FFont.Free; + FFont := fpgGetFont(AValue); + Repaint; +end; + +function TfpgPanel.GetLineSpace: integer; +begin + Result := FLineSpace; +end; + +procedure TfpgPanel.SetLineSpace(const AValue: integer); +begin + if FLineSpace <> AValue then + begin + FLineSpace := AValue; + Repaint; + end; +end; + +function TfpgPanel.GetMargin: integer; +begin + Result := FMargin; +end; + +procedure TfpgPanel.SetMargin(const AValue: integer); +begin + if FMargin <> AValue then + begin + FMargin := AValue; + Repaint; + end; +end; + +function Tfpgpanel.GetWrapText: boolean; +begin + Result := FWrapText; +end; + +procedure Tfpgpanel.SetWrapText(const AValue: boolean); +begin + if FWrapText <> AValue then + begin + FWrapText := AValue; + Repaint; + end; +end; +procedure TfpgPanel.HandlePaint; +var + lTxtFlags: TFTextFlags; +begin + inherited HandlePaint; + + Canvas.Clear(BackgroundColor); + + // Canvas.SetLineStyle(2, lsSolid); + // Canvas.SetColor(clWindowBackground); + // Canvas.DrawRectangle(1, 1, Width - 1, Height - 1); + if FPanelBorder = bsSingle then + Canvas.SetLineStyle(1, lsSolid) + else + Canvas.SetLineStyle(2, lsSolid); + + if Style = bsRaised then + Canvas.SetColor(clHilite2) + else + Canvas.SetColor(clShadow2); + + if FPanelBorder = bsSingle then + begin + Canvas.DrawLine(0, 0, Width - 1, 0); + Canvas.DrawLine(0, 1, 0, Height - 1); + end + else + begin + Canvas.DrawLine(0, 1, Width - 1, 1); + Canvas.DrawLine(1, 1, 1, Height - 1); + end; + + if Style = bsRaised then + Canvas.SetColor(clShadow2) + else + Canvas.SetColor(clHilite2); + + Canvas.DrawLine(Width - 1, 0, Width - 1, Height - 1); + Canvas.DrawLine(0, Height - 1, Width, Height - 1); + + Canvas.SetTextColor(FTextColor); + Canvas.SetFont(Font); + + lTxtFlags:= []; + if not Enabled then + Include(lTxtFlags, txtDisabled); + + if FWrapText then + Include(lTxtFlags, txtWrap); + case FAlignment of + taLeftJustify: + Include(lTxtFlags, txtLeft); + taRightJustify: + Include(lTxtFlags, txtRight); + taCenter: + Include(lTxtFlags, txtHCenter); + end; + case FLayout of + tlTop: + Include(lTxtFlags, txtTop); + tlBottom: + Include(lTxtFlags, txtBottom); + tlCenter: + Include(lTxtFlags, txtVCenter); + end; + Canvas.DrawText(FMargin, FMargin, Width - FMargin * 2, Height - FMargin * 2, FText, lTxtFlags, FLineSpace); +end; + +constructor TfpgPanel.Create(Aowner: TComponent); +begin + inherited Create(AOwner); + FText := 'Panel'; + FFont := fpgGetFont('#Label1'); + FPanelShape := bsBox; + FPanelStyle := bsRaised; + FWidth := 80; + FHeight := 80; + FFocusable := True; // otherwise children can't get focus + FBackgroundColor := Parent.BackgroundColor; + FAlignment := taCenter; + FLayout := tlCenter; + FWrapText := False; + FLineSpace := 2; + FMargin := 2; +end; + +destructor TfpgPanel.Destroy; +begin + FText := ''; + FFont.Free; + inherited Destroy; +end; + +{TfpgGroupBox} + +function TfpgGroupBox.GetAlignment: TAlignment; +begin + Result := FAlignment; +end; + +procedure TfpgGroupBox.SetAlignment(const AValue: TAlignment); +begin + if FAlignment <> AValue then + begin + FAlignment := AValue; + Repaint; + end; +end; + +function TfpgGroupBox.GetText: string; +begin + Result := FText; +end; + +procedure TfpgGroupBox.SetText(const AValue: string); +begin + if FText <> AValue then + begin + FText := AValue; + Repaint; + end; +end; + +function TfpgGroupBox.GetFontDesc: string; +begin + Result := FFont.FontDesc; +end; + +procedure TfpgGroupBox.SetFontDesc(const AValue: string); +begin + FFont.Free; + FFont := fpgGetFont(AValue); + Repaint; +end; + +function TfpgGroupBox.GetMargin: integer; +begin + Result := FMargin; +end; + +procedure TfpgGroupBox.SetMargin(const AValue: integer); +begin + if FMargin <> AValue then + begin + FMargin := AValue; + Repaint; + end; +end; + +function TfpgGroupBox.GetClientRect: TfpgRect; +var + h: integer; +begin + h := FFont.Height + 4; + Result.SetRect(2, h, Width - 4, Height - (h + 2)); +end; + +procedure TfpgGroupBox.HandlePaint; +var + r: TfpgRect; + w: integer; + lTxtFlags: TFTextFlags; +begin + inherited HandlePaint; + + Canvas.Clear(Parent.BackgroundColor); + Canvas.ClearClipRect; + r.SetRect(0, 5, Width, Height); + Canvas.SetClipRect(r); + Canvas.Clear(FBackgroundColor); + + lTxtFlags := TextFlagsDflt; + if not Enabled then + Include(lTxtFlags, txtDisabled); + +// Canvas.ClearClipRect; + + // Canvas.SetLineStyle(2, lsSolid); + // Canvas.SetColor(clWindowBackground); + // Canvas.DrawRectangle(1, 1, Width - 1, Height - 1); + if FPanelBorder = bsSingle then + Canvas.SetLineStyle(1, lsSolid) + else + Canvas.SetLineStyle(2, lsSolid); + + if Style = bsRaised then + Canvas.SetColor(clHilite2) + else + Canvas.SetColor(clShadow2); + + if FPanelBorder = bsSingle then + begin + Canvas.DrawLine(0, 5, Width - 1, 5); + Canvas.DrawLine(0, 6, 0, Height - 1); + end + else + begin + Canvas.DrawLine(0, 6, Width - 1, 6); + Canvas.DrawLine(1, 6, 1, Height - 1); + end; + + if Style = bsRaised then + Canvas.SetColor(clShadow2) + else + Canvas.SetColor(clHilite2); + + Canvas.DrawLine(Width - 1, 5, Width - 1, Height - 1); + Canvas.DrawLine(0, Height - 1, Width, Height - 1); + + Canvas.SetTextColor(FTextColor); + Canvas.SetFont(Font); + + case FAlignment of + taLeftJustify: + begin + w := FFont.TextWidth(FText) + FMargin * 2; + r.SetRect(5, 0, w, FFont.Height + FMargin); + Canvas.SetClipRect(r); + Canvas.Clear(FBackgroundColor); + + if Style = bsRaised then + Canvas.SetColor(clHilite2) + else + Canvas.SetColor(clShadow2); + + if FPanelBorder = bsSingle then + begin + Canvas.DrawLine(5, 0, w + 5, 0); + Canvas.DrawLine(5, 0, 5, 6); + end + else + begin + Canvas.DrawLine(5, 1, w + 5, 1); + Canvas.DrawLine(6, 0, 6, 7); + end; + + if Style = bsRaised then + Canvas.SetColor(clShadow2) + else + Canvas.SetColor(clHilite2); + + Canvas.DrawLine(w + 5, 0, w + 5, 6); + Canvas.DrawText(FMargin + 5, 0, FText, lTxtFlags); + end; + taRightJustify: + begin + w := Width - FFont.TextWidth(FText) - (FMargin * 2) - 5; + r.SetRect(w, 0, FFont.TextWidth(FText) + FMargin * 2, FFont.Height + FMargin); + Canvas.SetClipRect(r); + Canvas.Clear(FBackgroundColor); + + if Style = bsRaised then + Canvas.SetColor(clHilite2) + else + Canvas.SetColor(clShadow2); + + if FPanelBorder = bsSingle then + begin + Canvas.DrawLine(w, 0, Width - 5, 0); + Canvas.DrawLine(w, 0, w, 6); + end + else + begin + Canvas.DrawLine(w, 1, Width - 5, 1); + Canvas.DrawLine(w + 1, 0, w + 1, 7); + end; + + if Style = bsRaised then + Canvas.SetColor(clShadow2) + else + Canvas.SetColor(clHilite2); + + Canvas.DrawLine(Width - 6, 0, Width - 6, 6); + Canvas.DrawText(Width - FFont.TextWidth(FText) - FMargin - 5, 0, FText, lTxtFlags); + end; + taCenter: + begin + w := (Width - FFont.TextWidth(FText) - FMargin * 2) div 2; + r.SetRect(w, 0, FFont.TextWidth(FText) + FMargin * 2, FFont.Height + FMargin); + Canvas.SetClipRect(r); + Canvas.Clear(FBackgroundColor); + + if Style = bsRaised then + Canvas.SetColor(clHilite2) + else + Canvas.SetColor(clShadow2); + + if FPanelBorder = bsSingle then + begin + Canvas.DrawLine(w, 0, w + FFont.TextWidth(FText) + FMargin * 2, 0); + Canvas.DrawLine(w, 0, w, 6); + end + else + begin + Canvas.DrawLine(w, 1, w + FFont.TextWidth(FText) + FMargin * 2, 1); + Canvas.DrawLine(w + 1, 0, w + 1, 7); + end; + + if Style = bsRaised then + Canvas.SetColor(clShadow2) + else + Canvas.SetColor(clHilite2); + + Canvas.DrawLine(w + FFont.TextWidth(FText) + FMargin * 2 - 1, 0, w + FFont.TextWidth(FText) + FMargin * 2 - 1, 6); + Canvas.DrawText(w + FMargin, 0, FText, lTxtFlags); + end; + end; +end; + +constructor TfpgGroupBox.Create(Aowner: TComponent); +begin + inherited Create(AOwner); + FText := 'Group box'; + FFont := fpgGetFont('#Label1'); + FPanelShape := bsBox; + FPanelStyle := bsRaised; + FWidth := 80; + FHeight := 80; + FFocusable := True; // otherwise children can't get focus + FBackgroundColor := Parent.BackgroundColor; + FAlignment := taLeftJustify; + FMargin := 2; +end; + +end. + diff --git a/src/gui/fpg_popupcalendar.pas b/src/gui/fpg_popupcalendar.pas new file mode 100644 index 00000000..5884a722 --- /dev/null +++ b/src/gui/fpg_popupcalendar.pas @@ -0,0 +1,807 @@ +{ + fpGUI - Free Pascal GUI Toolkit + + Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this + distribution, for details of the copyright. + + See the file COPYING.modifiedLGPL, included in this distribution, + for details about redistributing fpGUI. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + Description: + A calendar component. Soon it would be possible to use it in a + popup windows like Calender Combobox, or directly in a Form. +} + +unit fpg_popupcalendar; + +{$mode objfpc}{$H+} + +{.$Define DEBUG} // while developing the component + +{ + *********************************************************** + ********** This is still under development! *********** + *********************************************************** + + It needs lots of testing and debugging. +} + + +{ todo: Support highlighting special days. } +{ todo: Support custom colors. } +{ todo: Must be able to switch the first day of the week. } +{ todo: Create a TfpgDateTimeEdit component with options for Date, Time or Date & Time. } +{ todo: Changing months and checking min/max limits takes into account the + original date, not the selected day in the grid. It should use the + selected day in grid. } +{ todo: Paint previous and next months days in grey. Visiblity of these must + be user selectable. } +{ todo: Paint days out of min/max range in grey. } + +interface + +uses + SysUtils, + Classes, + fpg_base, + fpg_main, + fpg_widget, + fpg_popupwindow, + fpg_edit, + fpg_button, + fpg_combobox, + fpg_grid, + fpg_dialogs; + +type + + TfpgOnDateSetEvent = procedure(Sender: TObject; const ADate: TDateTime) of object; + + + TfpgPopupCalendar = class(TfpgPopupWindow) + private + {@VFD_HEAD_BEGIN: fpgPopupCalendar} + edtYear: TfpgEdit; + btnYearUp: TfpgButton; + btnYearDown: TfpgButton; + edtMonth: TfpgEdit; + btnMonthUp: TfpgButton; + btnMonthDown: TfpgButton; + btnToday: TfpgButton; + grdName1: TfpgStringGrid; + {@VFD_HEAD_END: fpgPopupCalendar} + FMonthOffset: integer; + FDate: TDateTime; + FMaxDate: TDateTime; + FMinDate: TDateTime; + FCallerWidget: TfpgWidget; + FOnValueSet: TfpgOnDateSetEvent; + FCloseOnSelect: boolean; + function GetDateElement(Index: integer): Word; + procedure PopulateDays; + procedure CalculateMonthOffset; + function CalculateCellDay(const ACol, ARow: Integer): Integer; + procedure SetDateElement(Index: integer; const AValue: Word); + procedure SetDateValue(const AValue: TDateTime); + procedure SetMaxDate(const AValue: TDateTime); + procedure SetMinDate(const AValue: TDateTime); + procedure SetCloseOnSelect(const AValue: boolean); + procedure UpdateCalendar; + procedure btnYearUpClicked(Sender: TObject); + procedure btnYearDownClicked(Sender: TObject); + procedure btnMonthUpClicked(Sender: TObject); + procedure btnMonthDownClicked(Sender: TObject); + procedure btnTodayClicked(Sender: TObject); + procedure grdName1DoubleClick(Sender: TObject; AButton: TMouseButton; AShift: TShiftState; const AMousePos: TPoint); + procedure grdName1KeyPress(Sender: TObject; var KeyCode: word; var ShiftState: TShiftState; var Consumed: boolean); + procedure TearDown; + protected + FOrigFocusWin: TfpgWidget; + procedure HandlePaint; override; + procedure HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override; + procedure HandleShow; override; + procedure HandleHide; override; + property CallerWidget: TfpgWidget read FCallerWidget write FCallerWidget; + public + constructor Create(AOwner: TComponent; AOrigFocusWin: TfpgWidget); reintroduce; + procedure AfterCreate; + property CloseOnSelect: boolean read FCloseOnSelect write SetCloseOnSelect default True; + property Day: Word index 1 read GetDateElement write SetDateElement; + property Month: Word index 2 read GetDateElement write SetDateElement; + property Year: Word index 3 read GetDateElement write SetDateElement; + property OnValueSet: TfpgOnDateSetEvent read FOnValueSet write FOnValueSet; + published + property DateValue: TDateTime read FDate write SetDateValue; + property MinDate: TDateTime read FMinDate write SetMinDate; + property MaxDate: TDateTime read FMaxDate write SetMaxDate; + end; + + + TfpgCalendarCombo = class(TfpgBaseStaticCombo) + private + FDate: TDateTime; + FDateFormat: string; + FMaxDate: TDateTime; + FMinDate: TDateTime; + FCloseOnSelect: boolean; + procedure InternalOnValueSet(Sender: TObject; const ADate: TDateTime); + procedure SetDateFormat(const AValue: string); + procedure SetDateValue(const AValue: TDateTime); + procedure SetMaxDate(const AValue: TDateTime); + procedure SetMinDate(const AValue: TDateTime); + procedure SetText(const AValue: string); override; + function GetText: string; override; + procedure SetCloseOnSelect(const AValue: boolean); + protected + function HasText: boolean; override; + procedure DoDropDown; override; + public + constructor Create(AOwner: TComponent); override; + published + property BackgroundColor; + property DateFormat: string read FDateFormat write SetDateFormat; + property DateValue: TDateTime read FDate write SetDateValue; + property FontDesc; + property MinDate: TDateTime read FMinDate write SetMinDate; + property MaxDate: TDateTime read FMaxDate write SetMaxDate; + property ParentShowHint; + property ShowHint; + { Clicking on calendar Today button will close the popup calendar by default } + property CloseOnSelect: boolean read FCloseOnSelect write SetCloseOnSelect default True; + property TabOrder; + property OnChange; + property OnCloseUp; + property OnDropDown; + end; + +{@VFD_NEWFORM_DECL} + +implementation + +uses + fpg_scrollbar, + fpg_constants; + + +{@VFD_NEWFORM_IMPL} + +procedure TfpgPopupCalendar.PopulateDays; +var + r, c: integer; + lCellDay: Integer; +begin + grdName1.BeginUpdate; + for r := -1 to 5 do + for c := 0 to 6 do + begin + if r = -1 then + grdName1.ColumnTitle[c] := ShortDayNames[c+1] // ShortDayNames is 1-based indexing + else + begin + lCellDay := CalculateCellDay(c, r); + if lCellDay = -1 then + grdName1.Cells[c, r] := '' + else + grdName1.Cells[c, r] := IntToStr(lCellDay); + end; + end; + grdName1.EndUpdate; +end; + +procedure TfpgPopupCalendar.grdName1DoubleClick(Sender: TObject; + AButton: TMouseButton; AShift: TShiftState; const AMousePos: TPoint); +begin + TearDown; +end; + +procedure TfpgPopupCalendar.grdName1KeyPress(Sender: TObject; + var KeyCode: word; var ShiftState: TShiftState; var Consumed: boolean); +begin + // Pass the grid event on to the TfpgPopupCalender instance. + HandleKeyPress(KeyCode, ShiftState, consumed); + Consumed := True; +end; + +procedure TfpgPopupCalendar.TearDown; +var + lD: Word; + s: string; + d: TDateTime; +begin + s := grdName1.Cells[grdName1.FocusCol, grdName1.FocusRow]; + if s = '' then + Exit; //==> + lD := StrToInt(s); + d := EncodeDate(Year, Month, lD); + if (d >= FMinDate) and (d <= FMaxDate) then + begin + DateValue := d; + if Assigned(OnValueSet) then + OnValueSet(self, DateValue); + {$IFDEF DEBUG} + writeln('Selected date: ', FormatDateTime('yyyy-mm-dd', DateValue)); + {$ENDIF} + if CloseOnSelect then + Close; + end; +end; + +function TfpgPopupCalendar.GetDateElement(Index: integer): Word; +var + lD, lM, lY: Word; +begin + DecodeDate(FDate, lY, lM, lD); + case Index of + 1: Result := lD; + 2: Result := lM; + 3: Result := lY; + end; +end; + +procedure TfpgPopupCalendar.CalculateMonthOffset; +var + lD, lM, lY: Word; + lTheFirst: TDateTime; +begin + DecodeDate(FDate, lY, lM, lD); + lTheFirst := EncodeDate(lY, lM, 1); + FMonthOffset := 2 - DayOfWeek(lTheFirst); +end; + +function TfpgPopupCalendar.CalculateCellDay(const ACol, ARow: Integer): Integer; +begin + Result := FMonthOffset + ACol + ARow * 7; + if (Result < 1) or (Result > MonthDays[IsLeapYear(Year), Month]) then + Result := -1; +end; + +procedure TfpgPopupCalendar.SetDateElement(Index: integer; const AValue: Word); +var + lD, lM, lY: Word; + lDate: TDateTime; +begin + if AValue > 0 then + begin + DecodeDate(FDate, lY, lM, lD); + case Index of + 1: lD := AValue; + 2: lM := AValue; + 3: lY := AValue; + end; + try + lDate := EncodeDate(lY, lM, lD); + SetDateValue(lDate); + except + // do nothing! Not nice? + end; + end; +end; + +procedure TfpgPopupCalendar.SetDateValue(const AValue: TDateTime); +begin + if FDate = AValue then + Exit; //==> + + if (trunc(FDate) >= trunc(FMinDate)) then + {$IFDEF DEBUG} + writeln('Passed min test') + {$ENDIF} + else + exit; + + if (FDate <= FMaxDate) then + {$IFDEF DEBUG} + writeln('Passed max test') + {$ENDIF} + else + exit; + + {$IFDEF DEBUG} writeln('SetDateValue: ', FormatDateTime('yyyy-mm-dd', AValue)); {$ENDIF} + FDate := AValue; + UpdateCalendar; +end; + +procedure TfpgPopupCalendar.SetMaxDate(const AValue: TDateTime); +begin + if FMaxDate = AValue then + Exit; //==> + FMaxDate := AValue; + + // correct min/max values + if FMinDate > AValue then + FMinDate := IncMonth(AValue, -12); // one year less + + if FDate > FMaxDate then + begin + FDate := FMaxDate; + UpdateCalendar; + end; +end; + +procedure TfpgPopupCalendar.SetMinDate(const AValue: TDateTime); +begin + if FMinDate = AValue then + Exit; //==> + FMinDate := AValue; + + // correct min/max values + if AValue > FMaxDate then + FMaxDate := IncMonth(AValue, 12); // one year more + + if FDate < FMinDate then + begin + FDate := FMinDate; + UpdateCalendar; + end; +end; + +procedure TfpgPopupCalendar.SetCloseOnSelect(const AValue: boolean); +begin + if FCloseOnSelect = AValue then + Exit; + FCloseOnSelect := AValue; +end; + +procedure TfpgPopupCalendar.UpdateCalendar; +var + lD, lM, lY: Word; +begin + if (FDate >= FMinDate) and (FDate <= FMaxDate) then + begin + CalculateMonthOffset; + PopulateDays; + edtYear.Text := IntToStr(Year); + edtMonth.Text := LongMonthNames[Month]; + DecodeDate(FDate, lY, lM, lD); + + grdName1.FocusCol := (lD - FMonthOffset) mod 7{ + 1}; + grdName1.FocusRow := (lD - FMonthOffset) div 7{ + 1}; + end; +end; + +procedure TfpgPopupCalendar.btnYearUpClicked(Sender: TObject); +var + d: TDateTime; +begin + d := IncMonth(FDate, 12); + if d <= FMaxDate then + DateValue := d; +end; + +procedure TfpgPopupCalendar.btnYearDownClicked(Sender: TObject); +var + d: TDateTime; +begin + d := IncMonth(FDate, -12); + if d >= FMinDate then + DateValue := d; +end; + +procedure TfpgPopupCalendar.btnMonthUpClicked(Sender: TObject); +var + d: TDateTime; +begin + d := IncMonth(FDate); + if d <= FMaxDate then + DateValue := d; +end; + +procedure TfpgPopupCalendar.btnMonthDownClicked(Sender: TObject); +var + d: TDateTime; +begin + d := IncMonth(FDate, -1); + if d >= FMinDate then + DateValue := d; +end; + +procedure TfpgPopupCalendar.btnTodayClicked(Sender: TObject); +begin + if Now >= FMinDate then + begin + DateValue := Now; + TearDown; + end; +end; + +procedure TfpgPopupCalendar.HandlePaint; +begin + Canvas.BeginDraw; + inherited HandlePaint; + if PopupFrame then + Canvas.SetClipRect(fpgRect(1, 1, Width-2, Height-2)); + Canvas.Clear(clWindowBackground); + Canvas.ClearClipRect; + Canvas.EndDraw; +end; + +procedure TfpgPopupCalendar.HandleKeyPress(var keycode: word; + var shiftstate: TShiftState; var consumed: boolean); +begin + case keycode of + keyUp: + begin + if (ssCtrl in shiftstate) then + begin + btnYearUpClicked(nil); // Ctrl+Up Arrow + consumed := True; + end; + end; + keyDown: + begin + if (ssCtrl in shiftstate) then + begin + btnYearDownClicked(nil); // Ctrl+Down Arrow + consumed := True; + end; + end; + keyLeft: + begin + if (ssCtrl in shiftstate) then + begin + btnMonthDownClicked(nil); // Ctrl+Left Arrow + consumed := True; + end; + end; + keyRight: + begin + if (ssCtrl in shiftstate) then + begin + btnMonthUpClicked(nil); // Ctrl+Right Arrow + consumed := True; + end; + end; + keyPageUp: + begin + if (ssCtrl in shiftstate) then + btnYearUpClicked(nil) // Ctrl+PageUp + else + btnMonthUpClicked(nil); // PageUp + consumed := True; + end; + keyPageDown: + begin + if (ssCtrl in shiftstate) then + btnYearDownClicked(nil) // Ctrl+PageDown + else + btnMonthDownClicked(nil); // PageDown + consumed := True; + end; + end; + + if not consumed then + begin + if keycode = keyEnter then + begin + consumed := True; + TearDown; + end + else if keycode = keyEscape then + begin + consumed := True; + Close; + end; + end; + + if not consumed then + inherited HandleKeyPress(keycode, shiftstate, consumed); +end; + +procedure TfpgPopupCalendar.HandleShow; +begin + inherited HandleShow; + grdName1.SetFocus; + {$IFDEF DEBUG} + writeln('Min: ', FormatDateTime('yyyy-mm-dd', MinDate), + ' Max: ', FormatDateTime('yyyy-mm-dd', MaxDate)); + {$ENDIF} +end; + +procedure TfpgPopupCalendar.HandleHide; +begin + FocusRootWidget := FOrigFocusWin; + FOrigFocusWin := nil; + inherited HandleHide; + if Assigned(FocusRootWidget) then + FocusRootWidget.SetFocus; +end; + +constructor TfpgPopupCalendar.Create(AOwner: TComponent; AOrigFocusWin: TfpgWidget); +begin + inherited Create(AOwner); + FOrigFocusWin := AOrigFocusWin; + AfterCreate; + FDate := Date; + FMonthOffset := 0; + FCloseOnSelect := True; + UpdateCalendar; +end; + +procedure TfpgPopupCalendar.AfterCreate; +begin + {@VFD_BODY_BEGIN: fpgPopupCalendar} + Name := 'fpgPopupCalendar'; + SetPosition(285, 249, 233, 142); +// WindowTitle := 'fpgPopupCalendar'; +// Sizeable := False; +// WindowPosition := wpUser; + + edtYear := TfpgEdit.Create(self); + with edtYear do + begin + Name := 'edtYear'; + SetPosition(0, 0, 52, 22); + Text := ''; + FontDesc := '#Edit1'; + Focusable := False; + BorderStyle := ebsSingle; + end; + + btnYearUp := TfpgButton.Create(self); + with btnYearUp do + begin + Name := 'btnYearUp'; + SetPosition(52, 0, 13, 11); + Text := ''; + Embedded := True; + FontDesc := '#Label1'; + ImageMargin := 0; + ImageName := 'sys.sb.up'; + Focusable := False; + OnClick := @btnYearUpClicked; + end; + + btnYearDown := TfpgButton.Create(self); + with btnYearDown do + begin + Name := 'btnYearDown'; + SetPosition(52, 11, 13, 11); + Text := ''; + Embedded := True; + FontDesc := '#Label1'; + ImageMargin := 0; + ImageName := 'sys.sb.down'; + Focusable := False; + OnClick := @btnYearDownClicked; + end; + + edtMonth := TfpgEdit.Create(self); + with edtMonth do + begin + Name := 'edtMonth'; + SetPosition(65, 0, 115, 22); + Text := ''; + FontDesc := '#Edit1'; + Focusable := False; + BorderStyle := ebsSingle; + end; + + btnMonthUp := TfpgButton.Create(self); + with btnMonthUp do + begin + Name := 'btnMonthUp'; + SetPosition(180, 0, 13, 11); + Text := ''; + Embedded := True; + FontDesc := '#Label1'; + ImageMargin := 0; + ImageName := 'sys.sb.up'; + Focusable := False; + OnClick := @btnMonthUpClicked; + end; + + btnMonthDown := TfpgButton.Create(self); + with btnMonthDown do + begin + Name := 'btnMonthDown'; + SetPosition(180, 11, 13, 11); + Text := ''; + Embedded := True; + FontDesc := '#Label1'; + ImageMargin := 0; + ImageName := 'sys.sb.down'; + Focusable := False; + OnClick := @btnMonthDownClicked; + end; + + btnToday := TfpgButton.Create(self); + with btnToday do + begin + Name := 'btnToday'; + SetPosition(194, 0, 40, 22); + Text := 'Today'; + FontDesc := '#Label1'; + Focusable := True; + OnClick := @btnTodayClicked; + end; + + grdName1 := TfpgStringGrid.Create(self); + with grdName1 do + begin + Name := 'grdName1'; + SetPosition(0, 23, 233, 119); + AddColumn('Sun', 33, taCenter); + AddColumn('Mon', 32, taCenter); + AddColumn('Tue', 33, taCenter); + AddColumn('Wed', 32, taCenter); + AddColumn('Thu', 33, taCenter); + AddColumn('Fri', 32, taCenter); + AddColumn('Sat', 33, taCenter); + FontDesc := '#Grid'; + HeaderFontDesc := '#GridHeader'; + RowCount := 6; + ScrollBarStyle := ssNone; + OnDoubleClick := @grdName1DoubleClick; + OnKeyPress := @grdName1KeyPress; + end; + + {@VFD_BODY_END: fpgPopupCalendar} +{ + // Setup localization + // UI Designer doesn't support resource strings yet! + grdName1.ColumnTitle[0] := rsShortSun; + grdName1.ColumnTitle[1] := rsShortMon; + grdName1.ColumnTitle[2] := rsShortTue; + grdName1.ColumnTitle[3] := rsShortWed; + grdName1.ColumnTitle[4] := rsShortThu; + grdName1.ColumnTitle[5] := rsShortFri; + grdName1.ColumnTitle[6] := rsShortSat; +} + btnToday.Text := rsToday; +end; + + +{ TfpgCalendarCombo } + +procedure TfpgCalendarCombo.SetDateValue(const AValue: TDateTime); +begin + if FDate = AValue then + Exit; //==> + FDate := AValue; + RePaint; +end; + +procedure TfpgCalendarCombo.SetMaxDate(const AValue: TDateTime); +begin + if FMaxDate = AValue then + Exit; //==> + FMaxDate := AValue; + + // correct min/max values + if FMinDate > AValue then + FMinDate := IncMonth(AValue, -12); // one year less + + if FDate > FMaxDate then + begin + FDate := FMaxDate; + Repaint; + end; +end; + +procedure TfpgCalendarCombo.SetMinDate(const AValue: TDateTime); +begin + if FMinDate = AValue then + Exit; //==> + FMinDate := AValue; + + // correct min/max values + if AValue > FMaxDate then + FMaxDate := IncMonth(AValue, 12); // one year more + + if FDate < FMinDate then + begin + FDate := FMinDate; + Repaint; + end; +end; + +procedure TfpgCalendarCombo.SetText(const AValue: string); +begin + try + FDate := StrToDateTime(AValue); + except + on E: Exception do + begin + ShowMessage(E.Message); + end; + end; +end; + +function TfpgCalendarCombo.GetText: string; +begin + Result := FormatDateTime(FDateFormat, FDate); +end; + +procedure TfpgCalendarCombo.SetCloseOnSelect(const AValue: boolean); +begin + if FCloseOnSelect = AValue then + Exit; //==> + FCloseOnSelect := AValue; +end; + +function TfpgCalendarCombo.HasText: boolean; +begin + Result := FDate >= FMinDate; +end; + +constructor TfpgCalendarCombo.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FMinDate := EncodeDate(1900, 01, 01); + FMaxDate := EncodeDate(2100, 01, 31); + FDate := Now; + FCloseOnSelect := True; + DateFormat := ShortDateFormat; +end; + +procedure TfpgCalendarCombo.InternalOnValueSet(Sender: TObject; + const ADate: TDateTime); +begin + DateValue := ADate; + if Assigned(OnChange) then + OnChange(self); + {$IFDEF DEBUG} + writeln('New value: ', FormatDateTime(FDateFormat, ADate)); + {$ENDIF} +end; + +procedure TfpgCalendarCombo.SetDateFormat(const AValue: string); +var + OldFormat: string; +begin + if FDateFormat = AValue then + Exit; //==> + OldFormat := FDateFormat; + FDateFormat := AValue; + try + FormatDateTime(FDateFormat, FDate); + RePaint; + except + on E: Exception do + begin + FDateFormat := OldFormat; + fpgApplication.HandleException(self); + end; + end; +end; + +procedure TfpgCalendarCombo.DoDropDown; +var + ddw: TfpgPopupCalendar; +begin + if (not Assigned(FDropDown)) or (not FDropDown.HasHandle) then + begin + FDropDown := TfpgPopupCalendar.Create(nil, FocusRootWidget); + ddw := TfpgPopupCalendar(FDropDown); + ddw.DontCloseWidget := self; + { Set to false CloseOnSelect to leave opened popup calendar menu } + ddw.CloseOnSelect := CloseOnSelect; + ddw.CallerWidget := self; + + if Assigned(OnDropDown) then + OnDropDown(self); + + ddw.MinDate := FMinDate; + ddw.MaxDate := FMaxDate; + ddw.DateValue := FDate; + ddw.ShowAt(Parent, Left, Top+Height); + { I added this call to UpdateCalendar because sometimes after + btnTodayClicked event, reopeing the dropdown menu gave an empty calendar } + ddw.UpdateCalendar; //slapshot + ddw.PopupFrame := True; + ddw.OnValueSet := @InternalOnValueSet; + ddw.OnClose := @InternalOnClose; + end + else + begin + FBtnPressed := False; + FDropDown.Close; + FreeAndNil(FDropDown); + end; +end; + +end. diff --git a/src/gui/fpg_progressbar.pas b/src/gui/fpg_progressbar.pas new file mode 100644 index 00000000..72355493 --- /dev/null +++ b/src/gui/fpg_progressbar.pas @@ -0,0 +1,227 @@ +{ + fpGUI - Free Pascal GUI Toolkit + + Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this + distribution, for details of the copyright. + + See the file COPYING.modifiedLGPL, included in this distribution, + for details about redistributing fpGUI. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + Description: + Defines a component for a progress bar. +} + +unit fpg_progressbar; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, + SysUtils, + fpg_base, + fpg_main, + fpg_widget; + +type + TfpgCustomProgressBar = class(TfpgWidget) + private + FMax: longint; + FMin: longint; + FPosition: longint; + FShowCaption: boolean; + FStep: longint; + FFont: TfpgFont; + procedure SetMax(const AValue: longint); + procedure SetMin(const AValue: longint); + procedure SetPBPosition(const AValue: longint); + procedure SetShowCaption(const AValue: boolean); + procedure SetStep(const AValue: longint); + protected + procedure HandlePaint; override; + property Max: longint read FMax write SetMax default 100; + property Min: longint read FMin write SetMin default 0; + property Position: longint read FPosition write SetPBPosition default 0; + property Step: longint read FStep write SetStep; +// property FontName: string read GetFontName write SetFontName; + property ShowCaption: boolean read FShowCaption write SetShowCaption default False; + public + constructor Create(AOwner: TComponent); override; + procedure StepIt; + procedure StepBy(AStep: integer); + property Font: TfpgFont read FFont; + end; + + + TfpgProgressBar = class(TfpgCustomProgressBar) + published + property BackgroundColor default $c4c4c4; + property ShowCaption; + property Max; + property Min; + property ParentShowHint; + property Position; + property ShowHint; + property Step; + property TextColor; + end; + + +implementation + + +{ TfpgCustomProgressBar } + +procedure TfpgCustomProgressBar.SetMax(const AValue: longint); +begin + if FMax = AValue then + Exit; //==> + + // correct wrong inputs + if FMin > AValue then + FMin := AValue - 1; + if FPosition > AValue then + FPosition := AValue; + + FMax := AValue; + RePaint; +end; + +procedure TfpgCustomProgressBar.SetMin(const AValue: longint); +begin + if FMin = AValue then + Exit; //==> + + // correct wrong inputs + if AValue > FPosition then + FPosition := AValue; + if AValue > FMax then + FMax := AValue+1; + + FMin := AValue; + RePaint; +end; + +procedure TfpgCustomProgressBar.SetPBPosition(const AValue: longint); +begin + if FPosition = AValue then + Exit; //==> + + // correct limits + if AValue < Min then + FPosition := Min + else if AValue > Max then + FPosition := Max + else + FPosition := AValue; + + RePaint; +end; + +procedure TfpgCustomProgressBar.SetShowCaption(const AValue: boolean); +begin + if FShowCaption = AValue then + Exit; //==> + FShowCaption := AValue; + RePaint; +end; + +procedure TfpgCustomProgressBar.SetStep(const AValue: longint); +begin + if AValue < 1 then + Exit; //==> + if FStep = AValue then + Exit; //==> + FStep := AValue; +end; + +procedure TfpgCustomProgressBar.HandlePaint; +var + r: TfpgRect; + diff: integer; + aPos: integer; // absolute position + pos: integer; + percent: integer; + txt: string; + x: TfpgCoord; + y: TfpgCoord; +begin + inherited HandlePaint; + Canvas.ClearClipRect; + r.SetRect(0, 0, Width, Height); + + Canvas.Clear(BackgroundColor); +// Canvas.SetColor(clInactiveWgFrame); + + // calculate position + diff := Max - Min; // diff.. + aPos := Position - Min; // absolute position + percent := round(((100 / diff) * aPos)); + txt := IntToStr(percent) + '%'; + pos := round(percent * (Width-2) / 100); + + // Bluecurve theme :) + // outer dark border + Canvas.SetColor(TfpgColor($999999)); + Canvas.SetLineStyle(1, lsSolid); + Canvas.DrawRectangle(r); + InflateRect(r, -1, -1); + r.Width := pos; + if FPosition > 0 then + begin + // left top + Canvas.SetColor(TfpgColor($98b2ed)); + Canvas.DrawLine(r.Left, r.Bottom, r.Left, r.Top); // left + Canvas.DrawLine(r.Left, r.Top, r.Right, r.Top); // top + // right bottom + Canvas.SetColor(TfpgColor($3b4c71)); + Canvas.DrawLine(r.Right, r.Top, r.Right, r.Bottom); // right + Canvas.DrawLine(r.Right, r.Bottom, r.Left, r.Bottom); // bottom + // inside gradient fill + InflateRect(r, -1, -1); + Canvas.GradientFill(r, TfpgColor($425d9b), TfpgColor($97b0e8), gdVertical); + end; + // paint percentage if required + if FShowCaption then + begin + x := (Width - FFont.TextWidth(txt)) div 2; + y := (Height - FFont.Height) div 2; + Canvas.SetTextColor(TextColor); + Canvas.Font := FFont; + Canvas.DrawString(x, y, txt); + end; +end; + +constructor TfpgCustomProgressBar.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + Focusable := False; + Width := 150; + Height := 22; + FMin := 0; + FMax := 100; + FStep := 1; + FPosition := 0; + FBackgroundColor := TfpgColor($c4c4c4); // clListBox; + FTextColor := Parent.TextColor; + FShowCaption := False; + FFont := fpgStyle.DefaultFont; +end; + +procedure TfpgCustomProgressBar.StepIt; +begin + Position := Position + Step; +end; + +procedure TfpgCustomProgressBar.StepBy(AStep: integer); +begin + Position := Position + AStep; +end; + +end. + diff --git a/src/gui/fpg_radiobutton.pas b/src/gui/fpg_radiobutton.pas new file mode 100644 index 00000000..1d58e0ea --- /dev/null +++ b/src/gui/fpg_radiobutton.pas @@ -0,0 +1,377 @@ +{ + fpGUI - Free Pascal GUI Toolkit + + Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this + distribution, for details of the copyright. + + See the file COPYING.modifiedLGPL, included in this distribution, + for details about redistributing fpGUI. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + Description: + Defines a Radio Button control. +} + +unit fpg_radiobutton; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, + SysUtils, + fpg_base, + fpg_main, + fpg_widget; + +type + + { TfpgRadioButton } + + TfpgRadioButton = class(TfpgWidget) + private + FAutoSize: boolean; + FChecked: boolean; + FFont: TfpgFont; + FGroupIndex: integer; + FOnChange: TNotifyEvent; + FText: string; + FBoxSize: integer; + FIsPressed: boolean; + function GetFontDesc: string; + procedure SetAutoSize(const AValue: boolean); + procedure SetChecked(const AValue: boolean); + procedure SetFontDesc(const AValue: string); + procedure SetText(const AValue: string); + procedure DoAdjustWidth; + protected + procedure HandlePaint; override; + procedure HandleLMouseDown(x, y: integer; shiftstate: TShiftState); override; + procedure HandleLMouseUp(x, y: integer; shiftstate: TShiftState); override; + procedure HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override; + procedure HandleKeyRelease(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override; + function FindNeighbour(direction: TFocusSearchDirection): TfpgRadioButton; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + property Font: TfpgFont read FFont; + published + property AutoSize: boolean read FAutoSize write SetAutoSize default False; + property BackgroundColor; + property Checked: boolean read FChecked write SetChecked default False; + property FontDesc: string read GetFontDesc write SetFontDesc; + property GroupIndex: integer read FGroupIndex write FGroupIndex; + property ParentShowHint; + property ShowHint; + property TabOrder; + property Text: string read FText write SetText; + property TextColor; + property OnChange: TNotifyEvent read FOnChange write FOnChange; + end; + + +function CreateRadioButton(AOwner: TComponent; x, y: TfpgCoord; AText: string): TfpgRadioButton; + + +implementation + + +function CreateRadioButton(AOwner: TComponent; x, y: TfpgCoord; AText: string): TfpgRadioButton; +begin + Result := TfpgRadioButton.Create(AOwner); + Result.Top := y; + Result.Left := x; + Result.Text := AText; + Result.Width := Result.Font.TextWidth(Result.Text) + 24; +end; + +{ TfpgRadioButton } + +function TfpgRadioButton.GetFontDesc: string; +begin + Result := FFont.FontDesc; +end; + +procedure TfpgRadioButton.SetAutoSize(const AValue: boolean); +begin + if FAutoSize = AValue then + Exit; //==> + FAutoSize := AValue; + if FAutoSize then + DoAdjustWidth; + Repaint; +end; + +procedure TfpgRadioButton.SetChecked(const AValue: boolean); +var + i: integer; + wg: TfpgWidget; +begin + if FChecked = AValue then + Exit; //==> + FChecked := AValue; + + // Clear other radio buttons in the same group + if FChecked and (Parent <> nil) then + begin + for i := 0 to Parent.ComponentCount-1 do + if (Parent.Components[i] is TfpgWidget) then + begin + wg := TfpgWidget(Parent.Components[i]); + if (wg <> nil) and (wg <> self) and (wg is TfpgRadioButton) and + (TfpgRadioButton(wg).GroupIndex = GroupIndex) then + begin + TfpgRadioButton(wg).Checked := False; + end; + end; { if } + end; { if } + + RePaint; + + if Assigned(FOnChange) then + FOnChange(self); +end; + +procedure TfpgRadioButton.SetFontDesc(const AValue: string); +begin + FFont.Free; + FFont := fpgGetFont(AValue); + RePaint; +end; + +procedure TfpgRadioButton.SetText(const AValue: string); +begin + if FText = AValue then + Exit; //==> + FText := AValue; + if AutoSize then + DoAdjustWidth; + RePaint; +end; + +procedure TfpgRadioButton.DoAdjustWidth; +begin + if AutoSize then + begin + Width := Font.TextWidth(FText) + 24; // 24 is extra padding for image + UpdateWindowPosition; + end; +end; + +procedure TfpgRadioButton.HandlePaint; +var + r: TfpgRect; + ty: integer; + tx: integer; + img: TfpgImage; + ix: integer; +begin + inherited HandlePaint; + + Canvas.SetColor(FBackgroundColor); + Canvas.FillRectangle(0, 0, Width, Height); + Canvas.SetFont(Font); + + if FFocused then + begin + Canvas.SetColor(clText1); + Canvas.SetLineStyle(1, lsDot); + Canvas.DrawRectangle(1, 1, Width-2, Height-2); + end; + Canvas.SetLineStyle(1, lsSolid); + + r.SetRect(2, (Height div 2) - (FBoxSize div 2), FBoxSize, FBoxSize); + if r.top < 0 then + r.top := 0; + + // calculate which image to paint. + if Enabled then + begin + ix := Ord(FChecked); + if FIsPressed then + Inc(ix, 2); + end + else + ix := (2 + (Ord(FChecked) * 2)) - Ord(FChecked); + + // paint the radio button + tx := r.right + 8; + inc(r.left, 2); + inc(r.top, 1); + img := fpgImages.GetImage('sys.radiobuttons'); // Do NOT localize + Canvas.DrawImagePart(r.Left, r.Top, img, ix*12, 0, 12, 12); + + ty := (Height div 2) - (Font.Height div 2); + if ty < 0 then + ty := 0; + Canvas.SetTextColor(FTextColor); + fpgStyle.DrawString(Canvas, tx, ty, FText, Enabled); +end; + +procedure TfpgRadioButton.HandleLMouseDown(x, y: integer; + shiftstate: TShiftState); +begin + inherited HandleLMouseDown(x, y, shiftstate); + FIsPressed := True; + Repaint; +end; + +procedure TfpgRadioButton.HandleLMouseUp(x, y: integer; shiftstate: TShiftState); +begin + inherited HandleLMouseUp(x, y, shiftstate); + FIsPressed := False; + if not FChecked then + Checked := true + else + RePaint; +end; + +procedure TfpgRadioButton.HandleKeyPress(var keycode: word; + var shiftstate: TShiftState; var consumed: boolean); +var + nbr: TfpgRadioButton; +begin + case keycode of + keyUp, keyLeft: + begin + consumed := True; + nbr := FindNeighbour(fsdPrev); + if nbr = Self then + nbr := FindNeighbour(fsdLast); + nbr.SetFocus; + nbr.Checked := True; + end; + keyDown, keyRight: + begin + consumed := True; + nbr := FindNeighbour(fsdNext); + if nbr = Self then + nbr := FindNeighbour(fsdFirst); + nbr.SetFocus; + nbr.Checked := True; + end; + end; + + if consumed then + Exit; //==> + + inherited HandleKeyPress(keycode, shiftstate, consumed); +end; + +procedure TfpgRadioButton.HandleKeyRelease(var keycode: word; + var shiftstate: TShiftState; var consumed: boolean); +begin + if (keycode = keySpace) then + begin + consumed := True; + Checked := true; + end; + + if consumed then + Exit; //==> + + inherited HandleKeyRelease(keycode, shiftstate, consumed); +end; + +function TfpgRadioButton.FindNeighbour(direction: TFocusSearchDirection): TfpgRadioButton; +var + i: integer; + wg: TfpgWidget; + bestdtab: integer; + FoundIt: boolean; +begin + Result := Self; + if (Parent <> nil) then + begin + FoundIt := False; + if direction in [fsdLast, fsdPrev] then + bestdtab := Low(integer) + else + bestdtab := High(integer); + + for i := 0 to Parent.ComponentCount-1 do + begin + if (Parent.Components[i] is TfpgWidget) then + begin + wg := TfpgWidget(Parent.Components[i]); + if (wg <> nil) and (wg is TfpgRadioButton) and + wg.Visible and wg.Enabled and wg.Focusable and + (TfpgRadioButton(wg).GroupIndex = GroupIndex) then + begin + case direction of + fsdFirst: + if (wg.TabOrder < bestdtab) then + begin + Result := TfpgRadioButton(wg); + bestdtab := wg.TabOrder; + end; + + fsdLast: + if (wg.TabOrder >= bestdtab) then + begin + Result := TfpgRadioButton(wg); + bestdtab := wg.TabOrder; + end; + + fsdNext: + if wg = Self then + FoundIt := True + else + begin + if ((wg.TabOrder > Self.TabOrder) and (wg.TabOrder < bestdtab)) or + ((wg.TabOrder = Self.TabOrder) and FoundIt) then + begin + Result := TfpgRadioButton(wg); + bestdtab := wg.TabOrder; + end; + end; + + fsdPrev: + if wg = Self then + FoundIt := True + else + begin + if ((wg.TabOrder < Self.TabOrder) and (wg.TabOrder >= bestdtab)) or + ((wg.TabOrder = Self.TabOrder) and not FoundIt) then + begin + Result := TfpgRadioButton(wg); + bestdtab := wg.TabOrder; + end; + end; + end; { case } + end; { if } + end; { if is TfpgWidget } + end; { for ComponentCount } + end; { if } +end; + +constructor TfpgRadioButton.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FText := 'RadioButton'; + FFont := fpgGetFont('#Label1'); + FHeight := FFont.Height + 4; + FWidth := 120; + FTextColor := Parent.TextColor; + FBackgroundColor := Parent.BackgroundColor; + FFocusable := True; + FBoxSize := 12; + FChecked := False; + FGroupIndex := 0; + FIsPressed := False; + FAutoSize := False; + FOnChange := nil; +end; + +destructor TfpgRadioButton.Destroy; +begin + FFont.Free; + inherited Destroy; +end; + +end. + diff --git a/src/gui/fpg_scrollbar.pas b/src/gui/fpg_scrollbar.pas new file mode 100644 index 00000000..92793fa9 --- /dev/null +++ b/src/gui/fpg_scrollbar.pas @@ -0,0 +1,581 @@ +{ + fpGUI - Free Pascal GUI Toolkit + + Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this + distribution, for details of the copyright. + + See the file COPYING.modifiedLGPL, included in this distribution, + for details about redistributing fpGUI. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + Description: + Defines Scrollbar controls. +} + +unit fpg_scrollbar; + +{$mode objfpc}{$H+} + +{ + TODO: + * Set slider button to minimum length (default setting) + * Create property to enable dynamic sizing of slider button length. + * Paint scroll area between arrow buttons and slider button a different + color on click. +} + +interface + +uses + Classes, + SysUtils, + fpg_base, + fpg_main, + fpg_widget; + +type + TScrollNotifyEvent = procedure(Sender: TObject; position: integer) of object; + + TfpgScrollStyle = (ssNone, ssHorizontal, ssVertical, ssAutoBoth); + + TfpgScrollBarPart = (sbpNone, sbpUpBack, sbpPageUpBack, sbpSlider, sbpDownForward, sbpPageDownForward); + + { TfpgScrollBar } + + TfpgScrollBar = class(TfpgWidget) + private + FLargeChange: Integer; + FScrollbarDownPart: TfpgScrollBarPart; + procedure SetMax(const AValue: integer); + procedure SetMin(const AValue: integer); + procedure SetSBPosition(const AValue: integer); + procedure Step(ASteps: Integer); + procedure StepPage(ASteps: Integer); + procedure StepStart; + procedure StepEnd; + protected + FMax: integer; + FMin: integer; + FPageSize: integer; + FPosition: integer; + FScrollStep: integer; + FSliderPos: TfpgCoord; + FSliderLength: TfpgCoord; + FSliderDragPos: TfpgCoord; + FSliderDragStart: TfpgCoord; + FScrollTimer: TfpgTimer; + FActiveButtonRect: TfpgRect; + FMousePosition: TPoint; + FOnScroll: TScrollNotifyEvent; + procedure ScrollTimer(Sender: TObject); + procedure DrawButton(x, y, w, h: TfpgCoord; const imgname: string; Pressed: Boolean = False); virtual; + procedure DrawSlider(recalc: boolean); virtual; + procedure HandleLMouseDown(x, y: integer; shiftstate: TShiftState); override; + procedure HandleLMouseUp(x, y: integer; shiftstate: TShiftState); override; + procedure HandleMouseMove(x, y: integer; btnstate: word; shiftstate: TShiftState); override; + procedure HandleMouseScroll(x, y: integer; shiftstate: TShiftState; delta: smallint); override; + procedure HandlePaint; override; + procedure PositionChange(d: integer); + public + Orientation: TOrientation; + SliderSize: double; // 0-1 + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure RepaintSlider; + property PageSize: integer read FPageSize write FPageSize default 5; + property Position: integer read FPosition write SetSBPosition default 10; + property ScrollStep: integer read FScrollStep write FScrollStep default 1; +// property LargeChange: Integer read FLargeChange write FLargeChange default 0; + property Min: integer read FMin write SetMin default 0; + property Max: integer read FMax write SetMax default 100; + property OnScroll: TScrollNotifyEvent read FOnScroll write FOnScroll; + end; + + +implementation + +{ TfpgScrollBar } + +constructor TfpgScrollBar.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FScrollTimer := TfpgTimer.Create(500); + FScrollTimer.Enabled := False; + FScrollTimer.OnTimer := @ScrollTimer; + Orientation := orVertical; + FMin := 0; + FMax := 100; + FPosition := 10; + SliderSize := 0.5; + FOnScroll := nil; + FSliderPos := 0; + FSliderLength := 10; + FScrollStep := 1; + FPageSize := 5; + FLargeChange := 0; +end; + +destructor TfpgScrollBar.Destroy; +begin + FScrollTimer.Free; + inherited Destroy; +end; + +procedure TfpgScrollBar.HandlePaint; +begin + // Do NOT localize + Canvas.BeginDraw; + + if Orientation = orVertical then + begin + DrawButton(0, 0, Width, Width, 'sys.sb.up', FScrollbarDownPart = sbpUpBack); + DrawButton(0, Height-Width, Width, Width, 'sys.sb.down', FScrollbarDownPart = sbpDownForward); + end + else + begin + DrawButton(0, 0, Height, Height, 'sys.sb.left', FScrollbarDownPart = sbpUpBack); + DrawButton(Width-Height, 0, Height, Height, 'sys.sb.right', FScrollbarDownPart = sbpDownForward); + end; + + DrawSlider(True); + Canvas.EndDraw; +end; + +procedure TfpgScrollBar.RepaintSlider; +begin + if not HasHandle then + Exit; //==> + DrawSlider(True); +end; + +procedure TfpgScrollBar.SetMax(const AValue: integer); +begin + if AValue = FMax then + Exit; + if AValue < FMin then + FMax := FMin + else + FMax := AValue; + if FPosition > FMax then + StepEnd; +end; + +procedure TfpgScrollBar.SetMin(const AValue: integer); +begin + if AValue = FMin then + Exit; + if AValue > FMax then + FMin := FMax + else + FMin := AValue; + if FPosition < FMin then + StepStart; +end; + +procedure TfpgScrollBar.SetSBPosition(const AValue: integer); +begin + if AValue < FMin then + FPosition := FMin + else if AValue > FMax then + FPosition := FMax + else + FPosition := AValue; + + if HasHandle then + DrawSlider(False); +end; + +procedure TfpgScrollBar.Step(ASteps: Integer); +begin + PositionChange(FScrollStep*ASteps); +end; + +procedure TfpgScrollBar.StepPage(ASteps: Integer); +begin + PositionChange(ASteps*FPageSize); +end; + +procedure TfpgScrollBar.StepStart; +begin + SetSBPosition(FMin) +end; + +procedure TfpgScrollBar.StepEnd; +begin + SetSBPosition(FMax); +end; + +procedure TfpgScrollBar.ScrollTimer(Sender: TObject); + function WithinActiveButton: Boolean; + begin + Result := (FMousePosition.X < FActiveButtonRect.Right) + and (FMousePosition.X > FActiveButtonRect.Left) + and (FMousePosition.Y < FActiveButtonRect.Bottom) + and (FMousePosition.Y > FActiveButtonRect.Top); + end; + function WithinPageArea(IsBefore: Boolean): Boolean; + begin + case Orientation of + orVertical: + if IsBefore then + Result := (FMousePosition.X > -1) + and (FMousePosition.X < Width) + and (FMousePosition.Y < FSliderPos + Width) + and (FMousePosition.Y > Width) + else + Result := (FMousePosition.X > -1) + and (FMousePosition.X < Width) + and (FMousePosition.Y < Height - Width) + and (FMousePosition.Y > Width + FSliderPos + FSliderLength); + orHorizontal: + if IsBefore then + Result := (FMousePosition.X > Height) + and (FMousePosition.X < FSliderPos + Height) + and (FMousePosition.Y < Height) + and (FMousePosition.Y > -1) + else + Result := (FMousePosition.X > Height + FSliderPos + FSliderLength) + and (FMousePosition.X < Width - Height) + and (FMousePosition.Y < Height) + and (FMousePosition.Y > -1); + end; + end; +begin + + case FScrollbarDownPart of + sbpDownForward, + sbpUpBack : FScrollTimer.Interval := 25; + sbpPageDownForward, + sbpPageUpBack : FScrollTimer.Interval := 50; + end; + + case FScrollbarDownPart of + sbpUpBack: + begin + if WithinActiveButton then + Step(-1); + if Position = FMin then + FScrollTimer.Enabled := False; + end; + sbpDownForward: + begin + if WithinActiveButton then + Step(1); + if Position = FMax then + FScrollTimer.Enabled := False; + end; + sbpPageUpBack: + begin + if (Position = FMin) or not WithinPageArea(True) then + FScrollTimer.Enabled := False + else + StepPage(-1); + end; + sbpPageDownForward: + begin + if (Position = FMax) or not WithinPageArea(False) then + FScrollTimer.Enabled := False + else + StepPage(1); + end; + else + FScrollTimer.Enabled := False; + end; +end; + +procedure TfpgScrollBar.DrawButton(x, y, w, h: TfpgCoord; const imgname: string; Pressed: Boolean = False); +var + img: TfpgImage; + dx: integer; + dy: integer; +begin + if Pressed then + begin + Canvas.DrawButtonFace(x, y, w, h, [btfIsEmbedded, btfIsPressed]); + dx := 1; + dy := 1; + end + else + begin + Canvas.DrawButtonFace(x, y, w, h, [btfIsEmbedded]); + dx := 0; + dy := 0; + end; + Canvas.SetColor(clText1); + img := fpgImages.GetImage(imgname); + if img <> nil then + Canvas.DrawImage(x + w div 2 - (img.Width div 2) + dx, y + h div 2 - (img.Height div 2) + dy, img); +end; + +procedure TfpgScrollBar.DrawSlider(recalc: boolean); +var + area: TfpgCoord; + mm: TfpgCoord; +begin + Canvas.BeginDraw; + + if SliderSize > 1 then + SliderSize := 1; + + Canvas.SetColor(clScrollBar); + + if Orientation = orVertical then + begin + Canvas.FillRectangle(0, Width, Width, Height-Width-Width); + area := Height - (Width shl 1); + end + else + begin + Canvas.FillRectangle(Height, 0, Width-Height-Height, Height); + area := Width - (Height shl 1); + end; + + if recalc then + begin + if FPosition > FMax then + FPosition := FMax; + if FPosition < FMin then + FPosition := FMin; + + FSliderLength := Trunc(area * SliderSize); + //FSliderLength := Trunc((width/area) * (fmax /area )); + if FSliderLength < 20 then + FSliderLength := 20; + if FSliderLength > area then + FSliderLength := area; + area := area - FSliderLength; + mm := FMax - FMin; + if mm = 0 then + FSliderPos := 0 + else + FSliderPos := Trunc(area * ((FPosition - FMin) / mm)); + end; + + // Paint the area between the buttons and the Slider + if Orientation = orVertical then + begin + if FScrollbarDownPart in [{sbpUpBack,} sbpPageUpBack] then + begin + Canvas.SetColor(clShadow1); + Canvas.FillRectangle(0, Width, Width, FSliderPos); + Canvas.SetColor(clScrollBar); + end + else if FScrollbarDownPart in [{sbpDownForward,} sbpPageDownForward] then + begin + Canvas.SetColor(clShadow1); + Canvas.FillRectangle(0, FSliderPos + FSliderLength, Width, Height - Width - (FSliderPos + FSliderLength)); + Canvas.SetColor(clScrollBar); + end; + end + else + begin + if FScrollbarDownPart in [{sbpUpBack,} sbpPageUpBack] then + begin + Canvas.SetColor(clShadow1); + Canvas.FillRectangle(Height, 0, FSliderPos, Height); + Canvas.SetColor(clScrollBar); + end + else if FScrollbarDownPart in [{sbpDownForward,} sbpPageDownForward] then + begin + Canvas.SetColor(clShadow1); + Canvas.FillRectangle(FSliderPos + FSliderLength, 0, Width - Height - (FSliderPos + FSliderLength), Height); + Canvas.SetColor(clScrollBar); + end; + end; + + // Paint the slider button + if Orientation = orVertical then + begin + Canvas.DrawButtonFace(0, Width + FSliderPos, Width, FSliderLength, [btfIsEmbedded]); + Canvas.EndDraw(0, Width, Width, Height - Width - Width); + end + else + begin + Canvas.DrawButtonFace(Height + FSliderPos, 0, FSliderLength, Height, [btfIsEmbedded]); + Canvas.EndDraw(Height, 0, Width - Height - Height, Height); + end; +end; + +procedure TfpgScrollBar.HandleLMouseDown(x, y: integer; shiftstate: TShiftState); +var + lPos: TfpgCoord; +begin + inherited; + CaptureMouse; + + if Orientation = orVertical then + begin + if y <= Width then + begin + // Up button has been pressed + Step(-1); + FScrollbarDownPart := sbpUpBack; + FActiveButtonRect.SetRect(0, 0, Width, Width); + end + else if y >= Height - Width then + begin + // Down button has been pressed + Step(1); + FScrollbarDownPart := sbpDownForward; + FActiveButtonRect.SetRect(0,Height-Width, Width, Height); + end + else if (y >= (Width + FSliderPos)) and (y <= Width + FSliderPos + FSliderLength) then + begin + FScrollbarDownPart := sbpSlider; + FSliderDragPos := y; + end + else if (y > Width) and (y < (Width + FSliderPos)) then + begin + // Clicked between Up button and Slider + FScrollbarDownPart := sbpPageUpBack; + StepPage(-1); + end + else if (y < (Height - Width)) and (y > (Width + FSliderPos + FSliderLength)) then + begin + // Clicked between Down button and Slider + FScrollbarDownPart := sbpPageDownForward; + StepPage(1); + end; + end + else + begin + if x <= Height then + begin + // Left button has been pressed + StepPage(-1); + FScrollbarDownPart := sbpUpBack; + FActiveButtonRect.SetRect(0, 0, Height, Height); + end + else if x >= Width - Height then + begin + // Right button has been pressed + StepPage(1); + FScrollbarDownPart := sbpDownForward; + FActiveButtonRect.SetRect(Width-Height, 0, Width, Height); + end + else if (x >= (Height + FSliderPos)) and (x <= Height + FSliderPos + FSliderLength) then + begin + FScrollbarDownPart := sbpSlider; + FSliderDragPos := x; + end + else if (x > Height) and (x < (Height + FSliderPos)) then + begin + // Clicked between Left button and Slider + FScrollbarDownPart := sbpPageUpBack; + StepPage(-1); + end + else if (x < (Width - Height)) and (x > (Height + FSliderPos + FSliderLength)) then + begin + // Clicked between the Right button and Slider + FScrollbarDownPart := sbpPageDownForward; + StepPage(1); + end; + end; + + if FScrollbarDownPart = sbpSlider then + begin + FSliderDragStart := FSliderPos; + DrawSlider(False); + end + else if not (FScrollbarDownPart in [sbpNone, sbpSlider]) then + begin + FScrollTimer.Interval := 300; + FScrollTimer.Enabled := True; + + HandlePaint; + end; +end; + +procedure TfpgScrollBar.HandleLMouseUp(x, y: integer; shiftstate: TShiftState); +var + WasPressed: Boolean; +begin + inherited; + ReleaseMouse; + + WasPressed := FScrollbarDownPart <> sbpNone; + FScrollTimer.Enabled := False; + + FScrollbarDownPart := sbpNone; + + if WasPressed then + HandlePaint; +end; + +procedure TfpgScrollBar.HandleMouseMove(x, y: integer; btnstate: word; shiftstate: TShiftState); +var + d: integer; + area: integer; + newp: integer; + ppos: integer; +begin + inherited HandleMouseMove(x, y, btnstate, shiftstate); + + FMousePosition.X := x; + FMousePosition.Y := y; + + if (FScrollbarDownPart <> sbpSlider) or ((btnstate and MOUSE_LEFT) = 0) then + Exit; + + if Orientation = orVertical then + begin + d := y - FSliderDragPos; + area := Height - (Width shl 1) - FSliderLength; + end + else + begin + d := x - FSliderDragPos; + area := Width - (Height shl 1) - FSliderLength; + end; + + ppos := FSliderPos; + FSliderPos := FSliderDragStart + d; + + if FSliderPos < 0 then + FSliderPos := 0; + if FSliderPos > area then + FSliderPos := area; + + if ppos <> FSliderPos then + DrawSlider(False); + + if area <> 0 then + newp := FMin + Trunc((FMax - FMin) * (FSliderPos / area)) + else + newp := FMin; + + if newp <> FPosition then + begin + Position := newp; + if Assigned(FOnScroll) then + FOnScroll(self, FPosition); + end; +end; + +procedure TfpgScrollBar.HandleMouseScroll(x, y: integer; shiftstate: TShiftState; + delta: smallint); +begin + inherited HandleMouseScroll(x, y, shiftstate, delta); + Step(delta); +end; + +procedure TfpgScrollBar.PositionChange(d: integer); +begin + FPosition := FPosition + d; + if FPosition < FMin then + FPosition := FMin; + if FPosition > FMax then + FPosition := FMax; + + if Visible then + DrawSlider(True); + + if Assigned(FOnScroll) then + FOnScroll(self, FPosition); +end; + +end. + diff --git a/src/gui/fpg_splitter.pas b/src/gui/fpg_splitter.pas new file mode 100644 index 00000000..cf627081 --- /dev/null +++ b/src/gui/fpg_splitter.pas @@ -0,0 +1,470 @@ +{ + fpGUI - Free Pascal GUI Toolkit + + Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this + distribution, for details of the copyright. + + See the file COPYING.modifiedLGPL, included in this distribution, + for details about redistributing fpGUI. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + Description: + Defines a Splitter control. +} + +unit fpg_splitter; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, + SysUtils, + fpg_base, + fpg_main, + fpg_widget; + +const + clColorGrabBar = $839EFE; // Pale navy blue + cSplitterWidth = 8; + +type + + NaturalNumber = 1..High(Integer); + + + TfpgSplitter = class(TfpgWidget) + private + FAutoSnap: Boolean; + FColorGrabBar: TfpgColor; + FControl: TfpgWidget; + FDownPos: TPoint; + FMinSize: NaturalNumber; + FMaxSize: Integer; + FNewSize: Integer; + FOldSize: Integer; + FSplit: Integer; + FMouseOver: Boolean; + procedure CalcSplitSize(X, Y: Integer; out NewSize, Split: Integer); + function FindControl: TfpgWidget; + procedure SetColorGrabBar(const AValue: TfpgColor); + procedure UpdateControlSize; + procedure UpdateSize(const X, Y: Integer); + protected + function DoCanResize(var NewSize: Integer): Boolean; virtual; + procedure HandleLMouseDown(x, y: integer; shiftstate: TShiftState); override; + procedure HandleLMouseUp(x, y: integer; shiftstate: TShiftState); override; + procedure HandleMouseMove(x, y: integer; btnstate: word; shiftstate: TShiftState); override; + procedure HandleMouseEnter; override; + procedure HandleMouseExit; override; + procedure HandlePaint; override; + procedure StopSizing; dynamic; + Procedure DrawGrabBar(ARect: TfpgRect); virtual; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + published + property ColorGrabBar: TfpgColor read FColorGrabBar write SetColorGrabBar default clColorGrabBar; + end; + +function CreateSplitter(AOwner: TComponent; ALeft, ATop, AWidth, AHeight: TfpgCoord; + AnAlign: TAlign): TfpgSplitter; + +implementation + +function CreateSplitter(AOwner: TComponent; ALeft, ATop, AWidth, AHeight: TfpgCoord; + AnAlign: TAlign): TfpgSplitter; +begin + Result := TfpgSplitter.Create(AOwner); + Result.Left := ALeft; + Result.Top := ATop; + Result.Width := AWidth; + Result.Height := AHeight; + Result.Align := AnAlign; +end; + +{ TfpgSplitter } + +procedure TfpgSplitter.CalcSplitSize(X, Y: Integer; out NewSize, Split: Integer); +var + S: Integer; +begin + if Align in [alLeft, alRight] then + Split := X - FDownPos.X + else + Split := Y - FDownPos.Y; + S := 0; + case Align of + alLeft: S := FControl.Width + Split; + alRight: S := FControl.Width - Split; + alTop: S := FControl.Height + Split; + alBottom: S := FControl.Height - Split; + end; + NewSize := S; + if S < FMinSize then + NewSize := FMinSize + else if S > FMaxSize then + NewSize := FMaxSize; + if S <> NewSize then + begin + if Align in [alRight, alBottom] then + S := S - NewSize + else + S := NewSize - S; + Inc(Split, S); + end; +end; + +function TfpgSplitter.FindControl: TfpgWidget; +var + i: Integer; + wg: TfpgWidget; + p: TPoint; + r: TfpgRect; +begin + Result := nil; + p := Point(Left, Top); + case Align of + alLeft: Dec(p.X); + alRight: Inc(p.X, Width); + alTop: Dec(p.Y); + alBottom: Inc(p.Y, Height); + else + Exit; + end; + + for i := 0 to Parent.ComponentCount-1 do + begin + wg := TfpgWidget(Parent.Components[i]); + if (wg <> nil) and wg.Visible and wg.Enabled then + begin + Result := wg; + r := Result.GetBoundsRect; + if (r.Width = 0) then + if Align in [alTop, alLeft] then + Dec(r.Left) + else + Inc(r.Width); + if (r.Height = 0) then + if Align in [alTop, alLeft] then + Dec(r.Top) + else + Inc(r.Height); + if PtInRect(r, p) then Exit; + end; + end; + Result := nil; +end; + +procedure TfpgSplitter.SetColorGrabBar(const AValue: TfpgColor); +begin + if FColorGrabBar = AValue then + Exit; //==> + FColorGrabBar := AValue; + Repaint; +end; + +procedure TfpgSplitter.UpdateControlSize; +begin + if FNewSize <> FOldSize then + begin + case Align of + alLeft, alRight: +// FControl.Width := FNewSize; // (1) + FControl.SetPosition(FControl.Left, FControl.Top, FNewSize, FControl.Height); // (2) + alTop, alBottom: +// FControl.Height := FNewSize; // (1) + FControl.SetPosition(FControl.Left, FControl.Top, FControl.Width, FNewSize); // (2) + end; +// FControl.UpdateWindowPosition; // (1) + // vvzh: + // Lines marked with (1) work wrong under Linux (e.g. folding/unfolding Memo1) + // Lines marked with (2) work OK under both platforms. Why? + Parent.Realign; + // if Assigned(FOnMoved) then FOnMoved(Self); + FOldSize := FNewSize; + end; +end; + +procedure TfpgSplitter.UpdateSize(const X, Y: Integer); +begin + CalcSplitSize(X, Y, FNewSize, FSplit); +end; + +function TfpgSplitter.DoCanResize(var NewSize: Integer): Boolean; +begin + // Result := CanResize(NewSize); // omit onCanResize call + Result := True; + if Result and (NewSize <= FMinSize) and FAutoSnap then + NewSize := 0; +end; + +procedure TfpgSplitter.HandleLMouseDown(x, y: integer; shiftstate: TShiftState); +var + i: integer; + wg: TfpgWidget; +begin + inherited HandleLMouseDown(x, y, shiftstate); + + FControl := FindControl; + FDownPos := Point(X, Y); + + if Assigned(FControl) then + begin + if Align in [alLeft, alRight] then + begin + FMaxSize := Parent.Width - FMinSize; + for i := 0 to Parent.ComponentCount-1 do + begin + wg := TfpgWidget(Parent.Components[i]); + if wg.Visible and (wg.Align in [alLeft, alRight]) then + Dec(FMaxSize, Width); + end; + Inc(FMaxSize, FControl.Width); + end + else + begin + FMaxSize := Parent.Height - FMinSize; + for i := 0 to Parent.ComponentCount-1 do + begin + wg := TfpgWidget(Parent.Components[i]); + if (wg.Align in [alTop, alBottom]) then + Dec(FMaxSize, Height); + end; + Inc(FMaxSize, FControl.Height); + end; + UpdateSize(X, Y); + CaptureMouse; + {AllocateLineDC; + with ValidParentForm(Self) do + if ActiveControl <> nil then + begin + FActiveControl := ActiveControl; + FOldKeyDown := TWinControlAccess(FActiveControl).OnKeyDown; + TWinControlAccess(FActiveControl).OnKeyDown := FocusKeyDown; + end; + if ResizeStyle in [rsLine, rsPattern] then DrawLine;} + end; +end; + +procedure TfpgSplitter.HandleLMouseUp(x, y: integer; shiftstate: TShiftState); +begin + inherited HandleLMouseUp(x, y, shiftstate); + if Assigned(FControl) then + begin + ReleaseMouse; + // if ResizeStyle in [rsLine, rsPattern] then DrawLine; + UpdateControlSize; + {writeln('LT: ', FControl.Left, ':', FControl.Width, ' ', Self.Left, ':', Self.Width); + writeln('RB: ', FControl.Top, ':', FControl.Height, ' ', Self.Top, ':', Self.Height);} + StopSizing; + end; +end; + +procedure TfpgSplitter.HandleMouseMove(x, y: integer; btnstate: word; + shiftstate: TShiftState); +var + NewSize, Split: Integer; +begin + inherited HandleMouseMove(x, y, btnstate, shiftstate); + if (ssLeft in shiftstate) and Assigned(FControl) then + begin + CalcSplitSize(X, Y, NewSize, Split); + if DoCanResize(NewSize) then + begin + // if ResizeStyle in [rsLine, rsPattern] then DrawLine; + FNewSize := NewSize; + FSplit := Split; + // if ResizeStyle = rsUpdate then + UpdateControlSize; + // if ResizeStyle in [rsLine, rsPattern] then DrawLine; + end; + end; +end; + +procedure TfpgSplitter.HandleMouseEnter; +begin + FMouseOver := True; + if Align in [alBottom, alTop] then + MouseCursor := mcSizeNS + else + MouseCursor := mcSizeEW; + Repaint; +end; + +procedure TfpgSplitter.HandleMouseExit; +begin + FMouseOver := False; + if FControl = nil then + MouseCursor := mcDefault; + Repaint; +end; + +procedure TfpgSplitter.HandlePaint; +var + lRect: TfpgRect; +begin + Canvas.SetColor(clWindowBackground); + Canvas.FillRectangle(GetClientRect); + + case Align of + alRight, + alLeft: + begin + lRect.Top := Height div 4; + lRect.SetBottom(Height div 4 * 3); + lRect.Left := 1; + lRect.SetRight(6); + end; + + alTop, + alBottom: + begin + lRect.Left := Width div 4; + lRect.SetRight(Width div 4 * 3); + lRect.Top := 1; + lRect.SetBottom(6); + end; + end; + DrawGrabBar(lRect); +end; + +procedure TfpgSplitter.StopSizing; +begin + if Assigned(FControl) then + begin + // if FLineVisible then DrawLine; + FControl := nil; + {ReleaseLineDC; + if Assigned(FActiveControl) then + begin + TWinControlAccess(FActiveControl).OnKeyDown := FOldKeyDown; + FActiveControl := nil; + end;} + end; + {if Assigned(FOnMoved) then + FOnMoved(Self);} +end; + +procedure TfpgSplitter.DrawGrabBar(ARect: TfpgRect); +var + lFillRect: TfpgRect; + lSaveColor: TfpgColor; +begin + lSaveColor := Canvas.Color; + + // Draw the outline of the rectangle + Canvas.Color := clGray; + Canvas.DrawRectangle(ARect); + + // If the mouse is over the splitter bar, then fill the grab bar part + // with colour. + if FMouseOver then + begin + lFillRect := ARect; + InflateRect(lFillRect, -1, -1); + Canvas.Color := FColorGrabBar; + Canvas.FillRectangle(lFillRect); + end; + + // Draw a shadow around the inside of the grab bar + Canvas.Color := clWhite; + Canvas.DrawLine(ARect.Left+1, ARect.Top+1, ARect.Right, ARect.Top+1); + Canvas.DrawLine(ARect.Left+1, ARect.Top+1, ARect.Left+1, ARect.Bottom); + + // Draw some texture inside the grab bar + Canvas.SetLineStyle(1, lsDot); + if Align in [alLeft, alRight] then + begin + Canvas.DrawLine(ARect.Left+3, ARect.Top+15, ARect.Left+3, ARect.Bottom-15); + Canvas.Color := clGray; + Canvas.DrawLine(ARect.Left+4, ARect.Top+16, ARect.Left+4, ARect.Bottom-16); + end + else + begin + Canvas.DrawLine(ARect.Left+15, ARect.Top+3, ARect.Right-15, ARect.Top+3); + Canvas.Color := clGray; + Canvas.DrawLine(ARect.Left+16, ARect.Top+4, ARect.Right-16, ARect.Top+4); + end; + + Canvas.SetLineStyle(1, lsSolid); + Canvas.Color := clBlack; + + { TODO : Improve the look of the triangles } + case Align of + alRight: + begin + // Draw the top triangle + Canvas.FillTriangle(ARect.Left+2, ARect.Top+5, + ARect.Left+2, ARect.Top+10, + ARect.Left+4, ARect.Top+7); + // Draw the bottom triangle + Canvas.FillTriangle(ARect.Left+2, ARect.Bottom-5, + ARect.Left+2, ARect.Bottom-10, + ARect.Left+4, ARect.Bottom-7); + end; + + alLeft: + begin + // Draw the top triangle + Canvas.FillTriangle(ARect.Right-2, ARect.Top+5, + ARect.Right-2, ARect.Top+10, + ARect.Right-4, ARect.Top+7); + // Draw the bottom triangle + Canvas.FillTriangle(ARect.Right-2, ARect.Bottom-5, + ARect.Right-2, ARect.Bottom-10, + ARect.Right-4, ARect.Bottom-7); + end; + + alBottom: + begin + // Draw the left triangle + Canvas.FillTriangle(ARect.Left+5, ARect.Top+2, + ARect.Left+10, ARect.Top+2, + ARect.Left+7, ARect.Top+4); + // Draw the right triangle + Canvas.FillTriangle(ARect.Right-5, ARect.Top+2, + ARect.Right-10, ARect.Top+2, + ARect.Right-7, ARect.Top+4); + end; + + alTop: + begin + // Draw the left triangle + Canvas.FillTriangle(ARect.Left+5, ARect.Bottom-1, + ARect.Left+10, ARect.Bottom-1, + ARect.Left+7, ARect.Bottom-4); + // Draw the right triangle + Canvas.FillTriangle(ARect.Right-5, ARect.Bottom-1, + ARect.Right-10, ARect.Bottom-1, + ARect.Right-7, ARect.Bottom-4); + end; + end; + + Canvas.Color := lSaveColor; +end; + +constructor TfpgSplitter.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FAutoSnap := True; + Height := 100; + Align := alLeft; + Width := cSplitterWidth; + FMinSize := 30; + // FResizeStyle := rsPattern; + FOldSize := -1; + FMouseOver := False; + FColorGrabBar := clColorGrabBar; +end; + +destructor TfpgSplitter.Destroy; +begin + inherited Destroy; +end; + +end. diff --git a/src/gui/fpg_style.pas b/src/gui/fpg_style.pas new file mode 100644 index 00000000..b5a799c2 --- /dev/null +++ b/src/gui/fpg_style.pas @@ -0,0 +1,315 @@ +{ + fpGUI - Free Pascal GUI Toolkit + + Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this + distribution, for details of the copyright. + + See the file COPYING.modifiedLGPL, included in this distribution, + for details about redistributing fpGUI. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + Description: + This is where all style related types should be defined. The base + Style class should also be defined here. + This is still work in progress! +} + +unit fpg_style; + +{$mode objfpc}{$H+} + +{.$Define DEBUG} + +interface + +uses + Classes, + SysUtils, + fpg_base, + fpg_main, + fpg_widget; + + +type + TfpgPrimitiveElement = ( + peFocusRectangle, // The focus rectangle + pePanel, // Generic bevel of a panel + pePanelButton, // Panel are of standard button + pePanelButtonBevel, // The bevel of a button + pePanelEditBox, // Frame around a text edit box + pePanelToolbarButton, // Panel area of a toolbar button + pePanelMenuBar, // The menu bar panel + pePanelScrollAreaCorner, // Panel at the bottom right corner of the scroll area + peFrameMenu, // Frame for popup windows and menus + peFrameDefaultButton, // Frame around a default button like in a dialog + peFrameToolbarButton, // Frame around a toolbar button + peFramePageControl, // Frame for a Page Control + peIndicatorArrowUp, // Generic up arrow + peIndicatorArrowDown, // Generic down arrow + peIndicatorArrowRight, // Generic right arrow + peIndicatorArrowLeft, // Generic left arrow + peIndicatorCheckBox, // On/off indicator used in a CheckBox + peIndicatorRadioButton, // Exclusive on indicator used in a Radio Button + peIndicatorHeaderArrow, // Indicator used in List or Tabel header to show sorting + peIndicatorMenuCheckMark, // Check mark used in menus + peIndicatorProgressBar // Body section of a Progress Bar + ); + + + TfpgControlElement = ( + cePushButton, // The Bevel, Label and FocusRect + cePushButtonBevel, + cePushButtonLabel, + ceRadioButton, // Indicator, FocusRect and Label + ceRadioButtonLabel, + ceCheckBox, // Indicator, FocusRect and Label + ceCheckBoxLabel, + ceMenuItem, + ceMenuBarItem, + ceMenuBarEmptyArea, + ceMenuTearOff, + ceMenuHMargin, + ceMenuVMargin, + ceProgressBar, + cePageControlTab, // Both the Shape and Label + cePageControlShape, + cePageControlLabel + ); + + + TfpgStyleOptionEnum = ( + soDefault, + soFocusRect, + soButton, + soComboBox, + soCheckBox, + soMenuItem, + soTrackBar, + soPanel, + soComplex + ); + + + TfpgStateItem = ( + stNone, + stActive, + stReadOnly, + stSelected, + stRaised, + stLowered, + stHasFocus, + stEnabled + ); + TfpgState = set of TfpgStateItem; + + + TfpgStandardPixmap = ( + spMessageBoxInformation, + spMessageBoxCritical, + spMessageBoxError, + spMessageBoxWarning, + spMessageBoxQuestion, + spDirOpenIcon, + spDirCloseIcon, + spDirIcon, + spDirLinkIcon, + spFileIcon, + spFileLinkIcon, + spFileDialogToParent, // Icon of back to parent dir + spFileDialogNewFolder, + spDialogOkButton, + spDialogCancelButton, + spDialogHelpButton, + spDialogSaveButton, + spDialogOpenButton, + spDialogCloseButton, + spDialogApplyButton, + spDialogResetButton, + spDialogDiscardButton, + spDialogYesButton, + spDialogNoButton + ); + + + // Just a data class + TfpgStyleOption = class(TObject) + private + FRect: TfpgRect; + FState: TfpgState; + FStyleOption: TfpgStyleOptionEnum; + public + property StyleOption: TfpgStyleOptionEnum read FStyleOption write FStyleOption; + property Rect: TfpgRect read FRect write FRect; + property State: TfpgState read FState write FState; + end; + + + TfpgButtonFeatures = set of (bfNone, bfFlat, bfDefault, bfEmbedded); + + // Button specific options + TfpgButtonStyleOption = class(TfpgStyleOption) + private + FButtonFeatures: TfpgButtonFeatures; + public + property ButtonFeatures: TfpgButtonFeatures read FButtonFeatures write FButtonFeatures; + end; + + + TfpgBaseStyle = class(TObject) + public + procedure DrawControl(element: TfpgControlElement; const option: TfpgStyleOption; canvas: TfpgCanvas; widget: TfpgWidget = nil); virtual; abstract; + procedure DrawPrimitive(element: TfpgPrimitiveElement; const option: TfpgStyleOption; canvas: TfpgCanvas; widget: TfpgWidget = nil); virtual; abstract; + end; + + + + //----------------------------------------- + // The classes below will be better placed in their own units! + + + // This class encapsulates the common look and feel of the GUI + TfpgCommonStyle = class(TfpgBaseStyle) + public + procedure DrawControl(element: TfpgControlElement; const option: TfpgStyleOption; canvas: TfpgCanvas; widget: TfpgWidget=nil); override; + procedure DrawPrimitive(element: TfpgPrimitiveElement; const option: TfpgStyleOption; canvas: TfpgCanvas; widget: TfpgWidget=nil); override; + end; + + + // The Windows 2000 look + TfpgWin2000Style = class(TfpgCommonStyle) + end; + + + TfpgWinXPStyle = class(TfpgCommonStyle) + end; + + + // This class provides a widgte style similar to the classic BlueCurve theme + // originally created by Red Hat. + TfpgBlueCurveStyle = class(TfpgCommonStyle) + end; + + + // This class provides a widget style similar to GNOME + TfpgClearLookStyle = class(TfpgCommonStyle) + end; + + + // For the die-hard unix fans! + TfpgMotifStyle = class(TfpgCommonStyle) + end; + + +implementation + + +{ TfpgCommonStyle } + +procedure TfpgCommonStyle.DrawControl(element: TfpgControlElement; + const option: TfpgStyleOption; canvas: TfpgCanvas; widget: TfpgWidget); +var + r: TfpgRect; +begin + // Do common things here + case element of + cePushButtonBevel: + begin + {$IFDEF DEBUG} + writeln('TfpgCommonStyle.DrawControl: cePushButtonBevel'); + {$ENDIF} + r.SetRect(option.Rect.Left, option.Rect.Top, option.Rect.Width, option.Rect.Height); + + if bfDefault in TfpgButtonStyleOption(option).ButtonFeatures then + begin + Canvas.SetColor(clBlack); + Canvas.SetLineStyle(1, lsSolid); + Canvas.DrawRectangle(r); + InflateRect(r, -1, -1); + end; + +// Canvas.SetColor(clButtonFace); +// Canvas.SetLineStyle(1, lsSolid); + // Canvas.FillRectangle(r.Left, r.Top, r.Width, r.Height); + + // Left and Top (outer) + if stLowered in option.State then + begin + if bfEmbedded in TfpgButtonStyleOption(option).ButtonFeatures then + Canvas.SetColor(clHilite1) + else + Canvas.SetColor(clShadow2); + end + else + Canvas.SetColor(clHilite1); + Canvas.DrawLine(r.Left, r.Bottom, r.Left, r.Top); // left + Canvas.DrawLine(r.Left, r.Top, r.Right, r.Top); // top + + // Right and Bottom (outer) + if stLowered in option.State then + begin + if bfEmbedded in TfpgButtonStyleOption(option).ButtonFeatures then + Canvas.SetColor(clHilite1) + else + Canvas.SetColor(clShadow2); + end + else + Canvas.SetColor(clShadow2); + Canvas.DrawLine(r.Right, r.Top, r.Right, r.Bottom); // right + Canvas.DrawLine(r.Right, r.Bottom, r.Left-1, r.Bottom); // bottom + + // Right and Bottom (inner) + if stLowered in option.State then + begin + if bfEmbedded in TfpgButtonStyleOption(option).ButtonFeatures then + Canvas.SetColor(clButtonFace) + else + Canvas.SetColor(clHilite1); + end + else + Canvas.SetColor(clShadow1); + Canvas.DrawLine(r.Right-1, r.Top+1, r.Right-1, r.Bottom-1); // right + Canvas.DrawLine(r.Right-1, r.Bottom-1, r.Left, r.Bottom-1); // bottom + end { cePushButtonBevel } + end; +end; + +procedure TfpgCommonStyle.DrawPrimitive(element: TfpgPrimitiveElement; + const option: TfpgStyleOption; canvas: TfpgCanvas; widget: TfpgWidget); +var + r: TfpgRect; +begin + // Do common things here. It's going to be a huge case statement. This design + // allows us to add new controls or elements without having to instantly + // implement them in all descendant classes! + case element of + peFocusRectangle: + begin + {$IFDEF DEBUG} + writeln('TfpgCommonStyle.DrawPrimitive: peFocusRectangle'); + {$ENDIF} + if stHasFocus in option.State then + begin + r.SetRect(option.Rect.Left, option.Rect.Top, option.Rect.Width, option.Rect.Height); + InflateRect(r, -3, -3); + Canvas.DrawFocusRect(r); + end; + end; { peFocusRectangle } + + peIndicatorRadioButton: + begin // just an example!!!!!!!! + {$IFDEF DEBUG} + writeln('TfpgCommonStyle.DrawPrimitive: peIndicatorRadioButton'); + {$ENDIF} + Canvas.SetColor(clShadow1); + Canvas.DrawArc(option.Rect.Left, option.Rect.Top, option.Rect.Width, option.Rect.Height, 0, 180); + Canvas.SetColor(clHilite1); + Canvas.DrawArc(option.Rect.Left, option.Rect.Top, option.Rect.Width, option.Rect.Height, 180, 0); + end; { peIndicatorRadioButton } + end; +end; + +end. + diff --git a/src/gui/fpg_tab.pas b/src/gui/fpg_tab.pas new file mode 100644 index 00000000..3f368774 --- /dev/null +++ b/src/gui/fpg_tab.pas @@ -0,0 +1,843 @@ +{ + fpGUI - Free Pascal GUI Toolkit + + Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this + distribution, for details of the copyright. + + See the file COPYING.modifiedLGPL, included in this distribution, + for details about redistributing fpGUI. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + Description: + Defines a Page Control and Tab Sheets. +} + +unit fpg_tab; + +{$mode objfpc}{$H+} + +{ + TODO: + * Tab Styles (tab, button, flat button, angled) + * Tab Position (top, bottom, left, right) + * Better keyboard support + * Focus rectangle drawn on tabs itself + * FindNextPage() must be implemented +} + +interface + +uses + Classes, + SysUtils, + fpg_base, + fpg_main, + fpg_widget, + fpg_button; + +type + // forward declaration + TfpgPageControl = class; + + TfpgTabStyle = (tsTabs, tsButtons, tsFlatButtons); + TfpgTabPosition = (tpTop, tpBottom{, tpLeft, tpRight}); + + + TfpgTabSheet = class(TfpgWidget) + private + FText: string; + function GetPageControl: TfpgPageControl; + function GetPageIndex: Integer; + function GetText: string; + procedure SetPageIndex(const AValue: Integer); + procedure SetText(const AValue: string); + protected + procedure HandlePaint; override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure AfterConstruction; override; + property Text: string read GetText write SetText; + property PageIndex: Integer read GetPageIndex write SetPageIndex; + property PageControl: TfpgPageControl read GetPageControl; + end; + + + TTabSheetChange = procedure(Sender: TObject; NewActiveSheet: TfpgTabSheet) of object; + + + TfpgPageControl = class(TfpgWidget) + private + FFont: TfpgFont; + FActivePage: TfpgTabSheet; + FMargin: integer; + FFixedTabWidth: integer; + FPages: TList; + FActivePageIndex: integer; + FOnChange: TTabSheetChange; + FRightButton: TfpgButton; + FLeftButton: TfpgButton; + FFirstTabButton: TfpgTabSheet; + FSortPages: boolean; + FStyle: TfpgTabStyle; + FTabPosition: TfpgTabPosition; + function GetActivePageIndex: integer; + function GetPage(AIndex: integer): TfpgTabSheet; + function GetPageCount: Integer; + procedure InsertPage(const APage: TfpgTabSheet); + procedure RemovePage(const APage: TfpgTabSheet); + procedure SetActivePageIndex(const AValue: integer); + procedure SetActivePage(const AValue: TfpgTabSheet); + function MaxButtonWidthSum: integer; + function MaxButtonHeight: integer; + function MaxButtonWidth: integer; + function ButtonHeight: integer; + function ButtonWidth(AText: string): integer; + procedure SetFixedTabWidth(const AValue: integer); + function GetTabText(AText: string): string; + procedure LeftButtonClick(Sender: TObject); + procedure RightButtonClick(Sender: TObject); + function FindNextPage(ACurrent: TfpgTabSheet; AForward: boolean): TfpgTabSheet; + procedure SetSortPages(const AValue: boolean); + procedure SetStyle(const AValue: TfpgTabStyle); + procedure SetTabPosition(const AValue: TfpgTabPosition); + procedure DoChange(ATabSheet: TfpgTabSheet); + function DrawTab(const rect: TfpgRect; const Selected: Boolean = False; const Mode: Integer = 1): TfpgRect; + protected + procedure OrderSheets; // currently using bubblesort + procedure RePaintTitles; virtual; + procedure HandlePaint; override; + procedure HandleShow; override; + procedure HandleLMouseUp(x, y: integer; shiftstate: TShiftState); override; + procedure HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + function AppendTabSheet(ATitle: string): TfpgTabSheet; + property PageCount: Integer read GetPageCount; + property ActivePage: TfpgTabSheet read FActivePage write SetActivePage; + property Pages[AIndex: integer]: TfpgTabSheet read GetPage; + property OnChange: TTabSheetChange read FOnChange write FOnChange; + published + property ActivePageIndex: integer read GetActivePageIndex write SetActivePageIndex; + property BackgroundColor; + property FixedTabWidth: integer read FFixedTabWidth write SetFixedTabWidth default 0; + property ParentShowHint; + property ShowHint; + property SortPages: boolean read FSortPages write SetSortPages default False; + property Style: TfpgTabStyle read FStyle write SetStyle default tsTabs; + property TabOrder; + property TabPosition: TfpgTabPosition read FTabPosition write SetTabPosition default tpTop; + property TextColor; + end; + + +implementation + +uses + fpg_stringutils; + + +// compare function used by FPages.Sort + +function SortCompare(Item1, Item2: Pointer): integer; +begin + Result := CompareText(TfpgTabSheet(Item1).Text, TfpgTabSheet(Item2).Text); +end; + +{ TfpgTabSheet } + +function TfpgTabSheet.GetPageControl: TfpgPageControl; +begin + if Owner is TfpgPageControl then + Result := TfpgPageControl(Owner) + else + Result := nil; +end; + +function TfpgTabSheet.GetPageIndex: Integer; +begin + if PageControl <> nil then + Result := PageControl.FPages.IndexOf(Self) + else + Result := -1; +end; + +function TfpgTabSheet.GetText: string; +begin + Result := FText; +end; + +procedure TfpgTabSheet.SetPageIndex(const AValue: Integer); +begin + if PageControl <> nil then + begin + PageControl.FPages.Move(PageIndex, AValue); + PageControl.RePaint;//Titles; + end; +end; + +procedure TfpgTabSheet.SetText(const AValue: string); +begin + if FText = AValue then + Exit; //==> + FText := AValue; + if PageControl <> nil then + PageControl.RePaintTitles; +end; + +procedure TfpgTabSheet.HandlePaint; +begin + inherited HandlePaint; + Canvas.Clear(FBackgroundColor); +end; + +constructor TfpgTabSheet.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FText := ''; + FFocusable := True; + FBackgroundColor := Parent.BackgroundColor; + FTextColor := Parent.TextColor; + FIsContainer := True; +end; + +destructor TfpgTabSheet.Destroy; +begin + if Owner is TfpgPageControl then + TfpgPageControl(Owner).RemovePage(self); + inherited Destroy; +end; + +procedure TfpgTabSheet.AfterConstruction; +begin + inherited AfterConstruction; + if Owner is TfpgPageControl then + TfpgPageControl(Owner).InsertPage(self); +end; + +{ TfpgPageControl } + +function TfpgPageControl.GetActivePageIndex: integer; +begin + Result := FActivePageIndex; +end; + +function TfpgPageControl.GetPage(AIndex: integer): TfpgTabSheet; +begin + Result := nil; + if (AIndex >= 0) and (AIndex < FPages.Count) then + Result := TfpgTabSheet(FPages[AIndex]); +end; + +function TfpgPageControl.GetPageCount: Integer; +begin + Result := FPages.Count; +end; + +procedure TfpgPageControl.InsertPage(const APage: TfpgTabSheet); +begin + if FPages.IndexOf(APage) <> -1 then + Exit; //==> The page has already been added. + FPages.Add(APage); + ActivePage := APage; +end; + +procedure TfpgPageControl.RemovePage(const APage: TfpgTabSheet); +begin + FPages.Remove(APage); + {$Note This still needs to be fixed.} + if APage = FActivePage then + begin +// FActivePage := FindNextPage(APage, True); +// if FPages.Count > 0 then + ActivePage := TfpgTabSheet(FPages.First); +// else +// ActivePage := nil; + end; +end; + +procedure TfpgPageControl.SetActivePageIndex(const AValue: integer); +begin + if (AValue >= 0) or (AValue < FPages.Count) then + ActivePage := TfpgTabSheet(FPages[AValue]); +end; + +procedure TfpgPageControl.SetActivePage(const AValue: TfpgTabSheet); +begin + if FActivePage = AValue then + Exit; //==> + FActivePage := AValue; + ActiveWidget := AValue; + FActivePageIndex := FPages.IndexOf(AValue); + RePaint; +end; + +function TfpgPageControl.MaxButtonWidthSum: integer; +var + i: integer; + t: TfpgTabSheet; +begin + {$IFDEF DEBUG}writeln(Classname + '.MaxButtonWidthSum');{$ENDIF} + Result := 0; + + for i := 0 to FPages.Count-1 do + begin + t := TfpgTabSheet(FPages[i]); + Result := Result + ButtonWidth(t.Text); + end; +end; + +function TfpgPageControl.MaxButtonHeight: integer; +begin + result := PageCount * ButtonHeight; +end; + +function TfpgPageControl.MaxButtonWidth: integer; +var + t: TfpgTabSheet; + i: integer; +begin + Result := 0; + for i := 0 to FPages.Count-1 do + begin + t := TfpgTabSheet(FPages[i]); + if ButtonWidth(t.Text) > Result then + Result := ButtonWidth(t.Text); + end; +end; + +function TfpgPageControl.ButtonHeight: integer; +begin + Result := FRightButton.Height; +end; + +function TfpgPageControl.ButtonWidth(AText: string): integer; +begin + if FFixedTabWidth > 0 then + result := FFixedTabWidth + else + result := FFont.TextWidth(AText) + 10; +end; + +procedure TfpgPageControl.SetFixedTabWidth(const AValue: integer); +begin + if FFixedTabWidth = AValue then + Exit; //==> + if AValue > 5 then + begin + FFixedTabWidth := AValue; + RePaint; + end; +end; + +function TfpgPageControl.GetTabText(AText: string): string; +var + s, s1: string; + i: integer; +begin + {$IFDEF DEBUG}writeln(Classname + '.GetTabText');{$ENDIF} + Result := AText; + s := AText; + s1 := ''; + i := 1; + if FFixedTabWidth > 0 then + begin + while FFont.TextWidth(s1) < (FFixedTabWidth-10) do + begin + if Length(s1) = Length(s) then + Break; + s1 := UTF8Copy(s, 1, i); + inc(i); + end; + if FFont.TextWidth(s1) > (FFixedTabWidth-10) then + Delete(s1, length(s1), 1); {$Note This must become a UTF8 function} + if Length(s1) > 0 then + s1 := Trim(s1); + Result := s1; + end; +end; + +procedure TfpgPageControl.LeftButtonClick(Sender: TObject); +begin + {$IFDEF DEBUG}writeln(Classname + '.LeftButtonClick');{$ENDIF} + if FFirstTabButton <> nil then + begin + if TfpgTabSheet(FPages.First) <> FFirstTabButton then + begin + FFirstTabButton := TfpgTabSheet(FPages[FPages.IndexOf(FFirstTabButton)-1]); + RePaint; + end; + end; +end; + +procedure TfpgPageControl.RightButtonClick(Sender: TObject); +begin + {$IFDEF DEBUG}writeln(Classname + '.RightButtonClick');{$ENDIF} + if FFirstTabButton <> nil then + begin + if TfpgTabSheet(FPages.Last) <> FFirstTabButton then + begin + FFirstTabButton := TfpgTabSheet(FPages[FPages.IndexOf(FFirstTabButton)+1]); + RePaint; + end; + end; +end; + +function TfpgPageControl.FindNextPage(ACurrent: TfpgTabSheet; AForward: boolean + ): TfpgTabSheet; +begin + // To be completed + result := nil; +end; + +procedure TfpgPageControl.SetSortPages(const AValue: boolean); +begin + if FSortPages = AValue then + Exit; //==> + FSortPages := AValue; + RePaint; +end; + +procedure TfpgPageControl.SetStyle(const AValue: TfpgTabStyle); +begin + if FStyle = AValue then + Exit; //==> + FStyle := AValue; + RePaintTitles; +end; + +procedure TfpgPageControl.SetTabPosition(const AValue: TfpgTabPosition); +begin + if FTabPosition = AValue then + Exit; //==> + FTabPosition := AValue; + RePaint; +end; + +procedure TfpgPageControl.DoChange(ATabSheet: TfpgTabSheet); +begin + if Assigned(FOnChange) then + FOnChange(self, ATabSheet); +end; + +function TfpgPageControl.DrawTab(const rect: TfpgRect; const Selected: Boolean = False; const Mode: Integer = 1): TfpgRect; +var + r: TfpgRect; +begin + r := rect; + if Selected then + begin + Result := rect; + InflateRect(Result, 2, 2); + Exit; //==> + end; + + if Mode = 2 then + r.Height := r.Height - 1; + + Canvas.SetColor(clButtonFace); + Canvas.FillRectangle(r.Left, r.Top, r.Width, r.Height-2); + Canvas.SetColor(clHilite2); + Canvas.DrawLine(r.Left, r.Bottom-2, r.Left, r.Top+2); + Canvas.DrawLine(r.Left, r.Top+2, r.Left+2, r.Top); + Canvas.DrawLine(r.Left+2, r.Top, r.Right-1, r.Top); + Canvas.SetColor(clShadow1); + Canvas.DrawLine(r.Right-1, r.Top+1, r.Right-1, r.Bottom-1); + Canvas.SetColor(clShadow2); + Canvas.DrawLine(r.Right-1, r.Top+1, r.Right, r.Top+2); + Canvas.DrawLine(r.Right, r.Top+2, r.Right, r.Bottom-1); +end; + +procedure TfpgPageControl.OrderSheets; +begin + FPages.Sort(@SortCompare); +end; + +procedure TfpgPageControl.RePaintTitles; +var + r: TfpgRect; + r2: TfpgRect; + r3: TfpgRect; + h: TfpgTabSheet; + lp: integer; + toffset: integer; + dx: integer; + lTxtFlags: TFTextFlags; +begin + if not HasHandle then + Exit; //==> + + if PageCount = 0 then + Exit; //==> + + h := TfpgTabSheet(FPages.First); + if h = nil then + Exit; + Canvas.BeginDraw; + Canvas.SetTextColor(TextColor); + lTxtFlags := TextFlagsDflt; + if not Enabled then + Include(lTxtFlags, txtDisabled); + + case TabPosition of + tpBottom: + begin +(* + if MaxButtonWidthSum > (Width-(FMargin*2)) then + begin + if FFirstTabButton = nil then + FFirstTabButton := h + else + h := FFirstTabButton; + r.SetRect(FMargin, FMargin, Width-(FMargin*2)-(FRightButton.Width*2)-1, FRightButton.Height); + FLeftButton.SetPosition(Width - FMargin * 2 - FRightButton.Width * 2, FMargin, FRightButton.Height, FRightButton.Height); + FRightButton.SetPosition(Width - FMargin * 2 - FrightButton.Width, FMargin, FRightButton.Height, FRightButton.Height); + FLeftButton.Visible := True; + FRightButton.Visible := True; + end + else + begin + r.SetRect(FMargin, FMargin, Width-(FMargin*2), ButtonHeight); + FLeftButton.Visible := False; + FRightButton.Visible := False; + end; + // tabsheet area - left outer line + Canvas.SetColor(clHilite1); + Canvas.DrawLine(FMargin, ButtonHeight, FMargin, Height-(FMargin*2)); + // tabsheet area - left inner line + Canvas.SetColor(clHilite2); + Canvas.DrawLine(FMargin+1, ButtonHeight+1, FMargin+1, Height - (FMargin*2) - 1); + // tabsheet area - outer bottom & right line + Canvas.SetColor(clShadow2); + Canvas.DrawLine(FMargin, Height - (FMargin*2), Width - (FMargin*2), Height - (FMargin*2)); + Canvas.DrawLine(Width - (FMargin*2), Height - (FMargin*2), Width - (FMargin*2), FMargin + ButtonHeight - 3); + // tabsheet area - inner bottom & right line + Canvas.SetColor(clShadow1); + Canvas.DrawLine(FMargin + 1, Height - (FMargin*2) - 1, Width - (FMargin*2) - 1, Height - (FMargin*2) - 1); + Canvas.DrawLine(Width - FMargin - 2, Height - FMargin - 2, Width - FMargin - 2, FMargin + ButtonHeight - 2); + Canvas.SetClipRect(r); + lp := 0; + while h <> nil do + begin + if h <> ActivePage then + begin + toffset := 4; + // tabsheet area - top lines under inactive tabs + Canvas.SetColor(clHilite1); + Canvas.DrawLine(FMargin + lp, FMargin + ButtonHeight - 2, FMargin + lp + ButtonWidth(h.Text), FMargin + ButtonHeight - 2); + Canvas.SetColor(clHilite2); + if TfpgTabSheet(FPages.First) = h then + dx := 1 + else + dx := -1; + Canvas.DrawLine(FMargin + lp+dx, FMargin + ButtonHeight - 1, FMargin + lp + ButtonWidth(h.Text) + 1, FMargin + ButtonHeight - 1); + // vertical divider line between inactive tabs + Canvas.SetColor(clShadow1); + Canvas.DrawLine(lp + FMargin + ButtonWidth(h.Text), FMargin, lp + FMargin + ButtonWidth(h.Text), FMargin + ButtonHeight - 2); + h.Visible := False; + end + else + begin + toffset := 2; + h.Visible := True; + h.SetPosition(FMargin+2, FMargin + ButtonHeight, Width - (FMargin*2) - 4, Height - (FMargin*2) - ButtonHeight - 2); + // tab outer left & top line + Canvas.SetColor(clHilite1); + Canvas.DrawLine(lp + FMargin, FMargin + ButtonHeight - 2, lp + FMargin, FMargin); + Canvas.DrawLine(lp + FMargin, FMargin, lp + FMargin + ButtonWidth(h.Text)-1, FMargin); + // tab inner left & top line + Canvas.SetColor(clHilite2); + Canvas.DrawLine(lp + FMargin + 1, FMargin + ButtonHeight - 1, lp + FMargin + 1, FMargin + 1); + Canvas.DrawLine(lp + FMargin + 1, FMargin + 1, lp + FMargin + ButtonWidth(h.Text) - 2, FMargin + 1); + // tab inner right line + Canvas.SetColor(clShadow1); + Canvas.DrawLine(lp + FMargin + ButtonWidth(h.Text) - 2, FMargin + 1, lp + FMargin + ButtonWidth(h.Text) - 2, FMargin + ButtonHeight); + // tab outer right line + Canvas.SetColor(clShadow2); + Canvas.DrawLine(lp + FMargin + ButtonWidth(h.Text) - 1, FMargin, lp + FMargin + ButtonWidth(h.Text) - 1, FMargin + ButtonHeight-1); + end; + // paint text + Canvas.DrawString(lp + (ButtonWidth(h.Text) div 2) - FFont.TextWidth(GetTabText(h.Text)) div 2, FMargin+toffset, GetTabText(h.Text)); + + lp := lp + ButtonWidth(h.Text); + if h <> TfpgTabSheet(FPages.Last) then + h := TfpgTabSheet(FPages[FPages.IndexOf(h)+1]) + else + h := nil; + end; { while } + // tabsheet area - top lines on right of tabs + Canvas.SetColor(clHilite1); + Canvas.Drawline(lp + 1, FMargin + ButtonHeight - 2, Width - (FMargin*2), FMargin + ButtonHeight - 2); + Canvas.SetColor(clHilite2); + Canvas.Drawline(lp , FMargin + ButtonHeight - 1, Width - (FMargin*2)-1, FMargin + ButtonHeight - 1); +*) + end; + + tpTop: + begin + if MaxButtonWidthSum > (Width-(FMargin*2)) then + begin + if FFirstTabButton = nil then + FFirstTabButton := h + else + h := FFirstTabButton; + r.SetRect(FMargin, FMargin, Width-(FMargin*2)-(FRightButton.Width*2)-1, FRightButton.Height); + FLeftButton.SetPosition(Width - FRightButton.Width * 2, FMargin, FRightButton.Height, FRightButton.Height); + FRightButton.SetPosition(Width - FrightButton.Width, FMargin, FRightButton.Height, FRightButton.Height); + FLeftButton.Visible := True; + FRightButton.Visible := True; + end + else + begin + r.SetRect(FMargin, FMargin, Width-(FMargin*2), ButtonHeight); + FLeftButton.Visible := False; + FRightButton.Visible := False; + end; + + lp := 0; + r2.SetRect(2, 2, 50, 21); + while h <> nil do + begin + if h <> ActivePage then + begin + toffset := 4; + h.Visible := False; + end + else + begin + toffset := 2; + h.Visible := True; + h.SetPosition(FMargin+2, FMargin+2 + r2.Height, Width - (FMargin*2) - 4, Height - r2.Height - ((FMargin+2)*2)); + end; + // paint tab button + r2.Width := ButtonWidth(h.Text); + r3 := DrawTab(r2, h = ActivePage); + + // paint text on non-active tabs + if h <> ActivePage then + Canvas.DrawText(lp + (ButtonWidth(h.Text) div 2) - FFont.TextWidth(GetTabText(h.Text)) div 2, FMargin+toffset, GetTabText(h.Text), lTxtFlags); + + r2.Left := r2.Left + r2.Width; + lp := lp + ButtonWidth(h.Text); + if h <> TfpgTabSheet(FPages.Last) then + h := TfpgTabSheet(FPages[FPages.IndexOf(h)+1]) + else + h := nil; + end; + // Draw Page Control body rectangle (client area) + r2.Left := 0; + r2.Top := r2.Top + r2.Height-2; + r2.Width := Width; + r2.Height := Height - r2.Height; + Canvas.DrawButtonFace(r2, []); + + // Draw text of ActivePage, because we didn't before. + DrawTab(r3, false, 2); + Canvas.DrawText(r3.Left+4, r3.Top+3, r3.Width, r3.Height, ActivePage.Text, lTxtFlags); + end; + end; + + Canvas.EndDraw; +end; + +procedure TfpgPageControl.HandlePaint; +begin + inherited HandlePaint; + if SortPages then + OrderSheets; + Canvas.ClearClipRect; + Canvas.Clear(FBackgroundColor); + + // To make it more visible in the UI Designer + if csDesigning in ComponentState then + begin + Canvas.SetColor(clInactiveWgFrame); + Canvas.DrawRectangle(0, 0, Width, Height); + Canvas.SetTextColor(clText1); + Canvas.DrawString(2, 2, Name + ': ' + Classname); + end; + + if TabPosition = tpBottom then + begin + if Focused then + Canvas.SetColor(clWidgetFrame) + else + Canvas.SetColor(clInactiveWgFrame); + Canvas.DrawRectangle(0, 0, Width, Height); + end; + RePaintTitles; +end; + +procedure TfpgPageControl.HandleShow; +begin + inherited HandleShow; + FLeftButton.Visible := False; + FRightButton.Visible := False; +end; + +procedure TfpgPageControl.HandleLMouseUp(x, y: integer; shiftstate: TShiftState); +var + h: TfpgTabSheet; + lp: integer; // left position + bw: integer; // button width +begin + h := TfpgTabSheet(FPages.First); + if h = nil then + Exit; //==> + + lp := FMargin; + if MaxButtonWidthSum > (Width-(FMargin*2)) then + h := FFirstTabButton; + + case TabPosition of + tpTop: + begin + if (y > FMargin) and (y < ButtonHeight) then + begin + while h <> nil do + begin + bw := ButtonWidth(h.Text); // initialize button width + if (x > lp) and (x < lp + bw) then + begin + if h <> ActivePage then + begin + ActivePage := h; + DoChange(ActivePage); + end; + exit; + end; { if } + lp := lp + bw; + if h <> TfpgTabSheet(FPages.Last) then + h := TfpgTabSheet(FPages[FPages.IndexOf(h)+1]) + else + h := nil; + end; { while } + end; { if } + end; + + tpBottom: + begin +(* + if (y > Height - FMargin - buttonheight) and (y < height - FMargin) then + begin + while h <> nil do + begin + bw := ButtonWidth(h^.TabSheet.Text); // initialize button width + if (x > lp) and (x < lp + bw) then + begin + if h^.TabSheet <> ActiveTabSheet then + begin + ActiveTabSheet := h^.TabSheet; + DoChange(ActiveTabSheet); + end; + exit; + end; + lp := lp + bw; + h := h^.next; + end; { while } + end; { if } +*) + end; + end; { case } + inherited HandleLMouseUp(x, y, shiftstate); +end; + +procedure TfpgPageControl.HandleKeyPress(var keycode: word; + var shiftstate: TShiftState; var consumed: boolean); +var + i: integer; +begin +// writeln(Classname, '.Keypress'); + consumed := True; + i := ActivePageIndex; + + case keycode of + keyLeft: + begin + if ActivePage <> TfpgTabSheet(FPages.First) then + begin + ActivePage := TfpgTabSheet(FPages[i-1]); + DoChange(ActivePage); + end; + end; + + keyRight: + begin + if ActivePage <> TfpgTabSheet(FPages.Last) then + begin + ActivePage := TfpgTabSheet(FPages[i+1]); + DoChange(ActivePage); + end; + end; + + else + consumed := False; + end; { case/else } + inherited HandleKeyPress(keycode, shiftstate, consumed); +end; + +constructor TfpgPageControl.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FFont := fpgStyle.DefaultFont; + FPages := TList.Create; + FWidth := 150; + FHeight := 100; + FIsContainer := True; + + FTextColor := Parent.TextColor; + FBackgroundColor := Parent.BackgroundColor; + FFocusable := True; + FOnChange := nil; + FFixedTabWidth := 0; + FFirstTabButton := nil; + FStyle := tsTabs; + FTabPosition := tpTop; + FMargin := 1; + FSortPages := False; + + FLeftButton := TfpgButton.Create(self); + FLeftButton.Text := '<'; + FLeftButton.Height := 20; + FLeftButton.Width := 20; + FLeftButton.OnClick := @LeftButtonClick; + + FRightButton := TfpgButton.Create(self); + FRightButton.Text := '>'; + FRightButton.Height := 20; + FRightButton.Width := 20; + FRightButton.OnClick := @RightButtonClick; +end; + +destructor TfpgPageControl.Destroy; +var + ts: TfpgTabSheet; +begin + FOnChange := nil; + if FPages.Count > 0 then + FActivePage := TfpgTabSheet(FPages[0]); + ActiveWidget := nil; + while FPages.Count > 0 do + begin + ts := TfpgTabSheet(FPages.Last); + FPages.Remove(ts); + ts.Free; + end; + FPages.Free; + FFirstTabButton := nil; + inherited Destroy; +end; + +function TfpgPageControl.AppendTabSheet(ATitle: string): TfpgTabSheet; +begin + Result := TfpgTabSheet.Create(self); + Result.Text := ATitle; + InsertPage(Result); +end; + +end. + diff --git a/src/gui/fpg_trackbar.pas b/src/gui/fpg_trackbar.pas new file mode 100644 index 00000000..9dc15b95 --- /dev/null +++ b/src/gui/fpg_trackbar.pas @@ -0,0 +1,647 @@ +{ + fpGUI - Free Pascal GUI Toolkit + + Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this + distribution, for details of the copyright. + + See the file COPYING.modifiedLGPL, included in this distribution, + for details about redistributing fpGUI. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + Description: + Defines two types of TrackBar controls. Also known as Slider controls. +} + +unit fpg_trackbar; + +{$mode objfpc}{$H+} + +{ + TODO: + - TfpgTrackBarExtra + * Tick line orientation (top, bottom, left or right) + * Slide the slider with the mouse button down (like a scrollbar) + * Slider button style (rectangle, pointer, double pointer) + * Tick captions + + - TfpgTrackBar + * Vertical orientation + * show ticks property +} + +interface + +uses + Classes, + SysUtils, + fpg_base, + fpg_main, + fpg_widget; + +type + TTrackBarChange = procedure(Sender: TObject; APosition: integer) of object; + + + TfpgTrackBarExtra = class(TfpgWidget) + private + FMax: integer; + FMin: integer; + FOnChange: TTrackBarChange; + FOrientation: TOrientation; + FPosition: integer; + FSliderSize: integer; + procedure DoChange; + procedure SetMax(const AValue: integer); + procedure SetMin(const AValue: integer); + procedure SetTBPosition(const AValue: integer); + procedure SetSliderSize(const AValue: integer); + procedure FixMinMaxOrder; + procedure FixPositionLimits; + procedure DrawSlider(p: integer); + protected + procedure HandlePaint; override; + procedure HandleLMouseUp(x, y: integer; shiftstate: TShiftState); override; + procedure HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override; + public + constructor Create(AOwner: TComponent); override; + published + property BackgroundColor; + property Min: integer read FMin write SetMin default 0; + property Max: integer read FMax write SetMax default 10; + property Position: integer read FPosition write SetTBPosition default 0; + property SliderSize: integer read FSliderSize write SetSliderSize default 11; + property Orientation: TOrientation read FOrientation write FOrientation default orHorizontal; + property TabOrder; + property OnChange: TTrackBarChange read FOnChange write FOnChange; + end; + + + TfpgTrackBar = class(TfpgWidget) + private + FMax: integer; + FMin: integer; + FOrientation: TOrientation; + FPosition: integer; + FScrollStep: integer; + FShowPosition: boolean; + FSliderPos: TfpgCoord; + FSliderLength: TfpgCoord; + FSliderDragging: boolean; + FSliderDragPos: TfpgCoord; + FSliderDragStart: TfpgCoord; + FMousePosition: TPoint; + FOnChange: TTrackBarChange; + FFont: TfpgFont; + procedure SetMax(const AValue: integer); + procedure SetMin(const AValue: integer); + procedure SetTBPosition(const AValue: integer); + procedure SetShowPosition(const AValue: boolean); + function GetTextWidth: TfpgCoord; + protected + procedure HandleLMouseDown(x, y: integer; shiftstate: TShiftState); override; + procedure HandleLMouseUp(x, y: integer; shiftstate: TShiftState); override; + procedure HandleMouseMove(x, y: integer; btnstate: word; shiftstate: TShiftState); override; + procedure HandlePaint; override; + procedure DrawSlider(recalc: boolean); virtual; + procedure RepaintSlider; + procedure PositionChange(d: integer); + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + published + property BackgroundColor; + property Position: integer read FPosition write SetTBPosition default 0; + property ScrollStep: integer read FScrollStep write FScrollStep default 1; + property Min: integer read FMin write SetMin default 0; + property Max: integer read FMax write SetMax default 100; + property ParentShowHint; + property ShowHint; + property ShowPosition: boolean read FShowPosition write SetShowPosition default False; + property Orientation: TOrientation read FOrientation write FOrientation default orHorizontal; + property TabOrder; + property TextColor; + property OnChange: TTrackBarChange read FOnChange write FOnChange; + property OnEnter; + property OnExit; + end; + + +implementation + +{ TfpgTrackBarExtra } + +procedure TfpgTrackBarExtra.DoChange; +begin + if Assigned(FOnChange) then + FOnChange(self, FPosition); +end; + +procedure TfpgTrackBarExtra.SetMax(const AValue: integer); +begin + if FMax = AValue then + Exit; //==> + FMax := AValue; + RePaint; +end; + +procedure TfpgTrackBarExtra.SetMin(const AValue: integer); +begin + if FMin = AValue then + Exit; //==> + FMin := AValue; + RePaint; +end; + +procedure TfpgTrackBarExtra.SetTBPosition(const AValue: integer); +begin + if FPosition = AValue then + Exit; //==> + FPosition := AValue; + RePaint; + DoChange; +end; + +procedure TfpgTrackBarExtra.SetSliderSize(const AValue: integer); +begin + if FSliderSize = AValue then + Exit; //==> + if AValue > 11 then + begin + FSliderSize := AValue; + RePaint; + end; +end; + +procedure TfpgTrackBarExtra.FixMinMaxOrder; +var + lmin: integer; + lmax: integer; +begin + if FMax < FMin then + begin + lmin := FMax; // change order + lmax := FMin; + FMax := lmax; // reassign values + FMin := lmin; + end; +end; + +procedure TfpgTrackBarExtra.FixPositionLimits; +begin + if FPosition < FMin then + FPosition := FMin; + if FPosition > FMax then + FPosition := FMax; +end; + +procedure TfpgTrackBarExtra.DrawSlider(p: integer); +var + h: integer; +begin + if Orientation = orHorizontal then + begin + h := Height div 2 - 1; + Canvas.SetColor(clHilite1); + Canvas.DrawLine(p - FSliderSize div 2,5, p + FSliderSize div 2, 5); + Canvas.DrawLine(p - FSliderSize div 2,5, p - FSliderSize div 2, h - FSliderSize div 2); + Canvas.DrawLine(p - FSliderSize div 2, h - FSliderSize div 2, p, h + FSliderSize div 2); + Canvas.SetColor(clHilite2); + Canvas.DrawLine(p - FSliderSize div 2 + 1,6, p + FSliderSize div 2 - 1, 6); + Canvas.DrawLine(p - FSliderSize div 2 + 1,6, p - FSliderSize div 2 + 1, h - FSliderSize div 2); + Canvas.DrawLine(p - FSliderSize div 2 + 1, h - FSliderSize div 2, p, h + FSliderSize div 2 - 1); + Canvas.SetColor(clShadow2); + Canvas.DrawLine(p + FSliderSize div 2, 6, p + FSliderSize div 2, h - FSliderSize div 2); + Canvas.DrawLine(p + FSliderSize div 2, h - FSliderSize div 2, p + 1, h + FSliderSize div 2 - 1); + Canvas.SetColor(clShadow1); + Canvas.DrawLine(p + FSliderSize div 2 - 1, 7, p + FSliderSize div 2 - 1, h - FSliderSize div 2); + Canvas.DrawLine(p + FSliderSize div 2 - 1, h - FSliderSize div 2, p + 1, h + FSliderSize div 2 - 2); + end + else + begin + h := Width div 2 - 1; + Canvas.SetColor(clHilite1); + Canvas.DrawLine(5,p - FSliderSize div 2, 5, p + FSliderSize div 2); + Canvas.DrawLine(5,p - FSliderSize div 2, h - FSliderSize div 2, p - FSliderSize div 2); + Canvas.DrawLine( h - FSliderSize div 2, p - FSliderSize div 2, h + FSliderSize div 2,p); + Canvas.SetColor(clHilite2); + Canvas.DrawLine(6,p - FSliderSize div 2 + 1, 6, p + FSliderSize div 2 - 1); + Canvas.DrawLine(6,p - FSliderSize div 2 + 1, h - FSliderSize div 2, p - FSliderSize div 2 + 1); + Canvas.DrawLine(h - FSliderSize div 2,p - FSliderSize div 2 + 1, h + FSliderSize div 2 - 1,p); + Canvas.SetColor(clShadow2); + Canvas.DrawLine( 6,p + FSliderSize div 2, h - FSliderSize div 2, p + FSliderSize div 2); + Canvas.DrawLine( h - FSliderSize div 2,p + FSliderSize div 2, h + FSliderSize div 2 - 1, p + 1); + Canvas.SetColor(clShadow1); + Canvas.DrawLine( 7, p + FSliderSize div 2 - 1, h - FSliderSize div 2,p + FSliderSize div 2 - 1); + Canvas.DrawLine( h - FSliderSize div 2, p + FSliderSize div 2 - 1, h + FSliderSize div 2 - 2, p + 1); + end; +end; + +procedure TfpgTrackBarExtra.HandlePaint; +var + r: TfpgRect; + linepos: double; + drawwidth: integer; + i: integer; +begin + Canvas.BeginDraw; +// inherited HandlePaint; + r.SetRect(0, 0, Width, Height); + Canvas.Clear(FBackgroundColor); + + if FFocused then + Canvas.SetColor(clWidgetFrame) + else + Canvas.SetColor(clInactiveWgFrame); + Canvas.DrawRectangle(r); + + FixMinMaxOrder; + FixPositionLimits; + + if Orientation = orHorizontal then + begin + drawwidth := Width - 5 - FSliderSize; + linepos := FMax - FMin; + if linepos <> 0 then + begin + linepos := drawwidth / linepos; + Canvas.SetColor(clWidgetFrame); + for i := 0 to (FMax - FMin) do + Canvas.DrawLine(round(2 + (FSliderSize div 2) + (linepos * i)), Height div 2 + FSliderSize * 2, round(2 + FSliderSize div 2 + linepos * i), Height - 5); + DrawSlider(round(2 + FSliderSize div 2 + linepos * position)); + end; + end + else + begin + drawwidth := Height - 5 - FSliderSize; + linepos := FMax - FMin; + if linepos <> 0 then + begin + linepos := drawwidth / linepos; + Canvas.SetColor(clWidgetFrame); + for i := 0 to (FMax - FMin) do + Canvas.DrawLine(Width div 2 + FSliderSize * 2, round(2 + (FSliderSize div 2) + (linepos * i)), Width - 5, round(2 + FSliderSize div 2 + linepos * i)); + DrawSlider(round(2 + FSliderSize div 2 + linepos * position)); + end; + end; { if/else } + + Canvas.EndDraw; +end; + +procedure TfpgTrackBarExtra.HandleLMouseUp(x, y: integer; shiftstate: TShiftState); +var + linepos: double; + drawwidth: integer; + OldPos: integer; +begin + OldPos := Position; + FixMinMaxOrder; + linepos := FMax - FMin; + + if Orientation = orHorizontal then + begin + drawwidth := Width - 5 - FSliderSize; + linepos := drawwidth / linepos; + FPosition := round((x - 2 - FSliderSize div 2) / linepos) + FMin; + end + else + begin + drawwidth := Height - 5 - FSliderSize; + linepos := drawwidth / linepos; + FPosition := round((y - 2 - FSliderSize div 2) / linepos) + FMin; + end; + RePaint; + + if Position <> OldPos then + DoChange; + +// inherited HandleLMouseUp(x, y, shiftstate); +end; + +procedure TfpgTrackBarExtra.HandleKeyPress(var keycode: word; + var shiftstate: TShiftState; var consumed: boolean); +var + OldPos: integer; +begin + consumed := True; + OldPos := FPosition; + + if Orientation = orHorizontal then + begin + case keycode of + keyLeft: Position := Position - 1; + keyRight: Position := Position + 1; + keyPageUp: Position := FMin; + keyPageDown: Position := FMax; + else + consumed := False; + end; + end + else + begin + case keycode of + keyUp: Position := Position - 1; + keyDown: Position := Position + 1; + keyPageUp: Position := FMin; + keyPageDown: Position := FMax; + else + consumed := False; + end; + end; { if/else } + + inherited HandleKeyPress(keycode, shiftstate, consumed); + if OldPos <> Position then + DoChange; +end; + +constructor TfpgTrackBarExtra.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FFocusable := True; + FMin := 0; + FMax := 10; + FPosition := 0; + FSliderSize := 11; + FOrientation := orHorizontal; + FOnChange := nil; + FTextColor := Parent.TextColor; + FBackgroundColor := Parent.BackgroundColor; +end; + +{ TfpgTrackBar } + +procedure TfpgTrackBar.SetMax(const AValue: integer); +begin + if AValue = FMax then + Exit; + if AValue < FMin then + FMax := FMin + else + FMax := AValue; + if FPosition > FMax then + SetTBPosition(FMax); + Repaint; +end; + +procedure TfpgTrackBar.SetMin(const AValue: integer); +begin + if AValue = FMin then + Exit; + if AValue > FMax then + FMin := FMax + else + FMin := AValue; + if FPosition < FMin then + SetTBPosition(FMin); + Repaint; +end; + +procedure TfpgTrackBar.SetTBPosition(const AValue: integer); +begin + if AValue < FMin then + FPosition := FMin + else if AValue > FMax then + FPosition := FMax + else + FPosition := AValue; + + if HasHandle then + DrawSlider(False); + Repaint; +end; + +procedure TfpgTrackBar.SetShowPosition(const AValue: boolean); +begin + if FShowPosition = AValue then + Exit; //==> + FShowPosition := AValue; + RePaint; +end; + +function TfpgTrackBar.GetTextWidth: TfpgCoord; +begin + if FShowPosition then + Result := FFont.TextWidth(IntToStr(Max)) + 4 + else + Result := 0; +end; + +procedure TfpgTrackBar.HandleLMouseDown(x, y: integer; shiftstate: TShiftState); +var + tw: TfpgCoord; +begin + inherited HandleLMouseDown(x, y, shiftstate); + + if Orientation = orVertical then + begin + if (y >= Width + FSliderPos) and (y <= Width + FSliderPos + FSliderLength) then + begin + FSliderDragging := True; + FSliderDragPos := y; + end; + end + else + begin + tw := GetTextWidth; + if (x >= FSliderPos) and (x <= (FSliderPos + FSliderLength + tw)) then + begin + FSliderDragging := True; + FSliderDragPos := x; + end; + end; + + if FSliderDragging then + begin + FSliderDragStart := FSliderPos; + DrawSlider(False); + end; +end; + +procedure TfpgTrackBar.HandleLMouseUp(x, y: integer; shiftstate: TShiftState); +begin + inherited HandleLMouseUp(x, y, shiftstate); + FSliderDragging := False; + HandlePaint; +end; + +procedure TfpgTrackBar.HandleMouseMove(x, y: integer; btnstate: word; shiftstate: TShiftState); +var + d: integer; + area: integer; + newp: integer; + ppos: integer; + tw: TfpgCoord; +begin + inherited HandleMouseMove(x, y, btnstate, shiftstate); + + FMousePosition.X := x; + FMousePosition.Y := y; + + if (not FSliderDragging) or ((btnstate and MOUSE_LEFT) = 0) then + begin + FSliderDragging := False; + Exit; + end; + + if Orientation = orVertical then + begin + d := y - FSliderDragPos; + area := Height - FSliderLength-4; + end + else + begin + d := x - FSliderDragPos; + tw := GetTextWidth; + area := Width - FSliderLength-4-tw; + end; + + ppos := FSliderPos; + FSliderPos := FSliderDragStart + d; + + if FSliderPos < 0 then + FSliderPos := 0; + if FSliderPos > area then + FSliderPos := area; + + if ppos <> FSliderPos then + DrawSlider(False); + + if area <> FMin then + newp := FMin + Trunc((FMax - FMin) * (FSliderPos / area)) + else + newp := FMin; + + if newp <> FPosition then + begin + Position := newp; + if Assigned(FOnChange) then + FOnChange(self, FPosition); + end; +end; + +procedure TfpgTrackBar.HandlePaint; +var + r: TfpgRect; +begin + Canvas.BeginDraw; + + DrawSlider(True); + if Focused then + begin + r.SetRect(0, 0, Width, Height); + Canvas.DrawFocusRect(r); + end; + + Canvas.EndDraw; +end; + +procedure TfpgTrackBar.DrawSlider(recalc: boolean); +var + area: TfpgCoord; + mm: TfpgCoord; + r: TfpgRect; + tw: TfpgCoord; +begin + Canvas.BeginDraw; + Canvas.Clear(FBackgroundColor); + Canvas.SetColor(FBackgroundColor); + + if Orientation = orVertical then + area := Height-4 + else + begin + tw := GetTextWidth; + area := Width-4-tw; + end; + + if recalc then + begin + if FPosition > FMax then + FPosition := FMax; + if FPosition < FMin then + FPosition := FMin; + + mm := FMax - FMin; + area := area - FSliderLength; + if mm = 0 then + FSliderPos := FMin + else + FSliderPos := Trunc(area * ((FPosition - FMin) / mm)); + if FPosition = FMin then + inc(FSliderPos, 2); + end; + + if Orientation = orVertical then + begin + Canvas.DrawButtonFace(0, Width + FSliderPos, Width, FSliderLength, [btfIsEmbedded]); + Canvas.EndDraw(0, Width, Width, Height - Width - Width); + end + else + begin + r.SetRect(1, (Height-4) div 2, Width - tw - 4, 4); + Canvas.DrawControlFrame(r); + r.SetRect(FSliderPos, (Height-20) div 2, FSliderLength, 21); + Canvas.DrawButtonFace(r, []); + if FShowPosition then + begin + Canvas.SetTextColor(TextColor); + fpgStyle.DrawString(Canvas, Width - tw, (Height - FFont.Height) div 2, IntToStr(Position), Enabled); + end; + end; + Canvas.EndDraw; +end; + +procedure TfpgTrackBar.RepaintSlider; +begin + if not HasHandle then + Exit; //==> + DrawSlider(True); +end; + +procedure TfpgTrackBar.PositionChange(d: integer); +begin + FPosition := FPosition + d; + if FPosition < FMin then + FPosition := FMin; + if FPosition > FMax then + FPosition := FMax; + + if Visible then + DrawSlider(True); + + if Assigned(FOnChange) then + FOnChange(self, FPosition); +end; + +constructor TfpgTrackBar.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FFocusable := True; + Height := 30; + Width := 100; + FOrientation := orHorizontal; + FMin := 0; + FMax := 100; + FPosition := 0; + FSliderPos := 0; + FSliderDragging := False; + FSliderLength := 11; + FScrollStep := 1; + FShowPosition := False; + FFont := fpgGetFont('#Grid'); + FTextColor := Parent.TextColor; + FBackgroundColor := Parent.BackgroundColor; + FOnChange := nil; +end; + +destructor TfpgTrackBar.Destroy; +begin + FOnChange := nil; + FFont.Free; + inherited Destroy; +end; + +end. + diff --git a/src/gui/fpg_tree.pas b/src/gui/fpg_tree.pas new file mode 100644 index 00000000..2a13c803 --- /dev/null +++ b/src/gui/fpg_tree.pas @@ -0,0 +1,1835 @@ +{ + fpGUI - Free Pascal GUI Toolkit + + Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this + distribution, for details of the copyright. + + See the file COPYING.modifiedLGPL, included in this distribution, + for details about redistributing fpGUI. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + Description: + Defines a basic Treeview control and Node classes. The treeview + keeps track of the nodes in a double-linked list structure. + Each Node as .prev and .next property pointing to it's neighbours. +} + +unit fpg_tree; + +{$mode objfpc}{$H+} + +{ + TODO: + * Lots!! + * Columns need to be reworked. We don't want coluns per node levels. Instead + we want a main column covering the tree. Then extra columns for user + text and data. + * Implement event handlers the user can hook into and do custom drawing. + + WARNING: This is still under heavy development. Use at own risk! +} + +{.$Define Debug} + +interface + +uses + Classes, + SysUtils, + fpg_base, + fpg_main, + fpg_widget, + fpg_imagelist, + fpg_scrollbar, + fpg_menu; + +type + + PfpgTreeColumnWidth = ^TfpgTreeColumnWidth; + TfpgTreeColumnWidth = record + next: PfpgTreeColumnWidth; + width: word; + end; + + // forward declaration + TfpgTreeNode = class; + + TfpgTreeNodeFindMethod = procedure(ANode: TfpgTreeNode; var AFound: boolean) of object; + + + TfpgTreeNode = class(TObject) + private + FCollapsed: boolean; + FData: Pointer; + FFirstSubNode: TfpgTreeNode; // the subnodes - for list implementation + FImageIndex: integer; + FInactSelColor: TfpgColor; + FInactSelTextColor: TfpgColor; + FLastSubNode: TfpgTreeNode; + FNext: TfpgTreeNode; + FParent: TfpgTreeNode; + FPrev: TfpgTreeNode; + FSelColor: TfpgColor; + FSelTextColor: TfpgColor; + FText: string; + FTextColor: TfpgColor; + procedure SetCollapsed(const AValue: boolean); + procedure SetInactSelColor(const AValue: TfpgColor); + procedure SetInactSelTextColor(const AValue: TfpgColor); + procedure SetParent(const AValue: TfpgTreeNode); + procedure SetSelColor(const AValue: TfpgColor); + procedure SetSelTextColor(const AValue: TfpgColor); + procedure SetText(const AValue: string); + procedure SetTextColor(const AValue: TfpgColor); + procedure DoRePaint; + public + constructor Create; + destructor Destroy; override; + // node related + function AppendText(AText: string): TfpgTreeNode; + function Count: integer; + function CountRecursive: integer; + function FindSubNode(AText: string; ARecursive: Boolean): TfpgTreeNode; overload; + function FindSubNode(ATreeNodeFindMethod: TfpgTreeNodeFindMethod): TfpgTreeNode; overload; + function GetMaxDepth: integer; + function GetMaxVisibleDepth: integer; + procedure Append(aValue: TfpgTreeNode); + procedure Clear; // remove all nodes recursively + procedure Collapse; + procedure Expand; + procedure Remove(aNode: TfpgTreeNode); + procedure UnregisterSubNode(aNode: TfpgTreeNode); + // parent color settings + function ParentInactSelColor: TfpgColor; + function ParentInactSelTextColor: TfpgColor; + function ParentSelColor: TfpgColor; + function ParentSelTextColor: TfpgColor; + function ParentTextColor: TfpgColor; + // general properties + property Collapsed: boolean read FCollapsed write SetCollapsed; + property Data: Pointer read FData write FData; + property FirstSubNode: TfpgTreeNode read FFirstSubNode; + property ImageIndex: integer read FImageIndex write FImageIndex; + property LastSubNode: TfpgTreeNode read FLastSubNode; + property Next: TfpgTreeNode read FNext write FNext; + property Parent: TfpgTreeNode read FParent write SetParent; + property Prev: TfpgTreeNode read FPrev write FPrev; + property Text: string read FText write SetText; + // color settings + property InactSelColor: TfpgColor read FInactSelColor write SetInactSelColor; + property InactSelTextColor: TfpgColor read FInactSelTextColor write SetInactSelTextColor; + property SelColor: TfpgColor read FSelColor write SetSelColor; + property SelTextColor: TfpgColor read FSelTextColor write SetSelTextColor; + property TextColor: TfpgColor read FTextColor write SetTextColor; + end; + + + TfpgTreeExpandEvent = procedure(Sender: TObject; ANode: TfpgTreeNode) of object; + + + { TfpgTreeView } + + TfpgTreeView = class(TfpgWidget) + private + FImageList: TfpgImageList; + FColumnHeight: integer; // height of the column header + FDefaultColumnWidth: word; + FIndentNodeWithNoImage: boolean; + FFirstColumn: PfpgTreeColumnWidth; // the list for column widths + FFont: TfpgFont; + FHScrollbar: TfpgScrollbar; + FMoving: boolean; + FMovingCol: integer; + FMovingPos: integer; + FNoImageIndent: integer; + FOnChange: TNotifyEvent; + FOnExpand: TfpgTreeExpandEvent; + FRootNode: TfpgTreeNode; + FScrollWheelDelta: integer; + FSelection: TfpgTreeNode; // currently selected node + FShowColumns: boolean; + FShowImages : boolean; + FTreeLineColor: TfpgColor; + FTreeLineStyle: TfpgLineStyle; + FVScrollbar: TfpgScrollbar; + FXOffset: integer; // for repaint and scrollbar-calculation + FYOffset: integer; + function GetFontDesc: string; + function GetRootNode: TfpgTreeNode; + procedure SetDefaultColumnWidth(const AValue: word); + procedure SetFontDesc(const AValue: string); + procedure SetSelection(const AValue: TfpgTreeNode); + procedure SetShowColumns(const AValue: boolean); + procedure SetShowImages(const AValue: boolean); + procedure SetTreeLineColor(const AValue: TfpgColor); + procedure SetTreeLineStyle(const AValue: TfpgLineStyle); + procedure SetIndentNodeWithNoImage(const AValue: boolean); + function VisibleWidth: integer; + function VisibleHeight: integer; + function GetNodeHeightSum: integer; + function MaxNodeWidth: integer; + function GetNodeHeight: integer; + // width of a node inclusive image + function GetNodeWidth(ANode: TfpgTreeNode): integer; + function NodeIsVisible(ANode: TfpgTreeNode): boolean; + // returns the node-top in pixels + function GetAbsoluteNodeTop(ANode: TfpgTreeNode): integer; + function GetColumnLeft(AIndex: integer): integer; + procedure PreCalcColumnLeft; + procedure VScrollbarScroll(Sender: TObject; position: integer); + procedure HScrollbarScroll(Sender: TObject; position: integer); + procedure UpdateScrollbars; + procedure ResetScrollbar; + procedure ClearColumnLeft; + procedure FreeAllTreeNodes; + protected + FColumnLeft: TList; + FPopupMenu: TfpgPopupMenu; + procedure HandleResize(awidth, aheight: TfpgCoord); override; + procedure HandleLMouseUp(x, y: integer; shiftstate: TShiftState); override; + procedure HandleLMouseDown(x, y: integer; shiftstate: TShiftState); override; + procedure HandleRMouseUp(x, y: integer; shiftstate: TShiftState); override; + procedure HandleDoubleClick(x, y: integer; button: word; shiftstate: TShiftState); override; + procedure HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override; + procedure HandleMouseScroll(x, y: integer; shiftstate: TShiftState; delta: smallint); override; + procedure HandleShow; override; + procedure HandlePaint; override; + procedure DrawHeader(ACol: integer; ARect: TfpgRect; AFlags: integer); virtual; + procedure DoChange; virtual; + procedure DoExpand(ANode: TfpgTreeNode); virtual; + function NextVisualNode(ANode: TfpgTreeNode): TfpgTreeNode; + function PrevVisualNode(ANode: TfpgTreeNode): TfpgTreeNode; + // the nodes between the given node and the direct next node + function SpaceToVisibleNext(aNode: TfpgTreeNode): integer; + function StepToRoot(aNode: TfpgTreeNode): integer; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure SetColumnWidth(AIndex, AWidth: word); + // the width of a column - aIndex of the rootnode = 0 + function GetColumnWidth(AIndex: word): word; + property Font: TfpgFont read FFont; + // Invisible node that starts the tree + property RootNode: TfpgTreeNode read GetRootNode; + property Selection: TfpgTreeNode read FSelection write SetSelection; + property ImageList: TfpgImageList read FImageList write FImageList; + property PopupMenu: TfpgPopupMenu read FPopupMenu write FPopupMenu; + published + property DefaultColumnWidth: word read FDefaultColumnWidth write SetDefaultColumnWidth default 15; + property FontDesc: string read GetFontDesc write SetFontDesc; + property IndentNodeWithNoImage: boolean read FIndentNodeWithNoImage write SetIndentNodeWithNoImage default True; + property NoImageIndent: integer read FNoImageIndent write FNoImageIndent default 16; + property ParentShowHint; + property ScrollWheelDelta: integer read FScrollWheelDelta write FScrollWheelDelta default 15; + property ShowColumns: boolean read FShowColumns write SetShowColumns default False; + property ShowHint; + property ShowImages: boolean read FShowImages write SetShowImages default False; + property TabOrder; + property TreeLineColor: TfpgColor read FTreeLineColor write SetTreeLineColor default clShadow1; + property TreeLineStyle: TfpgLineStyle read FTreeLineStyle write SetTreeLineStyle default lsDot; + property OnChange: TNotifyEvent read FOnChange write FOnChange; + property OnExpand: TfpgTreeExpandEvent read FOnExpand write FOnExpand; + end; + + +implementation + +type + PColumnLeft = ^integer; + + +{ TfpgTreeNode } + +procedure TfpgTreeNode.SetInactSelColor(const AValue: TfpgColor); +begin + if AValue <> FInactSelColor then + begin + FInactSelColor := AValue; + DoRePaint; + end; +end; + +procedure TfpgTreeNode.SetCollapsed(const AValue: boolean); +begin + if aValue <> FCollapsed then + begin + FCollapsed := AValue; + DoRePaint; + end; +end; + +procedure TfpgTreeNode.SetInactSelTextColor(const AValue: TfpgColor); +begin + if AValue <> FInactSelTextColor then + begin + FInactSelTextColor := AValue; + DoRePaint; + end; +end; + +procedure TfpgTreeNode.SetParent(const AValue: TfpgTreeNode); +begin + if aValue <> FParent then + begin + if FParent <> nil then + FParent.UnRegisterSubNode(self); // unregisteres + FParent := aValue; + if FParent <> nil then + begin + DoRePaint; + end; + end; +end; + +procedure TfpgTreeNode.SetSelColor(const AValue: TfpgColor); +begin + if FSelColor <> aValue then + begin + FSelColor := aValue; + DoRePaint; + end; +end; + +procedure TfpgTreeNode.SetSelTextColor(const AValue: TfpgColor); +begin + if FTextColor <> aValue then + begin + FSelTextColor := aValue; + DoRePaint; + end; +end; + +procedure TfpgTreeNode.SetText(const AValue: string); +begin + if aValue <> FText then + begin + FText := aValue; + DoRePaint; + end; +end; + +procedure TfpgTreeNode.SetTextColor(const AValue: TfpgColor); +begin + if FTextColor <> aValue then + begin + FTextColor := aValue; + DoRePaint; + end; +end; + +procedure TfpgTreeNode.DoRePaint; +begin + // todo +end; + +constructor TfpgTreeNode.Create; +begin + FData := nil; + FFirstSubNode := nil; + FLastSubNode := nil; + FText := ''; + FImageIndex := -1; + + FParent := nil; + FNext := nil; + FPrev := nil; + + FSelColor := clUnset; + FSelTextColor := clUnset; + FTextColor := clUnset; + FInactSelColor := clUnset; + FInactSelTextColor := clUnset; +end; + +destructor TfpgTreeNode.Destroy; +begin + if FParent <> nil then + FParent.UnregisterSubNode(self); + FData := nil; + FParent := nil; + FNext := nil; + FPrev := nil; + FFirstSubNode := nil; + FLastSubNode := nil; + inherited Destroy; +end; + +procedure TfpgTreeNode.UnregisterSubNode(aNode: TfpgTreeNode); +var + h: TfpgTreeNode; +begin + h := FFirstSubNode; + while h <> nil do + begin + if h = aNode then + begin + if h = FFirstSubNode then + FFirstSubNode := FFirstSubNode.Next; + if h = FLastSubNode then + FLastSubNode := FLastSubNode.Prev; + if h.prev <> nil then + h.prev.next := h.next; + if h.next <> nil then + h.next.prev := h.prev; + exit; + end; + h := h.next; + end; +end; + +procedure TfpgTreeNode.Append(aValue: TfpgTreeNode); +begin + aValue.Parent := self; + aValue.Next := nil; + + if FFirstSubNode = nil then + FFirstSubNode := aValue; + + aValue.prev := FLastSubNode; + + if FLastSubNode <> nil then + FLastSubNode.Next := aValue; + + FLastSubNode := aValue; +end; + +function TfpgTreeNode.FindSubNode(AText: string; ARecursive: Boolean): TfpgTreeNode; +var + h: TfpgTreeNode; +begin + result := nil; + if ARecursive then + begin + h := FirstSubNode; + while h <> nil do + begin +// writeln('h.Text = ', h.Text); + if h.Text = AText then + begin + result := h; + Exit; //==> + end; + if h.count > 0 then + begin + result := h.FindSubNode(AText, ARecursive); + if result <> nil then + Exit; //==> + end; + h := h.next; + end; { while } + end + else + begin + h := FirstSubNode; + while h <> nil do + begin + if h.Text = AText then + begin + result := h; + break; + end; + h := h.next; + end; + end; { if/else } +end; + +function TfpgTreeNode.FindSubNode(ATreeNodeFindMethod: TfpgTreeNodeFindMethod): TfpgTreeNode; +var + lFound: Boolean; + h: TfpgTreeNode; +begin + result := nil; + lFound := False; + if not Assigned(ATreeNodeFindMethod) then + Exit; //==> + + h := FirstSubNode; + while h <> nil do + begin + ATreeNodeFindMethod(h, lFound); + if lFound then + begin + result := h; + Exit; //==> + end; + if h.Count > 0 then + begin + result := h.FindSubNode(ATreeNodeFindMethod); + if result <> nil then + Exit; //==> + end; + h := h.next; + end; +end; + +function TfpgTreeNode.AppendText(AText: string): TfpgTreeNode; +var + h: TfpgTreeNode; +begin + {$IFDEF DEBUG} + writeln('TfpgTreeNode.AppendText'); + {$ENDIF} + h := TfpgTreeNode.Create; + h.Text := AText; + Append(h); + result := h; +end; + +function TfpgTreeNode.GetMaxDepth: integer; +var + h: TfpgTreeNode; + a: integer; + t: integer; +begin + {$IFDEF DEBUG} + writeln('TfpgTreeNode.GetMaxDepth'); + {$ENDIF} + h := FirstSubNode; + result := 1; + a := 0; + while h <> nil do + begin + t := h.GetMaxDepth; + if t > a then + a := t; + h := h.next; + end; + result := result + a; +end; + +function TfpgTreeNode.GetMaxVisibleDepth: integer; +var + h: TfpgTreeNode; + a: integer; + t: integer; +begin + {$IFDEF DEBUG} + writeln('TfpgTreeNode.GetMaxVisibleDepth'); + {$ENDIF} + result := 1; + h := FirstSubNode; + if h.Collapsed then + exit; + a := 0; + while h <> nil do + begin + t := h.GetMaxDepth; + if t > a then + a := t; + h := h.next; + end; + result := result + a; +end; + +procedure TfpgTreeNode.Collapse; +begin + Collapsed := True; +end; + +procedure TfpgTreeNode.Expand; +begin + Collapsed := False; +end; + +function TfpgTreeNode.Count: integer; +var + h: TfpgTreeNode; + i: integer; +begin + h := FirstSubNode; + i := 0; + while h <> nil do + begin + inc(i); + h := h.next; + end; + result := i; +end; + +function TfpgTreeNode.CountRecursive: integer; +var + h: TfpgTreeNode; + i: integer; +begin + h := FFirstSubNode; + i := 0; + while h <> nil do + begin + inc(i); // current node + i := i + h.CountRecursive; // increases i by the count of the subnodes of the subnode + h := h.next; + end; + result := i; +end; + +procedure TfpgTreeNode.Remove(aNode: TfpgTreeNode); +begin + if FirstSubNode = aNode then + begin + FFirstSubNode := aNode.next; + if FFirstSubNode <> nil then + FFirstSubNode.Prev := nil; + end + else + if aNode.prev <> nil then + aNode.Prev.next := aNode.next; + if LastSubNode = aNode then + begin + FLastSubNode := aNode.prev; + if FLastSubNode <> nil then + FLastSubNode.next := nil; + end + else + if aNode.next <> nil then + aNode.next.prev := aNode.prev; + aNode.prev := nil; + aNode.next := nil; + aNode.parent := nil; +end; + +procedure TfpgTreeNode.Clear; +begin + while FirstSubNode <> nil do + begin + if FirstSubNode.Count > 0 then + FirstSubNode.Clear; + Remove(FirstSubNode); + end; +end; + +function TfpgTreeNode.ParentTextColor: TfpgColor; +begin + if TextColor <> clUnset then + result := TextColor + else + begin + if parent <> nil then + result := parent.ParentTextColor + else + result := clText1; + end; +end; + +function TfpgTreeNode.ParentSelTextColor: TfpgColor; +begin + if SelTextColor <> clUnset then + result := SelTextColor + else + begin + if parent <> nil then + result := parent.ParentSelTextColor + else + result := clSelectionText; + end; +end; + +function TfpgTreeNode.ParentSelColor: TfpgColor; +begin + if SelColor <> clUnset then + result := SelColor + else + begin + if parent <> nil then + result := parent.ParentSelColor + else + result := clSelection; + end; +end; + +function TfpgTreeNode.ParentInactSelTextColor: TfpgColor; +begin + if InactSelTextColor <> clUnset then + result := InactSelTextColor + else + begin + if Parent <> nil then + Result := Parent.ParentInactSelTextColor + else + Result := clInactiveSelText; + end; +end; + +function TfpgTreeNode.ParentInactSelColor: TfpgColor; +begin + if InactSelColor <> clUnset then + result := InactSelColor + else + begin + if Parent <> nil then + result := parent.ParentInactSelColor + else + result := clInactiveSel; + end; +end; + +{ TfpgTreeview } + +procedure TfpgTreeview.VScrollbarScroll(Sender: TObject; position: integer); +begin + {$IFDEF DEBUG} + writeln(Classname, '.VScrollbarMove'); + {$ENDIF} + FYOffset := Position; + RePaint; +end; + +function TfpgTreeview.GetFontDesc: string; +begin + Result := FFont.FontDesc; +end; + +function TfpgTreeview.GetRootNode: TfpgTreeNode; +begin + if FRootNode = nil then + FRootNode := TfpgTreeNode.Create; + FRootNode.TextColor := clText1; + FRootnode.SelTextColor := clSelectionText; + FRootnode.SelColor := clSelection; + Result := FRootNode; +end; + +procedure TfpgTreeview.SetDefaultColumnWidth(const AValue: word); +begin + if (aValue <> FDefaultColumnWidth) and (aValue > 3) then + begin + FDefaultColumnWidth := AValue; + RePaint; + end; +end; + +procedure TfpgTreeview.SetFontDesc(const AValue: string); +begin + FFont.Free; + FFont := fpgGetFont(AValue); + RePaint; +end; + +procedure TfpgTreeview.SetSelection(const AValue: TfpgTreeNode); +var + n: TfpgTreeNode; +begin + if aValue <> FSelection then + begin + FSelection := aValue; + if aValue <> nil then + begin + n := aValue.parent; + while n <> nil do + begin + n.Expand; + DoExpand(n); + n := n.parent; + end; + end; + + if GetAbsoluteNodeTop(Selection) + GetNodeHeight - FVScrollbar.Position > VisibleHeight then + begin + FVScrollbar.Position := GetAbsoluteNodeTop(Selection) + GetNodeHeight - VisibleHeight; + FYOffset := FVScrollbar.Position; + UpdateScrollBars; + end; + + if GetAbsoluteNodeTop(Selection) - FVScrollbar.Position < 0 then + begin + FVScrollbar.Position := GetAbsoluteNodeTop(Selection); + FYOffset := FVScrollbar.Position; + UpdateScrollbars; + end; + end; +end; + +procedure TfpgTreeview.SetShowColumns(const AValue: boolean); +begin + if FShowColumns <> aValue then + begin + FShowColumns := aValue; + RePaint; + end; +end; + +procedure TfpgTreeview.SetShowImages(const AValue: boolean); +begin + if AValue <> FShowImages then + begin + FShowImages := AValue; + UpdateScrollbars; + RePaint; + end; +end; + +procedure TfpgTreeview.SetTreeLineColor(const AValue: TfpgColor); +begin + if FTreeLineColor = AValue then + Exit; //==> + FTreeLineColor := AValue; + RePaint; +end; + +procedure TfpgTreeview.SetTreeLineStyle(const AValue: TfpgLineStyle); +begin + if FTreeLineStyle = AValue then + Exit; //==> + FTreeLineStyle := AValue; + RePaint; +end; + +procedure TfpgTreeView.SetIndentNodeWithNoImage(const AValue: boolean); +begin + if AValue <> FIndentNodeWithNoImage then + begin + FIndentNodeWithNoImage := AValue; + UpdateScrollbars; + RePaint; + end; +end; + +function TfpgTreeview.VisibleWidth: integer; +begin + Result := Width - 2; + if FVScrollbar.Visible then + dec(Result, FVScrollbar.Width); +end; + +function TfpgTreeview.VisibleHeight: integer; +begin + Result := Height - 2; + if FShowColumns then + dec(Result, FColumnHeight); + if FHScrollbar.Visible then + dec(Result, FHScrollbar.Height); +end; + +function TfpgTreeview.GetNodeHeightSum: integer; +var + h: TfpgTreeNode; + i: integer; +begin + h := RootNode; + i := -1; + while h <> nil do + begin + inc(i); + if (not h.Collapsed) and (h.Count > 0) then + begin + h := h.FirstSubNode; + end + else + begin + if h.next <> nil then + h := h.next + else + begin + while h.next = nil do + begin + h := h.parent; + if h = nil then + begin + result := i; + exit; + end; + end; + h := h.next; + end; + end; + end; + result := i; +end; + +function TfpgTreeview.MaxNodeWidth: integer; +var + h: TfpgTreeNode; + w: integer; + r: integer; +begin + {$IFDEF DEBUG} + writeln('TfpgTreeView.MaxNodeWidth'); + {$ENDIF} + result := 0; + h := RootNode.FirstSubNode; + r := 0; + while h <> nil do + begin + w := GetColumnLeft(StepToRoot(h)); + if r < w + GetNodeWidth(h) then + r := w + GetNodeWidth(h); + if (not h.collapsed) and (h.count > 0) then + h := h.FirstSubNode + else + begin + if h.next <> nil then + h := h.next + else + begin + while h.next = nil do + begin + h := h.parent; + if h = nil then + begin + result := r + 4; + exit; + end; + end; { while } + h := h.next; + end; + end; { if/else } + end; { while } +end; + +function TfpgTreeview.GetNodeHeight: integer; +begin + Result := FFont.Height + 2; +end; + +function TfpgTreeview.GetNodeWidth(ANode: TfpgTreeNode): integer; +var + AImage: TfpgImageItem; +begin + {$IFDEF DEBUG} + writeln('TfpgTreeView.GetNodeWidth'); + {$ENDIF} + if ANode = nil then + Result := 0 + else + begin + Result := FFont.TextWidth(ANode.Text) + 2; + if ShowImages and (ImageList <> nil) then + begin + if ANode.ImageIndex > -1 then + begin + AImage := ImageList.Item[ANode.ImageIndex]; + if AImage <> nil then + result := result + AImage.Image.Width + 2; + end + else if IndentNodeWithNoImage then + result := result + NoImageIndent + 2; + end; + end; { if/else } +end; + +function TfpgTreeview.NodeIsVisible(ANode: TfpgTreeNode): boolean; +begin + Result := True; + if ANode = nil then + begin + Result := False; + exit; + end; + ANode := ANode.Parent; + while ANode <> nil do + begin + if ANode.Collapsed and (ANode.Parent <> nil) then + Result := False; + ANode := ANode.Parent; + end; +end; + +function TfpgTreeview.GetAbsoluteNodeTop(ANode: TfpgTreeNode): integer; +var + i: integer; +begin + i := 0; + while (ANode <> nil) and (ANode <> RootNode) do + begin + ANode := PrevVisualNode(ANode); + inc(i); + end; + result := (i - 1) * GetNodeHeight; +end; + +function TfpgTreeview.GetColumnLeft(AIndex: integer): integer; +begin + if FColumnLeft = nil then + PreCalcColumnLeft; + + if AIndex < 0 then + Result := 0 + else + begin + if AIndex > FColumnLeft.Count - 1 then + result := PColumnLeft(FColumnLeft[FColumnLeft.Count - 1])^ + else + result := PColumnLeft(FColumnLeft[AIndex])^; + end; +end; + +function TfpgTreeview.GetColumnWidth(AIndex: word): word; +var + h: PfpgTreeColumnWidth; + i: integer; +begin +{$IFDEF DEBUG} + writeln('TfpgTreeView.GetColumnWidth'); +{$ENDIF} + h := FFirstColumn; + i := 0; + if h = nil then // not found + begin + result := DefaultColumnWidth; + exit; + end; + while i < aIndex do + begin + if h = nil then // not found - returns the default + begin + result := DefaultColumnWidth; + exit; + end; + h := h^.next; + inc(i); + end; + if h <> nil then + result := h^.width + else // not found -> returns the default + result := DefaultColumnWidth; +end; + +procedure TfpgTreeview.PreCalcColumnLeft; +var + Aleft: TfpgCoord; + ACounter: integer; + AColumnLeft: PColumnLeft; +begin + {$IFDEF DEBUG} + writeln('TfpgTreeView.PreCalcColumnWidth'); + {$ENDIf} + if FColumnLeft = nil then + FColumnLeft := TList.Create; + + ClearColumnLeft; // Freeing memory + + Aleft := 0; + for ACounter := 1 to RootNode.GetMaxDepth do + begin + AColumnLeft := new(PColumnLeft); + AColumnLeft^ := Aleft; + FColumnLeft.Add(AColumnLeft); + Aleft := Aleft + GetColumnWidth(ACounter); + end; +end; + +procedure TfpgTreeview.HScrollbarScroll(Sender: TObject; position: integer); +begin + FXOffset := Position; + RePaint; +end; + +procedure TfpgTreeview.UpdateScrollbars; +begin + {$IFDEF DEBUG} + writeln(Classname, '.UpdateScrollbars'); + {$ENDIF} + FVScrollbar.Visible := VisibleHeight < GetNodeHeightSum * GetNodeHeight; + FVScrollbar.Min := 0; + FVScrollbar.Max := (GetNodeHeightSum - 1) * GetNodeHeight; + FHScrollbar.Min := 0; + FHScrollbar.Max := MaxNodeWidth - VisibleWidth + FVScrollbar.Width; + FHScrollbar.Visible := MaxNodeWidth > Width - 2; + if not FVScrollbar.Visible then + begin + FVScrollbar.Position := 0; + FVScrollBar.RepaintSlider; + FYOffset := 0; + end; + if not FHScrollbar.Visible then + begin + FHScrollbar.Position := 0; + FHScrollBar.RepaintSlider; + FXOffset := 0; + end; +end; + +procedure TfpgTreeview.ResetScrollbar; +begin + {$IFDEF DEBUG} + writeln(Classname, '.ResetScrollbar'); + {$ENDIF} + UpdateScrollBars; + if FHScrollbar.Visible then + FVScrollbar.SetPosition(Width - 19, 1, 18, Height - 2 - 18) + else + FVScrollbar.SetPosition(Width - 19, 1, 18, Height - 2); + FHScrollbar.SetPosition(1, Height - 19, Width - 2, 18); +end; + +procedure TfpgTreeView.ClearColumnLeft; +var + i: integer; + AColumnLeft: PColumnLeft; +begin + for i := 0 to FColumnLeft.Count - 1 do // Freeing Memory + begin + AColumnLeft := FColumnLeft[i]; + Dispose(AColumnLeft); + end; + FColumnLeft.Clear; +end; + +procedure TfpgTreeView.FreeAllTreeNodes; +var + n: TfpgTreeNode; + list: TList; +begin + list := TList.Create; + n := RootNode.FirstSubNode; + list.Add(n); + + while n <> nil do + begin + // todo: this only frees of the first level of nodes!!!! + n := n.next; + list.Add(n); + end; + +// writeln('NodeCount = ', list.Count); + while list.Count > 0 do + begin + n := TfpgTreeNode(list.Last); + list.Remove(n); + n.Free; + end; + list.Clear; + list.Free; +end; + +procedure TfpgTreeview.HandleResize(awidth, aheight: TfpgCoord); +begin + {$IFDEF DEBUG} + writeln(Classname, '.HandleResize'); + {$ENDIF} + inherited HandleResize(awidth, aheight); + if (csLoading in ComponentState) then + exit; + ResetScrollbar; + RePaint; +end; + +procedure TfpgTreeview.HandleLMouseUp(x, y: integer; shiftstate: TShiftState); +var + col: integer; + i: integer; + w: integer; + i1: integer; + last: TfpgTreeNode; + node: TfpgTreeNode; + cancel: boolean; + OldSel: TfpgTreeNode; +begin + inherited HandleLMouseUp(x, y, shiftstate); + + node := nil; + OldSel := Selection; + if FMoving then // column resize + begin + FMoving := false; + x := x + FXOffset; + SetColumnWidth(FMovingCol, GetColumnWidth(FMovingCol) + x - FMovingPos); + FMoving := false; + end + else + begin + if ShowColumns then + col := FColumnHeight + else + col := 0; + y := y - col - 1 + FYOffset; + i := 0; + x := x + FXOffset; + cancel := False; + last := RootNode; + while not (((i - 1) * GetNodeHeight - 2 <= y) and ((i) * GetNodeHeight + 2 >= y)) do + begin + node := NextVisualNode(last); + if node = nil then + exit; //==> + if node = last then + begin + cancel := True; + break; //==> + end; + inc(i); + last := node; + end; + + if (not cancel) or (node <> nil) then + begin + // +/- or node-selection? + i1 := StepToRoot(node); + w := GetColumnLeft(i1); + if (x >= w - GetColumnWidth(i1) div 2 - 3) and (x <= w - GetColumnWidth(i1) div 2 + 6) then + // collapse or expand? + begin // yes + if node.Count > 0 then + begin + if node.Collapsed then + begin + node.expand; + DoExpand(node); + end + else + node.Collapse; + ResetScrollBar; + RePaint; + end; + end + else + begin + if x > w - GetColumnWidth(i1) div 2 + 6 then + Selection := node; + end; + end; + end; + if OldSel <> Selection then + begin + RePaint; + DoChange; + end; +end; + +procedure TfpgTreeview.HandleLMouseDown(x, y: integer; shiftstate: TShiftState); +var + xpos: integer; + i: integer; +begin + inherited HandleLMouseDown(x, y, shiftstate); + if ShowColumns then + begin + x := x + FXOffset; + xpos := 0; + i := 0; + while xpos + 2 < x do + begin + inc(i); + xpos := xpos + GetColumnWidth(i); + end; + if (x > xpos - 2) and (x < xpos + 2) then + begin + FMoving := True; + FMovingPos := xpos; + FMovingCol := i; + SetColumnWidth(i, GetColumnWidth(i)); + end; + end; + RePaint; +end; + +procedure TfpgTreeView.HandleRMouseUp(x, y: integer; shiftstate: TShiftState); +begin + inherited HandleRMouseUp(x, y, shiftstate); + if Assigned(PopupMenu) then + PopupMenu.ShowAt(self, x, y); +end; + +procedure TfpgTreeview.HandleDoubleClick(x, y: integer; button: word; + shiftstate: TShiftState); +begin + // to setup cursor co-ordinates and handle selection + HandleLMouseUp(x, y, shiftstate); + inherited HandleDoubleClick(x, y, button, shiftstate); + if Selection <> nil then + begin + if Selection.Collapsed then + begin + Selection.Expand; + DoExpand(Selection); + end + else + Selection.Collapse; + RePaint; + end; +end; + +procedure TfpgTreeview.HandleShow; +begin + if (csLoading in ComponentState) then + Exit; + ResetScrollbar; + inherited HandleShow; +end; + +procedure TfpgTreeview.HandlePaint; +var + r: TfpgRect; + h: TfpgTreeNode; + i: integer; + i1: integer; + w: integer; + YPos: integer; + col: integer; + ACenterPos: integer; + x: integer; + y: integer; + AImageItem: TfpgImageItem; + AVisibleHeight: integer; +begin + {$IFDEF DEBUG} + writeln('TfpgTreeview.HandlePaint'); + {$ENDIF} +// inherited HandlePaint; + if not HasHandle then + Exit; //==> + i1 := 0; + PreCalcColumnLeft; + UpdateScrollbars; + AVisibleHeight := VisibleHeight; + + Canvas.BeginDraw; // start double buffering + Canvas.ClearClipRect; + Canvas.Clear(FBackgroundColor); + if FFocused then + Canvas.SetColor(clWidgetFrame) + else + Canvas.SetColor(clInactiveWgFrame); + r.SetRect(0, 0, Width, Height); + Canvas.DrawRectangle(r); // border + + { TODO : Columns need to be redesigned completely } + if ShowColumns then + begin + // Drawing column headers + r.SetRect(1, 1, 0, FColumnHeight); + for col := 1 to rootnode.getMaxDepth - 1 do + begin + r.Width := GetColumnWidth(col); + DrawHeader(col, r, 0); + inc(r.Left, r.Width); + if r.Left >= VisibleWidth then + Break; // small optimization. Don't draw what we can't see + end; + // Fill remainder of the client area with one big header + r.width := VisibleWidth - r.Left + 1; + DrawHeader(col+1, r, 0); + end; + + // Calculate the client area used for nodes and lines + if ShowColumns then + begin + r.SetRect(1, 1 + FColumnHeight, VisibleWidth, VisibleHeight); + col := FColumnHeight; + end + else + begin + r.SetRect(1, 1, VisibleWidth, VisibleHeight); + col := 0; + end; + Canvas.ClearClipRect; + Canvas.SetClipRect(r); + + // draw the nodes with lines + h := RootNode.FirstSubNode; + YPos := 0; + while h <> nil do + begin + Canvas.SetTextColor(h.ParentTextColor); + // lines with + or - + w := GetColumnLeft(StepToRoot(h)); + ACenterPos := YPos - FYOffset + col + (GetNodeHeight div 2); + YPos := YPos + GetNodeHeight; + i := GetColumnLeft(StepToRoot(h)) + GetNodeWidth(h); + + // only paint the node if it is fully visible + if i > FXOffset then + begin +// writeln('painting node: ', h.Text); + if h = Selection then // draw the selection rectangle and text + begin + if Focused then + begin + Canvas.SetColor(h.ParentSelColor); + Canvas.SetTextColor(h.ParentSelTextColor); + end + else + begin + Canvas.SetColor(h.ParentInactSelColor); + Canvas.SetTextColor(h.ParentInActSelTextColor); + end; + Canvas.FillRectangle(w - FXOffset, YPos - FYOffset + col - GetNodeHeight + FFont.Ascent div 2 - 2, GetNodeWidth(h), GetNodeHeight); + if (ImageList <> nil) and ShowImages then + begin + AImageItem := ImageList.Item[h.ImageIndex]; + if AImageItem <> nil then + begin + Canvas.DrawImagePart(w - FXOffset + 1, ACenterPos - 4, AImageItem.Image, 0, 0, 16, 16); + Canvas.DrawString(w - FXOffset + 1 + AImageItem.Image.Width + 2, ACenterPos - FFont.Ascent div 2, h.text); + end + else + begin + if FIndentNodeWithNoImage then + Canvas.DrawString(w - FXOffset + 1 + FNoImageIndent + 2 {spacer}, ACenterPos - FFont.Ascent div 2, h.text) + else + Canvas.DrawString(w - FXOffset + 1, ACenterPos - FFont.Ascent div 2, h.text); + end; + end + else + Canvas.DrawString(w - FXOffset + 1, ACenterPos - FFont.Ascent div 2, h.text); + Canvas.SetTextColor(h.ParentTextColor); + end + else + begin + if (ImageList <> nil) and ShowImages then + begin + AImageItem := ImageList.Item[h.ImageIndex]; + if AImageItem <> nil then + begin + Canvas.DrawImagePart(w - FXOffset + 1, ACenterPos - 4, AImageItem.Image, 0, 0, 16, 16); + Canvas.DrawString(w - FXOffset + 1 + AImageItem.Image.Width + 2, ACenterPos - FFont.Ascent div 2, h.text); + end + else + begin + if FIndentNodeWithNoImage then + Canvas.DrawString(w - FXOffset + 1 + FNoImageIndent + 2 {spacer}, ACenterPos - FFont.Ascent div 2, h.text) + else + Canvas.DrawString(w - FXOffset + 1, ACenterPos - FFont.Ascent div 2, h.text); + end + end + else + Canvas.DrawString(w - FXOffset + 1, ACenterPos - FFont.Ascent div 2, h.text); + end; { if/else } + + Canvas.SetLineStyle(1, FTreeLineStyle); + if h.Count > 0 then // do we have subnodes? + begin + // small horizontal line above rectangle for first subnode (with children) only + if (h <> RootNode.FirstSubNode) then + begin + if (h.Parent.FirstSubNode = h) then + begin + Canvas.SetLineStyle(1, FTreeLineStyle); + Canvas.DrawLine(w - FXOffset - GetColumnWidth(i1) div 2 + 1, ACenterPos - 7, w - FXOffset - GetColumnWidth(i1) div 2 + 1, ACenterPos - 3); + end; + end; + + // subnode rectangle around the "+" or "-" + Canvas.SetColor(FTreeLineColor); + Canvas.SetLineStyle(1, lsSolid); // rectangle is always solid line style + Canvas.DrawRectangle(w - FXOffset - GetColumnWidth(i1) div 2 - 3, ACenterPos - 3, 9, 9); + + Canvas.SetColor(clText1); + + if h.Collapsed then + begin + // draw a "+" + Canvas.DrawLine(w - FXOffset - GetColumnWidth(i1) div 2 - 1, ACenterPos + 1, w - FXOffset - GetColumnWidth(i1) div 2 + 4, ACenterPos + 1); + Canvas.DrawLine(w - FXOffset - GetColumnWidth(i1) div 2 + 1, ACenterPos - 1, w - FXOffset - GetColumnWidth(i1) div 2 + 1, ACenterPos + 4); + end + else + begin + // draw a "-" + Canvas.DrawLine(w - FXOffset - GetColumnWidth(i1) div 2 - 1, ACenterPos + 1, w - FXOffset - GetColumnWidth(i1) div 2 + 4, ACenterPos + 1); + end; + + Canvas.SetLineStyle(1, FTreeLineStyle); + end + else + begin + // short horizontal line for each node + Canvas.SetColor(FTreeLineColor); + Canvas.DrawLine(w - FXOffset - GetColumnWidth(i1) div 2 + 1, ACenterPos + 1, w - FXOffset - 1, ACenterPos + 1); + end; + + Canvas.SetColor(FTreeLineColor); + if h.prev <> nil then + begin + // line up to the previous node + if h.prev.count > 0 then + begin + // take the previous subnode rectangle in account + if h.count > 0 then + // we have a subnode rectangle + Canvas.DrawLine(w - FXOffset - GetColumnWidth(i1) div 2 + 1, ACenterPos - 4, w - FXOffset - GetColumnWidth(i1) div 2 + 1, ACenterPos - (SpaceToVisibleNext(h.prev) * GetNodeHeight) + 5) + else + Canvas.DrawLine(w - FXOffset - GetColumnWidth(i1) div 2 + 1, ACenterPos, w - FXOffset - GetColumnWidth(i1) div 2 + 1, ACenterPos - (SpaceToVisibleNext(h.prev) * GetNodeHeight) + 5); + end + else + begin + // previous node has no subnodes + if h.count > 0 then + // we have a subnode rectangle + Canvas.DrawLine(w - FXOffset - GetColumnWidth(i1) div 2 + 1, ACenterPos - 3, w - FXOffset - GetColumnWidth(i1) div 2 + 1, ACenterPos - SpaceToVisibleNext(h.prev) * GetNodeHeight + 1) + else + Canvas.DrawLine(w - FXOffset - GetColumnWidth(i1) div 2 + 1, ACenterPos, w - FXOffset - GetColumnWidth(i1) div 2 + 1, ACenterPos - SpaceToVisibleNext(h.prev) * GetNodeHeight + 1); + end; + end + else + begin + if h.count > 0 then + // take the subnode rectangle in account + Canvas.DrawLine(w - FXOffset - GetColumnWidth(i1) div 2 + 1,ACenterPos - 3, w - FXOffset - GetColumnWidth(i1) div 2 + 1, ACenterPos - GetNodeHeight div 2 + 3) + else + Canvas.DrawLine(w - FXOffset - GetColumnWidth(i1) div 2 + 1, ACenterPos, w - FXOffset - GetColumnWidth(i1) div 2 + 1, ACenterPos - GetNodeHeight div 2 + 3); + end; + end; + + if ShowColumns then + i := ACenterPos + else + i := ACenterPos + GetNodeHeight; + + if AVisibleHeight > i then + begin + if (h.count > 0) and (not h.Collapsed) then + begin + h := h.FirstSubNode; + continue; + end; + + if h.next <> nil then + h := h.next // next node + else + begin + while h.next = nil do // or recurse next node per parent + begin + h := h.parent; + if (h = nil) or (h = rootnode) then + begin + break; //==> + end; + end; { while } + h := h.next; + end; { if/else } + end + else + begin + // Draw Lines up to the parent nodes + ACenterPos := ACenterPos + GetNodeHeight; + while h <> RootNode do + begin + w := GetColumnLeft(StepToRoot(h)); + if h.next <> nil then + begin + h := h.next; + if h.prev.count > 0 then + begin + x := w - FXOffset - GetColumnWidth(i1) div 2 + 1; + y := GetAbsoluteNodeTop(h.prev) - FYOffset + 5 + (GetNodeHeight div 2); + if ShowColumns then + inc(y, FColumnHeight); + Canvas.DrawLine(x, ACenterPos, x, y); + end + else + begin + x := w - FXOffset - GetColumnWidth(i1) div 2 + 1; + y := GetAbsoluteNodeTop(h.prev) - FYOffset + 1 + (GetNodeHeight div 2); + if ShowColumns then + inc(y, FColumnHeight); + Canvas.DrawLine(x, ACenterPos, x, y); + end; + end; + h := h.parent; + end; + break; //==> + end; + end; { while h <> nil } + Canvas.EndDraw; +end; + +procedure TfpgTreeview.DrawHeader(ACol: integer; ARect: TfpgRect; + AFlags: integer); +begin + // Here we can implement a head style check + Canvas.DrawButtonFace(ARect, [btfIsEmbedded]); +end; + +procedure TfpgTreeview.HandleKeyPress(var keycode: word; + var shiftstate: TShiftState; var consumed: boolean); +var + h: TfpgTreeNode; + OldSelection: TfpgTreeNode; +begin + OldSelection := Selection; + case KeyCode of + keyRight: + begin + Consumed := True; + Selection.Collapsed := false; + DoExpand(Selection); + ResetScrollbar; + RePaint; + end; + + keyLeft: + begin + Consumed := True; + Selection.Collapsed := true; + ResetScrollbar; + RePaint; + end; + + keyUp: + begin + if Selection = nil then + Selection := RootNode.FirstSubNode + else + if Selection <> RootNode then + begin + if NodeIsVisible(selection) then + begin + h := PrevVisualNode(Selection); + if (h <> RootNode) and (h <> nil) then + Selection := h; + end + else + begin + Selection := RootNode.FirstSubNode; + end; + end; + Consumed := True; + end; + + keyDown: + begin + Consumed := True; + if Selection = nil then + Selection := RootNode.FirstSubNode + else + begin + if NodeIsVisible(selection) then + begin + h := NextVisualNode(Selection); + if (h <> nil) then + Selection := h; + end + else + Selection := RootNode.FirstSubNode; + end; + end; + + else + Consumed := False; + end; + + if Selection <> OldSelection then + begin + RePaint; + DoChange; + end; + + if not Consumed then + inherited HandleKeyPress(keycode, shiftstate, consumed); +end; + +procedure TfpgTreeview.HandleMouseScroll(x, y: integer; + shiftstate: TShiftState; delta: smallint); +begin + inherited HandleMouseScroll(x, y, shiftstate, delta); + if delta > 0 then + begin + inc(FYOffset, FScrollWheelDelta); + if FYOffset > VisibleHeight then + FYOffset := VisibleHeight; + end + else + begin + dec(FYOffset, FScrollWheelDelta); + if FYOffset < 0 then + FYOffset := 0; + end; + + UpdateScrollbars; + RePaint; +end; + +procedure TfpgTreeview.DoChange; +begin + if Assigned(FOnChange) then + FOnChange(self); +end; + +procedure TfpgTreeview.DoExpand(ANode: TfpgTreeNode); +begin + if Assigned(FOnExpand) then + FOnExpand(self, ANode); +end; + +function TfpgTreeview.NextVisualNode(ANode: TfpgTreeNode): TfpgTreeNode; + //---------------- + procedure _FindNextNode; + begin + if ANode.Next <> nil then + begin + result := ANode.Next; + end + else + begin + while ANode.Next = nil do + begin + ANode := ANode.Parent; + if ANode = nil then + exit; //==> + end; + result := ANode.Next; + end; + end; + +begin + result := nil; + if ANode.Collapsed then + begin + _FindNextNode; + end + else + begin + if ANode.Count > 0 then + begin + result := ANode.FirstSubNode; + end + else + _FindNextNode; + end; +end; + +function TfpgTreeview.PrevVisualNode(ANode: TfpgTreeNode): TfpgTreeNode; +var + n: TfpgTreeNode; +begin + n := ANode; + if ANode.Prev <> nil then + begin + result := ANode.Prev; + ANode := ANode.Prev; + while (not ANode.Collapsed) and (ANode.Count > 0) do + begin + result := ANode.LastSubNode; + ANode := ANode.LastSubNode; + end; + end + else + begin + if ANode.Parent <> nil then + result := ANode.Parent + else + result := n; + end; +end; + +function TfpgTreeview.SpaceToVisibleNext(aNode: TfpgTreeNode): integer; +var + h: TfpgTreeNode; + i: integer; +begin + result := 0; + i := 0; + if aNode.next = nil then + exit; + h := aNode; + while h <> aNode.next do + begin + inc(i); + if (h.count > 0) and (not h.collapsed) then + begin + h := h.FirstSubNode; + end + else + begin + while h.next = nil do + h := h.parent; + h := h.next; + end; + end; + result := i; +end; + +function TfpgTreeview.StepToRoot(aNode: TfpgTreeNode): integer; +var + i: integer; +begin + i := -1; + while aNode <> nil do + begin + aNode := aNode.parent; + inc(i); + end; + result := i; +end; + +constructor TfpgTreeview.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FRootNode := nil; + FSelection := nil; + FShowImages := False; + FShowColumns := False; + FDefaultColumnWidth := 15; + FFirstColumn := nil; + FFont := fpgGetFont('#Label1'); + FWidth := 150; + FHeight := 100; + + FHScrollbar := TfpgScrollbar.Create(self); + FHScrollbar.Orientation := orHorizontal; + FHScrollbar.OnScroll := @HScrollbarScroll; + FHScrollbar.Visible := False; + FHScrollbar.Position := 0; + FHScrollbar.SliderSize := 0.2; + + FVScrollbar := TfpgScrollbar.Create(self); + FVScrollbar.Orientation := orVertical; + FVScrollbar.OnScroll := @VScrollbarScroll; + FVScrollbar.Visible := False; + FVScrollbar.Position := 0; + FVScrollbar.SliderSize := 0.2; + + FBackgroundColor := clListBox; + FTreeLineColor := clShadow1; //clText1; + FTreeLineStyle := lsDot; + FFocusable := True; + FMoving := False; + FXOffset := 0; + FYOffset := 0; + FColumnHeight := FFont.Height + 2; + FScrollWheelDelta := 15; + FNoImageIndent := 16; + FIndentNodeWithNoImage := True; +end; + +destructor TfpgTreeView.Destroy; +begin + if Assigned(FColumnLeft) then + ClearColumnLeft; + FFont.Free; + FreeAllTreeNodes; + inherited Destroy; +end; + +procedure TfpgTreeview.SetColumnWidth(AIndex, AWidth: word); +var + h: PfpgTreeColumnWidth; + n: PfpgTreeColumnWidth; + i: word; +begin + {$IFDEF DEBUG} + writeln('TfpgTreeView.SetColumnWidth'); + {$ENDIF} + h := FFirstColumn; + if h = nil then + begin + new(h); + h^.width := FDefaultColumnWidth; + h^.next := nil; + FFirstColumn := h; + end; + i := 0; + while i < AIndex do + begin + if h^.next = nil then + begin + new(n); + h^.next := n; + n^.width := DefaultColumnWidth; + n^.next := nil; + end; + h := h^.next; + inc(i); + end; + if h^.width <> AWidth then + begin + h^.width := AWidth; + RePaint; + end; +end; + + +end. + diff --git a/src/gui/gui_animation.pas b/src/gui/gui_animation.pas deleted file mode 100644 index 5ad6042d..00000000 --- a/src/gui/gui_animation.pas +++ /dev/null @@ -1,185 +0,0 @@ -{ - fpGUI - Free Pascal GUI Toolkit - - Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this - distribution, for details of the copyright. - - See the file COPYING.modifiedLGPL, included in this distribution, - for details about redistributing fpGUI. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - - Description: - It's a simple little component that animates an image that contains - multiple frames (in a horizontal direction). See the Animation - demo for image examples. -} - -unit gui_animation; - -{$mode objfpc}{$H+} - -interface - -uses - Classes, - fpg_base, - fpg_main, - fpg_widget; - -type - - TfpgBaseImgAnim = class(TfpgWidget) - private - FFrameCount: integer; - FImageFilename: TfpgString; - FImage: TfpgImage; - FInterval: integer; - FTimer: TfpgTimer; - FPos: integer; - FImageWidth: TfpgCoord; - FTransparent: Boolean; - procedure InternalTimerFired(Sender: TObject); - procedure SetAnimPosition(const AValue: integer); - procedure SetInterval(const AValue: integer); - procedure RecalcImageWidth; - protected - procedure HandlePaint; override; - procedure SetEnabled(const AValue: boolean); override; - procedure SetImageFilename(const AValue: TfpgString); virtual; - // - property Interval: integer read FInterval write SetInterval default 50; - property ImageFileName: TfpgString read FImageFilename write SetImageFilename; - property IsTransparent: Boolean read FTransparent write FTransparent default True; - property FrameCount: integer read FFrameCount write FFrameCount default 4; - property Position: integer read FPos write SetAnimPosition default 0; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - end; - - - TfpgImgAnim = class(TfpgBaseImgAnim) - public - property Position; - published - property Enabled; - property Interval; - property ImageFileName; - property IsTransparent; - property FrameCount; - end; - - -implementation - -uses - SysUtils, - fpg_imgfmt_bmp, - fpg_utils; - - -{ TfpgBaseImgAnim } - -procedure TfpgBaseImgAnim.InternalTimerFired(Sender: TObject); -begin - Repaint; - inc(FPos); - if FPos > FrameCount-1 then - FPos := 0; -end; - -procedure TfpgBaseImgAnim.SetAnimPosition(const AValue: integer); -begin - if FTimer.Enabled then - Exit; // ignore position because animation is running - if AValue < 0 then - FPos := 0 - else - FPos := AValue; - Repaint; -end; - -procedure TfpgBaseImgAnim.SetInterval(const AValue: integer); -begin - if FInterval = AValue then - Exit; //==> - FInterval := AValue; - FTimer.Interval := FInterval; - RecalcImageWidth; -end; - -procedure TfpgBaseImgAnim.RecalcImageWidth; -begin - FImageWidth := FImage.Width div FrameCount; - FPos := 0; -end; - -procedure TfpgBaseImgAnim.HandlePaint; -begin - if (FImageFilename = '') or (FImage = nil) then - Exit; //==> - Canvas.BeginDraw; - Canvas.Clear(clWindowBackground); - Canvas.DrawImagePart(0, 0, FImage, (FImageWidth * FPos), 0, FImageWidth, FImage.Height); - Canvas.EndDraw; -end; - -procedure TfpgBaseImgAnim.SetEnabled(const AValue: boolean); -begin - inherited SetEnabled(AValue); - FTimer.Enabled := FEnabled; -end; - -procedure TfpgBaseImgAnim.SetImageFilename(const AValue: TfpgString); -begin - if FImageFilename = AValue then - Exit; //==> - - if Trim(AValue) = '' then - Exit; //==> - - if not fpgFileExists(AValue) then - raise Exception.CreateFmt('The file <%s> does not exist.', [AValue]) - else - FImageFilename := AValue; - - FTimer.Enabled := False; - FImage.Free; - FImage := LoadImage_BMP(FImageFilename); - if FTransparent then - begin - FImage.CreateMaskFromSample(0, 0); - FImage.UpdateImage; - end; - RecalcImageWidth; - Repaint; -end; - -constructor TfpgBaseImgAnim.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - FPos := 0; - FFrameCount := 4; - FInterval := 50; - FImage := nil; - FEnabled := False; - FTransparent := True; - - FTimer := TfpgTimer.Create(FInterval); - FTimer.OnTimer := @InternalTimerFired; -end; - -destructor TfpgBaseImgAnim.Destroy; -begin - FTimer.Enabled := False; - FTimer.Free; - FImage.Free; - inherited Destroy; -end; - - -end. - diff --git a/src/gui/gui_basegrid.pas b/src/gui/gui_basegrid.pas deleted file mode 100644 index 9916761a..00000000 --- a/src/gui/gui_basegrid.pas +++ /dev/null @@ -1,1206 +0,0 @@ -{ - fpGUI - Free Pascal GUI Toolkit - - Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this - distribution, for details of the copyright. - - See the file COPYING.modifiedLGPL, included in this distribution, - for details about redistributing fpGUI. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - - Description: - Defines a Base Grid control. Usable as the base for any grid type of - component. -} - -unit gui_basegrid; - -{$mode objfpc}{$H+} - -{.$Define DEBUG} - -interface - -uses - Classes, - SysUtils, - fpg_base, - fpg_main, - fpg_widget, - gui_scrollbar; - -type - - TfpgGridDrawState = set of (gdSelected, gdFocused, gdFixed); - - TfpgFocusChangeNotify = procedure(Sender: TObject; ARow, ACol: Integer) of object; - TfpgRowChangeNotify = procedure(Sender: TObject; ARow: Integer) of object; - TfpgCanSelectCellEvent = procedure(Sender: TObject; const ARow, ACol: Integer; var ACanSelect: boolean) of object; - TfpgDrawCellEvent = procedure(Sender: TObject; const ARow, ACol: Integer; const ARect: TfpgRect; const AFlags: TfpgGridDrawState; var ADefaultDrawing: boolean) of object; - - // widget options - TfpgGridOption = (go_HideFocusRect); - TfpgGridOptions = set of TfpgGridOption; - - // Column 2 is special just for testing purposes. Descendant classes will - // override that special behavior anyway. - TfpgBaseGrid = class(TfpgWidget) - private - FColResizing: boolean; - FDragPos: integer; // used for column resizing - FOnDrawCell: TfpgDrawCellEvent; - FResizedCol: integer; // used for column resizing - FDefaultColWidth: integer; - FDefaultRowHeight: integer; - FFocusCol: Integer; - FFocusRow: Integer; - FHeaderHeight: integer; - FOnCanSelectCell: TfpgCanSelectCellEvent; - FOnFocusChange: TfpgFocusChangeNotify; - FOnRowChange: TfpgRowChangeNotify; - FPrevCol: Integer; - FPrevRow: Integer; - FFirstRow: Integer; - FFirstCol: Integer; - FMargin: integer; - FFont: TfpgFont; - FHeaderFont: TfpgFont; - FRowSelect: boolean; - FScrollBarStyle: TfpgScrollStyle; - FShowGrid: boolean; - FShowHeader: boolean; - FTemp: integer; - FVScrollBar: TfpgScrollBar; - FHScrollBar: TfpgScrollBar; - FUpdateCount: integer; - FOptions: TfpgGridOptions; - function GetFontDesc: string; - function GetHeaderFontDesc: string; - procedure HScrollBarMove(Sender: TObject; position: integer); - procedure SetFontDesc(const AValue: string); - procedure SetHeaderFontDesc(const AValue: string); - procedure SetRowSelect(const AValue: boolean); - procedure SetScrollBarStyle(const AValue: TfpgScrollStyle); - procedure VScrollBarMove(Sender: TObject; position: integer); - procedure SetDefaultColWidth(const AValue: integer); - procedure SetDefaultRowHeight(const AValue: integer); - procedure SetFocusCol(const AValue: Integer); - procedure SetFocusRow(const AValue: Integer); - procedure CheckFocusChange; - procedure SetShowGrid(const AValue: boolean); - procedure SetShowHeader(const AValue: boolean); - function VisibleLines: Integer; - function VisibleWidth: integer; - function VisibleHeight: integer; - procedure SetFirstRow(const AValue: Integer); - protected - property UpdateCount: integer read FUpdateCount; - procedure UpdateScrollBars; virtual; - function GetHeaderText(ACol: Integer): string; virtual; - function GetColumnWidth(ACol: Integer): integer; virtual; - procedure SetColumnWidth(ACol: Integer; const AValue: integer); virtual; - function GetColumnBackgroundColor(ACol: Integer): TfpgColor; virtual; - procedure SetColumnBackgroundColor(ACol: Integer; const AValue: TfpgColor); virtual; - function GetColumnTextColor(ACol: Integer): TfpgColor; virtual; - procedure SetColumnTextColor(ACol: Integer; const AValue: TfpgColor); virtual; - function GetColumnCount: Integer; virtual; - function GetRowCount: Integer; virtual; - function CanSelectCell(const ARow, ACol: Integer): boolean; - function DoDrawCellEvent(ARow, ACol: Integer; ARect: TfpgRect; AFlags: TfpgGridDrawState): boolean; virtual; - procedure DoCanSelectCell(const ARow, ACol: Integer; var ACanSelect: boolean); - procedure DrawCell(ARow, ACol: Integer; ARect: TfpgRect; AFlags: TfpgGridDrawState); virtual; - procedure DrawHeader(ACol: Integer; ARect: TfpgRect; AFlags: integer); virtual; - procedure DrawGrid(ARow, ACol: Integer; ARect: TfpgRect; AFlags: integer); virtual; - procedure HandlePaint; override; - procedure HandleShow; override; - procedure HandleResize(awidth, aheight: TfpgCoord); override; - procedure HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override; - procedure HandleMouseScroll(x, y: integer; shiftstate: TShiftState; delta: smallint); override; - procedure HandleMouseMove(x, y: integer; btnstate: word; shiftstate: TShiftState); override; - procedure HandleLMouseUp(x, y: integer; shiftstate: TShiftState); override; - procedure HandleLMouseDown(x, y: integer; shiftstate: TShiftState); override; - procedure FollowFocus; virtual; - property DefaultColWidth: integer read FDefaultColWidth write SetDefaultColWidth default 64; - property DefaultRowHeight: integer read FDefaultRowHeight write SetDefaultRowHeight; - property Font: TfpgFont read FFont; - property FontDesc: string read GetFontDesc write SetFontDesc; - property HeaderFont: TfpgFont read FHeaderFont; - property HeaderFontDesc: string read GetHeaderFontDesc write SetHeaderFontDesc; - property FocusCol: Integer read FFocusCol write SetFocusCol default -1; - property FocusRow: Integer read FFocusRow write SetFocusRow default -1; - property RowSelect: boolean read FRowSelect write SetRowSelect; - property ColumnCount: Integer read GetColumnCount; - property RowCount: Integer read GetRowCount; - property ShowHeader: boolean read FShowHeader write SetShowHeader default True; - property ShowGrid: boolean read FShowGrid write SetShowGrid default True; - property ScrollBarStyle: TfpgScrollStyle read FScrollBarStyle write SetScrollBarStyle default ssAutoBoth; - property HeaderHeight: integer read FHeaderHeight; -// property ColResizing: boolean read FColResizing write FColResizing; - property ColumnWidth[ACol: Integer]: integer read GetColumnWidth write SetColumnWidth; - property ColumnBackgroundColor[ACol: Integer]: TfpgColor read GetColumnBackgroundColor write SetColumnBackgroundColor; - property ColumnTextColor[ACol: Integer]: TfpgColor read GetColumnTextColor write SetColumnTextColor; - property VisibleRows: Integer read VisibleLines; - property TopRow: Integer read FFirstRow write SetFirstRow; - property Options: TfpgGridOptions read FOptions write FOptions default []; - property OnDrawCell: TfpgDrawCellEvent read FOnDrawCell write FOnDrawCell; - property OnFocusChange: TfpgFocusChangeNotify read FOnFocusChange write FOnFocusChange; - property OnRowChange: TfpgRowChangeNotify read FOnRowChange write FOnRowChange; - property OnCanSelectCell: TfpgCanSelectCellEvent read FOnCanSelectCell write FOnCanSelectCell; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - procedure AfterConstruction; override; - procedure Update; - procedure BeginUpdate; - procedure EndUpdate; - procedure MouseToCell(X, Y: Integer; var ACol, ARow: Integer); - end; - - -implementation - -{ TfpgBaseGrid } - -procedure TfpgBaseGrid.HScrollBarMove(Sender: TObject; position: integer); -begin - if FFirstCol <> position then - begin - if Position < 0 then - Position := 0; - FFirstCol := position; - RePaint; - end; -end; - -function TfpgBaseGrid.GetFontDesc: string; -begin - Result := FFont.FontDesc; -end; - -function TfpgBaseGrid.GetHeaderFontDesc: string; -begin - Result := FHeaderFont.FontDesc; -end; - -procedure TfpgBaseGrid.SetFontDesc(const AValue: string); -begin - FFont.Free; - FFont := fpgGetFont(AValue); - if DefaultRowHeight < FFont.Height + 2 then - DefaultRowHeight := FFont.Height + 2; - RePaint; -end; - -procedure TfpgBaseGrid.SetHeaderFontDesc(const AValue: string); -begin - FHeaderFont.Free; - FHeaderFont := fpgGetFont(AValue); - if FHeaderHeight < FHeaderFont.Height + 2 then - FHeaderHeight := FHeaderFont.Height + 2; - RePaint; -end; - -procedure TfpgBaseGrid.SetRowSelect(const AValue: boolean); -begin - if FRowSelect = AValue then - Exit; //==> - FRowSelect := AValue; - RePaint; -end; - -procedure TfpgBaseGrid.SetScrollBarStyle(const AValue: TfpgScrollStyle); -begin - if FScrollBarStyle = AValue then - Exit; //==> - FScrollBarStyle := AValue; -end; - -procedure TfpgBaseGrid.VScrollBarMove(Sender: TObject; position: integer); -begin - if FFirstRow <> position then - begin - FFirstRow := position; - RePaint; - end; -end; - -procedure TfpgBaseGrid.SetDefaultColWidth(const AValue: integer); -begin - if FDefaultColWidth = AValue then - Exit; //==> - FDefaultColWidth := AValue; - RePaint; -end; - -procedure TfpgBaseGrid.SetDefaultRowHeight(const AValue: integer); -begin - if FDefaultRowHeight = AValue then - Exit; //==> - FDefaultRowHeight := AValue; - RePaint; -end; - -function TfpgBaseGrid.GetColumnWidth(ACol: Integer): integer; -begin - Result := 50; -end; - -procedure TfpgBaseGrid.SetColumnWidth(ACol: Integer; const AValue: integer); -begin - // GetColumnWidth and SetColumnWidth will be overriden in decendant! - // Column 2 is special just for testing purposes - if (ACol = 2) and (AValue <> FTemp) then - begin - FTemp := AValue; - UpdateScrollBars; - Repaint; - end; -end; - -function TfpgBaseGrid.GetColumnBackgroundColor(ACol: Integer): TfpgColor; -begin - // implemented in descendant -end; - -procedure TfpgBaseGrid.SetColumnBackgroundColor(ACol: Integer; const AValue: TfpgColor); -begin - // implemented in descendant -end; - -function TfpgBaseGrid.GetColumnTextColor(ACol: Integer): TfpgColor; -begin - // implemented in descendant -end; - -procedure TfpgBaseGrid.SetColumnTextColor(ACol: Integer; const AValue: TfpgColor); -begin - // implemented in descendant -end; - -function TfpgBaseGrid.GetColumnCount: Integer; -begin - Result := 7; -end; - -function TfpgBaseGrid.GetRowCount: Integer; -begin - Result := 24; -end; - -function TfpgBaseGrid.CanSelectCell(const ARow, ACol: Integer): boolean; -begin - Result := (ARow >= 0) and (ACol >= 0) and (ARow < RowCount) and (ACol < ColumnCount); - if Result then - DoCanSelectCell(ARow, ACol, Result); -end; - -function TfpgBaseGrid.DoDrawCellEvent(ARow, ACol: Integer; ARect: TfpgRect; - AFlags: TfpgGridDrawState): boolean; -begin - Result := True; - if Assigned(OnDrawCell) then - FOnDrawCell(self, ARow, ACol, ARect, AFlags, Result); -end; - -procedure TfpgBaseGrid.DoCanSelectCell(const ARow, ACol: Integer; var - ACanSelect: boolean); -begin - if Assigned(OnCanSelectCell) then - FOnCanSelectCell(self, ARow, ACol, ACanSelect); -end; - -procedure TfpgBaseGrid.DrawCell(ARow, ACol: Integer; ARect: TfpgRect; AFlags: TfpgGridDrawState); -var - s: string; -begin - s := 'c(' + IntToStr(ARow) + ',' + IntToStr(ACol) + ')'; - if (ARow = 5) and (ACol = 2) then - s := 'Here lives Graeme!'; - if not Enabled then - Canvas.SetTextColor(clShadow1); - Canvas.DrawText(ARect, s, [txtHCenter, txtVCenter]); -end; - -procedure TfpgBaseGrid.DrawHeader(ACol: Integer; ARect: TfpgRect; AFlags: integer); -var - s: string; - r: TfpgRect; - x: integer; -begin - // Here we can implement a head style check - Canvas.DrawButtonFace(ARect, [btfIsEmbedded]); - r := ARect; - InflateRect(r, -2, -2); - Canvas.AddClipRect(r); // text may not overshoot header border -(* - // drawing grid lines - Canvas.SetColor(clGridLines); - Canvas.DrawLine(r.Left, r.Bottom+1, r.Right+1, r.Bottom+1); // horizontal bottom - Canvas.DrawLine(r.Right+1, r.Top, r.Right+1, r.Bottom+1); // vertical right - - if (ACol mod 2) = 0 then - Canvas.SetColor(clGridHeader) - else - Canvas.SetColor(clMagenta); - Canvas.FillRectangle(ARect); -*) - - Canvas.SetTextColor(clText1); - s := GetHeaderText(ACol); - x := (ARect.Left + (ARect.Width div 2)) - (FHeaderFont.TextWidth(s) div 2); - if x < 1 then - x := 1; - fpgStyle.DrawString(Canvas, x, ARect.Top+1, s, Enabled); -end; - -procedure TfpgBaseGrid.DrawGrid(ARow, ACol: Integer; ARect: TfpgRect; - AFlags: integer); -begin - // default is inside bottom/right edge or cell - Canvas.SetColor(clGridLines); - Canvas.DrawLine(ARect.Left, ARect.Bottom, ARect.Right, ARect.Bottom); // cell bottom - Canvas.DrawLine(ARect.Right, ARect.Bottom, ARect.Right, ARect.Top-1); // cell right -end; - -procedure TfpgBaseGrid.SetFocusCol(const AValue: Integer); -begin - if FFocusCol = AValue then - Exit; //==> - FFocusCol := AValue; - - // apply min/max limit - if FFocusCol < 0 then - FFocusCol := 0; - if FFocusCol > ColumnCount-1 then - FFocusCol := ColumnCount-1; - - FollowFocus; - CheckFocusChange; -end; - -procedure TfpgBaseGrid.SetFocusRow(const AValue: Integer); -begin - if FFocusRow = AValue then - Exit; //==> - FFocusRow := AValue; - - // apply min/max limit - if FFocusRow < 0 then - FFocusRow := 0; - if FFocusRow > RowCount-1 then - FFocusRow := RowCount-1; - - FollowFocus; - CheckFocusChange; -end; - -procedure TfpgBaseGrid.CheckFocusChange; -begin - if ((FPrevCol <> FFocusCol) and not RowSelect) or (FPrevRow <> FFocusRow) then - if Assigned(FOnFocusChange) then - FOnFocusChange(self, FFocusRow, FFocusCol); - - if (FPrevRow <> FFocusRow) then - if Assigned(FOnRowChange) then - FOnRowChange(self, FFocusRow); - - FPrevCol := FFocusCol; - FPrevRow := FFocusRow; -end; - -procedure TfpgBaseGrid.SetShowGrid(const AValue: boolean); -begin - if FShowGrid = AValue then - Exit; //==> - FShowGrid := AValue; - RePaint; -end; - -procedure TfpgBaseGrid.SetShowHeader(const AValue: boolean); -begin - if FShowHeader = AValue then - Exit; //==> - FShowHeader := AValue; - UpdateScrollBars; - RePaint; -end; - -// Return the fully visible lines only. Partial lines not counted -function TfpgBaseGrid.VisibleLines: Integer; -var - hh: integer; -begin - if FHScrollBar.Visible then - hh := FHScrollbar.Height - else - hh := 0; - if ShowHeader then - hh := hh + FHeaderHeight+1; - Result := (Height - (2*FMargin) - hh) div FDefaultRowHeight; -end; - -function TfpgBaseGrid.VisibleWidth: integer; -var - sw: integer; -begin - if FVScrollBar.Visible then - sw := FVScrollBar.Width-1 - else - sw := 0; - Result := Width - (FMargin*2) - sw; -end; - -function TfpgBaseGrid.VisibleHeight: integer; -var - sw: integer; -begin - if FHScrollBar.Visible then - sw := FHScrollBar.Height-1 - else - sw := 0; - Result := Height - (FMargin*2) - sw; -end; - -procedure TfpgBaseGrid.SetFirstRow(const AValue: Integer); -begin - if FFirstRow = AValue then - Exit; //==> - if AValue < ((RowCount - VisibleLines)) then - FFirstRow := AValue - else - FFirstRow := (RowCount - VisibleLines); - UpdateScrollBars; - RePaint; -end; - -procedure TfpgBaseGrid.UpdateScrollBars; -var - HWidth: integer; - VHeight: integer; - vw: integer; - cw: integer; - i: integer; -begin - VHeight := Height - 4; - HWidth := Width - 4; - - vw := VisibleWidth; - cw := 0; - for i := 0 to ColumnCount-1 do - cw := cw + ColumnWidth[i]; - - // This needs improving while resizing - if cw > vw then - FHScrollBar.Visible := not (FScrollBarStyle in [ssNone, ssVertical]) - else - begin - FHScrollBar.Visible := False; - FFirstCol := 0; - end; - - // This needs improving while resizing - if (RowCount > VisibleLines) then - FVScrollBar.Visible := not (FScrollBarStyle in [ssNone, ssHorizontal]) - else - begin - FVScrollBar.Visible := False; - FFirstRow := 0; - end; - - if FVScrollBar.Visible then - begin - Dec(HWidth, FVScrollBar.Width); - FVScrollBar.Min := 0; - if RowCount > 0 then - FVScrollBar.SliderSize := VisibleLines / RowCount - else - FVScrollBar.SliderSize := 0; - FVScrollBar.Max := RowCount-VisibleLines; - FVScrollBar.Position := FFirstRow; - FVScrollBar.RepaintSlider; - end; - - if FHScrollBar.Visible then - begin - Dec(VHeight, FHScrollBar.Height); - FHScrollBar.Min := 0; - FHScrollBar.SliderSize := 0.2; - FHScrollBar.Max := ColumnCount-1; - FHScrollBar.Position := FFirstCol; - FHScrollBar.RepaintSlider; - end; - - FHScrollBar.Top := Height -FHScrollBar.Height - 2; - FHScrollBar.Left := 2; - FHScrollBar.Width := HWidth; - - FVScrollBar.Top := 2; - FVScrollBar.Left := Width - FVScrollBar.Width - 2; - FVScrollBar.Height := VHeight; - - FVScrollBar.UpdateWindowPosition; - FHScrollBar.UpdateWindowPosition; -end; - -function TfpgBaseGrid.GetHeaderText(ACol: Integer): string; -begin - Result := 'Head ' + IntToStr(ACol); -end; - -procedure TfpgBaseGrid.HandlePaint; -var - r: TfpgRect; - r2: TfpgRect; - col: Integer; - row: Integer; - clipr: TfpgRect; // clip rectangle - drawstate: TfpgGridDrawState; -begin - drawstate := []; - Canvas.BeginDraw; -// inherited HandlePaint; - Canvas.ClearClipRect; - - r.SetRect(0, 0, Width, Height); - Canvas.DrawControlFrame(r); - - InflateRect(r, -2, -2); - Canvas.SetClipRect(r); - Canvas.SetColor(FBackgroundColor); - Canvas.FillRectangle(r); - - clipr.SetRect(FMargin, FMargin, VisibleWidth, VisibleHeight); - r := clipr; - - if (ColumnCount > 0) and ShowHeader then - begin - // Drawing horizontal headers - r.Height := FHeaderHeight; - Canvas.SetFont(FHeaderFont); - for col := FFirstCol to ColumnCount-1 do - begin - r.Width := ColumnWidth[col]; - Canvas.SetClipRect(clipr); - Canvas.AddClipRect(r); - DrawHeader(col, r, 0); - inc(r.Left, r.Width); - if r.Left >= clipr.Right then - Break; // small optimization. Don't draw what we can't see - end; - inc(r.Top, r.Height); - end; - - if (RowCount > 0) and (ColumnCount > 0) then - begin - // Drawing cells - r.Height := DefaultRowHeight; - Canvas.SetFont(FFont); - - for row := FFirstRow to RowCount-1 do - begin - r.Left := FMargin; - for col := FFirstCol to ColumnCount-1 do - begin - r.Width := ColumnWidth[col]; - Canvas.SetClipRect(clipr); - - if (row = FFocusRow) and (RowSelect or (col = FFocusCol)) and not (go_HideFocusRect in FOptions) then - begin - if FFocused then - begin - Canvas.SetColor(clSelection); - Canvas.SetTextColor(clSelectionText); - end - else - begin - Canvas.SetColor(clInactiveSel); - Canvas.SetTextColor(clInactiveSelText); - end; - end - else - begin - Canvas.SetColor(ColumnBackgroundColor[col]); - Canvas.SetTextColor(ColumnTextColor[col]); - end; - Canvas.AddClipRect(r); - Canvas.FillRectangle(r); - // setup drawstate - if FFocused then - Include(drawstate, gdFocused); - if (row = FFocusRow) and (col = FFocusCol) then - Include(drawstate, gdSelected); - - if DoDrawCellEvent(row, col, r, drawstate) then - DrawCell(row, col, r, drawstate); - - // drawing grid lines - if FShowGrid then - DrawGrid(row, col, r, 0); - - inc(r.Left, r.Width); - if r.Left >= clipr.Right then - Break; // small optimization. Don't draw what we can't see - end; -// Inc(r.Top, FDefaultRowHeight+1); - inc(r.Top, r.Height); - if r.Top >= clipr.Bottom then - break; - end; - end; // item drawing - - Canvas.SetClipRect(clipr); - Canvas.SetColor(FBackgroundColor); - - // clearing after the last column - if r.Left <= clipr.Right then - begin - r2.Left := r.Left; - r2.Top := clipr.Top; - r2.SetRight(clipr.Right); - r2.Height := clipr.Height; - Canvas.FillRectangle(r2); - end; - - // clearing after the last row - if r.Top <= clipr.Bottom then - begin - r.Left := clipr.Left; - r.Width := clipr.Width; - r.SetBottom(clipr.Bottom); - Canvas.FillRectangle(r); - end; - - // The little square in the bottom right corner - if FHScrollBar.Visible and FVScrollBar.Visible then - begin - Canvas.ClearClipRect; - Canvas.SetColor(clButtonFace); - Canvas.FillRectangle(FHScrollBar.Left+FHScrollBar.Width, - FVScrollBar.Top+FVScrollBar.Height, - FVScrollBar.Width, - FHScrollBar.Height); - end; - - Canvas.EndDraw; -end; - -procedure TfpgBaseGrid.HandleShow; -begin - inherited HandleShow; - if (csLoading in ComponentState) then - Exit; - UpdateScrollBars; -end; - -procedure TfpgBaseGrid.HandleResize(awidth, aheight: TfpgCoord); -begin - inherited HandleResize(awidth, aheight); - if (csLoading in ComponentState) then - Exit; //==> - if csUpdating in ComponentState then - Exit; //==> - if HasHandle then - UpdateScrollBars; -end; - -procedure TfpgBaseGrid.HandleKeyPress(var keycode: word; - var shiftstate: TShiftState; var consumed: boolean); -var - w: integer; - r: integer; -begin - consumed := True; - case keycode of - keyRight: - begin - if RowSelect then - begin - w := 0; - FFocusCol := FFirstCol; - while FFocusCol < ColumnCount do - begin - inc(w, ColumnWidth[FFocusCol]+1); - if w + ColumnWidth[FFocusCol+1]+1 > VisibleWidth then - Break; - inc(FFocusCol); - end; - end; - - if CanSelectCell(FFocusRow, FFocusCol+1) then - begin - inc(FFocusCol); - FollowFocus; - RePaint; - end; - end; - - keyLeft: - begin - if RowSelect then - FFocusCol := FFirstCol; - if CanSelectCell(FFocusRow, FFocusCol-1) then - begin - dec(FFocusCol); - FollowFocus; - RePaint; - end; - end; - - keyUp: - begin - if CanSelectCell(FFocusRow-1, FFocusCol) then - begin - dec(FFocusRow); - FollowFocus; - RePaint; - end; - end; - - keyDown: - begin - if CanSelectCell(FFocusRow+1, FFocusCol) then - begin - inc(FFocusRow); - FollowFocus; - RePaint; - end; - end; - - keyPageUp: - begin - r := FFocusRow-VisibleLines; - if r < 0 then - r := 0; - - if (FFocusRow <> 0) and CanSelectCell(r, FFocusCol) then - begin - FFocusRow := r; - FollowFocus; - RePaint; - end; - end; - - keyPageDown: - begin - r := FFocusRow+VisibleLines; - if r > (RowCount-1) then - r := RowCount-1; - - if (FFocusRow <> (RowCount-1)) and CanSelectCell(r, FFocusCol) then - begin - FFocusRow := r; - FollowFocus; - RePaint; - end; - end; - - keyHome: - begin - if FRowSelect then - begin - if (FFocusRow <> 0) and CanSelectCell(0, FFocusCol) then - begin - FFocusRow := 0; - FollowFocus; - RePaint; - end; - end - else if (FFocusCol <> 0) and CanSelectCell(FFocusRow, 0) then - begin - FFocusCol := 0; - FollowFocus; - RePaint; - end; - end; - - keyEnd: - begin - if FRowSelect then - begin - if (FFocusRow <> (RowCount-1)) and CanSelectCell(RowCount-1, FFocusCol) then - begin - FFocusRow := RowCount-1; - FollowFocus; - RePaint; - end; - end - else if (FFocusCol <> (ColumnCount-1)) and CanSelectCell(FFocusRow, ColumnCount-1) then - begin - FFocusCol := ColumnCount-1; - FollowFocus; - RePaint; - end; - end; - - else - consumed := False; - end; - - if consumed then - CheckFocusChange; - - inherited HandleKeyPress(keycode, shiftstate, consumed); -end; - -procedure TfpgBaseGrid.HandleMouseScroll(x, y: integer; shiftstate: TShiftState; delta: smallint); -var - lRow: Integer; - lCol: Integer; -begin - inherited HandleMouseScroll(x, y, shiftstate, delta); - - lRow := FFirstRow; - lCol := FFirstCol; - - if delta > 0 then // scroll down - inc(FFirstRow, abs(delta)) - else // scroll up - if FFirstRow > 0 then - dec(FFirstRow, abs(delta)); - - // apply limits - if FFirstRow > RowCount - VisibleLines then - FFirstRow := RowCount - VisibleLines; - if FFirstRow < 0 then - FFirstRow := 0; - - // scroll left/right - // If vertical scrollbar is not visible, but - // horizontal is. Mouse wheel will scroll horizontally. :) - if FHScrollBar.Visible and (not FVScrollBar.Visible) then - begin - if delta > 0 then // scroll right - begin - if FFirstCol < (ColumnCount-1) then - inc(FFirstCol); - end - else - begin - if FFirstCol > 0 then - dec(FFirstCol); - end; - end; - - if (lRow <> FFirstRow) or (lCol <> FFirstCol) then - begin - UpdateScrollBars; - RePaint; - end; -end; - -procedure TfpgBaseGrid.HandleMouseMove(x, y: integer; btnstate: word; shiftstate: TShiftState); -var - hh: integer; - cw: integer; - n: integer; - colresize: boolean; -begin - inherited HandleMouseMove(x, y, btnstate, shiftstate); - - if (ColumnCount = 0) or (RowCount = 0) then - Exit; //==> - - if FColResizing then - begin - if (btnstate and 1) = 0 then - FColResizing := False - else - begin - cw := ColumnWidth[FResizedCol]+x-FDragPos; - if cw < 1 then - cw := 1; - SetColumnWidth(FResizedCol, cw); - FDragPos := x; - end; - end - else if ShowHeader then - begin - colresize := False; - hh := FHeaderHeight; - - if (y <= FMargin + hh) then // we are over the Header row - begin - cw := 0; - for n := FFirstCol to ColumnCount-1 do - begin - inc(cw, ColumnWidth[n]); - // Resizing is enabled 4 pixel either way of the cell border - if ((x >= (FMargin+cw - 4)) and (x <= (FMargin+cw+4))) or - (cw > (FMargin + VisibleWidth)) and (x >= FMargin + VisibleWidth-4) then - begin - colresize := True; - Break; - end; - - if cw > VisibleWidth then - Break; - end; { if } - end; { if/else } - - if colresize then - MouseCursor := mcSizeEW - else - MouseCursor := mcDefault; - end; { if/else } -end; - -procedure TfpgBaseGrid.HandleLMouseUp(x, y: integer; shiftstate: TShiftState); -begin - inherited HandleLMouseUp(x, y, shiftstate); - - {$IFDEF DEBUG} - if FColResizing then - Writeln('Column ', FResizedCol,' width = ', ColumnWidth[FResizedCol]); - {$ENDIF} - - FColResizing := False; - MouseCursor := mcDefault; -end; - -procedure TfpgBaseGrid.HandleLMouseDown(x, y: integer; shiftstate: TShiftState); -var - hh: integer; - n: Integer; - cw: integer; - nw: integer; - prow: Integer; - pcol: Integer; -begin - inherited HandleLMouseDown(x, y, shiftstate); - - if (ColumnCount = 0) or (RowCount = 0) then - Exit; //==> - - pcol := FFocusCol; - prow := FFocusRow; - - // searching for the appropriate character position - if ShowHeader then - hh := FHeaderHeight+1 - else - hh := 0; - - if ShowHeader and (y <= FMargin+hh) then // inside Header row - begin - {$IFDEF DEBUG} Writeln('header click...'); {$ENDIF} - cw := 0; - for n := FFirstCol to ColumnCount-1 do - begin - inc(cw, ColumnWidth[n]); - if (x >= (FMargin+cw - 4)) and (x <= (FMargin+cw + 4)) then - begin - {$IFDEF DEBUG} Writeln('column resize...'); {$ENDIF} - FColResizing := True; - FResizedCol := n; - FDragPos := x; - Break; - end - else if (cw > FMargin+VisibleWidth) and (x >= FMargin+VisibleWidth-4) then - begin - FColResizing := True; - FResizedCol := n; - FDragPos := x; - nw := ColumnWidth[FResizedCol] - (cw+FMargin-x); - if nw > 0 then - SetColumnWidth(FResizedCol, nw ); - Break; - end; { if/else } - - if cw > VisibleWidth then - Break; - end; { for } - end - else - begin // Selecting a Cell via mouse - MouseToCell(x, y, FFocusCol, FFocusRow); - end; { if/else } - - if not CanSelectCell(FFocusRow, FFocusCol) then - begin - // restore previous values - FFocusRow := prow; - FFocusCol := pcol; - end; - - if (prow <> FFocusRow) or (pcol <> FFocusCol) then - begin - FollowFocus; - Repaint; - end; - - if FColResizing then - MouseCursor := mcSizeEW; - - CheckFocusChange; -end; - -procedure TfpgBaseGrid.FollowFocus; -var - n: Integer; - w: TfpgCoord; -begin - if (RowCount > 0) and (FFocusRow < 0) then - FFocusRow := 0; - if FFocusRow > RowCount-1 then - FFocusRow := RowCount-1; - - if (ColumnCount > 0) and (FFocusCol < 0) then - FFocusCol := 0; - if FFocusCol > ColumnCount-1 then - FFocusCol := ColumnCount-1; - - if FFirstRow < 0 then - FFirstRow := 0; - if FFirstCol < 0 then - FFirstCol := 0; - - if FFocusRow < FFirstRow then - FFirstRow := FFocusRow - else - begin - if (FFirstRow + VisibleLines) <= FFocusRow then - FFirstRow := (FFocusRow - VisibleLines) + 1; // scroll last partial row into view - end; { if/else } - - if FFocusCol < FFirstCol then - FFirstCol := FFocusCol - else - begin - w := 0; - for n := FFocusCol downto FFirstCol do - begin - w := w + ColumnWidth[n]+1; - if w > VisibleWidth then - begin - if n = FFocusCol then - FFirstCol := n - else - FFirstCol := n+1; - break; - end; - end; { for } - end; { if/else } - - UpdateScrollBars; -end; - -constructor TfpgBaseGrid.Create(AOwner: TComponent); -begin - Updating; - inherited Create(AOwner); - Focusable := True; - Width := 120; - Height := 80; - FFocusCol := -1; - FPrevCol := -1; - FFocusRow := -1; - FPrevRow := -1; - FFirstRow := 0; - FFirstCol := 0; - FMargin := 2; - FShowHeader := True; - FShowGrid := True; - FRowSelect := False; - FScrollBarStyle := ssAutoBoth; - FUpdateCount := 0; - FOptions := []; - - FFont := fpgGetFont('#Grid'); - FHeaderFont := fpgGetFont('#GridHeader'); - - FTemp := 50; // Just to prove that ColumnWidth does adjust. - FDefaultColWidth := 64; - FDefaultRowHeight := FFont.Height + 2; - FHeaderHeight := FHeaderFont.Height + 2; - FBackgroundColor := clBoxColor; - FColResizing := False; - - MinHeight := HeaderHeight + DefaultRowHeight + FMargin; - MinWidth := DefaultColWidth + FMargin; - - FVScrollBar := TfpgScrollBar.Create(self); - FVScrollBar.Orientation := orVertical; - FVScrollBar.Visible := False; - FVScrollBar.OnScroll := @VScrollBarMove; - - FHScrollBar := TfpgScrollBar.Create(self); - FHScrollBar.Orientation := orHorizontal; - FHScrollBar.Visible := False; - FHScrollBar.OnScroll := @HScrollBarMove; - FHScrollBar.ScrollStep := 5; -end; - -destructor TfpgBaseGrid.Destroy; -begin - FOnRowChange := nil; - FOnFocusChange := nil; - FFont.Free; - FHeaderFont.Free; - inherited Destroy; -end; - -procedure TfpgBaseGrid.AfterConstruction; -begin - inherited AfterConstruction; - Updated; -end; - -procedure TfpgBaseGrid.Update; -begin - UpdateScrollBars; - FollowFocus; - RePaint; -end; - -procedure TfpgBaseGrid.BeginUpdate; -begin - Inc(FUpdateCount); - Updating; -end; - -procedure TfpgBaseGrid.EndUpdate; -begin - if FUpdateCount > 0 then - begin - Dec(FUpdateCount); - if FUpdateCount = 0 then - begin - Updated; - RePaint; - end; - end; -end; - -procedure TfpgBaseGrid.MouseToCell(X, Y: Integer; var ACol, ARow: Integer); -var - hh: integer; - cw: integer; - n: Integer; -begin - if ShowHeader then - hh := FHeaderHeight+1 - else - hh := 0; - - ARow := FFirstRow + ((y - FMargin - hh) div FDefaultRowHeight); - if ARow > RowCount-1 then - ARow := RowCount-1; - - cw := 0; - for n := FFirstCol to ColumnCount-1 do - begin - inc(cw, ColumnWidth[n]); - if FMargin+cw >= x then - begin - ACol := n; - Break; - end; - end; -end; - - -end. - diff --git a/src/gui/gui_button.pas b/src/gui/gui_button.pas deleted file mode 100644 index 01a05145..00000000 --- a/src/gui/gui_button.pas +++ /dev/null @@ -1,765 +0,0 @@ -{ - fpGUI - Free Pascal GUI Toolkit - - Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this - distribution, for details of the copyright. - - See the file COPYING.modifiedLGPL, included in this distribution, - for details about redistributing fpGUI. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - - Description: - Defines a push button control. -} - -unit gui_button; - -{$mode objfpc}{$H+} - -interface - -uses - Classes, - SysUtils, - fpg_base, - fpg_main, - fpg_widget, - fpg_command_intf; - -type - - TImageLayout = (ilImageLeft, ilImageTop, ilImageRight, ilImageBottom); - - { TfpgBaseButton } - - TfpgBaseButton = class(TfpgWidget, ICommandHolder) - private - FCommand: ICommand; - FImageLayout: TImageLayout; - FFlat: Boolean; - FImageName: string; - FClicked: Boolean; - FShowImage: Boolean; - FClickOnPush: Boolean; - FGroupIndex: integer; - FAllowAllUp: boolean; - FModalResult: TfpgModalResult; - function GetFontDesc: string; - procedure SetDefault(const AValue: boolean); - procedure SetEmbedded(const AValue: Boolean); - procedure SetFlat(const AValue: Boolean); - procedure SetFontDesc(const AValue: string); - procedure SetImageLayout(const AValue: TImageLayout); - procedure SetImageName(const AValue: string); - procedure SetText(const AValue: string); - procedure SetDown(AValue: Boolean); - procedure SetImageMargin(const Value: integer); - procedure SetImageSpacing(const Value: integer); - function GetAllowDown: Boolean; - procedure SetAllowDown(const Value: Boolean); - procedure SetAllowAllUp(const Value: boolean); - procedure DoPush; - procedure DoRelease(x, y: integer); - protected - FImageMargin: integer; - FImageSpacing: integer; - FEmbedded: Boolean; - FDown: Boolean; - FImage: TfpgImage; - FText: string; - FFont: TfpgFont; - FDefault: boolean; - FState: integer; // 0 - normal // 1 - hover - procedure SetShowImage(AValue: Boolean); - procedure HandlePaint; override; - procedure HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override; - procedure HandleKeyRelease(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override; - procedure HandleLMouseDown(X, Y: integer; ShiftState: TShiftState); override; - procedure HandleLMouseUp(x, y: integer; shiftstate: TShiftState); override; - procedure HandleMouseExit; override; - procedure HandleMouseEnter; override; - { When buttons are in a toggle state (GroupIndex > 0), are all buttons in the group - allowed to be up. } - property AllowAllUp: boolean read FAllowAllUp write SetAllowAllUp default False; - { Buttons behave like toggle buttons. This is an alias for GroupIndex > 0 } - property AllowDown: Boolean read GetAllowDown write SetAllowDown; - property Default: boolean read FDefault write SetDefault default False; - property Down: Boolean read FDown write SetDown; - { The button will not show focus. It might also have a different down state (look). - This is similar to Focusable = False, but the appearance of the down state might differ. } - property Embedded: Boolean read FEmbedded write SetEmbedded default False; - property Flat: Boolean read FFlat write SetFlat default False; - property FontDesc: string read GetFontDesc write SetFontDesc; - { Used in combination with AllowDown and AllowAllUp. Allows buttons in the same - group to work together. } - property GroupIndex: integer read FGroupIndex write FGroupIndex default 0; - property ImageMargin: integer read FImageMargin write SetImageMargin default 3; - property ImageName: string read FImageName write SetImageName; - property ImageSpacing: integer read FImageSpacing write SetImageSpacing default -1; - property ImageLayout: TImageLayout read FImageLayout write SetImageLayout default ilImageLeft; - property ModalResult: TfpgModalResult read FModalResult write FModalResult default mrNone; - property ShowImage: Boolean read FShowImage write SetShowImage default True; - property Text: string read FText write SetText; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - procedure Click; - function GetCommand: ICommand; // ICommandHolder interface - procedure SetCommand(ACommand: ICommand); // ICommandHolder interface - property Font: TfpgFont read FFont; - end; - - - { A standard push button component. - - If you want toolbar style buttons you need to set the following properties: - AllowAllUp = True; AllowDown = True; - and each button's GroupIndex must be greater than 0, but not the same as any - other button. - - If you want toggle buttons - only one button my be down at a time: - Set AllowAllUp = False and AllowDown = True - AllowDown = True will automatically set the GroupIndex = 1. If you want more - than one set of toggle buttons in a Parent, you need to manually set the - GroupIndex property instead. All buttons with the same GroupIndex work - together. } - TfpgButton = class(TfpgBaseButton) - published - property AllowAllUp; - property AllowDown; - property BackgroundColor default clButtonFace; - property Default; - property Down; - property Embedded; - property Flat; - property FontDesc; - property GroupIndex; - property Hint; - property ImageLayout; - property ImageMargin; - property ImageName; - property ImageSpacing; - property ModalResult; - property ParentShowHint; - property ShowHint; - property ShowImage; - property Text; - property TextColor; - property TabOrder; - property OnMouseExit; - property OnMouseEnter; - property OnClick; - end; - - -function CreateButton(AOwner: TComponent; x, y, w: TfpgCoord; AText: string; - AOnClickEvent: TNotifyEvent; AImage: string = ''): TfpgButton; - - -implementation - -uses - gui_form; {$Note Try and remove this gui_form dependency.} - -function CreateButton(AOwner: TComponent; x, y, w: TfpgCoord; AText: string; - AOnClickEvent: TNotifyEvent; AImage: string): TfpgButton; -begin - Result := TfpgButton.Create(AOwner); - Result.Text := AText; - Result.SetPosition(x, y, w, Result.Height); // font was used to calculate height. - Result.OnClick := AOnClickEvent; - Result.ImageName := AImage; -end; - -{ TfpgBaseButton } - -procedure TfpgBaseButton.SetDown(AValue: Boolean); -begin - if AValue <> FDown then - begin - FDown := AValue; - if AllowDown then - RePaint; - end; -end; - -procedure TfpgBaseButton.SetShowImage(AValue: Boolean); -begin - if AValue <> FShowImage then - begin - FShowImage := AValue; - if (FImage <> nil) and ShowImage then - RePaint; - end; -end; - -procedure TfpgBaseButton.SetText(const AValue: string); -begin - if FText = AValue then - Exit; - FText := AValue; - RePaint; -end; - -procedure TfpgBaseButton.SetImageName(const AValue: string); -begin - FImageName := AValue; - FImage := fpgImages.GetImage(FImageName); - Repaint; -end; - -function TfpgBaseButton.GetFontDesc: string; -begin - Result := FFont.FontDesc; -end; - -procedure TfpgBaseButton.SetDefault(const AValue: boolean); -var - i: integer; - wg: TfpgWidget; -begin - if FDefault = AValue then - Exit; //==> - FDefault := AValue; - - // Clear other buttons Default state - if FDefault and (Parent <> nil) then - begin - for i := 0 to Parent.ComponentCount-1 do - begin - wg := TfpgWidget(Parent.Components[i]); - if (wg <> nil) and (wg <> self) and (wg is TfpgBaseButton) then - begin - TfpgBaseButton(wg).Default := False; - end; - end; { for } - end; { if } - - RePaint; -end; - -procedure TfpgBaseButton.SetEmbedded(const AValue: Boolean); -begin - if FEmbedded = AValue then - Exit; - FEmbedded := AValue; -end; - -procedure TfpgBaseButton.SetFlat(const AValue: Boolean); -begin - if FFlat = AValue then - Exit; //==> - FFlat := AValue; - if FFlat then - FDefault := False; // you can't have it all! -end; - -procedure TfpgBaseButton.SetFontDesc(const AValue: string); -begin - FFont.Free; - FFont := fpgGetFont(AValue); - RePaint; -end; - -constructor TfpgBaseButton.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - FText := 'Button'; - FFont := fpgGetFont('#Label1'); - FHeight := FFont.Height + 8; - FWidth := 80; - FFocusable := True; - FTextColor := Parent.TextColor; - FBackgroundColor := clButtonFace; - OnClick := nil; - FDown := False; - FClicked := False; - FDown := False; - FClickOnPush := False; - FGroupIndex := 0; - FImage := nil; - FImageName := ''; - FShowImage := True; - FImageLayout := ilImageLeft; - FImageMargin := 3; // image is 3 pixels from edge of button. -1 will centre image. - FImageSpacing := -1; // text is centered in remaining space - FModalResult := mrNone; - FEmbedded := False; - FDefault := False; - FAllowAllUp := False; - FState := 0; -end; - -destructor TfpgBaseButton.Destroy; -begin - FImage := nil; - FText := ''; - FFont.Free; - inherited Destroy; -end; - -procedure TfpgBaseButton.HandlePaint; - - procedure CalculatePositions (var ImageX, ImageY, TextX, TextY : integer); - var {clientHeight, clientWidth,} textWidth, textHeight : integer; - w : integer; - begin - if text = '' then - begin - textWidth := 0; - textHeight := 0; - end - else - begin - textWidth := FFont.TextWidth (Text); - textHeight := FFont.Height; - // Only single line texts will be placed correctly. - // Normally FFont.TextHeight should be used (not yet implemented) - end; - if FImageLayout in [ilImageLeft, ilImageRight] then - begin - TextY := (Height - textHeight) div 2; - // center vertically - if FShowImage and assigned (FImage) then - begin - ImageY := (Height - FImage.Height) div 2; - // horizontal places if image and text - if FImageMargin = -1 then - begin // Free space between border and image is the same as between border and text - if FImageSpacing = -1 then // free space between image/text = border/text = border/image - begin - w := (Width - FImage.Width - textWidth) div 3; - if w < 3 then // minimal margin from border for rectangle/focusrect/... - w := 3; - if FImageLayout = ilImageLeft then - begin - ImageX := w; - TextX := Width - w - textWidth; - end - else // if FImageLayout = ilImageRight then - begin - ImageX := Width - w - FImage.width; - TextX := w; - end; - end - else // fixed space between image/text - begin - w := (Width - FImageSpacing - FImage.width - textWidth) div 2; - if w < 3 then // minimal margin from border for rectangle/focusrect/... - w := 3; - if FImageLayout = ilImageLeft then - begin - ImageX := w; - TextX := w + FImage.width + FImageSpacing; - end - else // if FImageLayout = ilImageRight then - begin - ImageX := width - w - FImage.Width; - TextX := w; - end; - end; - end - else // Fixed image - begin - if FImageLayout = ilImageLeft then - begin - ImageX := FImageMargin + 3; - if FImageSpacing = -1 then - begin - w := (Width - FImage.Width - ImageX - textWidth) div 2; - if w < 0 then - w := 0; - end - else - w := FImageSpacing; - TextX := ImageX + FImage.width + w; - end - else // if FImageLayout = ilImageRight then - begin - ImageX := Width - FImageMargin - 3 - FImage.width; - if FImageSpacing = -1 then - begin - w := (Width - FImageMargin - FImage.width - textWidth) div 2; - if w < 3 then - w := 3; - TextX := w; - end - else - begin - textX := ImageX - textWidth - FImageSpacing; - if textX < 3 then - textX := 3; - end; - end; - end; - end - else - begin // no image, - ImageY := 0; - ImageX := 0; - TextX := (Width - textWidth) div 2; - end; - end - else // if ImageLayout in [ilImageTop, ilImageBottom] then - begin - TextX := (Width - textWidth) div 2; - // center horizontaly - if FShowImage and assigned (FImage) then - begin - ImageX := (Width - FImage.Width) div 2; - // vertical places if image and text - if FImageMargin = -1 then - begin // Free space between border and image is the same as between border and text - if FImageSpacing = -1 then // free space between image/text = border/text = border/image - begin - w := (Height - FImage.Height - textHeight) div 3; - if w < 3 then // minimal margin from border for rectangle/focusrect/... - w := 3; - if FImageLayout = ilImageTop then - begin - ImageY := w; - TextY := Height - w - textHeight; - end - else // if FImageLayout = ilImageBottom then - begin - ImageY := Height - w - FImage.Height; - TextY := w; - end; - end - else // fixed space between image/text - begin - w := (Height - FImageSpacing - FImage.Height - textHeight) div 2; - if w < 3 then // minimal margin from border for rectangle/focusrect/... - w := 3; - if FImageLayout = ilImageTop then - begin - ImageY := w; - TextY := w + FImage.Height + FImageSpacing; - end - else // if FImageLayout = ilImageRight then - begin - ImageY := Height - w - FImage.Height; - TextY := w; - end; - end; - end - else // Fixed image - begin - if FImageLayout = ilImageTop then - begin - ImageY := FImageMargin + 3; - if FImageSpacing = -1 then - begin - w := (Height - FImage.Height - ImageY - textHeight) div 2; - if w < 0 then - w := 0; - end - else - w := FImageSpacing; - TextY := ImageY + FImage.Height + w; - end - else // if FImageLayout = ilImageRight then - begin - ImageY := Height - FImageMargin - 3 - FImage.Height; - if FImageSpacing = -1 then - begin - w := (Height - FImageMargin - FImage.Height - textHeight) div 2; - if w < 3 then - w := 3; - TextY := w; - end - else - begin - textY := ImageY - textHeight - FImageSpacing; - if textY < 3 then - textY := 3; - end; - end; - end; - end - else - begin // no image, - ImageY := 0; - ImageX := 0; - TextY := (Height - textHeight) div 2; - end; - end; - end; - - -var - AText: string; - tx, ty, ix, iy: integer; - r: TfpgRect; - pofs: integer; - lBtnFlags: TFButtonFlags; - clr: TfpgColor; - -begin -// inherited HandlePaint; - Canvas.ClearClipRect; - - r.SetRect(0, 0, Width, Height); - - lBtnFlags := []; - if FDown then - Include(lBtnFlags, btfIsPressed); - - if FFocused and (not FEmbedded) then - Include(lBtnFlags, btfHasFocus); - - if FEmbedded then - Include(lBtnFlags, btfIsEmbedded); - - // In the UI Designer we want the button more visible - if not (csDesigning in ComponentState) then - begin - if FFlat and (FState = 1) then // mouse over - Include(lBtnFlags, btfHover) - else if FFlat then - Include(lBtnFlags, btfFlat); - end; - - if not FFlat and FDefault then - Include(lBtnFlags, btfIsDefault); - - if FBackgroundColor <> clButtonFace then - begin - clr := fpgColorToRGB(clButtonFace); - fpgSetNamedColor(clButtonface, FBackgroundColor); - Canvas.DrawButtonFace(r, lBtnFlags); - fpgSetNamedColor(clButtonface, clr); - end - else - Canvas.DrawButtonFace(r, lBtnFlags); - - if FFocused and (not FEmbedded) then - begin - InflateRect(r, -3, -3); - Canvas.DrawFocusRect(r); - end; - - Canvas.SetTextColor(FTextColor); - Canvas.SetColor(clText1); - - Canvas.SetClipRect(r); - Canvas.SetFont(Font); - AText := FText; - - if FDown then - pofs := 1 - else - pofs := 0; - - CalculatePositions (ix, iy, tx, ty); - - if FShowImage and assigned (FImage) then - Canvas.DrawImage(ix + pofs, iy + pofs, FImage); - - fpgStyle.DrawString(Canvas, tx+pofs, ty+pofs, Text, Enabled); -end; - -procedure TfpgBaseButton.DoPush; -var - n: integer; - c: TComponent; -begin - FClickOnPush := (not FDown) and AllowDown; - - // search the other buttons in the group - for n := 0 to Parent.ComponentCount - 1 do - begin - c := Parent.Components[n]; - if (c <> self) and (c is TfpgBaseButton) then - with TfpgBaseButton(c) do - if GroupIndex = self.GroupIndex then - Down := False; - end; - - FDown := True; - FClicked := True; - - RePaint; - if FClickOnPush then - Click; -end; - -procedure TfpgBaseButton.DoRelease(x, y: integer); -var - r: TfpgRect; -begin - r.SetRect(0, 0, Width, Height); - if AllowDown then - begin - if FDown and (not FClickOnPush) and FAllowAllUp then - begin - FDown := False; - RePaint; - fpgApplication.ProcessMessages; - if PtInRect(r, Point(x, y)) then - Click; - end; - end - else - begin - if FDown and FClicked then - begin - FDown := False; - RePaint; - fpgApplication.ProcessMessages; - if PtInRect(r, Point(x, y)) then - Click; - end; - end; - - FClickOnPush := False; - FClicked := False; -end; - -procedure TfpgBaseButton.HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); -begin - if (keycode = keyReturn) or (keycode = keySpace) or (keycode = keyPEnter) then - begin - DoPush; - Consumed := True; - end - else - inherited; -end; - -procedure TfpgBaseButton.HandleKeyRelease(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); -begin - if (keycode = keyReturn) or (keycode = keySpace) or (keycode = keyPEnter) then - begin - DoRelease(1, 1); // fake co-ordinates to it executes the Click - Consumed := True; - end - else - inherited; -end; - -procedure TfpgBaseButton.HandleLMouseDown(X, Y: integer; ShiftState: TShiftState); -begin - inherited; - if (csDesigning in ComponentState) then - Exit; - CaptureMouse; - DoPush; -end; - -procedure TfpgBaseButton.HandleLMouseUp(x, y: integer; shiftstate: TShiftState); -begin -// inherited; - if (csDesigning in ComponentState) then - Exit; - ReleaseMouse; - DoRelease(x, y); -end; - -procedure TfpgBaseButton.HandleMouseExit; -begin - inherited HandleMouseExit; - if (csDesigning in ComponentState) then - Exit; - if Enabled then - FState := 0; - if FDown and (not AllowDown) then - begin - FDown := False; - Repaint; - end - else if FFlat then - begin - if Enabled then - Repaint; - end; -end; - -procedure TfpgBaseButton.HandleMouseEnter; -begin - inherited HandleMouseEnter; - if (csDesigning in ComponentState) then - Exit; - if Enabled then - FState := 1; - if FClicked and (not AllowDown) then - begin - FDown := True; - Repaint; - end - else if FFlat then - begin - if Enabled then - Repaint; - end; -end; - -procedure TfpgBaseButton.Click; -var - pform: TfpgForm; -begin - if (not AllowDown) then - begin - FDown := False; - FClicked := False; - end; - - pform := WidgetParentForm(self); - if pform <> nil then - pform.ModalResult := ModalResult; - - if Assigned(OnClick) then - OnClick(self); -end; - -function TfpgBaseButton.GetCommand: ICommand; -begin - Result := FCommand; -end; - -procedure TfpgBaseButton.SetCommand(ACommand: ICommand); -begin - FCommand := ACommand; -end; - -procedure TfpgBaseButton.SetImageMargin(const Value: integer); -begin - FImageMargin := Value; - Repaint; -end; - -procedure TfpgBaseButton.SetImageSpacing(const Value: integer); -begin - FImageSpacing := Value; - Repaint; -end; - -procedure TfpgBaseButton.SetImageLayout(const AValue: TImageLayout); -begin - if FImageLayout <> AValue then - begin - FImageLayout := AValue; - Repaint; //Isn't Invalidate better ? - end; -end; - -function TfpgBaseButton.GetAllowDown: Boolean; -begin - Result := GroupIndex > 0; -end; - -procedure TfpgBaseButton.SetAllowDown(const Value: Boolean); -begin - GroupIndex := 1; -end; - -procedure TfpgBaseButton.SetAllowAllUp(const Value: boolean); -begin - FAllowAllUp := Value; -end; - -end. - diff --git a/src/gui/gui_checkbox.pas b/src/gui/gui_checkbox.pas deleted file mode 100644 index 17146eb3..00000000 --- a/src/gui/gui_checkbox.pas +++ /dev/null @@ -1,216 +0,0 @@ -{ - fpGUI - Free Pascal GUI Toolkit - - Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this - distribution, for details of the copyright. - - See the file COPYING.modifiedLGPL, included in this distribution, - for details about redistributing fpGUI. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - - Description: - Defines a CheckBox control. Also known as a Check Button control. -} - -unit gui_checkbox; - -{$mode objfpc}{$H+} - -interface - -uses - Classes, - SysUtils, - fpg_base, - fpg_main, - fpg_widget; - -type - - TfpgCheckBox = class(TfpgWidget) - private - FChecked: boolean; - FOnChange: TNotifyEvent; - FText: string; - FFont: TfpgFont; - FBoxSize: integer; - FIsPressed: boolean; - function GetFontDesc: string; - procedure SetChecked(const AValue: boolean); - procedure SetFontDesc(const AValue: string); - procedure SetText(const AValue: string); - protected - procedure HandlePaint; override; - procedure HandleLMouseDown(x, y: integer; shiftstate: TShiftState); override; - procedure HandleLMouseUp(x, y: integer; shiftstate: TShiftState); override; - procedure HandleKeyRelease(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - property Font: TfpgFont read FFont; - published - property BackgroundColor; - property Checked: boolean read FChecked write SetChecked default False; - property FontDesc: string read GetFontDesc write SetFontDesc; - property ParentShowHint; - property ShowHint; - property TabOrder; - property Text: string read FText write SetText; - property TextColor; - property OnChange: TNotifyEvent read FOnChange write FOnChange; - end; - - -function CreateCheckBox(AOwner: TComponent; x, y: TfpgCoord; AText: string): TfpgCheckBox; - -implementation - -function CreateCheckBox(AOwner: TComponent; x, y: TfpgCoord; AText: string): TfpgCheckBox; -begin - Result := TfpgCheckBox.Create(AOwner); - Result.Top := y; - Result.Left := x; - Result.Text := AText; - Result.Width := Result.Font.TextWidth(Result.Text) + 24; -end; - -{ TfpgCheckBox } - -procedure TfpgCheckBox.SetChecked(const AValue: boolean); -begin - if FChecked = AValue then - Exit; //==> - FChecked := AValue; - RePaint; -end; - -function TfpgCheckBox.GetFontDesc: string; -begin - Result := FFont.FontDesc; -end; - -procedure TfpgCheckBox.SetFontDesc(const AValue: string); -begin - FFont.Free; - FFont := fpgGetFont(AValue); - RePaint; -end; - -procedure TfpgCheckBox.SetText(const AValue: string); -begin - if FText = AValue then - Exit; //==> - FText := AValue; - RePaint; -end; - -procedure TfpgCheckBox.HandlePaint; -var - r: TfpgRect; - ty: integer; - tx: integer; - ix: integer; - img: TfpgImage; -begin - inherited HandlePaint; - - Canvas.SetColor(FBackgroundColor); - Canvas.FillRectangle(0, 0, Width, Height); - Canvas.SetFont(Font); - - if FFocused then - begin - Canvas.SetColor(clText1); - Canvas.SetLineStyle(1, lsDot); - Canvas.DrawRectangle(1, 1, Width-2, Height-2); - end; - Canvas.SetLineStyle(1, lsSolid); - - r.SetRect(2, (Height div 2) - (FBoxSize div 2), FBoxSize, FBoxSize); - if r.top < 0 then - r.top := 0; - - // calculate which image to paint. - if Enabled then - begin - ix := Ord(FChecked); - if FIsPressed then - Inc(ix, 2); - end - else - ix := (2 + (Ord(FChecked) * 2)) - Ord(FChecked); - - // paint the check (in this case a X) - tx := r.right + 8; - inc(r.left, 2); - inc(r.top, 1); - img := fpgImages.GetImage('sys.checkboxes'); // Do NOT localize - Canvas.DrawImagePart(r.Left, r.Top, img, ix*13, 0, 13, 13); - - ty := (Height div 2) - (Font.Height div 2); - if ty < 0 then - ty := 0; - Canvas.SetTextColor(FTextColor); - fpgStyle.DrawString(Canvas, tx, ty, FText, Enabled); -end; - -procedure TfpgCheckBox.HandleLMouseDown(x, y: integer; shiftstate: TShiftState); -begin - inherited HandleLMouseDown(x, y, shiftstate); - FIsPressed := True; - Repaint; -end; - -procedure TfpgCheckBox.HandleLMouseUp(x, y: integer; shiftstate: TShiftState); -begin - inherited HandleLMouseUp(x, y, shiftstate); - FIsPressed := False; - Checked := not FChecked; - if Assigned(FOnChange) then - FOnChange(self); -end; - -procedure TfpgCheckBox.HandleKeyRelease(var keycode: word; - var shiftstate: TShiftState; var consumed: boolean); -begin - if (keycode = keySpace) or (keycode = keyReturn) or (keycode = keyPEnter) then - begin - consumed := True; - Checked := not FChecked; - if Assigned(FOnChange) then - FOnChange(self); - end; - - if consumed then - Exit; //==> - - inherited HandleKeyRelease(keycode, shiftstate, consumed); -end; - -constructor TfpgCheckBox.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - FText := 'CheckBox'; - FFont := fpgGetFont('#Label1'); - FHeight := FFont.Height + 4; - FWidth := 120; - FTextColor := Parent.TextColor; - FBackgroundColor := Parent.BackgroundColor; - FFocusable := True; - FBoxSize := 14; - FChecked := False; - FIsPressed := False; - FOnChange := nil; -end; - -destructor TfpgCheckBox.Destroy; -begin - FFont.Free; - inherited Destroy; -end; - -end. - diff --git a/src/gui/gui_combobox.pas b/src/gui/gui_combobox.pas deleted file mode 100644 index 7fc2ef18..00000000 --- a/src/gui/gui_combobox.pas +++ /dev/null @@ -1,676 +0,0 @@ -{ - fpGUI - Free Pascal GUI Toolkit - - Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this - distribution, for details of the copyright. - - See the file COPYING.modifiedLGPL, included in this distribution, - for details about redistributing fpGUI. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - - Description: - Defines a ComboBox control. Also known as a Choice List control. -} - -unit gui_combobox; - -{$mode objfpc}{$H+} - -{.$Define DEBUG} - -{ TODO: When combobox Items changes, the combobox needs to refresh. We need a - custom StringItems class to notify us of changes. See TfpgListBox for - an example. } - -{ TODO: Implement .BeginUpdate and .EndUpdate methods so we know when to refresh - the items list. } - -{ -This is an example of what we can aim for: -You need a mono font to see the correct layout. - - - TfpgBaseComboBox - _________|______________ - | | - TfpgBaseStaticCombo TfpgBaseEditCombo - ______|_________ | - | | TfpgEditCombo - | | - TfpgComboBox TfpgBaseColorCombo - | - TfpgColorComboBox -} - -interface - -uses - Classes, - SysUtils, - fpg_base, - fpg_main, - fpg_widget, - fpg_popupwindow; - -type - // widget options - TfpgComboOption = (wo_FocusItemTriggersOnChange, wo_AllowUserBlank); - TfpgComboOptions = set of TfpgComboOption; - - - TfpgBaseComboBox = class(TfpgWidget) - private - FDropDownCount: integer; - FFont: TfpgFont; - FOnChange: TNotifyEvent; - FOnCloseUp: TNotifyEvent; - FOnDropDown: TNotifyEvent; - FOptions: TfpgComboOptions; - function GetFontDesc: string; - procedure SetDropDownCount(const AValue: integer); - procedure SetFocusItem(const AValue: integer); - procedure SetFontDesc(const AValue: string); - protected - FInternalBtnRect: TfpgRect; - FFocusItem: integer; - FItems: TStringList; - FBtnPressed: Boolean; - procedure CalculateInternalButtonRect; virtual; - procedure InternalOnClose(Sender: TObject); - procedure InternalItemsChanged(Sender: TObject); virtual; - procedure HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override; - procedure DoOnChange; virtual; - procedure DoOnDropDown; virtual; - procedure DoDropDown; virtual; abstract; - procedure DoOnCloseUp; virtual; - procedure PaintInternalButton; virtual; - function GetDropDownPos(AParent, AComboBox, ADropDown: TfpgWidget): TfpgRect; virtual; - property DropDownCount: integer read FDropDownCount write SetDropDownCount default 8; - property FocusItem: integer read FFocusItem write SetFocusItem; - property FontDesc: string read GetFontDesc write SetFontDesc; - property Items: TStringList read FItems; {$Note Make this read/write } - property Options: TfpgComboOptions read FOptions write FOptions; - property OnChange: TNotifyEvent read FOnChange write FOnChange; - property OnCloseUp: TNotifyEvent read FOnCloseUp write FOnCloseUp; - property OnDropDown: TNotifyEvent read FOnDropDown write FOnDropDown; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - property Font: TfpgFont read FFont; - end; - - - { TfpgBaseStaticCombo } - - TfpgBaseStaticCombo = class(TfpgBaseComboBox) - private - procedure InternalBtnClick(Sender: TObject); - protected - FMargin: integer; - FDropDown: TfpgPopupWindow; - procedure DoDropDown; override; - function GetText: string; virtual; - function HasText: boolean; virtual; - procedure SetText(const AValue: string); virtual; - procedure HandleResize(AWidth, AHeight: TfpgCoord); override; - procedure HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override; - procedure HandleLMouseDown(x, y: integer; shiftstate: TShiftState); override; - procedure HandleLMouseUp(x, y: integer; shiftstate: TShiftState); override; - procedure HandleMouseScroll(x, y: integer; shiftstate: TShiftState; delta: smallint); override; - procedure HandlePaint; override; - property Text: string read GetText write SetText; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - procedure Update; - end; - - - TfpgComboBox = class(TfpgBaseStaticCombo) - published - property BackgroundColor default clBoxColor; - property DropDownCount; - property FocusItem; - property FontDesc; - property Height; - property Items; - property Options; - property ParentShowHint; - property ShowHint; - property TabOrder; - property Text; - property TextColor; - property Width; - property OnChange; - property OnCloseUp; - property OnDropDown; - property OnEnter; - property OnExit; - end; - - -function CreateComboBox(AOwner: TComponent; x, y, w: TfpgCoord; AList: TStringList; - h: TfpgCoord = 0): TfpgComboBox; - - -implementation - -uses - gui_listbox, - math; - -var - OriginalFocusRoot: TfpgWidget; - -type - { This is the class representing the dropdown window of the combo box. } - TComboboxDropdownWindow = class(TfpgPopupWindow) - private - FCallerWidget: TfpgBaseStaticCombo; - FListBox: TfpgListBox; - procedure SetFirstItem; - protected - procedure ListBoxSelect(Sender: TObject); - procedure HandleShow; override; - procedure HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override; - public - constructor Create(AOwner: TComponent; ACallerWidget: TfpgBaseStaticCombo); reintroduce; - property ListBox: TfpgListBox read FListBox; - end; - - -{ TfpgBaseComboBox } - -procedure TfpgBaseComboBox.SetDropDownCount(const AValue: integer); -begin - if FDropDownCount = AValue then - Exit; - FDropDownCount := AValue; -end; - -function TfpgBaseComboBox.GetFontDesc: string; -begin - Result := FFont.FontDesc; -end; - -{ Focusitem is 0 based like the Delphi ItemIndex property. - So at startup, FocusItem = -1 which means nothing is selected. If - FocusItem = 0 it means the first item is selected etc. } -procedure TfpgBaseComboBox.SetFocusItem(const AValue: integer); -begin - if FFocusItem = AValue then - Exit; //==> - FFocusItem := AValue; - - // do some limit check corrections - if FFocusItem < -1 then - FFocusItem := -1 // nothing is selected - else if FFocusItem > FItems.Count-1 then - FFocusItem := FItems.Count-1; - - RePaint; - if wo_FocusItemTriggersOnChange in FOptions then - DoOnChange; -end; - -procedure TfpgBaseComboBox.SetFontDesc(const AValue: string); -begin - FFont.Free; - FFont := fpgGetFont(AValue); - if Height < FFont.Height + 6 then - Height := FFont.Height + 6; - RePaint; -end; - -procedure TfpgBaseComboBox.CalculateInternalButtonRect; -begin - FInternalBtnRect.SetRect(Width - Min(Height, 20), 2, Min(Height, 20)-2, Height-4); -end; - -procedure TfpgBaseComboBox.InternalOnClose(Sender: TObject); -begin - DoOnCloseUp; -end; - -procedure TfpgBaseComboBox.InternalItemsChanged(Sender: TObject); -begin - if FItems.Count = 0 then - FocusItem := -1; - Repaint; -end; - -procedure TfpgBaseComboBox.HandleKeyPress(var keycode: word; - var shiftstate: TShiftState; var consumed: boolean); -var - old: integer; -begin - inherited HandleKeyPress(keycode, shiftstate, consumed); - if not consumed then - begin - old := FocusItem; - case keycode of - keyDown: - begin - if (shiftstate = [ssAlt]) then - DoDropDown - else - begin - FocusItem := FocusItem + 1; - if old <> FocusItem then - DoOnChange; - consumed := True; - end; - end; - - keyUp: - begin - if (FocusItem = 0) and (wo_AllowUserBlank in FOptions) then - FocusItem := FocusItem - 1 - else if FocusItem > 0 then - FocusItem := FocusItem - 1; - if old <> FocusItem then - DoOnChange; - consumed := True; - end; - end; { case } - end; { if } -end; - -procedure TfpgBaseComboBox.DoOnChange; -begin - if Assigned(OnChange) then - FOnChange(self); -end; - -procedure TfpgBaseComboBox.DoOnDropDown; -begin - if Assigned(OnDropDown) then - FOnDropDown(self); -end; - -procedure TfpgBaseComboBox.DoOnCloseUp; -begin - if Assigned(OnCloseUp) then - OnCloseUp(self); -end; - -procedure TfpgBaseComboBox.PaintInternalButton; -var - ar: TfpgRect; - btnflags: TFButtonFlags; -begin - Canvas.BeginDraw; - btnflags := []; - ar := FInternalBtnRect; - InflateRect(ar, -2, -2); - if FBtnPressed then - begin - Include(btnflags, btfIsPressed); - OffsetRect(ar, 1, 1); - end; - // paint button face - fpgStyle.DrawButtonFace(Canvas, - FInternalBtnRect.Left, - FInternalBtnRect.Top, - FInternalBtnRect.Width, - FInternalBtnRect.Height, btnflags); - if Enabled then - Canvas.SetColor(clText1) - else - Canvas.SetColor(clShadow1); - - // paint arrow - fpgStyle.DrawDirectionArrow(Canvas, ar.Left, ar.Top, ar.Width, ar.Height, adDown); - Canvas.EndDraw(FInternalBtnRect); -end; - -function TfpgBaseComboBox.GetDropDownPos(AParent, AComboBox, ADropDown: TfpgWidget): TfpgRect; -var - pt: TPoint; -begin - // translate ComboBox coordinates - pt := WindowToScreen(AParent, Point(AComboBox.Left, AComboBox.Bottom)); - - // dropdown will not fit below combobox so we place it above - if (pt.y + ADropDown.Height) > fpgApplication.ScreenHeight then - Result.Top := AComboBox.Top - ADropDown.Height - else - Result.Top := AComboBox.Bottom; - - // dropdown height doesn't fit in screen height so shrink it - if (ADropDown.Height > fpgApplication.ScreenHeight) then - begin - // 50 is just some spacing for taskbars (top or bottom aligned) - Result.Top := AComboBox.Top - pt.y + 50; - Result.Height := fpgApplication.ScreenHeight - 50; - end - else - Result.Height := ADropDown.Height; - - Result.Left := AComboBox.Left; - Result.Width := ADropDown.Width; -end; - -constructor TfpgBaseComboBox.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - FDropDownCount := 8; - FFocusItem := -1; // nothing is selected - FItems := TStringList.Create; - FItems.OnChange := @InternalItemsChanged; - FFont := fpgGetFont('#List'); - FOptions := []; - FBtnPressed := False; - FOnChange := nil; -end; - -destructor TfpgBaseComboBox.Destroy; -begin - FFont.Free; - FItems.Free; - inherited Destroy; -end; - -{ TComboboxDropdownWindow } - -procedure TComboboxDropdownWindow.SetFirstItem; -var - i: integer; -begin - // If FocusItem is less than DropDownCount FirsItem = 0 - if ListBox.FocusItem+1 <= FCallerWidget.DropDownCount then - ListBox.SetFirstItem(0) - // If FocusItem is in the last DropDownCount of items - else if (ListBox.ItemCount - (ListBox.FocusItem+1)) < FCallerWidget.DropDownCount then - ListBox.SetFirstItem(ListBox.ItemCount - FCallerWidget.DropDownCount) - else - // Try and centre FocusItem in the drow down window - ListBox.SetFirstItem(ListBox.FocusItem - (FCallerWidget.DropDownCount div 2)); -end; - -procedure TComboboxDropdownWindow.ListBoxSelect(Sender: TObject); -begin - FCallerWidget.FocusItem := ListBox.FocusItem; - if not (wo_FocusItemTriggersOnChange in FCallerWidget.FOptions) then - FCallerWidget.DoOnChange; - Close; -end; - -procedure TComboboxDropdownWindow.HandleShow; -begin - ListBox.SetPosition(0, 0, Width, Height); - inherited HandleShow; - SetFirstItem; - ListBox.SetFocus; -end; - -procedure TComboboxDropdownWindow.HandleKeyPress(var keycode: word; - var shiftstate: TShiftState; var consumed: boolean); -begin - inherited HandleKeyPress(keycode, shiftstate, consumed); - if KeyCode = keyEscape then - begin - Close; - end -end; - -constructor TComboboxDropdownWindow.Create(AOwner: TComponent; ACallerWidget: TfpgBaseStaticCombo); -begin - inherited Create(nil); - Name := '_ComboboxDropdownWindow'; - if not Assigned(ACallerWidget) then - raise Exception.Create('ACallerWidget may not be '); - FCallerWidget := ACallerWidget; - - FListBox := CreateListBox(self, 0, 0, 80, 100); - FListBox.PopupFrame := True; - FListBox.Items.Assign(FCallerWidget.Items); - FListBox.FocusItem := FCallerWidget.FocusItem; - FListBox.OnSelect := @ListBoxSelect; -end; - - - -function CreateComboBox(AOwner: TComponent; x, y, w: TfpgCoord; AList: TStringList; - h: TfpgCoord = 0): TfpgComboBox; -begin - Result := TfpgComboBox.Create(AOwner); - Result.Left := x; - Result.Top := y; - Result.Width := w; - Result.Focusable := True; - - if h < TfpgComboBox(Result).FFont.Height + 6 then - Result.Height:= TfpgComboBox(Result).FFont.Height + 6 - else - Result.Height:= h; - - if Assigned(AList) then - Result.Items.Assign(AList); -end; - -{ TfpgBaseStaticCombo } - -function TfpgBaseStaticCombo.GetText: string; -begin - if (FocusItem >= 0) and (FocusItem < FItems.Count) then - Result := Items.Strings[FocusItem] - else - Result := ''; -end; - -function TfpgBaseStaticCombo.HasText: boolean; -begin - Result := FocusItem >= 0; -end; - -procedure TfpgBaseStaticCombo.DoDropDown; -var - ddw: TComboboxDropdownWindow; - rowcount: integer; - r: TfpgRect; -begin - {$IFDEF DEBUG} - write('DoDropDown'); - {$ENDIF} - if (not Assigned(FDropDown)) or (not FDropDown.HasHandle) then - begin - {$IFDEF DEBUG} - writeln('.... creating'); - {$ENDIF} - FreeAndNil(FDropDown); - OriginalFocusRoot := FocusRootWidget; - - FDropDown := TComboboxDropdownWindow.Create(nil, self); - ddw := TComboboxDropdownWindow(FDropDown); - - // adjust the height of the dropdown - rowcount := FItems.Count; - if rowcount > FDropDownCount then - rowcount := FDropDownCount; - if rowcount < 1 then - rowcount := 1; // Even if empty at least show one line dropdown - - ddw.Width := Width; - ddw.Height := (ddw.ListBox.RowHeight * rowcount) + 4; - ddw.DontCloseWidget := self; // now we can control when the popup window closes - r := GetDropDownPos(Parent, self, ddw); // find suitable position - ddw.Height := r.Height; // in case GetDropDownPos resized us - - if (FItems.Count > 0) then - DoOnDropDown; - ddw.OnClose := @InternalOnClose; - - ddw.ShowAt(Parent, r.Left, r.Top); - end - else - begin - {$IFDEF DEBUG} - writeln('.... destroying'); - {$ENDIF} - FBtnPressed := False; - ddw := TComboboxDropdownWindow(FDropDown); - ddw.Close; - FreeAndNil(FDropDown); - end; -end; - -procedure TfpgBaseStaticCombo.InternalBtnClick(Sender: TObject); -begin - DoDropDown; -end; - -procedure TfpgBaseStaticCombo.SetText(const AValue: string); -var - i: integer; -begin - if AValue = '' then - SetFocusItem(-1) // nothing selected - else - begin - for i := 0 to FItems.Count-1 do - begin - if SameText(Items.Strings[i], AValue) then - begin - SetFocusItem(i); - Exit; //==> - end; - end; - // if we get here, we didn't find a match - SetFocusItem(-1); - end; -end; - -procedure TfpgBaseStaticCombo.HandleResize( AWidth, AHeight: TfpgCoord); -begin - inherited HandleResize(AWidth, AHeight); - if FSizeIsDirty then - CalculateInternalButtonRect; -end; - -procedure TfpgBaseStaticCombo.HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); -begin - inherited HandleKeyPress(keycode, shiftstate, consumed); - if consumed then - RePaint -end; - -procedure TfpgBaseStaticCombo.HandleLMouseDown(x, y: integer; shiftstate: TShiftState); -begin - inherited HandleLMouseDown(x, y, shiftstate); - // button state is down only if user clicked in the button rectangle. - FBtnPressed := PtInRect(FInternalBtnRect, Point(x, y)); - PaintInternalButton; - DoDropDown; -end; - -procedure TfpgBaseStaticCombo.HandleLMouseUp(x, y: integer; shiftstate: TShiftState); -begin - inherited HandleLMouseUp(x, y, shiftstate); - FBtnPressed := False; - PaintInternalButton; -end; - -procedure TfpgBaseStaticCombo.HandleMouseScroll(x, y: integer; - shiftstate: TShiftState; delta: smallint); -var - NewIndex: Integer; -begin - if (FDropDown <> nil) and FDropDown.Visible then - Exit; //==> - if Items.Count < 1 then - Exit; //==> - - NewIndex := FocusItem + Delta; - - if NewIndex > Items.Count-1 then - NewIndex := Items.Count-1; - - if NewIndex < 0 then - NewIndex := 0; - - if NewIndex <> FocusItem then - begin - FocusItem := NewIndex; - RePaint; - end; -end; - -procedure TfpgBaseStaticCombo.HandlePaint; -var - r: TfpgRect; -begin -// inherited HandlePaint; - Canvas.ClearClipRect; - r.SetRect(0, 0, Width, Height); - Canvas.DrawControlFrame(r); - - // internal background rectangle (without frame) - InflateRect(r, -2, -2); - Canvas.SetClipRect(r); - - if Enabled then - Canvas.SetColor(FBackgroundColor) - else - Canvas.SetColor(clWindowBackground); - - Canvas.FillRectangle(r); - - // paint the fake dropdown button - PaintInternalButton; - - Dec(r.Width, FInternalBtnRect.Width); - Canvas.SetClipRect(r); - Canvas.SetFont(Font); - - if Focused then - begin - Canvas.SetColor(clSelection); - Canvas.SetTextColor(clSelectionText); - InflateRect(r, -1, -1); - end - else - begin - if Enabled then - Canvas.SetColor(FBackgroundColor) - else - Canvas.SetColor(clWindowBackground); - Canvas.SetTextColor(FTextColor); - end; - Canvas.FillRectangle(r); - - // Draw select item's text - if HasText then - fpgStyle.DrawString(Canvas, FMargin+1, FMargin, Text, Enabled); -end; - -constructor TfpgBaseStaticCombo.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - FBackgroundColor := clBoxColor; - FTextColor := Parent.TextColor; - FWidth := 120; - FMargin := 3; - FHeight := Font.Height + (2*FMargin); - FFocusable := True; - - CalculateInternalButtonRect; -end; - -destructor TfpgBaseStaticCombo.Destroy; -begin - FDropDown.Free; - inherited Destroy; -end; - -procedure TfpgBaseStaticCombo.Update; -begin - FFocusItem := -1; - Repaint; -end; - -end. - diff --git a/src/gui/gui_customgrid.pas b/src/gui/gui_customgrid.pas deleted file mode 100644 index f3f989dc..00000000 --- a/src/gui/gui_customgrid.pas +++ /dev/null @@ -1,362 +0,0 @@ -{ - fpGUI - Free Pascal GUI Toolkit - - Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this - distribution, for details of the copyright. - - See the file COPYING.modifiedLGPL, included in this distribution, - for details about redistributing fpGUI. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - - Description: - Defines a Custom Grid control and basic Column class. -} - -unit gui_customgrid; - -{$mode objfpc}{$H+} - -{ - TODO: - * Column text alignment needs to be implemented. Currently always Centre. - * AlternateColor for rows need to be implemented. -} - -{.$Define DEBUG} - -interface - -uses - Classes, - SysUtils, - fpg_base, - fpg_main, - gui_basegrid; - -type - - // data object for grid columns - TfpgGridColumn = class(TObject) - private - FAlignment: TAlignment; - FLayout: TLayout; - FHMargin: Integer; - FTitle: string; - FWidth: integer; - FBackgroundColor: TfpgColor; - FTextColor: TfpgColor; - public - constructor Create; virtual; - property Width: integer read FWidth write FWidth; - property Title: string read FTitle write FTitle; - property Alignment: TAlignment read FAlignment write FAlignment; - property Layout: TLayout read FLayout write FLayout; - property BackgroundColor: TfpgColor read FBackgroundColor write FBackgroundColor; - property HMargin: Integer read FHMargin write FHMargin; - property TextColor: TfpgColor read FTextColor write FTextColor; - end; - - - TfpgCustomGrid = class(TfpgBaseGrid) - protected - FRowCount: Integer; - FColumns: TList; - procedure HandleSetFocus; override; - procedure SetTextColor(const AValue: TfpgColor); override; - function GetColumns(AIndex: integer): TfpgGridColumn; virtual; - procedure DoDeleteColumn(ACol: integer); virtual; - procedure DoSetRowCount(AValue: integer); virtual; - procedure DoAfterAddColumn(ACol: integer); virtual; - function DoCreateColumnClass: TfpgGridColumn; virtual; - function GetColumnCount: Integer; override; - procedure SetColumnCount(const AValue: Integer); virtual; - function GetRowCount: Integer; override; - procedure SetRowCount(const AValue: Integer); virtual; - function GetColumnWidth(ACol: Integer): integer; override; - procedure SetColumnWidth(ACol: Integer; const AValue: integer); override; - function GetColumnBackgroundColor(ACol: Integer): TfpgColor; override; - procedure SetColumnBackgroundColor(ACol: Integer; const AValue: TfpgColor); override; - function GetColumnTextColor(ACol: Integer): TfpgColor; override; - procedure SetColumnTextColor(ACol: Integer; const AValue: TfpgColor); override; - function GetHeaderText(ACol: Integer): string; override; - property RowCount: Integer read GetRowCount write SetRowCount; - property ColumnCount: Integer read GetColumnCount write SetColumnCount; - property Columns[AIndex: integer]: TfpgGridColumn read GetColumns; -// property AlternateColor: TColor read FAlternateColor write SetAlternateColor stored IsAltColorStored; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - function AddColumn(ATitle: string; AWidth: integer): TfpgGridColumn; virtual; - procedure DeleteColumn(AIndex: integer); virtual; - procedure MoveColumn(oldindex, newindex: integer); virtual; - end; - - -implementation - -{ TfpgGridColumn } - -constructor TfpgGridColumn.Create; -begin - Width := 65; - Title := ''; - Alignment := taLeftJustify; - Layout := tlCenter; - HMargin := 2; -end; - -{ TfpgCustomGrid } - -function TfpgCustomGrid.GetRowCount: Integer; -begin - Result := FRowCount; -end; - -procedure TfpgCustomGrid.HandleSetFocus; -begin - inherited HandleSetFocus; - if (GetRowCount > 0) and (FocusRow = -1) then - begin - FocusRow := 0; - FocusCol := 0; - Repaint; - end; -end; - -procedure TfpgCustomGrid.SetTextColor(const AValue: TfpgColor); -var - i: integer; -begin - inherited SetTextColor(AValue); - for i := 0 to ColumnCount-1 do - begin - TfpgGridColumn(FColumns.Items[i]).TextColor := AValue; - end; - Repaint; -end; - -function TfpgCustomGrid.GetColumns(AIndex: integer): TfpgGridColumn; -begin - if (AIndex < 0) or (AIndex > FColumns.Count-1) then - Result := nil - else - Result := TfpgGridColumn(FColumns[AIndex]); -end; - -procedure TfpgCustomGrid.DoDeleteColumn(ACol: integer); -begin - TfpgGridColumn(FColumns.Items[ACol]).Free; - FColumns.Delete(ACol); -end; - -procedure TfpgCustomGrid.DoSetRowCount(AValue: integer); -begin - // do nothing yet -end; - -procedure TfpgCustomGrid.DoAfterAddColumn(ACol: integer); -begin - // do nothing yet - // update empty cells in descendants -end; - -function TfpgCustomGrid.DoCreateColumnClass: TfpgGridColumn; -begin - Result := TfpgGridColumn.Create; -end; - -function TfpgCustomGrid.GetColumnCount: Integer; -begin - Result := FColumns.Count; -end; - -procedure TfpgCustomGrid.SetColumnCount(const AValue: Integer); -var - n: Integer; -begin - n := FColumns.Count; - if (n = AValue) or (AValue < 0) then - Exit; //==> - - if n < AValue then - begin - // adding columns - while n < AValue do - begin - AddColumn('', DefaultColWidth); - inc(n); - end; - end - else - begin - // removing columns - while n > AValue do - begin - DoDeleteColumn(n-1); - dec(n); - end; - end; - - // graemeg 2008-07-18: I believe after all the repaint and event fixes - // this check is not required anymore. -// if csUpdating in ComponentState then -// Exit; - UpdateScrollBars; - RePaint; -end; - -procedure TfpgCustomGrid.SetRowCount(const AValue: Integer); -begin - if FRowCount = AValue then - Exit; //==> - FRowCount := AValue; - if FocusRow > FRowCount-1 then - FocusRow := FRowCount-1; - DoSetRowCount(AValue); // could be implemented by descendants - - // graemeg 2008-07-18: I believe after all the repaint and event fixes - // this check is not required anymore. -// if csUpdating in ComponentState then -// Exit; - UpdateScrollBars; - RePaint; -end; - -function TfpgCustomGrid.GetColumnWidth(ACol: Integer): integer; -begin - if (ACol >= 0) and (ACol < ColumnCount) then - Result := TfpgGridColumn(FColumns[ACol]).Width - else - result := DefaultColWidth; -end; - -procedure TfpgCustomGrid.SetColumnWidth(ACol: Integer; const AValue: integer); -var - lCol: TfpgGridColumn; -begin - lCol := TfpgGridColumn(FColumns[ACol]); - - if lCol.Width <> AValue then - begin - if AValue < 1 then - lCol.Width := 1 - else - lCol.Width := AValue; - UpdateScrollBars; - Repaint; - end; -end; - -function TfpgCustomGrid.GetColumnBackgroundColor(ACol: Integer): TfpgColor; -begin - if (ACol >= 0) and (ACol < ColumnCount) then - Result := TfpgGridColumn(FColumns[ACol]).FBackgroundColor - else - result := BackgroundColor; -end; - -procedure TfpgCustomGrid.SetColumnBackgroundColor(ACol: Integer; const AValue: TfpgColor); -var - lCol: TfpgGridColumn; -begin - lCol := TfpgGridColumn(FColumns[ACol]); - - if lCol.FBackgroundColor <> AValue then - begin - lCol.FBackgroundColor := AValue; -// UpdateScrollBars; - Repaint; - end; -end; - -function TfpgCustomGrid.GetColumnTextColor(ACol: Integer): TfpgColor; -begin - if (ACol >= 0) and (ACol < ColumnCount) then - Result := TfpgGridColumn(FColumns[ACol]).FTextColor - else - result := TextColor; -end; - -procedure TfpgCustomGrid.SetColumnTextColor(ACol: Integer; const AValue: TfpgColor); -var - lCol: TfpgGridColumn; -begin - lCol := TfpgGridColumn(FColumns[ACol]); - - if lCol.FTextColor <> AValue then - begin - lCol.FTextColor := AValue; -// UpdateScrollBars; - Repaint; - end; -end; - -function TfpgCustomGrid.GetHeaderText(ACol: Integer): string; -begin - Result := TfpgGridColumn(FColumns[ACol]).Title; -end; - -constructor TfpgCustomGrid.Create(AOwner: TComponent); -begin - FColumns := TList.Create; - inherited Create(AOwner); - ColumnCount := 0; - RowCount := 0; -end; - -destructor TfpgCustomGrid.Destroy; -begin - while FColumns.Count > 0 do - begin - TfpgGridColumn(FColumns.Items[0]).Free; - FColumns.Delete(0); - end; - - FColumns.Free; - inherited Destroy; -end; - -function TfpgCustomGrid.AddColumn(ATitle: string; AWidth: integer): TfpgGridColumn; -var - i: integer; -begin - Result := DoCreateColumnClass; - Result.Title := ATitle; - Result.Width := AWidth; - Result.Backgroundcolor := clBoxcolor; - Result.TextColor := TextColor; - i := FColumns.Add(Result); - DoAfterAddColumn(i); // update empty cells in descendants - - if csUpdating in ComponentState then - Exit; //==> - - UpdateScrollBars; - RePaint; -end; - -procedure TfpgCustomGrid.DeleteColumn(AIndex: integer); -var - c: TfpgGridColumn; -begin - c := Columns[AIndex]; - if c <> nil then - begin - DoDeleteColumn(AIndex); - if HasHandle then - Update; - end; -end; - -procedure TfpgCustomGrid.MoveColumn(oldindex, newindex: integer); -begin - FColumns.Move(oldindex, newindex); - if HasHandle then - Update; -end; - -end. - diff --git a/src/gui/gui_dialogs.pas b/src/gui/gui_dialogs.pas deleted file mode 100644 index 0f1035fb..00000000 --- a/src/gui/gui_dialogs.pas +++ /dev/null @@ -1,1387 +0,0 @@ -{ - fpGUI - Free Pascal GUI Toolkit - - Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this - distribution, for details of the copyright. - - See the file COPYING.modifiedLGPL, included in this distribution, - for details about redistributing fpGUI. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - - Description: - Standard dialogs used by fpGUI based applications. -} - -unit gui_dialogs; - -{$mode objfpc}{$H+} - -{ - TODO: - * Try and refactor the code to remove all IFDEF's - * Implement MessageDlg with icons and buttons [Work-In-Progress] - * Select Directory dialog (treeview style) -} - -{.$Define DEBUG} - -interface - -uses - Classes, - SysUtils, - fpg_base, - fpg_main, - fpg_imgfmt_bmp, - fpg_constants, - gui_form, - gui_button, - gui_label, - gui_listbox, - gui_checkbox, - gui_edit, - gui_grid, - gui_combobox, - gui_panel, - gui_memo; - -type - TfpgMsgDlgType = (mtAbout, mtWarning, mtError, mtInformation, mtConfirmation, - mtCustom); - - TfpgMsgDlgBtn = (mbNoButton, mbOK, mbCancel, mbYes, mbNo, mbAbort, - mbRetry, mbIgnore, mbAll, mbNoToAll, mbYesToAll, mbHelp, mbClose); - - TfpgMsgDlgButtons = set of TfpgMsgDlgBtn; - -const - mbYesNoCancel = [mbYes, mbNo, mbCancel]; - mbYesNo = [mbYes, mbNo]; - mbOKCancel = [mbOK, mbCancel]; - mbAbortRetryIgnore = [mbAbort, mbRetry, mbIgnore]; - - // make Select File Dialog calls more readable - sfdOpen = True; - sfdSave = False; - - cMsgDlgBtnText: array[TfpgMsgDlgBtn] of string = - ( '', rsOK, rsCancel, rsYes, rsNo, rsAbort, rsRetry, rsIgnore, - rsAll, rsNoToAll, rsYesToAll, rsHelp, rsClose ); - -type - - TfpgMessageBox = class(TfpgForm) - private - FLines: TStringList; - FFont: TfpgFont; - FTextY: integer; - FLineHeight: integer; - FMaxLineWidth: integer; - FButton: TfpgButton; - FCentreText: Boolean; - protected - procedure HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override; - procedure HandlePaint; override; - procedure HandleShow; override; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - procedure SetMessage(AMessage: string); - property CentreText: Boolean read FCentreText write FCentreText default False; - end; - - - TfpgBaseDialog = class(TfpgForm) - protected - FSpacing: integer; - FDefaultButtonWidth: integer; - btnOK: TfpgButton; - btnCancel: TfpgButton; - procedure btnOKClick(Sender: TObject); virtual; - procedure btnCancelClick(Sender: TObject); virtual; - procedure HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override; - procedure SetupCaptions; virtual; - public - constructor Create(AOwner: TComponent); override; - end; - - - TfpgFontSelectDialog = class(TfpgBaseDialog) - private - FSampleText: string; - FMode: Byte; // 1 - Normal Fonts; 2 - Alias Fonts - lblLabel1: TfpgLabel; - lblTypeface: TfpgLabel; - lblSize: TfpgLabel; - lblLabel4: TfpgLabel; - lblLabel5: TfpgLabel; - lbCollection: TfpgListBox; - lbFaces: TfpgListBox; - lbSize: TfpgListBox; - cbBold: TfpgCheckBox; - cbItalic: TfpgCheckBox; - cbUnderline: TfpgCheckBox; - cbAntiAlias: TfpgCheckBox; - memSample: TfpgMemo; - procedure OnCollectionChanged(Sender: TObject); - procedure OnParamChange(Sender: TObject); - procedure OnSameTextChanged(Sender: TObject); - procedure CreateFontList; - procedure CreateFontAliasList; - procedure SetupUI(AMode: Byte); - protected - function GetFontDesc: string; - procedure SetFontDesc(Desc: string); - procedure SetupCaptions; override; - public - constructor Create(AOwner: TComponent); override; - procedure SetSampleText(AText: string); - end; - - - TfpgFileDialog = class(TfpgBaseDialog) - private - chlDir: TfpgComboBox; - grid: TfpgFileGrid; - btnUpDir: TfpgButton; - btnDirNew: TfpgButton; - btnShowHidden: TfpgButton; - pnlFileInfo: TfpgPanel; - edFilename: TfpgEdit; - chlFilter: TfpgComboBox; - lb1: TfpgLabel; - lb2: TfpgLabel; - FOpenMode: boolean; - FFilterList: TStringList; - FFilter: string; - procedure SetFilter(const Value: string); - function GetShowHidden: boolean; - procedure SetShowHidden(const Value: boolean); - procedure ListChanged(Sender: TObject; ARow: Integer); - procedure GridDblClicked(Sender: TObject; AButton: TMouseButton; AShift: TShiftState; const AMousePos: TPoint); - procedure InitializeComponents; - procedure ProcessFilterString; - function GetFileFilter: string; - procedure FilterChange(Sender: TObject); - procedure DirChange(Sender: TObject); - procedure UpDirClick(Sender: TObject); - procedure btnDirNewClicked(Sender: TObject); - procedure edFilenameChanged(Sender: TObject); - procedure UpdateButtonState; - function HighlightFile(const AFilename: string): boolean; - protected - procedure HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override; - procedure btnOKClick(Sender: TObject); override; - procedure SetCurrentDirectory(const ADir: string); - public - FileName: string; - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - function RunOpenFile: boolean; - function RunSaveFile: boolean; - property Filter: string read FFilter write SetFilter; - property ShowHidden: boolean read GetShowHidden write SetShowHidden; - end; - - -{ This lets us use a single include file for both the Interface and - Implementation sections. } -{$define read_interface} -{$undef read_implementation} - -{$I logo.inc} -{$I messagedialog.inc} -{$I newdirdialog.inc} -{$I promptuserdialog.inc} - - - -procedure ShowMessage(AMessage, ATitle: string; ACentreText: Boolean = False); overload; -procedure ShowMessage(AMessage: string; ACentreText: Boolean = False); overload; - -function SelectFontDialog(var FontDesc: string): boolean; - -function SelectFileDialog(aDialogType: boolean = sfdOpen; - const aFilter: TfpgString = ''): TfpgString; - -implementation - -uses - fpg_widget, - fpg_utils, - fpg_stringutils - {$IFDEF MSWINDOWS} - ,Windows // used by File Dialog - {$ENDIF} - ,DateUtils - ; - - -procedure WrapText(const AText: String; ALines: TStrings; AFont: TfpgFont; - const ALineWidth: Integer; out AWidth: Integer); -var - maxw: integer; - n: integer; - s, s2: string; - c: char; - - // ----------------- - procedure AddLine(all: boolean); - var - w: integer; - m: integer; - begin - s2 := s; - w := AFont.TextWidth(s2); - if w > ALineWidth then - begin - while w > ALineWidth do - begin - m := UTF8Length(s); - repeat - Dec(m); - s2 := UTF8Copy(s,1,m); - w := AFont.TextWidth(s2); - until w <= ALineWidth; - if w > maxw then - maxw := w; - - // are we in the middle of a word. If so find the beginning of word. - while UTF8Copy(s2, m, m+1) <> ' ' do - begin - Dec(m); - s2 := UTF8Copy(s,1,m); - end; - - ALines.Add(s2); - s := UTF8Copy(s, m+1, UTF8length(s)); - s2 := s; - w := AFont.TextWidth(s2); - end; { while } - if all then - begin - ALines.Add(s2); - s := ''; - end; - end - else - begin - ALines.Add(s2); - s := ''; - end; { if/else } - - if w > maxw then - maxw := w; - end; - -begin - s := ''; - ALines.Clear; - n := 1; - maxw := 0; - while n <= Length(AText) do - begin - c := AText[n]; - if (c = #13) or (c = #10) then - begin - // True indicates that if the text is split over multiple lines the last - // line must also be pocessed before continuing. If False then double CR - // can get ignored. - AddLine(true); - if (c = #13) and (n < Length(AText)) and (AText[n+1] = #10) then - Inc(n); - end - else - s := s + c; - Inc(n); - end; { while } - - AddLine(true); - - // set out variable - AWidth := maxw; -end; - -procedure ShowMessage(AMessage, ATitle: string; ACentreText: Boolean); -var - frm: TfpgMessageBox; -begin - frm := TfpgMessageBox.Create(nil); - try - frm.WindowTitle := ATitle; - frm.CentreText := ACentreText; - frm.SetMessage(AMessage); - frm.ShowModal; - finally - frm.Free; - end; -end; - -procedure ShowMessage(AMessage: string; ACentreText: Boolean); -begin - ShowMessage(AMessage, rsMessage, ACentreText); -end; - -function SelectFontDialog(var FontDesc: string): boolean; -var - frm: TfpgFontSelectDialog; -begin - Result := False; - frm := TfpgFontSelectDialog.Create(nil); - frm.SetFontDesc(FontDesc); - if frm.ShowModal = 1 then - begin - FontDesc := frm.GetFontDesc; - Result := True; - end; - frm.Free; -end; - -function SelectFileDialog(aDialogType: boolean = sfdOpen; - const aFilter: TfpgString = ''): TfpgString; -var - dlg: TfpgFileDialog; - dres: boolean; - DefaultFilter: TfpgString; -begin - DefaultFilter := rsAllFiles+' ('+AllFilesMask+')'+'|'+AllFilesMask; - dlg := TfpgFileDialog.Create(nil); - try - if aFilter = '' then - dlg.Filter := DefaultFilter - else - dlg.Filter := aFilter+'|'+DefaultFilter; - - if aDialogType = sfdOpen then - dres := dlg.RunOpenFile - else - dres := dlg.RunSaveFile; - - if dres then - Result := dlg.FileName - else - Result := ''; - finally - dlg.Free; - end; -end; - -{ TfpgMessageBox } - -procedure TfpgMessageBox.HandleKeyPress(var keycode: word; - var shiftstate: TShiftState; var consumed: boolean); -begin - inherited HandleKeyPress(keycode, shiftstate, consumed); - if keycode = keyEscape then - Close; -end; - -procedure TfpgMessageBox.HandlePaint; -var - n, y: integer; - tw: integer; -begin - inherited HandlePaint; - - Canvas.SetFont(FFont); - y := FTextY; - for n := 0 to FLines.Count-1 do - begin - tw := FFont.TextWidth(FLines[n]); - if CentreText then - Canvas.DrawString(Width div 2 - tw div 2, y, FLines[n]) - else - Canvas.DrawString(10, y, FLines[n]); - Inc(y, FLineHeight); - end; -end; - -procedure TfpgMessageBox.HandleShow; -begin - inherited HandleShow; - FButton.SetFocus; -end; - -constructor TfpgMessageBox.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - WindowPosition := wpScreenCenter; - Sizeable := False; - - FLines := TStringList.Create; - FFont := fpgGetFont('#Label1'); - FTextY := 10; - FLineHeight := FFont.Height + 4; - MinWidth := 200; - FMaxLineWidth := 500; - FCentreText := False; - - FButton := TfpgButton.Create(self); - FButton.Text := cMsgDlgBtnText[mbOK]; - FButton.Width := 75; - FButton.ModalResult := mrOK; -end; - -destructor TfpgMessageBox.Destroy; -begin - FFont.Free; - FLines.Free; - inherited Destroy; -end; - -procedure TfpgMessageBox.SetMessage(AMessage: string); -var - outw: integer; -begin - WrapText(AMessage, FLines, FFont, FMaxLineWidth, outw); - - // dialog width with 10 pixel border on both sides - Width := outw + 2*10; - - if Width < FMinWidth then - Width := FMinWidth; - - // center button - FButton.Top := FTextY + FLineHeight*FLines.Count + FTextY; - FButton.Left := (Width div 2) - (FButton.Width div 2); - - // adjust dialog's height - Height := FButton.Top + FButton.Height + FTextY; -end; - -{ TfpgBaseDialog } - -procedure TfpgBaseDialog.btnOKClick(Sender: TObject); -begin - ModalResult := mrOK; -end; - -procedure TfpgBaseDialog.btnCancelClick(Sender: TObject); -begin - ModalResult := mrCancel; - Close; -end; - -procedure TfpgBaseDialog.HandleKeyPress(var keycode: word; - var shiftstate: TShiftState; var consumed: boolean); -begin - if keycode = keyEscape then // Esc cancels the dialog - btnCancelClick(nil) - else - inherited HandleKeyPress(keycode, shiftstate, consumed); -end; - -procedure TfpgBaseDialog.SetupCaptions; -begin - btnCancel.Text := rsCancel; - btnOK.Text := rsOK; -end; - -constructor TfpgBaseDialog.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - Width := 500; - Height := 400; - MinWidth := 300; - MinHeight := 300; - WindowPosition := wpScreenCenter; - FSpacing := 6; - FDefaultButtonWidth := 80; - - btnCancel := CreateButton(self, Width-FDefaultButtonWidth-FSpacing, 370, FDefaultButtonWidth, rsCancel, @btnCancelClick); - btnCancel.Name := 'btnCancel'; - btnCancel.ImageName := 'stdimg.Cancel'; // Do NOT localize - btnCancel.ShowImage := True; - btnCancel.Anchors := [anRight, anBottom]; - btnCancel.TabOrder := 2; - - btnOK := CreateButton(self, btnCancel.Left-FDefaultButtonWidth-FSpacing, 370, FDefaultButtonWidth, rsOK, @btnOKClick); - btnOK.Name := 'btnOK'; - btnOK.ImageName := 'stdimg.OK'; // Do NOT localize - btnOK.ShowImage := True; - btnOK.Anchors := [anRight, anBottom]; - btnOK.TabOrder := 1; -end; - - -{ TfpgFontSelectDialog } - -procedure TfpgFontSelectDialog.OnCollectionChanged(Sender: TObject); -begin - if lbCollection.Text = rsCollectionFontAliases then - begin - CreateFontAliasList; - SetupUI(2); - end - else - begin - CreateFontList; - SetupUI(1); - end; - OnParamChange(nil); -end; - -procedure TfpgFontSelectDialog.OnParamChange(Sender: TObject); -var - fdesc: string; -begin - fdesc := GetFontDesc; - {$IFDEF DEBUG} Writeln(fdesc); {$ENDIF} - memSample.FontDesc := fdesc; - memSample.Text := FSampleText; - if FMode = 2 then - memSample.Lines.Add(fpgGetNamedFontDesc(UTF8Copy(fdesc, 2, UTF8Length(fdesc)-1))); -end; - -procedure TfpgFontSelectDialog.OnSameTextChanged(Sender: TObject); -begin - FSampleText := memSample.Text; -end; - -procedure TfpgFontSelectDialog.CreateFontList; -var - fl: TStringList; -begin - lbFaces.BeginUpdate; - fl := fpgApplication.GetFontFaceList; - lbFaces.Items.Assign(fl); - fl.Free; - lbFaces.FocusItem := 0; - lbFaces.EndUpdate; -end; - -procedure TfpgFontSelectDialog.CreateFontAliasList; -var - fl: TStringList; - i: integer; -begin - lbFaces.BeginUpdate; - fl := fpgGetNamedFontList; - lbFaces.Items.Clear; - for i := 0 to fl.Count-1 do - lbFaces.Items.Add(fl.Names[i]); - fl.Free; - lbFaces.FocusItem := 0; - lbFaces.EndUpdate; -end; - -procedure TfpgFontSelectDialog.SetupUI(AMode: Byte); -begin - FMode := AMode; - case FMode of - 1: // Normal Fonts - begin - lblSize.Enabled := True; - lblTypeFace.Enabled := True; - lbSize.Enabled := True; - cbBold.Enabled := True; - cbItalic.Enabled := True; - cbUnderline.Enabled := True; - cbAntiAlias.Enabled := True; - end; - 2: // Font Aliases - begin - lblSize.Enabled := False; - lblTypeFace.Enabled := False; - lbSize.Enabled := False; - cbBold.Enabled := False; - cbItalic.Enabled := False; - cbUnderline.Enabled := False; - cbAntiAlias.Enabled := False; - end; - end; -end; - -function TfpgFontSelectDialog.GetFontDesc: string; -var - s: string; -begin - if FMode = 2 then - s := lbFaces.Text - else - begin - s := lbFaces.Text + '-' + lbSize.Text; - // Do NOT localize these! - if cbBold.Checked then - s := s + ':bold'; - - if cbItalic.Checked then - s := s + ':italic'; - - if cbAntiAlias.Checked then - s := s + ':antialias=true' - else - s := s + ':antialias=false'; - - if cbUnderline.Checked then - s := s + ':underline'; - end; - result := s; -end; - -procedure TfpgFontSelectDialog.SetFontDesc(Desc: string); -var - cp: integer; - c: char; - token: string; - prop: string; - propval: string; - - function NextC: char; - begin - inc(cp); - if cp > length(Desc) then - c := #0 - else - c := Desc[cp]; - result := c; - end; - - procedure NextToken; - begin - token := ''; - while (c <> #0) and (c in [' ','a'..'z','A'..'Z','_','0'..'9']) do - begin - token := token + c; - NextC; - end; - end; - - procedure ProcessAliasFont; - var - i: integer; - begin - lbCollection.FocusItem := lbCollection.ItemCount; - for i := 0 to lbFaces.ItemCount-1 do - begin - if SameText(lbFaces.Items[i], Desc) then - begin - lbFaces.FocusItem := i; - Exit; //==> - end; - end; - end; - -begin - cp := 1; - c := Desc[1]; - - if Desc[1] = '#' then - FMode := 2 - else - FMode := 1; - SetupUI(FMode); - - if FMode = 2 then - begin - ProcessAliasFont; - Exit; //==> - end; - - cbBold.Checked := False; - cbItalic.Checked := False; - cbUnderline.Checked := False; - cbAntiAlias.Checked := True; - - NextToken; - lbFaces.FocusItem := lbFaces.Items.IndexOf(token); - - if c = '-' then - begin - NextC; - NextToken; - lbSize.FocusItem := lbSize.Items.IndexOf(token); - end; - - while c = ':' do - begin - NextC; - NextToken; - - prop := UpperCase(token); - propval := ''; - - if c = '=' then - begin - NextC; - NextToken; - propval := UpperCase(token); - end; - - // Do NOT localize these! - if prop = 'BOLD' then - begin - cbBold.Checked := True; - end - else if prop = 'ITALIC' then - begin - cbItalic.Checked := True; - end - else if prop = 'ANTIALIAS' then - begin - if propval = 'FALSE' then - cbAntialias.Checked := False; - end - else if prop = 'UNDERLINE' then - begin - cbUnderline.Checked := True; - end; - - end; - - OnParamChange(self); -end; - -procedure TfpgFontSelectDialog.SetupCaptions; -begin - inherited SetupCaptions; -end; - -constructor TfpgFontSelectDialog.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - WindowTitle := rsSelectAFont; - Width := 600; - MinWidth := Width; - MinHeight := Height; - FSampleText := 'The quick brown fox jumps over the lazy dog. 0123456789 [oO0,ilLI]'; - FMode := 1; // normal fonts - - btnCancel.Left := Width - FDefaultButtonWidth - FSpacing; - btnOK.Left := btnCancel.Left - FDefaultButtonWidth - FSpacing; - - lblLabel5 := TfpgLabel.Create(self); - with lblLabel5 do - begin - SetPosition(8, 8, 73, 16); - AutoSize := True; - Text := fpgAddColon(rsCollection); - end; - - { TODO : This need to be fully implemented at some stage. } - lbCollection := TfpgListBox.Create(self); - with lbCollection do - begin - Name := 'lbCollection'; - SetPosition(8, 28, 145, 236); - Items.Add(rsCollectionAllFonts); - // These should be stored in /fpgui directory - Items.Add(rsCollectionRecentlyUsed); - Items.Add(rsCollectionFavourites); - // From here onwards, these should be created automatically. - Items.Add(rsCollectionFixedWidth); - Items.Add(rsCollectionSans); - Items.Add(rsCollectionSerif); - Items.Add(rsCollectionFontAliases); - FocusItem := 0; - OnChange := @OnCollectionChanged; -// Enabled := False; - end; - - lblLabel1 := TfpgLabel.Create(self); - with lblLabel1 do - begin - SetPosition(161, 8, 73, 16); - AutoSize := True; - Text := fpgAddColon(rsName); - end; - - lbFaces := TfpgListBox.Create(self); - with lbFaces do - begin - Name := 'lbFaces'; - SetPosition(161, 28, 232, 236); - Items.Add(' '); - OnChange := @OnParamChange; - end; - - lblSize := TfpgLabel.Create(self); - with lblSize do - begin - Name := 'lblSize'; - SetPosition(401, 8, 54, 16); - AutoSize := True; - Text := fpgAddColon(rsSize); - end; - - lbSize := TfpgListBox.Create(self); - with lbSize do - begin - Name := 'lbSize'; - SetPosition(401, 28, 52, 236); - Items.Add('6'); - Items.Add('7'); - Items.Add('8'); - Items.Add('9'); - Items.Add('10'); - Items.Add('11'); - Items.Add('12'); - Items.Add('13'); - Items.Add('14'); - Items.Add('15'); - Items.Add('16'); - Items.Add('18'); - Items.Add('20'); - Items.Add('24'); - Items.Add('28'); - Items.Add('32'); - Items.Add('48'); - Items.Add('64'); - Items.Add('72'); - OnChange := @OnParamChange; - end; - - lblTypeface := TfpgLabel.Create(self); - with lblTypeface do - begin - Name := 'lblTypeface'; - SetPosition(461, 8, 54, 16); - AutoSize := True; - Text := fpgAddColon(rsTypeface); - end; - - cbBold := TfpgCheckBox.Create(self); - with cbBold do - begin - SetPosition(461, 32, 110, 20); - Text := rsBold; - OnChange := @OnParamChange; - end; - - cbItalic := TfpgCheckBox.Create(self); - with cbItalic do - begin - SetPosition(461, 56, 110, 20); - Text := rsItalic; - OnChange := @OnParamChange; - end; - - cbUnderline := TfpgCheckBox.Create(self); - with cbUnderline do - begin - SetPosition(461, 80, 110, 20); - Text := rsUnderScore; - OnChange := @OnParamChange; - end; - - cbAntiAlias := TfpgCheckBox.Create(self); - with cbAntiAlias do - begin - SetPosition(461, 124, 110, 20); - Text := rsAntiAliasing; - OnChange := @OnParamChange; - Checked := True; - end; - - lblLabel4 := TfpgLabel.Create(self); - with lblLabel4 do - begin - SetPosition(8, 268, 584, 16); - AutoSize := True; - Text := fpgAddColon(rsExampleText); - end; - - memSample := TfpgMemo.Create(self); - with memSample do - begin - SetPosition(8, 288, 584, 65); - Text := FSampleText; - Anchors := [anLeft, anTop, anRight, anBottom]; - OnChange := @OnSameTextChanged; - end; - - CreateFontList; -end; - -procedure TfpgFontSelectDialog.SetSampleText(AText: string); -begin - if FSampleText = AText then - Exit; //==> - if AText = '' then - Exit; //==> - - FSampleText := AText; - memSample.Text := FSampleText; -end; - - -{ TfpgFileDialog } - -procedure TfpgFileDialog.ListChanged(Sender: TObject; ARow: Integer); -var - s: string; -begin - if grid.CurrentEntry = nil then - Exit; //==> - s := grid.CurrentEntry.Name; - - if grid.CurrentEntry.IsLink then - s := s + ' -> ' + grid.CurrentEntry.LinkTarget; - - if grid.CurrentEntry.EntryType <> etDir then - edFileName.Text := grid.CurrentEntry.Name; - - UpdateButtonState; - pnlFileInfo.Text := s; -end; - -procedure TfpgFileDialog.GridDblClicked(Sender: TObject; AButton: TMouseButton; - AShift: TShiftState; const AMousePos: TPoint); -var - e: TFileEntry; -begin - e := grid.CurrentEntry; - if (e = nil) then - Exit; //==> - - if (e.EntryType = etDir) then - SetCurrentDirectory(e.Name) - else if (e.EntryType = etFile) then - btnOKClick(Sender); -end; - -procedure TfpgFileDialog.SetFilter(const Value: string); -begin - FFilter := Value; - ProcessFilterString; -end; - -function TfpgFileDialog.GetShowHidden: boolean; -begin - Result := btnShowHidden.Down; -end; - -procedure TfpgFileDialog.SetShowHidden(const Value: boolean); -begin - btnShowHidden.Down := Value; -end; - -procedure TfpgFileDialog.InitializeComponents; -begin - chlDir := TfpgComboBox.Create(self); - with chlDir do - begin - SetPosition(8, 12, 526, 22); - Anchors := [anLeft, anRight, anTop]; - FontDesc := '#List'; - OnChange := @DirChange; - end; - - grid := TfpgFileGrid.Create(self); - with grid do - begin - SetPosition(8, 44, 622, 203); - Anchors := [anLeft, anRight, anTop, anBottom]; - OnRowChange := @ListChanged; - OnDoubleClick := @GridDblClicked; - end; - - btnUpDir := TfpgButton.Create(self); - with btnUpDir do - begin - SetPosition(540, 11, 26, 24); - Anchors := [anRight, anTop]; - Text := ''; - FontDesc := '#Label1'; - ImageName := 'stdimg.folderup'; // Do NOT localize - ModalResult := mrNone; - Focusable := False; - OnClick := @UpDirClick; - end; - - btnDirNew := TfpgButton.Create(self); - with btnDirNew do - begin - SetPosition(572, 11, 26, 24); - Anchors := [anRight, anTop]; - Text := ''; - FontDesc := '#Label1'; - ImageName := 'stdimg.foldernew'; // Do NOT localize - ModalResult := mrNone; - Focusable := False; - OnClick := @btnDirNewClicked; - end; - - btnShowHidden := TfpgButton.Create(self); - with btnShowHidden do - begin - SetPosition(604, 11, 26, 24); - Anchors := [anRight, anTop]; - Text := ''; - FontDesc := '#Label1'; - ImageName := 'stdimg.hidden'; // Do NOT localize - ModalResult := mrNone; - Focusable := False; - GroupIndex := 1; - AllowAllUp := True; - OnClick := @DirChange; - end; - - { Create lower Panel details } - - pnlFileInfo := TfpgPanel.Create(self); - with pnlFileInfo do - begin - Name := 'pnlFileInfo'; - SetPosition(8, 253, 622, 25); - Anchors := [anLeft, anRight, anBottom]; - Alignment := taLeftJustify; - Margin := 4; - Style := bsLowered; - Text := ''; - end; - - edFilename := TfpgEdit.Create(self); - with edFilename do - begin - SetPosition(8, 301, 622, 22); - Anchors := [anLeft, anRight, anBottom]; - Text := ''; - FontDesc := '#Edit1'; - OnChange := @edFilenameChanged; - end; - - { Filter section } - - chlFilter := TfpgComboBox.Create(self); - with chlFilter do - begin - SetPosition(8, 345, 622, 22); - Anchors := [anLeft, anRight, anBottom]; - FontDesc := '#List'; - OnChange := @FilterChange; - end; - - lb1 := TfpgLabel.Create(self); - with lb1 do - begin - SetPosition(8, 283, 80, 16); - Anchors := [anLeft, anBottom]; - Text := fpgAddColon(rsFileName); - FontDesc := '#Label1'; - end; - - lb2 := TfpgLabel.Create(self); - with lb2 do - begin - SetPosition(8, 327, 64, 16); - Anchors := [anLeft, anBottom]; - Text := fpgAddColon(rsFileType); - FontDesc := '#Label1'; - end; - - ActiveWidget := grid; - FileName := ''; - SetFilter(rsAllFiles + ' (*)|*'); - chlFilter.FocusItem := 0; -end; - -procedure TfpgFileDialog.HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); -var - e: TFileEntry; -begin - if not consumed then - begin - if (ActiveWidget = grid) then - begin - case keycode of - keyReturn: - begin - e := grid.CurrentEntry; - if (e <> nil) then - begin - if (e.EntryType = etDir) then - SetCurrentDirectory(e.Name) - else if (e.EntryType = etFile) then - btnOKClick(btnOK); - consumed := True; - end; - end; - keyBackSpace: - begin - SetCurrentDirectory('..'); - consumed := True; - end; - end; - end; - end; - if not consumed then - inherited HandleKeyPress(keycode, shiftstate, consumed); -end; - -procedure TfpgFileDialog.btnOKClick(Sender: TObject); -var - e: TFileEntry; -begin - if FOpenMode then - begin - e := grid.CurrentEntry; - if e.EntryType = etDir then - begin - SetCurrentDirectory(e.Name); - Exit; //==> - end; - end; - - if not FOpenMode or fpgFileExists(edFileName.Text) then - begin - ModalResult := mrOK; - end; - - if ModalResult = mrOK then - // FileName := fpgExpandFileName(edFileName.Text); - FileName := grid.FileList.DirectoryName + edFileName.Text; -end; - -constructor TfpgFileDialog.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - WindowTitle := rsFileSelection; - Width := 640; - Height := 410; - WindowPosition := wpScreenCenter; - FSpacing := 10; - - FFilterList := TStringList.Create; - - InitializeComponents; - - // position standard dialog buttons - btnCancel.Left := Width - FDefaultButtonWidth - FSpacing; - btnCancel.Top := Height - btnCancel.Height - FSpacing; - btnOK.Left := btnCancel.Left - FDefaultButtonWidth - 6; - btnOK.Top := btnCancel.Top; -end; - -destructor TfpgFileDialog.Destroy; -begin - FFilterList.Free; - inherited Destroy; -end; - -procedure TfpgFileDialog.DirChange(Sender: TObject); -begin - SetCurrentDirectory(chlDir.Text); -end; - -procedure TfpgFileDialog.FilterChange(Sender: TObject); -begin - SetCurrentDirectory('.'); -end; - -procedure TfpgFileDialog.UpDirClick(Sender: TObject); -begin - SetCurrentDirectory('..'); -end; - -procedure TfpgFileDialog.btnDirNewClicked(Sender: TObject); -var - dlg: TfpgNewDirDialog; -begin - dlg := TfpgNewDirDialog.Create(nil); - try - if dlg.ShowModal = 1 then - begin - if dlg.Directory <> '' then - begin - mkdir(dlg.Directory); - grid.FileList.FileMask := GetFileFilter; - grid.FileList.ShowHidden := ShowHidden; - grid.FileList.ReadDirectory(); - grid.FileList.Sort(soFileName); - grid.Invalidate; - end; - end; - finally - dlg.Free; - end; -end; - -procedure TfpgFileDialog.edFilenameChanged(Sender: TObject); -begin - UpdateButtonState; -end; - -procedure TfpgFileDialog.UpdateButtonState; -begin - if FOpenMode then - btnOK.Enabled := True - else - btnOK.Enabled := edFileName.Text <> ''; -end; - -procedure TfpgFileDialog.SetCurrentDirectory(const ADir: string); -var - fsel: string; -begin - if ADir = '..' then - fsel := ExtractFileName( - ExcludeTrailingPathDelimiter(grid.FileList.DirectoryName)) - else - fsel := ''; - - grid.FileList.FileMask := GetFileFilter; - grid.FileList.ShowHidden := ShowHidden; - - if not grid.FileList.ReadDirectory(ADir) then - begin - ShowMessage(Format(rsErrCouldNotOpenDir, [ADir]), rsError); - Exit; //==> - end; - - grid.FileList.Sort(soFileName); - - // we don't want chlDir to call DirChange while populating items - chlDir.OnChange := nil; - chlDir.Items.Assign(grid.FileList.SpecialDirs); - chlDir.FocusItem := grid.FileList.CurrentSpecialDir; - chlDir.OnChange := @DirChange; // restore event handler - - if fsel <> '' then - HighlightFile(fsel) - else - grid.FocusRow := 0; - - grid.Update; - grid.SetFocus; -end; - -function TfpgFileDialog.HighlightFile(const AFilename: string): boolean; -var - n: integer; -begin - for n := 0 to grid.FileList.Count-1 do - begin - if grid.FileList.Entry[n].Name = AFilename then - begin - grid.FocusRow := n; - Result := True; - Exit; //==> - end; - end; - Result := False; -end; - -procedure TfpgFileDialog.ProcessFilterString; -var - p: integer; - s: string; - fs: string; - fm: string; -begin - // we don't want chlFilter to call FilterChange while populating items - chlFilter.OnChange := nil; - s := FFilter; - FFilterList.Clear; - chlFilter.Items.Clear; - repeat - fs := ''; - fm := ''; - p := pos('|', s); - if p > 0 then - begin - fs := Copy(s, 1, p-1); - Delete(s, 1, p); - p := pos('|', s); - if p > 0 then - begin - fm := Copy(s, 1, p-1); - Delete(s, 1, p); - end - else - begin - fm := s; - s := ''; - end; - end; - - if (fs <> '') and (fm <> '') then - begin - chlFilter.Items.Add(fs); - FFilterList.Add(fm); - end; - until (fs = '') or (fm = ''); { repeat/until } - chlFilter.FocusItem := 0; // first filter - // restore event handler - chlFilter.OnChange := @FilterChange; -end; - -function TfpgFileDialog.GetFileFilter: string; -var - i: integer; -begin - i := chlFilter.FocusItem; - if (i >= 0) and (i < FFilterList.Count) then - Result := FFilterList[i] - else - Result := '*'; -end; - -function TfpgFileDialog.RunOpenFile: boolean; -var - sdir: string; - fname: string; -begin - FOpenMode := True; - sdir := ExtractFileDir(FileName); - if sdir = '' then - sdir := '.'; - - SetCurrentDirectory(sdir); - fname := ExtractFileName(FileName); - - if not HighlightFile(fname) then - edFilename.Text := fname; - - WindowTitle := rsOpenAFile; - btnOK.ImageName := 'stdimg.open'; // Do NOT localize - btnOK.Text := rsOpen; - - if ShowModal = 1 then - Result := True - else - Result := False; -end; - -function TfpgFileDialog.RunSaveFile: boolean; -var - sdir: string; - fname: string; -begin - FOpenMode := False; - sdir := ExtractFileDir(FileName); - if sdir = '' then - sdir := '.'; - SetCurrentDirectory(sdir); - fname := ExtractFileName(FileName); - if not HighlightFile(fname) then - edFilename.Text := fname; - - WindowTitle := rsSaveAFile; - btnOK.ImageName := 'stdimg.save'; // Do NOT localize - btnOK.Text := rsSave; - - if ShowModal = 1 then - Result := True - else - Result := False; -end; - - -{ This lets us use a single include file for both the Interface and - Implementation sections. } -{$undef read_interface} -{$define read_implementation} - - -{$I messagedialog.inc} -{$I newdirdialog.inc} -{$I promptuserdialog.inc} - - - -end. - diff --git a/src/gui/gui_edit.pas b/src/gui/gui_edit.pas deleted file mode 100644 index 1ea1bf2c..00000000 --- a/src/gui/gui_edit.pas +++ /dev/null @@ -1,1865 +0,0 @@ -{ - fpGUI - Free Pascal GUI Toolkit - - Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this - distribution, for details of the copyright. - - See the file COPYING.modifiedLGPL, included in this distribution, - for details about redistributing fpGUI. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - - Description: - Defines a Text Edit control. Also known a Text Entry control. -} - -unit gui_edit; - -{$mode objfpc}{$H+} - -interface - -uses - Classes, - SysUtils, - fpg_base, - fpg_main, - fpg_widget, - gui_menu; - -type - TfpgEditBorderStyle = (ebsNone, ebsDefault, ebsSingle); - - - TfpgBaseEdit = class(TfpgWidget) - private - FAutoSelect: Boolean; - FHideSelection: Boolean; - FPopupMenu: TfpgPopupMenu; - FDefaultPopupMenu: TfpgPopupMenu; - FText: string; - FFont: TfpgFont; - FPasswordMode: Boolean; - FBorderStyle: TfpgEditBorderStyle; - FOnChange: TNotifyEvent; - FMaxLength: integer; - FSelecting: Boolean; - procedure Adjust(UsePxCursorPos: boolean = false); - procedure AdjustTextOffset(UsePxCursorPos: boolean); - procedure AdjustDrawingInfo; - // function PointToCharPos(x, y: integer): integer; - procedure DeleteSelection; - procedure DoCopy; - procedure DoPaste; - procedure SetAutoSelect(const AValue: Boolean); - procedure SetBorderStyle(const AValue: TfpgEditBorderStyle); - procedure SetHideSelection(const AValue: Boolean); - procedure SetPasswordMode(const AValue: boolean); - function GetFontDesc: string; - procedure SetFontDesc(const AValue: string); - procedure SetText(const AValue: string); - procedure DefaultPopupCut(Sender: TObject); - procedure DefaultPopupCopy(Sender: TObject); - procedure DefaultPopupPaste(Sender: TObject); - procedure DefaultPopupClearAll(Sender: TObject); - procedure SetDefaultPopupMenuItemsState; - protected - FSideMargin: integer; - FMouseDragPos: integer; - FSelStart: integer; - FSelOffset: integer; - FCursorPos: integer; // Caret position (characters) - FCursorPx: integer; // Caret position (pixels) - FTextOffset: integer; - FDrawOffset: integer; - FVisibleText: TfpgString; - FVisSelStartPx: integer; - FVisSelEndPx: integer; - procedure DoOnChange; virtual; - procedure ShowDefaultPopupMenu(const x, y: integer; const shiftstate: TShiftState); virtual; - procedure HandlePaint; override; - procedure HandleResize(awidth, aheight: TfpgCoord); override; - procedure HandleKeyChar(var AText: TfpgChar; var shiftstate: TShiftState; var consumed: Boolean); override; - procedure HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: Boolean); override; - procedure HandleLMouseDown(x, y: integer; shiftstate: TShiftState); override; - procedure HandleRMouseUp(x, y: integer; shiftstate: TShiftState); override; - procedure HandleMouseMove(x, y: integer; btnstate: word; shiftstate: TShiftState); override; - procedure HandleDoubleClick(x, y: integer; button: word; shiftstate: TShiftState); override; - procedure HandleMouseEnter; override; - procedure HandleMouseExit; override; - procedure HandleSetFocus; override; - procedure HandleKillFocus; override; - function GetDrawText: String; - property AutoSelect: Boolean read FAutoSelect write SetAutoSelect default True; - property BorderStyle: TfpgEditBorderStyle read FBorderStyle write SetBorderStyle default ebsDefault; - property Font: TfpgFont read FFont; - property FontDesc: String read GetFontDesc write SetFontDesc; - property HideSelection: Boolean read FHideSelection write SetHideSelection default True; - property MaxLength: Integer read FMaxLength write FMaxLength; - property PasswordMode: Boolean read FPasswordMode write SetPasswordMode default False; - property PopupMenu: TfpgPopupMenu read FPopupMenu write FPopupMenu; - property Text: String read FText write SetText; - property OnChange: TNotifyEvent read FOnChange write FOnChange; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - function SelectionText: string; - procedure SelectAll; - procedure Clear; - procedure ClearSelection; - procedure CopyToClipboard; - procedure CutToClipboard; - procedure PasteFromClipboard; - end; - - - TfpgEdit = class(TfpgBaseEdit) - public - property Font; - property PopupMenu; // UI Designer doesn't fully support it yet - published - property AutoSelect; - property BackgroundColor default clBoxColor; - property BorderStyle; - property FontDesc; - property HideSelection; - property MaxLength; - property PasswordMode; - property ParentShowHint; - property ShowHint; - property TabOrder; - property Text; - property TextColor; - property OnChange; - property OnEnter; - property OnExit; - property OnKeyPress; - property OnMouseEnter; - property OnMouseExit; - property OnPaint; - end; - - - TfpgBaseNumericEdit = class(TfpgBaseEdit) - private - fOldColor: TfpgColor; - fAlignment: TAlignment; - fDecimalSeparator: char; - fNegativeColor: TfpgColor; - fThousandSeparator: char; - fShowThousand: boolean; - procedure SetOldColor(const AValue: TfpgColor); - procedure SetAlignment(const AValue: TAlignment); - procedure SetDecimalSeparator(const AValue: char); - procedure SetNegativeColor(const AValue: TfpgColor); - procedure SetThousandSeparator(const AValue: char); - protected - procedure HandleKeyChar(var AText: TfpgChar; var shiftstate: TShiftState; var consumed: Boolean); override; - procedure HandlePaint; override; - procedure Format; virtual; - procedure Justify; virtual; // to implement in derived classes - property OldColor: TfpgColor read fOldColor write SetOldColor; - property Alignment: TAlignment read fAlignment write SetAlignment default taRightJustify; - property AutoSelect; - property BackgroundColor default clBoxColor; - property BorderStyle; - {Someone likes to use English operating system but localized decimal and thousand separators - Still to implement !!} - property DecimalSeparator: char read fDecimalSeparator write SetDecimalSeparator; - property ThousandSeparator: char read fThousandSeparator write SetThousandSeparator; - property NegativeColor: TfpgColor read fNegativeColor write SetNegativeColor; - property HideSelection; -// property MaxLength; { probably MaxValue and MinValue } - property TabOrder; - property TextColor; - property ShowThousand: boolean read fShowThousand write fShowThousand default False; - property OnChange; - property OnEnter; - property OnExit; - property OnKeyPress; - property OnMouseEnter; - property OnMouseExit; - property OnPaint; - property Text; { this should become Value } - public - constructor Create(AOwner: TComponent); override; - published - property FontDesc; - end; - - - TfpgEditInteger = class(TfpgBaseNumericEdit) - protected - function GetValue: integer; virtual; - procedure SetValue(const AValue: integer); virtual; - procedure SetShowThousand; - procedure Format; override; - procedure HandleKeyChar(var AText: TfpgChar; var shiftstate: TShiftState; var consumed: Boolean); override; - public - constructor Create(AOwner: TComponent); override; - property Text; - published - property Alignment; - property NegativeColor; - property Value: integer read GetValue write SetValue; - property ShowThousand; - property TabOrder; - property TextColor; - property ThousandSeparator; - property OnChange; - property OnEnter; - property OnExit; - property OnKeyPress; - property OnMouseEnter; - property OnMouseExit; - end; - - - TfpgEditFloat = class(TfpgBaseNumericEdit) - private - fDecimals: integer; - protected - function GetValue: extended; virtual; - procedure SetValue(const AValue: extended); virtual; - procedure SetShowThousand; - procedure SetDecimals(AValue: integer); - procedure Format; override; - procedure HandleKeyChar(var AText: TfpgChar; var shiftstate: TShiftState; var consumed: Boolean); override; - public - constructor Create(AOwner: TComponent); override; - property Text; - published - property Alignment; - property Decimals: integer read fDecimals write SetDecimals; - property NegativeColor; - property DecimalSeparator; - property Value: extended read GetValue write SetValue; - property ShowThousand; - property TabOrder; - property TextColor; - property ThousandSeparator; - property OnChange; - property OnEnter; - property OnExit; - property OnKeyPress; - property OnMouseEnter; - property OnMouseExit; - end; - - - TfpgEditCurrency = class(TfpgBaseNumericEdit) - private - fDecimals: integer; - protected - function GetValue: Currency; virtual; - procedure SetValue(const AValue: Currency); virtual; - procedure SetShowThousand; - procedure SetDecimals(AValue: integer); - procedure Format; override; - procedure HandleKeyChar(var AText: TfpgChar; var shiftstate: TShiftState; var consumed: Boolean); override; - procedure HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: Boolean); override; - public - constructor Create(AOwner: TComponent); override; - property Text; - published - property Alignment; - property Decimals: integer read fDecimals write SetDecimals; - property NegativeColor; - property OldColor; - property DecimalSeparator; - property ThousandSeparator; - property ShowThousand; - property Value: Currency read GetValue write SetValue; - property OnChange; - property OnEnter; - property OnExit; - property OnKeyPress; - property OnMouseEnter; - property OnMouseExit; - end; - - -function CreateEdit(AOwner: TComponent; x, y, w, h: TfpgCoord): TfpgEdit; - -function CreateEditInteger(AOwner: TComponent; x, y, w, h: TfpgCoord; - AShowThousand: boolean= True): TfpgEditInteger; - -function CreateEditFloat(AOwner: TComponent; x, y, w, h: TfpgCoord; - AShowThousand: boolean= True; ADecimals: Integer= -1): TfpgEditFloat; - -function CreateEditCurrency(AOwner: TComponent; x, y, w, h: TfpgCoord; - AShowThousand: boolean= True; ADecimals: Integer= 2): TfpgEditCurrency; - - -implementation - -uses - fpg_stringutils, - fpg_constants, - gui_hint; - -const - // internal popupmenu item names - ipmCut = 'miDefaultCut'; - ipmCopy = 'miDefaultCopy'; - ipmPaste = 'miDefaultPaste'; - ipmClearAll = 'miDefaultClearAll'; - - -function CreateEdit(AOwner: TComponent; x, y, w, h: TfpgCoord): TfpgEdit; -begin - Result := TfpgEdit.Create(AOwner); - Result.Left := x; - Result.Top := y; - if w > 0 then - Result.Width := w; - if h < TfpgEdit(Result).FFont.Height + 6 then - Result.Height:= TfpgEdit(Result).FFont.Height + 6 - else - Result.Height:= h; -end; - -function CreateEditInteger(AOwner: TComponent; x, y, w, h: TfpgCoord; AShowThousand: boolean= True): TfpgEditInteger; -begin - Result := TfpgEditInteger.Create(AOwner); - Result.Left := x; - Result.Top := y; - Result.Width := w; - Result.ShowThousand:= AShowThousand; - if h < TfpgEditInteger(Result).FFont.Height + 6 then - Result.Height:= TfpgEditInteger(Result).FFont.Height + 6 - else - Result.Height:= h; -end; - -function CreateEditFloat(AOwner: TComponent; x, y, w, h: TfpgCoord; AShowThousand: boolean= True; - ADecimals: Integer= -1): TfpgEditFloat; -begin - Result := TfpgEditFloat.Create(AOwner); - Result.Left := x; - Result.Top := y; - Result.Width := w; - Result.ShowThousand:= AShowThousand; - Result.Decimals := ADecimals; - if h < TfpgEditFloat(Result).FFont.Height + 6 then - Result.Height:= TfpgEditFloat(Result).FFont.Height + 6 - else - Result.Height:= h; -end; - -function CreateEditCurrency(AOwner: TComponent; x, y, w, h: TfpgCoord; AShowThousand: boolean= True; - ADecimals: Integer= 2): TfpgEditCurrency; -begin - Result := TfpgEditCurrency.Create(AOwner); - Result.Left := x; - Result.Top := y; - Result.Width := w; - Result.ShowThousand:= AShowThousand; - Result.Decimals := ADecimals; - if h < TfpgEditCurrency(Result).FFont.Height + 6 then - Result.Height:= TfpgEditCurrency(Result).FFont.Height + 6 - else - Result.Height:= h; -end; - - -{ TfpgBaseEdit } - -procedure TfpgBaseEdit.Adjust(UsePxCursorPos: boolean = false); -begin - AdjustTextOffset(False); - AdjustDrawingInfo; -end; - -procedure TfpgBaseEdit.AdjustTextOffset(UsePxCursorPos: boolean); -{If UsePxCursorPos then determines FCursorPos from FCursorPx (that holds mouse pointer coordinates) - Calculates exact FCursorPx (relative to the widget bounding box) from FCursorPos - Calculates FTextOffset based on FCursorPx} -var - dtext: string; - ch: string; // current character - chnum: integer; // its ordinal number - chx: integer; // its X position relative to widget - bestchx: integer; // chx, nearest to the mouse position (indicated by FCursorPx if UsePxCursorPos = True) - tw: integer; // total characters width, that becomes FCursorPx relative to the beginning of the text - ptw: integer; - dpos: integer; // helps to pass through an utf-8 string quickly - VisibleWidth: integer; // width of the edit field minus side margins -begin - if UsePxCursorPos then - begin - if FCursorPx > 0 then // bestchx < chx minimum - bestchx := Low(chx) + 1 + FCursorPx - else // bestchx > chx maximum - bestchx := High(chx) - 1 + FCursorPx; - end else - FCursorPx := 0; - - dtext := GetDrawText; - ch := ''; - chnum := 0; - tw := 0; - dpos := 0; - - while dpos <= Length(dtext) do - begin - dpos := UTF8CharAtByte(dtext, dpos, ch); - ptw := tw; - tw := tw + FFont.TextWidth(ch); - chx := tw - FTextOffset + FSideMargin; - if UsePxCursorPos then - begin - if abs(chx - FCursorPx) < abs(bestchx - FCursorPx) then - begin - bestchx := chx; - FCursorPos := chnum; - end else - begin - tw := ptw; - break; - end; - end else - begin - if chnum >= FCursorPos then - break; - end; - Inc(chnum); - end; - - VisibleWidth := (FWidth - 2 * FSideMargin); - if tw - FTextOffset > VisibleWidth - 2 then - FTextOffset := tw - VisibleWidth + 2 - else if tw - FTextOffset < 0 then - begin - FTextOffset := tw; - if tw <> 0 then - Dec(FTextOffset, 2); - end; - - FCursorPx := tw - FTextOffset + FSideMargin; -end; - -procedure TfpgBaseEdit.AdjustDrawingInfo; -// Calculates FVisSelStartPx, FVisSelEndPx, FVisibleText, FDrawOffset -var - // fvc, lvc: integer; // first/last visible characters - vtstartbyte, vtendbyte: integer; // visible characters' start/end in utf-8 string, bytes - bestfx, bestlx: integer; - dtext: string; - ch: string; // current character - chnum: integer; // its ordinal number - chx: integer; // its X position relative to widget - tw: integer; // total characters width, that becomes FCursorPx relative to the beginning of the text - ptw: integer; // total width on the previous step - dpos: integer; // helps to pass through an utf-8 string quickly - pdp: integer; // dpos on the previous step - vstart, vend: integer; // visible area start and end, pixels - slstart, slend: integer; // selection start and end, pixels -begin - vstart := FSideMargin; - vend := FWidth - FSideMargin; - if FSelOffset > 0 then - begin - slstart := FSelStart; - slend := FSelStart + FSelOffset; - end else - begin - slstart := FSelStart + FSelOffset; - slend := FSelStart; - end; - FVisSelStartPx := vend; // because we stop the search - FVisSelEndPx := vend; // after last visible character is found - bestfx := High(chx) - 1 + vstart; - bestlx := Low(chx) + 1 + vend; - - dtext := GetDrawText; - ch := ''; - chnum := 0; - tw := 0; - dpos := 0; - {fvc := 0; - lvc := 0;} - FDrawOffset := 0; - while dpos <= Length(dtext) do - begin - pdp := dpos; - dpos := UTF8CharAtByte(dtext, dpos, ch); - ptw := tw; - tw := tw + FFont.TextWidth(ch); - chx := tw - FTextOffset + FSideMargin; - - // calculate selection-related fields - if chnum = slstart then - FVisSelStartPx := chx; - if chnum = slend then - FVisSelEndPx := chx; - - // search for the first/last visible characters - if abs(chx - vstart) < abs(bestfx - vstart) then - begin - bestfx := chx; - // fvc := chnum; - vtstartbyte := pdp; - FDrawOffset := ptw; - end; - // in small edit field the same character can be both the first and the last, so no 'else' allowed - if abs(chx - vend) < abs(bestlx - vend) then - begin - bestlx := chx; - // lvc := chnum; - vtendbyte := UTF8CharAtByte(dtext, dpos, ch); // plus one more character - end else - break; // we can safely break after last visible character is found - Inc(chnum); - end; - - if FVisSelStartPx < vstart then - FVisSelStartPx := vstart; - if FVisSelEndPx > vend then - FVisSelEndPx := vend; - - // FVisibleText := UTF8Copy(dtext, fvc, lvc - fvc + 2); - FVisibleText := Copy(dtext, vtstartbyte, vtendbyte - vtstartbyte); - FDrawOffset := FTextOffset - FDrawOffset; -end; - -{function TfpgBaseEdit.PointToCharPos(x, y: integer): integer; -var - n: integer; - cx: integer; // character X position - bestcx: integer; - dtext: string; - tw, dpos: integer; - ch: string; -begin - ch := ''; - dtext := GetDrawText; - if x > 0 then // bestcx < cx minimum - bestcx := Low(cx) + 1 + x - else // bestcx > cx maximum - bestcx := High(cx) - 1 + x; - - tw := 0; - dpos := 0; - n := 0; - Result := n; - // searching the appropriate character position - while dpos <= Length(dtext) do - begin - dpos := UTF8CharAtByte(dtext, dpos, ch); - tw := tw + FFont.TextWidth(ch); - cx := tw - FTextOffset + FSideMargin; - if abs(cx - x) < abs(bestcx - x) then - begin - bestcx := cx; - Result := n; - end else - Exit; //==> - Inc(n); - end; -end;} - -procedure TfpgBaseEdit.SetBorderStyle(const AValue: TfpgEditBorderStyle); -begin - if FBorderStyle = AValue then - Exit; //==> - FBorderStyle := AValue; - RePaint; -end; - -procedure TfpgBaseEdit.SetHideSelection(const AValue: Boolean); -begin - if FHideSelection = AValue then - Exit; - FHideSelection := AValue; -end; - -procedure TfpgBaseEdit.HandlePaint; -var - r: TfpgRect; - - // paint selection rectangle - procedure DrawSelection; - var - lcolor: TfpgColor; - r: TfpgRect; - begin - if Focused then - begin - lcolor := clSelection; - Canvas.SetTextColor(clSelectionText); - end - else - begin - lcolor := clInactiveSel; - Canvas.SetTextColor(clText1); - end; - - r.SetRect(FVisSelStartPx, 3, FVisSelEndPx - FVisSelStartPx, FFont.Height); - Canvas.SetColor(lcolor); - Canvas.FillRectangle(r); - Canvas.SetTextColor(clWhite); - Canvas.AddClipRect(r); - fpgStyle.DrawString(Canvas, -FDrawOffset + FSideMargin, 3, FVisibleText, Enabled); - Canvas.ClearClipRect; - end; - -begin - Canvas.ClearClipRect; - r.SetRect(0, 0, Width, Height); - case BorderStyle of - ebsNone: - begin - // do nothing - end; - ebsDefault: - begin - Canvas.DrawControlFrame(r); - InflateRect(r, -2, -2); - end; - ebsSingle: - begin - Canvas.SetColor(clShadow2); - Canvas.DrawRectangle(r); - InflateRect(r, -1, -1); - end; - end; - Canvas.SetClipRect(r); - - if Enabled then - Canvas.SetColor(FBackgroundColor) - else - Canvas.SetColor(clWindowBackground); - - Canvas.FillRectangle(r); - - Canvas.SetFont(FFont); - Canvas.SetTextColor(FTextColor); - fpgStyle.DrawString(Canvas, -FDrawOffset + FSideMargin, 3, FVisibleText, Enabled); - - if Focused then - begin - // drawing selection - if FSelOffset <> 0 then - DrawSelection; - - // drawing cursor - fpgCaret.SetCaret(Canvas, FCursorPx, 3, fpgCaret.Width, FFont.Height); - end - else - begin - // drawing selection - if (AutoSelect = False) and (FSelOffset <> 0) and (HideSelection = False) then - DrawSelection; - fpgCaret.UnSetCaret(Canvas); - end; -end; - -procedure TfpgBaseEdit.HandleResize(awidth, aheight: TfpgCoord); -begin - inherited HandleResize(awidth, aheight); - AdjustDrawingInfo; -end; - -procedure TfpgBaseEdit.HandleKeyChar(var AText: TfpgChar; - var shiftstate: TShiftState; var consumed: Boolean); -var - s: TfpgChar; - prevval: string; -begin - prevval := Text; - s := AText; - - if not consumed then - begin - // Handle only printable characters - // UTF-8 characters beyond ANSI range are supposed to be printable - if ((Ord(AText[1]) > 31) and (Ord(AText[1]) < 127)) or (Length(AText) > 1) then - begin - if (FMaxLength <= 0) or (UTF8Length(FText) < FMaxLength) then - begin - DeleteSelection; - UTF8Insert(s, FText, FCursorPos + 1); - Inc(FCursorPos); - FSelStart := FCursorPos; - Adjust; - end; - consumed := True; - end; - - if prevval <> Text then - DoOnChange; - end; - - if consumed then - RePaint; - - inherited HandleKeyChar(AText, shiftstate, consumed); -end; - -procedure TfpgBaseEdit.HandleKeyPress(var keycode: word; - var shiftstate: TShiftState; var consumed: boolean); -var - hasChanged: boolean; - - procedure StopSelection; - begin - FSelStart := FCursorPos; - FSelOffset := 0; - end; - -begin - hasChanged := False; - fpgApplication.HideHint; - - - Consumed := True; - case CheckClipBoardKey(keycode, shiftstate) of - ckCopy: - begin - DoCopy; - end; - ckPaste: - begin - DoPaste; - hasChanged := True; - end; - ckCut: - begin - DoCopy; - DeleteSelection; - Adjust; - hasChanged := True; - end; - else - Consumed := False; - end; - - - if not Consumed then - begin - // checking for movement keys: - case keycode of - keyLeft: - if FCursorPos > 0 then - begin - consumed := True; - Dec(FCursorPos); - - if (ssCtrl in shiftstate) then - // word search... - // while (FCursorPos > 0) and not ptkIsAlphaNum(copy(FText,FCursorPos,1)) - // do Dec(FCursorPos); - // while (FCursorPos > 0) and ptkIsAlphaNum(copy(FText,FCursorPos,1)) - // do Dec(FCursorPos); - ; - - end; - - keyRight: - if FCursorPos < UTF8Length(FText) then - begin - consumed := True; - Inc(FCursorPos); - - if (ssCtrl in shiftstate) then - // word search... - // while (FCursorPos < Length(FText)) and ptkIsAlphaNum(copy(FText,FCursorPos+1,1)) - // do Inc(FCursorPos); - // while (FCursorPos < Length(FText)) and not ptkIsAlphaNum(copy(FText,FCursorPos+1,1)) - // do Inc(FCursorPos); - ; - end; - - keyHome: - begin - consumed := True; - FCursorPos := 0; - end; - - keyEnd: - begin - consumed := True; - FCursorPos := UTF8Length(FText); - end; - end; - - if Consumed then - begin - FSelecting := (ssShift in shiftstate); - - if FSelecting then - FSelOffset := FCursorPos - FSelStart - else - StopSelection; - - Adjust; - end; - end; // movement key checking - - if not Consumed then - begin - consumed := True; - - case keycode of - keyBackSpace: - begin - if FCursorPos > 0 then - begin - UTF8Delete(FText, FCursorPos, 1); - Dec(FCursorPos); - hasChanged := True; - end;// backspace - end; - - - keyDelete: - begin - if FSelOffset <> 0 then - DeleteSelection - else if FCursorPos < UTF8Length(FText) then - UTF8Delete(FText, FCursorPos + 1, 1); - hasChanged := True; - end; - else - Consumed := False; - end; - - if Consumed then - begin - StopSelection; - Adjust; - end; - end; { if } - - if consumed then - RePaint - else - inherited; - - if hasChanged then - if Assigned(FOnChange) then - FOnChange(self); -end; - -procedure TfpgBaseEdit.HandleLMouseDown(x, y: integer; shiftstate: TShiftState); -begin - fpgApplication.HideHint; - inherited HandleLMouseDown(x, y, shiftstate); - - FCursorPx := x; - AdjustTextOffset(True); - FMouseDragPos := FCursorPos; - if (ssShift in shiftstate) then - FSelOffset := FCursorPos - FSelStart - else - begin - FSelStart := FCursorPos; - FSelOffset := 0; - end; - AdjustDrawingInfo; - RePaint; -end; - -procedure TfpgBaseEdit.HandleRMouseUp(x, y: integer; shiftstate: TShiftState); -begin - inherited HandleRMouseUp(x, y, shiftstate); - if Assigned(PopupMenu) then - PopupMenu.ShowAt(self, x, y) - else - ShowDefaultPopupMenu(x, y, ShiftState); -end; - -procedure TfpgBaseEdit.HandleMouseMove(x, y: integer; btnstate: word; shiftstate: TShiftState); -var - cp: integer; -begin - if (btnstate and MOUSE_LEFT) = 0 then // Left button not down - begin - inherited HandleMouseMove(x, y, btnstate, shiftstate); - Exit; //==> - end; - - cp := FCursorPos; - FCursorPx := x; - AdjustTextOffset(True); - if FCursorPos <> cp then - begin - FSelOffset := FCursorPos - FSelStart; - AdjustDrawingInfo; - Repaint; - end; -end; - -procedure TfpgBaseEdit.HandleDoubleClick(x, y: integer; button: word; shiftstate: TShiftState); -begin - // button is always Mouse_Left, but lets leave this test here for good measure - if button = MOUSE_LEFT then - SelectAll - else - inherited; -end; - -procedure TfpgBaseEdit.HandleMouseEnter; -begin - inherited HandleMouseEnter; - if (csDesigning in ComponentState) then - Exit; - if Enabled then - MouseCursor := mcIBeam; -end; - -procedure TfpgBaseEdit.HandleMouseExit; -begin - inherited HandleMouseExit; - if (csDesigning in ComponentState) then - Exit; - MouseCursor := mcDefault; -end; - -procedure TfpgBaseEdit.HandleSetFocus; -begin - inherited HandleSetFocus; - if AutoSelect then - SelectAll; -end; - -procedure TfpgBaseEdit.HandleKillFocus; -begin - inherited HandleKillFocus; - if AutoSelect then - FSelOffset := 0; -end; - -function TfpgBaseEdit.GetDrawText: string; -begin - if not PassWordMode then - Result := FText - else - Result := StringOfChar('*', UTF8Length(FText)); -end; - -constructor TfpgBaseEdit.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - FFont := fpgGetFont('#Edit1'); // owned object ! - Focusable := True; - FHeight := FFont.Height + 6; - FWidth := 120; - FTextColor := Parent.TextColor; - FBackgroundColor := clBoxColor; - FAutoSelect := True; - FSelecting := False; - FHideSelection := True; - FSideMargin := 3; - FMaxLength := 0; // no limit - FText := ''; - FCursorPos := UTF8Length(FText); - FSelStart := FCursorPos; - FSelOffset := 0; - FTextOffset := 0; - FPasswordMode := False; - FBorderStyle := ebsDefault; - FPopupMenu := nil; - FDefaultPopupMenu := nil; - FOnChange := nil; - -end; - -destructor TfpgBaseEdit.Destroy; -begin - if Assigned(FDefaultPopupMenu) then - FDefaultPopupMenu.Free; - FFont.Free; - inherited Destroy; -end; - -function TfpgBaseEdit.SelectionText: string; -begin - if FSelOffset <> 0 then - begin - if FSelOffset < 0 then - Result := UTF8Copy(FText, 1 + FSelStart + FSelOffset, -FSelOffset) - else - begin - Result := UTF8Copy(FText, 1 + FSelStart, FSelOffset); - end; - end - else - Result := ''; -end; - -procedure TfpgBaseEdit.SetPasswordMode (const AValue: boolean ); -begin - if FPasswordMode = AValue then - Exit; //==> - FPasswordMode := AValue; - Adjust; - RePaint; -end; - -function TfpgBaseEdit.GetFontDesc: string; -begin - Result := FFont.FontDesc; -end; - -procedure TfpgBaseEdit.SetFontDesc(const AValue: string); -begin - FFont.Free; - FFont := fpgGetFont(AValue); - if Height < FFont.Height + 6 then - Height:= FFont.Height + 6; - Adjust; - RePaint; -end; - -procedure TfpgBaseEdit.SetText(const AValue: string); -var - s: string; - prevval: TfpgString; -begin - if FText = AValue then - Exit; - prevval := FText; - - if FMaxLength <> 0 then - begin - if UTF8Length(FText) > FMaxLength then - s := UTF8Copy(AValue, 1, FMaxLength) - else - s := AValue; - end - else - s := AValue; - - FText := s; - FCursorPos := UTF8Length(FText); - FSelStart := FCursorPos; - FSelOffset := 0; - FTextOffset := 0; - - Adjust; - RePaint; - - if prevval <> Text then - DoOnChange; -end; - -procedure TfpgBaseEdit.DefaultPopupCut(Sender: TObject); -begin - CutToClipboard; -end; - -procedure TfpgBaseEdit.DefaultPopupCopy(Sender: TObject); -begin - CopyToClipboard; -end; - -procedure TfpgBaseEdit.DefaultPopupPaste(Sender: TObject); -begin - PasteFromClipboard -end; - -procedure TfpgBaseEdit.DefaultPopupClearAll(Sender: TObject); -begin - Clear; -end; - -procedure TfpgBaseEdit.SetDefaultPopupMenuItemsState; -var - i: integer; - itm: TfpgMenuItem; -begin - for i := 0 to FDefaultPopupMenu.ComponentCount-1 do - begin - if FDefaultPopupMenu.Components[i] is TfpgMenuItem then - begin - itm := TfpgMenuItem(FDefaultPopupMenu.Components[i]); - // enabled/disable menu items - if itm.Name = ipmCut then - itm.Enabled := FSelOffset <> 0 - else if itm.Name = ipmCopy then - itm.Enabled := FSelOffset <> 0 - else if itm.Name = ipmPaste then - itm.Enabled := fpgClipboard.Text <> '' - else if itm.Name = ipmClearAll then - itm.Enabled := Text <> ''; - end; - end; -end; - -procedure TfpgBaseEdit.DoOnChange; -begin - if Assigned(FOnChange) then - FOnChange(self); -end; - -procedure TfpgBaseEdit.ShowDefaultPopupMenu(const x, y: integer; - const shiftstate: TShiftState); -var - itm: TfpgMenuItem; -begin - if not Assigned(FDefaultPopupMenu) then - begin - { todo: This text needs to be localized } - FDefaultPopupMenu := TfpgPopupMenu.Create(nil); - itm := FDefaultPopupMenu.AddMenuItem(rsCut, '', @DefaultPopupCut); - itm.Name := ipmCut; - itm := FDefaultPopupMenu.AddMenuItem(rsCopy, '', @DefaultPopupCopy); - itm.Name := ipmCopy; - itm := FDefaultPopupMenu.AddMenuItem(rsPaste, '', @DefaultPopupPaste); - itm.Name := ipmPaste; - itm := FDefaultPopupMenu.AddMenuItem(rsDelete, '', @DefaultPopupClearAll); - itm.Name := ipmClearAll; - end; - - SetDefaultPopupMenuItemsState; - FDefaultPopupMenu.ShowAt(self, x, y); -end; - -procedure TfpgBaseEdit.DeleteSelection; -var - prevval: TfpgString; -begin - prevval := FText; - if FSelOffset <> 0 then - begin - if FSelOffset < 0 then - begin - UTF8Delete(FText, 1 + FSelStart + FSelOffset, -FSelOffset); - FCurSorPos := FSelStart + FSelOffset; - end - else - begin - UTF8Delete(FText, 1 + FSelStart, FSelOffset); - FCurSorPos := FSelStart; - end; - FSelOffset := 0; - FSelStart := FCursorPos; - end; - if prevval <> Text then - DoOnChange; -end; - -procedure TfpgBaseEdit.DoCopy; -begin - if FSelOffset = 0 then - Exit; //==> - fpgClipboard.Text := SelectionText; -end; - -procedure TfpgBaseEdit.DoPaste; -var - s: string; - prevval: TfpgString; -begin - prevval := FText; - DeleteSelection; - s := fpgClipboard.Text; - - if (FMaxLength > 0) then - if UTF8Length(FText) + UTF8Length(s) > FMaxLength then - s := UTF8Copy(s, 1, FMaxLength - UTF8Length(FText)); // trim the clipboard text if needed - - if UTF8Length(s) < 1 then - Exit; //==> - - UTF8Insert(s, FText, FCursorPos + 1); - FCursorPos := FCursorPos + UTF8Length(s); - FSelStart := FCursorPos; - Adjust; - Repaint; - if prevval <> Text then - DoOnChange; -end; - -procedure TfpgBaseEdit.SetAutoSelect(const AValue: Boolean); -begin - if FAutoSelect = AValue then - Exit; //==> - FAutoSelect := AValue; -end; - -procedure TfpgBaseEdit.SelectAll; -begin - FSelecting := True; - FSelStart := 0; - FSelOffset := UTF8Length(FText); - FCursorPos := FSelOffset; - Adjust; - Repaint; -end; - -procedure TfpgBaseEdit.Clear; -begin - Text := ''; -end; - -procedure TfpgBaseEdit.ClearSelection; -begin - DeleteSelection; - Adjust; - RePaint; -end; - -procedure TfpgBaseEdit.CopyToClipboard; -begin - DoCopy; -end; - -procedure TfpgBaseEdit.CutToClipboard; -begin - DoCopy; - DeleteSelection; - Adjust; - RePaint; -end; - -procedure TfpgBaseEdit.PasteFromClipboard; -begin - DoPaste; -end; - -{ TfpgBaseNumericEdit } - -procedure TfpgBaseNumericEdit.SetOldColor(const AValue: TfpgColor); -begin - if fOldColor=AValue then exit; - fOldColor:=AValue; -end; - -procedure TfpgBaseNumericEdit.SetAlignment(const AValue: TAlignment); -begin - if fAlignment=AValue then exit; - fAlignment:=AValue; -end; - -procedure TfpgBaseNumericEdit.SetDecimalSeparator(const AValue: char); -begin - if fDecimalSeparator=AValue then exit; - fDecimalSeparator:=AValue; -end; - -procedure TfpgBaseNumericEdit.SetNegativeColor(const AValue: TfpgColor); -begin - if fNegativeColor=AValue then exit; - fNegativeColor:=AValue; -end; - -procedure TfpgBaseNumericEdit.SetThousandSeparator(const AValue: char); -begin - if fThousandSeparator=AValue then exit; - fThousandSeparator:=AValue; -end; - -procedure TfpgBaseNumericEdit.Justify; -begin - //based on Alignment property this method will align the derived edit correctly. -end; - -procedure TfpgBaseNumericEdit.HandleKeyChar(var AText: TfpgChar; - var shiftstate: TShiftState; var consumed: Boolean); -begin - inherited HandleKeyChar(AText, shiftstate, consumed); - Format; // just call format virtual procedure to have a simple way to manage polymorphism here -end; - -procedure TfpgBaseNumericEdit.HandlePaint; -var - x: TfpgCoord; - r: TfpgRect; -begin - if Alignment = taRightJustify then - begin - Canvas.BeginDraw; - inherited HandlePaint; - // Canvas.ClearClipRect; - // r.SetRect(0, 0, Width, Height); - r.SetRect(2, 2, Width - 4, Height - 4); - Canvas.SetClipRect(r); - Canvas.Clear(BackgroundColor); - Canvas.SetFont(Font); - Canvas.SetTextColor(TextColor); - x := Width - Font.TextWidth(Text) - 3; - Canvas.DrawString(x,3,Text); - Canvas.EndDraw; - if Focused then - fpgCaret.SetCaret(Canvas, x + Font.TextWidth(Text) - 1, 3, fpgCaret.Width, Font.Height); - end - else - inherited; -end; - -procedure TfpgBaseNumericEdit.Format; -begin - // Colour negative number - if LeftStr(Text,1) = '-' then - TextColor := NegativeColor - else - TextColor := OldColor; -end; - -constructor TfpgBaseNumericEdit.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - fAlignment := taRightJustify; - DecimalSeparator := SysUtils.DecimalSeparator; - ThousandSeparator := SysUtils.ThousandSeparator; - NegativeColor := clRed; - OldColor := TextColor; -end; - -{ TfpgEditInteger } - -function TfpgEditInteger.GetValue: integer; -var - txt: string; -begin - if ShowThousand then - begin - if Copy(fText, 1, 1) = '-' then - txt := Copy(ftext, 2, Length(fText) - 1) - else - txt := fText; - while Pos(ThousandSeparator, txt) > 0 do - txt := Copy(txt, 1, Pred(Pos(ThousandSeparator, txt))) - +Copy(txt, Succ(Pos(ThousandSeparator, txt)), Length(txt) - Pos(ThousandSeparator, txt)); - if Copy(fText, 1, 1) = '-' then - fText := '-' + txt - else - fText := txt; - end; - if fText = '-' then - begin - Result := 0; - Text:= fText; - end - else - if Text > '' then - try - Result := StrToInt(fText); - except - on E: EConvertError do - begin - Result := 0; - Text := ''; - Invalidate; - end; - end - else - Result := 0; -end; - -procedure TfpgEditInteger.SetValue(const AValue: integer); -begin - try - Text := IntToStr(AValue); - except - on E: EConvertError do - Text := ''; - end; -end; - -procedure TfpgEditInteger.SetShowThousand; -var - i,long: integer; - txt, texte: string; -begin - if ShowThousand then - begin - if fText > '' then - if fText[1] = '-' then - txt:= UTF8Copy(fText, 2, UTF8Length(fText)-1) - else - txt:= fText; - long := UTF8Length(txt); - if long = 0 then - texte := '' - else - begin - for i := 1 to UTF8Length(txt) do - if txt[i] = ThousandSeparator then - Exit; // avoids additional separators when pressing return - i := 0; - texte := ''; - repeat - if i > 0 then - if ((i mod 3) = 0) and (txt[UTF8Length(txt)-UTF8Length(texte)] <> ThousandSeparator) then - begin - texte := ThousandSeparator + texte; - UTF8Insert(texte, txt, FCursorPos + 1); - if fText[1] = '-' then - begin - if Pred(FCursorPos) <= UTF8Length(texte) then - Inc(FCursorPos); - end - else - if FCursorPos <= UTF8Length(texte) then - Inc(FCursorPos); - end; - texte := Copy(txt, long - i, 1) + texte; - inc(i); - until i = long; - end; - if fText > '' then - if fText[1] = '-' then - fText:= '-' + texte - else - fText := texte; - end; -end; - -procedure TfpgEditInteger.Format; -begin - SetShowThousand; - inherited Format; -end; - -procedure TfpgEditInteger.HandleKeyChar(var AText: TfpgChar; - var shiftstate: TShiftState; var consumed: Boolean); -var - n: integer; -begin - n := Ord(AText[1]); - if ((n >= 48) and (n <= 57) or (n = Ord('-')) and (Pos(AText[1], Self.Text) <= 0)) then - consumed := False - else - consumed := True; - inherited HandleKeyChar(AText, shiftstate, consumed); -end; - -constructor TfpgEditInteger.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - fShowThousand := True; -end; - -{ TfpgEditFloat } - -function TfpgEditFloat.GetValue: extended; -var - txt: string; -begin - if fDecimals > 0 then - begin - if Pos(DecimalSeparator, fText) > 0 then - if UTF8Length(fText)-Pos(DecimalSeparator, fText) > fDecimals then - fText := Copy(fText, 1, UTF8Length(fText) - 1); - end - else - if fDecimals = 0 then - if Pos(DecimalSeparator, fText) > 0 then - fText := Copy(fText, 1, UTF8Length(fText) - 1); - if ShowThousand then - begin - if Copy(fText, 1, 1) = '-' then - txt := Copy(ftext, 2, Length(fText) - 1) - else - txt := fText; - while Pos(ThousandSeparator, txt) > 0 do - txt := Copy(txt, 1, Pred(Pos(ThousandSeparator, txt))) - +Copy(txt, Succ(Pos(ThousandSeparator, txt)), Length(txt) - Pos(ThousandSeparator, txt)); - if Copy(fText, 1, 1) = '-' then - fText := '-' + txt - else - fText := txt; - end; - if fText = '-' then - begin - Result := 0; - Text:= fText; - end - else - if fText > '' then - try - Result := StrToFloat(fText); - except - on E: EConvertError do - begin - Result := 0; - Text := ''; - Invalidate; - end; - end - else - Result := 0; -end; - -procedure TfpgEditFloat.SetValue(const AValue: extended); -begin - try - Text := FloatToStr(AValue); - except - on E: EConvertError do - Text := ''; - end; -end; - -procedure TfpgEditFloat.SetShowThousand; -var - i,long: integer; - txt, texte, decimal: string; -begin - if fDecimals > 0 then - if Pos(DecimalSeparator, fText) > 0 then - begin - txt := UTF8Copy(fText, 1, Pred(Pos(DecimalSeparator, fText))); - if UTF8Length(fText)-Pos(DecimalSeparator, fText) > fDecimals then - decimal := UTF8Copy(fText, Succ(Pos(DecimalSeparator, fText)), fDecimals) - else - decimal := UTF8Copy(fText, Succ(Pos(DecimalSeparator, fText)), UTF8Length(fText)-Pos(DecimalSeparator, fText)); - end - else - txt := fText - else - if fDecimals = 0 then - if Pos(DecimalSeparator, fText) > 0 then - txt := UTF8Copy(fText, 1, Pred(Pos(DecimalSeparator, fText))) - else - txt := fText - else - if Pos(DecimalSeparator, fText) > 0 then - begin - txt := UTF8Copy(fText, 1, Pred(Pos(DecimalSeparator, fText))); - decimal := UTF8Copy(fText, Succ(Pos(DecimalSeparator, fText)), UTF8Length(fText)-Pos(DecimalSeparator, fText)); - end - else - txt := fText; - if ShowThousand then - begin - if fText > '' then - if fText[1] = '-' then - txt:= UTF8Copy(txt, 2, UTF8Length(txt)-1); - long := UTF8Length(txt); - if long = 0 then - texte := '' - else - begin - for i := 1 to UTF8Length(txt) do - if txt[i] = ThousandSeparator then - Exit; // avoids additional separators when pressing return - i := 0; - texte := ''; - repeat - if i > 0 then - if ((i mod 3) = 0) and (txt[UTF8Length(txt)-UTF8Length(texte)] <> ThousandSeparator) then - begin - texte := ThousandSeparator + texte; - UTF8Insert(texte, txt, FCursorPos + 1); - if fText[1] = '-' then - begin - if Pred(FCursorPos) <= UTF8Length(texte) then - Inc(FCursorPos); - end - else - if FCursorPos <= UTF8Length(texte) then - Inc(FCursorPos); - end; - texte := Copy(txt, long - i, 1) + texte; - inc(i); - until i = long; - end; - if fText > '' then - if fText[1] = '-' then - if Pos(DecimalSeparator, fText) > 0 then - fText := '-' + texte + DecimalSeparator + decimal - else - fText := '-' + texte - else - if Pos(DecimalSeparator, fText) > 0 then - fText := texte + DecimalSeparator + decimal - else - fText := texte + decimal; - end; -end; - -procedure TfpgEditFloat.SetDecimals(AValue: integer); -begin - if AValue < -1 then - Exit; // => - if fDecimals <> AValue then - fDecimals := AValue -end; - -procedure TfpgEditFloat.Format; -begin - SetShowThousand; - inherited Format; -end; - -procedure TfpgEditFloat.HandleKeyChar(var AText: TfpgChar; - var shiftstate: TShiftState; var consumed: Boolean); -var - n: integer; -begin - n := Ord(AText[1]); - if ((n >= 48) and (n <= 57) or (n = Ord('-')) and (Pos(AText[1], Self.Text) <= 0)) - or ((n = Ord(Self.DecimalSeparator)) and (Pos(AText[1], Self.Text) <= 0)) then - consumed := False - else - consumed := True; - inherited HandleKeyChar(AText, shiftstate, consumed); -end; - -constructor TfpgEditFloat.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - fDecimals := -1; - fShowThousand := True; -end; - -{ TfpgEditCurrency } - -function TfpgEditCurrency.GetValue: Currency; -var - txt: string; -begin - if fDecimals > 0 then - if Pos(DecimalSeparator, fText) > 0 then - if UTF8Length(fText)-Pos(DecimalSeparator, fText) > fDecimals then - fText := Copy(fText, 1, UTF8Length(fText) - 1); - if ShowThousand then - begin - if Copy(fText, 1, 1) = '-' then - txt := Copy(ftext, 2, Length(fText) - 1) - else - txt := fText; - while Pos(ThousandSeparator, txt) > 0 do - txt := Copy(txt, 1, Pred(Pos(ThousandSeparator, txt))) - +Copy(txt, Succ(Pos(ThousandSeparator, txt)), Length(txt) - Pos(ThousandSeparator, txt)); - if Copy(fText, 1, 1) = '-' then - fText := '-' + txt - else - fText := txt; - end; - if fText = '-' then - begin - Result := 0; - Text:= fText; - end - else - if fText > '' then - try - Result := StrToCurr(fText); - except - on E: EConvertError do - begin - Result := 0; - Text := ''; - Invalidate; - end; - end - else - Result := 0; -end; - -procedure TfpgEditCurrency.SetValue(const AValue: Currency); -var - i,long: integer; - txt, texte, decimal: string; -begin - try - fText := CurrToStr(AValue); - if ShowThousand then - begin - if Pos(DecimalSeparator, fText) = 0 then - txt := fText - else - begin - txt := UTF8Copy(fText, 1, Pred(Pos(DecimalSeparator, fText))); - decimal := UTF8Copy(fText, Succ(Pos(DecimalSeparator, fText)), UTF8Length(fText) - Pos(DecimalSeparator, fText)); - end; - if AValue < 0 then - txt:= UTF8Copy(txt, 2, UTF8Length(txt)-1); - long := UTF8Length(txt); - i := 0; - texte := ''; - repeat - if i > 0 then - if ((i mod 3) = 0) and (txt[UTF8Length(txt)-UTF8Length(texte)] <> ThousandSeparator) then - begin - texte := ThousandSeparator + texte; - if AValue < 0 then - begin - if Pred(FCursorPos) <= UTF8Length(texte) then - Inc(FCursorPos); - end - else - if FCursorPos <= UTF8Length(texte) then - Inc(FCursorPos); - end; - texte := Copy(txt, long - i, 1) + texte; - inc(i); - until i = long; - if Pos(DecimalSeparator, fText) = 0 then - begin - if AValue < 0 then - begin - fText := '-' + texte; - Inc(FCursorPos); - end - else - fText := texte; - end - else - begin - if AValue < 0 then - begin - fText := '-' + texte + DecimalSeparator + decimal; - Inc(FCursorPos); - end - else - fText := texte + DecimalSeparator + decimal; - FCursorPos := FCursorPos + Succ(Length(decimal)); - end; - end; - if fDecimals > 0 then - begin - if Pos(DecimalSeparator, fText) = 0 then - begin - fText := fText + DecimalSeparator; - Inc(FCursorPos); - end; - if UTF8Length(fText)-Pos(DecimalSeparator, fText) < fDecimals then - while UTF8Length(fText)-Pos(DecimalSeparator, fText) < fDecimals do - begin - fText := fText + '0'; - Inc(FCursorPos); - end; - end; - if AValue < 0 then - TextColor := NegativeColor - else - TextColor := OldColor; - except - on E: EConvertError do - Text := ''; - end; -end; - -procedure TfpgEditCurrency.SetShowThousand; -var - i,long: integer; - txt, texte, decimal: string; -begin - if fDecimals > 0 then - if Pos(DecimalSeparator, fText) > 0 then - begin - txt := UTF8Copy(fText, 1, Pred(Pos(DecimalSeparator, fText))); - if UTF8Length(fText)-Pos(DecimalSeparator, fText) > fDecimals then - decimal := UTF8Copy(fText, Succ(Pos(DecimalSeparator, fText)), fDecimals) - else - decimal := UTF8Copy(fText, Succ(Pos(DecimalSeparator, fText)), UTF8Length(fText)-Pos(DecimalSeparator, fText)); - end - else - txt := fText; - if ShowThousand then - begin - if fText > '' then - if fText[1] = '-' then - txt:= UTF8Copy(txt, 2, UTF8Length(txt)-1); - long := UTF8Length(txt); - if long = 0 then - texte := '' - else - begin - for i := 1 to UTF8Length(txt) do - if txt[i] = ThousandSeparator then - Exit; // avoids additional separators when pressing return - i := 0; - texte := ''; - repeat - if i > 0 then - if ((i mod 3) = 0) and (txt[UTF8Length(txt)-UTF8Length(texte)] <> ThousandSeparator) then - begin - texte := ThousandSeparator + texte; - UTF8Insert(texte, txt, FCursorPos + 1); - if fText[1] = '-' then - begin - if Pred(FCursorPos) <= UTF8Length(texte) then - Inc(FCursorPos); - end - else - if FCursorPos <= UTF8Length(texte) then - Inc(FCursorPos); - end; - texte := Copy(txt, long - i, 1) + texte; - inc(i); - until i = long; - end; - if fText > '' then - if fText[1] = '-' then - if Pos(DecimalSeparator, fText) > 0 then - fText := '-' + texte + DecimalSeparator + decimal - else - fText := '-' + texte - else - if Pos(DecimalSeparator, fText) > 0 then - fText := texte + DecimalSeparator + decimal - else - fText := texte + decimal; - end; -end; - -procedure TfpgEditCurrency.SetDecimals(AValue: integer); -begin - if (AValue < 0) or (AValue > 4) then - Exit; // => - if fDecimals <> AValue then - fDecimals := AValue -end; - -procedure TfpgEditCurrency.Format; -begin - SetShowThousand; - inherited Format; -end; - -procedure TfpgEditCurrency.HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: Boolean); -begin - case keycode of - keyReturn, keyPEnter, keyTab: - if fDecimals > 0 then - begin - if Pos(DecimalSeparator, fText) = 0 then - begin - fText := fText + DecimalSeparator; - Inc(FCursorPos); - end; - if UTF8Length(fText)-Pos(DecimalSeparator, fText) < fDecimals then - while UTF8Length(fText)-Pos(DecimalSeparator, fText) < fDecimals do - begin - fText := fText + '0'; - Inc(FCursorPos); - end; - end; - end; - inherited HandleKeyPress(keycode,shiftstate,consumed); -end; - -procedure TfpgEditCurrency.HandleKeyChar(var AText: TfpgChar; - var shiftstate: TShiftState; var consumed: Boolean); -var - n: integer; -begin - n := Ord(AText[1]); - if ((n >= 48) and (n <= 57) or (n = Ord('-')) and (Pos(AText[1], Self.Text) <= 0)) - or ((n = Ord(Self.DecimalSeparator)) and (Pos(AText[1], Self.Text) <= 0)) then - consumed := False - else - consumed := True; - inherited HandleKeyChar(AText, shiftstate, consumed); -end; - -constructor TfpgEditCurrency.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - fDecimals := 2; - fShowThousand := True; -end; - - -end. - diff --git a/src/gui/gui_editcombo.pas b/src/gui/gui_editcombo.pas deleted file mode 100644 index d8f182ef..00000000 --- a/src/gui/gui_editcombo.pas +++ /dev/null @@ -1,776 +0,0 @@ -{ - fpGUI - Free Pascal GUI Toolkit - - Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this - distribution, for details of the copyright. - - See the file COPYING.modifiedLGPL, included in this distribution, - for details about redistributing fpGUI. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - - Description: - Defines a edit ComboBox control with auto-complete feature. -} - -unit gui_editcombo; - -{$mode objfpc}{$H+} - -{.$Define DEBUG} - -{ - *********************************************************** - ********** This is still under development! *********** - *********************************************************** - - It needs lots of testing and debugging. -} - - -{ TODO: Needs a lot of refactoring to get rid of code duplication. } - -{ -This is an example of what we can aim for: -You need a mono font to see the correct layout. - - - TfpgBaseComboBox - _________|______________ - | | - TfpgBaseStaticCombo TfpgBaseEditCombo - ______|_________ | - | | TfpgEditCombo - | | - TfpgComboBox TfpgBaseColorCombo - | - TfpgColorComboBox -} - -interface - -uses - Classes, - SysUtils, - fpg_base, - fpg_main, - fpg_widget, - fpg_popupwindow, - gui_combobox; - -type - TAllowNew = (anNo, anYes, anAsk); - - - { TfpgBaseEditCombo } - - TfpgBaseEditCombo = class(TfpgBaseComboBox) - private - FAutoCompletion: Boolean; - FAllowNew: TAllowNew; - FText: string; - FSelectedItem: integer; - FMaxLength: integer; - FNewItem: boolean; - procedure SetAllowNew(const AValue: TAllowNew); - procedure InternalBtnClick(Sender: TObject); - procedure InternalListBoxSelect(Sender: TObject); - procedure InternalListBoxKeyPress(Sender: TObject; var keycode: word; var shiftstate: TShiftState; - var consumed: Boolean); - protected - FMargin: integer; - FDropDown: TfpgPopupWindow; - FDrawOffset: integer; - FSelStart: integer; - FSelOffset: integer; - FCursorPos: integer; - procedure DoDropDown; override; - function GetText: string; virtual; - function HasText: boolean; virtual; - procedure SetText(const AValue: string); virtual; - procedure HandleResize(AWidth, AHeight: TfpgCoord); override; - procedure HandleKeyChar(var AText: TfpgChar; var shiftstate: TShiftState; var consumed: Boolean); override; - procedure HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: Boolean); override; - procedure HandleLMouseDown(x, y: integer; shiftstate: TShiftState); override; - procedure HandleLMouseUp(x, y: integer; shiftstate: TShiftState); override; - procedure HandlePaint; override; - property AutoCompletion: Boolean read FAutocompletion write FAutoCompletion default False; - property AllowNew: TAllowNew read FAllowNew write SetAllowNew default anNo; - property BackgroundColor default clBoxColor; - property TextColor default clText1; - property Text: string read GetText write SetText; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - procedure Update; - property NewText: boolean read FNewItem; - end; - - - TfpgEditCombo = class(TfpgBaseEditCombo) - published - property AutoCompletion; - property AllowNew; - property BackgroundColor; - property DropDownCount; - property FocusItem; - property FontDesc; - property Height; - property Items; - property Text; - property TextColor; - property Width; - property OnChange; - property OnCloseUp; - property OnDropDown; - property OnEnter; - property OnExit; - property OnKeyPress; - end; - - -function CreateEditCombo(AOwner: TComponent; x, y, w: TfpgCoord; AList:TStringList; ACompletion: boolean = False; - ANew: TAllowNew = anNo; h: TfpgCoord = 0): TfpgEditCombo; - - -implementation - -uses - fpg_stringutils, - fpg_constants, - gui_listbox, - gui_dialogs, - math; - -var - OriginalFocusRoot: TfpgWidget; - -type - { This is the class representing the dropdown window of the combo box. } - TDropDownWindow = class(TfpgPopupWindow) - private - FCallerWidget: TfpgWidget; - ListBox: TfpgListBox; - protected - procedure HandlePaint; override; - procedure HandleKeyChar(var AText: TfpgChar; var shiftstate: TShiftState; var consumed: Boolean); override; - procedure HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override; - procedure HandleShow; override; - procedure HandleHide; override; - public - constructor Create(AOwner: TComponent); override; - property CallerWidget: TfpgWidget read FCallerWidget write FCallerWidget; - end; - - -{ TDropDownWindow } - -procedure TDropDownWindow.HandlePaint; -begin - Canvas.BeginDraw; -// inherited HandlePaint; - Canvas.Clear(clWhite); - Canvas.EndDraw; -end; - -procedure TDropDownWindow.HandleKeyChar(var AText: TfpgChar; - var shiftstate: TShiftState; var consumed: Boolean); -begin - if TfpgEditCombo(FCallerWidget).FAutoCompletion then - TfpgEditCombo(FCallerWidget).HandleKeyChar(AText,shiftstate,consumed); -end; - -procedure TDropDownWindow.HandleKeyPress(var keycode: word; - var shiftstate: TShiftState; var consumed: boolean); -begin - if TfpgEditCombo(FCallerWidget).FAutoCompletion then - begin - TfpgEditCombo(FCallerWidget).HandleKeyPress(keycode,shiftstate,consumed); -// consumed:= True; - end - else - begin - inherited HandleKeyPress(keycode, shiftstate, consumed); - if keycode = keyEscape then - begin - consumed := True; - Close; - end; - end; -end; - -procedure TDropDownWindow.HandleShow; -begin - ListBox.SetPosition(0, 0, Width, Height); - inherited HandleShow; - ActiveWidget := ListBox; -end; - -procedure TDropDownWindow.HandleHide; -begin - // HandleHide also gets called in TfpgWidget.Destroy so we need a few - // if Assigned() tests here. This should be improved on. -// if Assigned(FocusRootWidget) then -// FocusRootWidget.ReleaseMouse; // for internal ListBox - - if Assigned(CallerWidget) then - CallerWidget.SetFocus; - inherited HandleHide; -end; - -constructor TDropDownWindow.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - ListBox := TfpgListBox.Create(self); - ListBox.PopupFrame := True; -end; - -function CreateEditCombo(AOwner: TComponent; x, y, w: TfpgCoord; AList:TStringList; ACompletion: boolean = False; - ANew: TAllowNew = anNo; h: TfpgCoord = 0): TfpgEditCombo; -begin - Result := TfpgEditCombo.Create(AOwner); - Result.Left := x; - Result.Top := y; - Result.Width := w; - Result.Focusable := True; - Result.AutoCompletion := ACompletion; - Result.AllowNew := ANew; - if h < TfpgEditCombo(Result).Font.Height + 6 then - Result.Height:= TfpgEditCombo(Result).Font.Height + 6 - else - Result.Height:= h; - - if Assigned(AList) then - Result.Items.Assign(AList); -end; - -{ TfpgBaseEditCombo } - -procedure TfpgBaseEditCombo.SetAllowNew(const AValue: TAllowNew); -begin - if FAllowNew <> AValue then - FAllowNew := AValue; -end; - -function TfpgBaseEditCombo.GetText: string; -var - i: integer; -begin - if FAutoCompletion then - Result := FText - else - if (FocusItem >= 0) and (FocusItem <= FItems.Count-1) then - Result := FItems.Strings[FocusItem] - else - Result := ''; -end; - -function TfpgBaseEditCombo.HasText: boolean; -begin - Result := FFocusItem >= 0; -end; - -procedure TfpgBaseEditCombo.DoDropDown; -var - ddw: TDropDownWindow; - rowcount, i: integer; - r: TfpgRect; -begin - if (not Assigned(FDropDown)) or (not FDropDown.HasHandle) then - begin - FreeAndNil(FDropDown); - OriginalFocusRoot := FocusRootWidget; - FDropDown := TDropDownWindow.Create(nil); - ddw := TDropDownWindow(FDropDown); - ddw.Width := Width; - ddw.CallerWidget := self; - ddw.ListBox.OnSelect := @InternalListBoxSelect; - ddw.ListBox.OnKeyPress := @InternalListBoxKeyPress; - - // Assign combobox text items to internal listbox - if FAutoCompletion then - begin - for i := 0 to FItems.Count-1 do - if SameText(UTF8Copy(FItems.Strings[i], 1, UTF8Length(FText)), FText) then - ddw.ListBox.Items.Add(FItems.Strings[i]); - end - else - ddw.ListBox.Items.Assign(FItems); - - // adjust the height of the dropdown - rowcount := ddw.ListBox.Items.Count; - if rowcount > DropDownCount then - rowcount := DropDownCount; - if rowcount < 1 then - rowcount := 1; - ddw.Height := (ddw.ListBox.RowHeight * rowcount) + 4; - ddw.ListBox.Height := ddw.Height; // needed in follow focus, otherwise, the default value (80) is used - - // set default focusitem - ddw.ListBox.FocusItem := FFocusItem; - - ddw.DontCloseWidget := self; // now we can control when the popup window closes - r := GetDropDownPos(Parent, self, ddw); - ddw.Height := r.Height; - - if (FItems.Count > 0) then - DoOnDropDown; - ddw.OnClose := @InternalOnClose; - - ddw.ShowAt(Parent, r.Left, r.Top); - end - else - begin - FBtnPressed := False; - ddw := TDropDownWindow(FDropDown); - ddw.Close; - FreeAndNil(FDropDown); - end; -end; - -procedure TfpgBaseEditCombo.InternalBtnClick(Sender: TObject); -begin - DoDropDown; -end; - -procedure TfpgBaseEditCombo.InternalListBoxSelect(Sender: TObject); -var - i: Integer; -begin - for i := 0 to Items.Count-1 do - begin - if Items[i]= TDropDownWindow(FDropDown).ListBox.Items[TDropDownWindow(FDropDown).ListBox.FocusItem] then - begin - FocusItem := i; - FSelectedItem:= i; - FText:= Items[i]; - Break; - end; - end; - FDropDown.Close; - //Repaint will check if Handle is created - Repaint; -end; - -procedure TfpgBaseEditCombo.InternalListBoxKeyPress(Sender: TObject; var keycode: word; - var shiftstate: TShiftState; var consumed: Boolean); -var - i: Integer; -begin - if ((keycode = keyUp) or (keycode = keyDown)) and (TDropDownWindow(FDropDown).ListBox.FocusItem > -1) then - for i := 0 to Items.Count-1 do - begin - if Items[i]= TDropDownWindow(FDropDown).ListBox.Items[TDropDownWindow(FDropDown).ListBox.FocusItem] then - begin - FSelectedItem:= i; - Break; - end; - end; - - //Repaint will check if Handle is created - Repaint; -end; - -procedure TfpgBaseEditCombo.SetText(const AValue: string); -var - i: integer; -begin - if AValue = '' then - begin - FText:= ''; - FocusItem := -1; // nothing selected - end - else - begin - for i := 0 to Items.Count-1 do - begin - if SameText(UTF8Copy(Items.Strings[i], 1, UTF8Length(AVAlue)), AValue) then - begin - FocusItem := i; - FText:= AValue; - Repaint; - Exit; //==> - end; - end; - // if we get here, we didn't find a match - FocusItem := -1; - end; -end; - -procedure TfpgBaseEditCombo.HandleResize(AWidth, AHeight: TfpgCoord); -begin - inherited HandleResize(AWidth, AHeight); - if FSizeIsDirty then - CalculateInternalButtonRect; -end; - -procedure TfpgBaseEditCombo.HandleKeyChar(var AText: TfpgChar; - var shiftstate: TShiftState; var consumed: Boolean); -var - s: TfpgChar; - prevval: string; - i: integer; -begin - prevval := FText; - s := AText; - consumed := False; - if FText = '' then - FNewItem := False; - - // Handle only printable characters - // Note: This is now UTF-8 compliant! - if Enabled and (Ord(AText[1]) > 31) and (Ord(AText[1]) < 127) or (Length(AText) > 1) then - begin - if (FMaxLength <= 0) or (UTF8Length(FText) < FMaxLength) then - begin - UTF8Insert(s, FText, FCursorPos + UTF8Length(s)); - Inc(FCursorPos); - FSelStart := FCursorPos; - if Assigned(FDropDown) then - FDropDown.Close; - FSelectedItem := -1; - for i := 0 to FItems.Count-1 do - if SameText(UTF8Copy(FItems.Strings[i], 1, UTF8Length(FText)), FText) then - begin - FSelectedItem:= i; - DoDropDown; - Break; - end; - if FSelectedItem = -1 then - if FAllowNew = anNo then - begin - UTF8Delete(FText, FCursorPos, 1); - Dec(FCursorPos); - FSelStart := FCursorPos; - for i := 0 to FItems.Count-1 do - if SameText(UTF8Copy(FItems.Strings[i], 1, UTF8Length(FText)), FText) then - begin - FSelectedItem:= i; - DoDropDown; - Break; - end; - end - else - FNewItem:= True; - end; - consumed := True; - end; - - if prevval <> FText then - DoOnChange; - - if consumed then - RePaint; -// else - inherited HandleKeyChar(AText, shiftstate, consumed); -end; - -procedure TfpgBaseEditCombo.HandleKeyPress(var keycode: word; - var shiftstate: TShiftState; var consumed: boolean); -var - hasChanged: boolean; - i: integer; -begin - hasChanged := False; - - if not Enabled then - consumed := False - else - begin - consumed := True; - - case keycode of - keyBackSpace: - begin - if FCursorPos > 0 then - begin - UTF8Delete(FText, FCursorPos, 1); - Dec(FCursorPos); - FSelStart := FCursorPos; - if Assigned(FDropDown) then - FDropDown.Close; - FSelectedItem := -1; - for i := 0 to FItems.Count-1 do - if SameText(UTF8Copy(FItems.Strings[i], 1, UTF8Length(FText)), FText) then - begin - FSelectedItem:= i; - if FNewItem then - FNewItem:= False; - DoDropDown; - Break; - end; - hasChanged := True; - end; - end; - keyDelete: - begin - if FAllowNew <> anNo then - begin - FocusItem := -1; - FSelectedItem := -1; - FNewItem:= True; - hasChanged := True; - end; - end; - - keyReturn, - keyPEnter: - begin - if FSelectedItem > -1 then - SetText(Items[FSelectedItem]) - else - FocusItem:= -1; - if FNewItem then - case FAllowNew of - anYes: - FItems.Add(FText); - anAsk: - begin - if TfpgMessageDialog.Question(rsNewItemDetected, Format(rsAddNewItem, [FText])) = mbYes then - begin - FItems.Add(FText); - FocusItem := Pred(FItems.Count); - end - else - begin - FNewItem:= False; - FocusItem := -1; - FText:= ''; - end; { if/else } - Parent.ActivateWindow; - end; - end; - hasChanged := True; - if Assigned(FDropDown) then - FDropDown.Close; - end; - else - begin - Consumed := False; - end; - end; - end; - - if Consumed then - begin - FSelStart := FCursorPos; - FSelOffset := 0; - end; - - if consumed and hasChanged then - RePaint; - - if hasChanged then - DoOnChange; - inherited HandleKeyPress(keycode, shiftstate, consumed); -end; - -procedure TfpgBaseEditCombo.HandleLMouseDown(x, y: integer; - shiftstate: TShiftState); -begin - inherited HandleLMouseDown(x, y, shiftstate); - // button state is down only if user clicked in the button rectangle. - FBtnPressed := PtInRect(FInternalBtnRect, Point(x, y)); - if not FAutoCompletion then - begin - PaintInternalButton; - DoDropDown; - end - else if FBtnPressed then - begin - PaintInternalButton; - DoDropDown; - end; -end; - -procedure TfpgBaseEditCombo.HandleLMouseUp(x, y: integer; - shiftstate: TShiftState); -begin - inherited HandleLMouseUp(x, y, shiftstate); - FBtnPressed := False; - PaintInternalButton; -end; - -procedure TfpgBaseEditCombo.HandlePaint; -var - r: TfpgRect; - tw, tw2, st, len: integer; - Texte: string; - - // paint selection rectangle - procedure DrawSelection; - var - lcolor: TfpgColor; - begin - if Focused then - begin - lcolor := clSelection; - Canvas.SetTextColor(clSelectionText); - end - else - begin - lcolor := clInactiveSel; - Canvas.SetTextColor(clText1); - end; - - len := FSelOffset; - st := FSelStart; - if len < 0 then - begin - st := st + len; - len := -len; - end; - tw := Font.TextWidth(UTF8Copy(Items[FSelectedItem], 1, st)); - tw2 := Font.TextWidth(UTF8Copy(Items[FSelectedItem], 1, st + len)); - - // XOR on Anti-aliased text doesn't look to good. Lets try standard - // Blue & White like what was doen in TfpgEdit. -{ Canvas.SetColor(lcolor); - Canvas.FillRectangle(-FDrawOffset + FMargin + tw, 3, tw2 - tw, Font.Height); - r.SetRect(-FDrawOffset + FMargin + tw, 3, tw2 - tw, Font.Height); - Canvas.AddClipRect(r); - Canvas.SetTextColor(clWhite); - fpgStyle.DrawString(Canvas, -FDrawOffset + FMargin, 3, Text, Enabled); - Canvas.ClearClipRect; -} - Canvas.XORFillRectangle(fpgColorToRGB(lcolor) xor $FFFFFF, - -FDrawOffset + FMargin + tw, 3, tw2 - tw, Font.Height); - end; - -begin - Canvas.BeginDraw; -// inherited HandlePaint; - Canvas.ClearClipRect; - r.SetRect(0, 0, Width, Height); - Canvas.DrawControlFrame(r); - - // internal background rectangle (without frame) - InflateRect(r, -2, -2); - Canvas.SetClipRect(r); - - if Enabled then - Canvas.SetColor(FBackgroundColor) - else - Canvas.SetColor(clWindowBackground); - - Canvas.FillRectangle(r); - - // paint the fake dropdown button - PaintInternalButton; - - Dec(r.Width, FInternalBtnRect.Width); - Canvas.SetClipRect(r); - Canvas.SetFont(Font); - - if not AutoCompletion then - if Focused then - begin - Canvas.SetColor(clSelection); - Canvas.SetTextColor(clSelectionText); - InflateRect(r, -1, -1); - end - else - begin - if Enabled then - Canvas.SetColor(FBackgroundColor) - else - Canvas.SetColor(clWindowBackground); - Canvas.SetTextColor(FTextColor); - end - else - begin - if Enabled then - Canvas.SetColor(FBackgroundColor) - else - Canvas.SetColor(clWindowBackground); - Canvas.SetTextColor(FTextColor); - end; - Canvas.FillRectangle(r); - - // Draw select item's text - if not AutoCompletion then - begin - if HasText then - fpgStyle.DrawString(Canvas, FMargin+1, FMargin, Text, Enabled); - end - else - begin - if HasText then - begin - FSelOffset := 0; - fpgStyle.DrawString(Canvas, FMargin+1, FMargin, Text, Enabled); - end - else - begin - Texte := Text; - if Texte <> '' then - if FSelectedItem > -1 then - begin - FSelOffset := Font.TextWidth(UTF8Copy(Items[FSelectedItem], UTF8Length(FText) + 1, - UTF8Length(Items[FSelectedItem]) - UTF8Length(FText))); - fpgStyle.DrawString(Canvas, FMargin+1, FMargin, FText + UTF8Copy(Items[FSelectedItem], - UTF8Length(FText) + 1, UTF8Length(Items[FSelectedItem]) - UTF8Length(FText)), Enabled); - end - else - begin - FSelOffset := 0; - fpgStyle.DrawString(Canvas, FMargin+1, FMargin, FText, Enabled); - end; - end; - - if Focused then - begin - // drawing selection - if FSelOffset <> 0 then - DrawSelection; - - // drawing cursor - FCursorPos:= UTF8Length(FText); - tw := Font.TextWidth(UTF8Copy(FText, 1, FCursorPos)); - fpgCaret.SetCaret(Canvas, -FDrawOffset + FMargin + tw, 3, fpgCaret.Width, Font.Height); - end - else - fpgCaret.UnSetCaret(Canvas); - end; - - Canvas.EndDraw; -end; - -constructor TfpgBaseEditCombo.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - FBackgroundColor := clBoxColor; - FTextColor := Parent.TextColor; - FWidth := 120; - FHeight := Font.Height + 6; - FMargin := 3; - FFocusable := True; - FAutocompletion := False; - FAllowNew := anNo; - - FText := ''; - FCursorPos := UTF8Length(FText); - FSelStart := FCursorPos; - FSelOffset := 0; - FDrawOffset := 0; - FSelectedItem := -1; // to allow typing if list is empty - FNewItem := False; - - CalculateInternalButtonRect; -end; - -destructor TfpgBaseEditCombo.Destroy; -begin - FDropDown.Free; - inherited Destroy; -end; - -procedure TfpgBaseEditCombo.Update; -begin - FFocusItem := -1; - Repaint; -end; - -end. diff --git a/src/gui/gui_form.pas b/src/gui/gui_form.pas deleted file mode 100644 index 230cfd44..00000000 --- a/src/gui/gui_form.pas +++ /dev/null @@ -1,429 +0,0 @@ -{ - fpGUI - Free Pascal GUI Toolkit - - Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this - distribution, for details of the copyright. - - See the file COPYING.modifiedLGPL, included in this distribution, - for details about redistributing fpGUI. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - - Description: - Defines a Form control. Also known as a Window which holds other - controls. -} - -unit gui_form; - -{$mode objfpc}{$H+} - -interface - -uses - Classes, - SysUtils, - fpg_base, - fpg_widget; - -type - TWindowPosition = (wpUser, wpAuto, wpScreenCenter); - TCloseAction = (caNone, caHide, caFree{, caMinimize}); - - TFormCloseEvent = procedure(Sender: TObject; var CloseAction: TCloseAction) of object; - TFormCloseQueryEvent = procedure(Sender: TObject; var CanClose: boolean) of object; - - TfpgBaseForm = class(TfpgWidget) - private - FFullScreen: boolean; - FOnActivate: TNotifyEvent; - FOnClose: TFormCloseEvent; - FOnCloseQuery: TFormCloseQueryEvent; - FOnCreate: TNotifyEvent; - FOnDeactivate: TNotifyEvent; - FOnDestroy: TNotifyEvent; - FOnHide: TNotifyEvent; - FOnShow: TNotifyEvent; - protected - FModalResult: TfpgModalResult; - FParentForm: TfpgBaseForm; - FWindowPosition: TWindowPosition; - FWindowTitle: string; - FSizeable: boolean; - procedure AdjustWindowStyle; override; - procedure SetWindowParameters; override; - procedure SetWindowTitle(const ATitle: string); override; - procedure MsgActivate(var msg: TfpgMessageRec); message FPGM_ACTIVATE; - procedure MsgDeActivate(var msg: TfpgMessageRec); message FPGM_DEACTIVATE; - procedure MsgClose(var msg: TfpgMessageRec); message FPGM_CLOSE; - procedure HandlePaint; override; - procedure HandleClose; virtual; - procedure HandleHide; override; - procedure HandleShow; override; - procedure HandleMove(x, y: TfpgCoord); override; - procedure HandleResize(awidth, aheight: TfpgCoord); override; - procedure HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override; - procedure DoOnClose(var CloseAction: TCloseAction); virtual; - // properties - property Sizeable: boolean read FSizeable write FSizeable; - property ModalResult: TfpgModalResult read FModalResult write FModalResult; - property FullScreen: boolean read FFullScreen write FFullScreen default False; - property WindowPosition: TWindowPosition read FWindowPosition write FWindowPosition default wpAuto; - property WindowTitle: string read FWindowTitle write SetWindowTitle; - // events - property OnActivate: TNotifyEvent read FOnActivate write FOnActivate; - property OnClose: TFormCloseEvent read FOnClose write FOnClose; - property OnCloseQuery: TFormCloseQueryEvent read FOnCloseQuery write FOnCloseQuery; - property OnCreate: TNotifyEvent read FOnCreate write FOnCreate; - property OnDeactivate: TNotifyEvent read FOnDeactivate write FOnDeactivate; - property OnDestroy: TNotifyEvent read FOnDestroy write FOnDestroy; - property OnHide: TNotifyEvent read FOnHide write FOnHide; - property OnShow: TNotifyEvent read FOnShow write FOnShow; - public - constructor Create(AOwner: TComponent); override; - procedure AfterConstruction; override; - procedure BeforeDestruction; override; - procedure AfterCreate; virtual; - procedure Show; - procedure Hide; - function ShowModal: integer; - procedure Close; - function CloseQuery: boolean; virtual; - end; - - - TfpgForm = class(TfpgBaseForm) - published - property BackgroundColor; - property FullScreen; - property ModalResult; - property Sizeable; - property ShowHint; - property TextColor; - property WindowPosition; - property WindowTitle; - property OnActivate; - property OnClose; - property OnCloseQuery; - property OnCreate; - property OnDeactivate; - property OnDestroy; - property OnHide; - property OnPaint; - property OnResize; - property OnShow; - end; - - -function WidgetParentForm(wg: TfpgWidget): TfpgForm; - - -implementation - -uses - fpg_main, - fpg_popupwindow, - gui_menu; - -type - // to access protected methods - TfpgMenuBarFriend = class(TfpgMenuBar) - end; - - -function WidgetParentForm(wg: TfpgWidget): TfpgForm; -var - w: TfpgWidget; -begin - w := wg; - while w <> nil do - begin - if w is TfpgForm then - begin - Result := TfpgForm(w); - Exit; //==> - end; - w := w.Parent; - end; - Result := nil; -end; - -{ TfpgBaseForm } - -procedure TfpgBaseForm.SetWindowTitle(const ATitle: string); -begin - FWindowTitle := ATitle; - inherited SetWindowTitle(ATitle); -end; - -procedure TfpgBaseForm.MsgActivate(var msg: TfpgMessageRec); -begin -// writeln('BaseForm - MsgActivate'); - if (fpgApplication.TopModalForm = nil) or (fpgApplication.TopModalForm = self) then - begin - FocusRootWidget := self; - - if FFormDesigner <> nil then - begin - FFormDesigner.Dispatch(msg); - Exit; - end; - - if ActiveWidget = nil then - ActiveWidget := FindFocusWidget(nil, fsdFirst) - else - ActiveWidget.SetFocus; - end; - - if Assigned(FOnActivate) then - FOnActivate(self); -end; - -procedure TfpgBaseForm.MsgDeActivate(var msg: TfpgMessageRec); -begin - ClosePopups; - if ActiveWidget <> nil then - ActiveWidget.KillFocus; - if Assigned(FOnDeactivate) then - FOnDeactivate(self); -end; - -procedure TfpgBaseForm.HandlePaint; -begin - inherited HandlePaint; - Canvas.Clear(FBackgroundColor); -end; - -procedure TfpgBaseForm.AdjustWindowStyle; -begin - if fpgApplication.MainForm = nil then - fpgApplication.MainForm := self; - - if FWindowPosition = wpAuto then - Include(FWindowAttributes, waAutoPos) - else - Exclude(FWindowAttributes, waAutoPos); - - if FWindowPosition = wpScreenCenter then - Include(FWindowAttributes, waScreenCenterPos) - else - Exclude(FWindowAttributes, waScreenCenterPos); - - if FSizeable then - Include(FWindowAttributes, waSizeable) - else - Exclude(FWindowAttributes, waSizeable); - - if FFullScreen then - Include(FWindowAttributes, waFullScreen) - else - Exclude(FWindowAttributes, waFullScreen); -end; - -procedure TfpgBaseForm.SetWindowParameters; -begin - inherited; - DoSetWindowTitle(FWindowTitle); -end; - -constructor TfpgBaseForm.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - FWindowPosition := wpAuto; - FWindowTitle := ''; - FSizeable := True; - FParentForm := nil; - FBackgroundColor := clWindowBackground; - FTextColor := clText1; - FMinWidth := 32; - FMinHeight := 32; - FModalResult := mrNone; - FFullScreen := False; - FIsContainer := True; -end; - -procedure TfpgBaseForm.AfterCreate; -begin - // for the user -end; - -procedure TfpgBaseForm.Show; -begin - FVisible := True; - HandleShow; -end; - -function TfpgBaseForm.ShowModal: integer; -var - lCloseAction: TCloseAction; -begin - FWindowType := wtModalForm; - fpgApplication.PushModalForm(self); - ModalResult := mrNone; - - Show; - - // processing messages until this form ends. - // delivering the remaining messages - fpgApplication.ProcessMessages; - try - repeat - fpgWaitWindowMessage; - until (ModalResult <> mrNone) or (not Visible); - except - on E: Exception do - begin - ModalResult := -1; - Visible := False; - fpgApplication.HandleException(self); - end; - end; - - fpgApplication.PopModalForm; - Result := ModalResult; - - if ModalResult <> mrNone then - begin - lCloseAction := caFree; // Dummy variable - we do nothing with it - DoOnClose(lCloseAction); // Simply so the OnClose event fires. - end; -end; - -procedure TfpgBaseForm.MsgClose(var msg: TfpgMessageRec); -begin - HandleClose; -end; - -procedure TfpgBaseForm.HandleClose; -begin - Close; -end; - -procedure TfpgBaseForm.HandleHide; -begin - if Assigned(FOnHide) then - FOnHide(self); - inherited HandleHide; -end; - -procedure TfpgBaseForm.HandleShow; -begin - inherited HandleShow; - HandleAlignments(0, 0); - if Assigned(FOnShow) then - FOnShow(self); -end; - -procedure TfpgBaseForm.HandleMove(x, y: TfpgCoord); -begin - ClosePopups; - inherited HandleMove(x, y); -end; - -procedure TfpgBaseForm.HandleResize(awidth, aheight: TfpgCoord); -begin - ClosePopups; - inherited HandleResize(awidth, aheight); -end; - -procedure TfpgBaseForm.HandleKeyPress(var keycode: word; - var shiftstate: TShiftState; var consumed: boolean); -var - i: integer; - wg: TfpgWidget; -begin -// writeln(Classname, '.Keypress'); - // find the TfpgMenuBar - if not consumed then - begin - for i := 0 to ComponentCount-1 do - begin - wg := TfpgWidget(Components[i]); - if (wg <> nil) and (wg <> self) and (wg is TfpgMenuBar) then - begin - TfpgMenuBarFriend(wg).HandleKeyPress(keycode, shiftstate, consumed); - Break; //==> - end; - end; - end; { if } - - inherited HandleKeyPress(keycode, shiftstate, consumed); -end; - -procedure TfpgBaseForm.AfterConstruction; -begin - inherited AfterConstruction; - AfterCreate; - if Assigned(FOnCreate) then - FOnCreate(self); -end; - -procedure TfpgBaseForm.BeforeDestruction; -begin - inherited BeforeDestruction; - if Assigned(FOnDestroy) then - FOnDestroy(self); -end; - -procedure TfpgBaseForm.DoOnClose(var CloseAction: TCloseAction); -begin - if Assigned(FOnClose) then - OnClose(self, CloseAction); -end; - -procedure TfpgBaseForm.Hide; -begin - Visible := False; -// HandleHide; - if ModalResult = mrNone then - ModalResult := -1; -end; - -procedure TfpgBaseForm.Close; -var - CloseAction: TCloseAction; - IsMainForm: Boolean; -begin - if CloseQuery then // May we close the form? User could override decision - begin - IsMainForm := fpgApplication.MainForm = self; - if IsMainForm then - CloseAction := caFree - else - CloseAction := caHide; - - // execute event handler - maybe user wants to modify it. - DoOnClose(CloseAction); - // execute action according to close action - case CloseAction of - caHide: - begin - Hide; - end; - // fpGUI Forms don't have a WindowState property yet! -// caMinimize: WindowState := wsMinimized; - caFree: - begin - HandleHide; - if IsMainForm then - fpgApplication.Terminate - else - // We can't free ourselves, somebody else needs to do it - fpgPostMessage(Self, fpgApplication, FPGM_CLOSE); - end; - end; { case CloseAction } - end; { if CloseQuery } -end; - -function TfpgBaseForm.CloseQuery: boolean; -begin - Result := True; - if Assigned(FOnCloseQuery) then - FOnCloseQuery(self, Result); -end; - - -end. - diff --git a/src/gui/gui_gauge.pas b/src/gui/gui_gauge.pas deleted file mode 100644 index 68fb864f..00000000 --- a/src/gui/gui_gauge.pas +++ /dev/null @@ -1,572 +0,0 @@ -{ - fpGUI - Free Pascal GUI Toolkit - - Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this - distribution, for details of the copyright. - - See the file COPYING.modifiedLGPL, included in this distribution, - for details about redistributing fpGUI. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - - Description: - A Gauge component that supports different display styles. eg: Needle, - Dial, Pie etc. -} - -unit gui_gauge; - -{$mode objfpc}{$H+} - -interface - -uses - Classes, SysUtils, math, - fpg_base, - fpg_main, - fpg_widget; - -type - - TGaugeKind = (gkText, gkHorizontalBar, gkVerticalBar, gkPie, gkNeedle, gkDial); - - TBorderStyle = (bsNone, bsSingle, bsDouble, bsRaisedPanel, bsSunkenPanel, - bsRaised3D, bsSunken3D, bsEtched, bsEmmbossed); - - - TfpgGauge = class(TfpgWidget) - private - FFont: TfpgFont; - FClientRect: TfpgRect; - FMin: Longint; - FMax: Longint; - FPosition: Longint; - FKind: TGaugeKind; - FShowText: Boolean; - { TODO: Implement Border style } - FBorderStyle: TBorderStyle; - FColor: TfpgColor; // Background color - { Currently little used colors, should be derived from style and possibly - overriden by user TODO - How to deal with gradients? Starting color and compute ending, - or give pair? } - FFirstColor: TfpgColor; // Text and Needle color - FSecondColor: TfpgColor; // Bar, Pie etc. main color - { TODO: Currently unused. Implement Low Watermark and High Watermark } -// FLWMColor: TfpgColor; // Low Watermark Color -// FLWMValue: Longint; // Low Watermark Value -// FHWMColor: TfpgColor; // High Watermark Color -// FHWMValue: Longint; // High Watermark Color - procedure BackgroundDraw; - procedure TextDraw; - procedure BarDraw; - procedure PieDraw; - procedure NeedleDraw; - procedure DialDraw; - procedure SetGaugeKind(AValue: TGaugeKind); - procedure SetShowText(AValue: Boolean); - procedure SetBorderStyle(AValue: TBorderStyle); - procedure SetFirstColor(AValue: TfpgColor); - procedure SetSecondColor(AValue: TfpgColor); - procedure SetMin(AValue: Longint); - procedure SetMax(AValue: Longint); - procedure SetProgress(AValue: Longint); - function GetPercentage: Longint; - protected - procedure HandlePaint; override; - public - constructor Create(AOwner: TComponent); override; - procedure AddProgress(AValue: Longint); - property Percentage: Longint read GetPercentage; - property Font: TfpgFont read FFont; - published - property Align; - property Anchors; - property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle; - property Color: TfpgColor read FColor write FColor default clButtonFace; - property Enabled; - property FirstColor: TfpgColor read FFirstColor write SetFirstColor default clBlack; - property Kind: TGaugeKind read FKind write SetGaugeKind default gkHorizontalBar; - property MaxValue: Longint read FMax write SetMax default 100; - property MinValue: Longint read FMin write SetMin default 0; - property ParentShowHint; - property Progress: Longint read FPosition write SetProgress; - property SecondColor: TfpgColor read FSecondColor write SetSecondColor default clWhite; - property ShowHint; - property ShowText: Boolean read FShowText write SetShowText default True; - property Visible; - end; - - -// A convenience function to quickly create a gauge from code -function CreateGauge (AOwner: TComponent; ALeft, ATop, AWidth, - AHeight: TfpgCoord; AKind: TGaugeKind ): TfpgGauge; - - -implementation - -uses - fpg_wuline; - -{ This procedure draws a filled arc with a color gradient - - to be moved in CanvasBase? } -procedure FillArcGradient(canvas: TfpgCanvas; X,Y,W,H: TfpgCoord; a1,a2: double; Astart,Astop: TfpgColor); -var - RGBStart: TRGBTriple; - RGBStop: TRGBTriple; - RDiff, GDiff, BDiff: Integer; - count: Integer; - i: Integer; - newcolor: TRGBTriple; -begin - if Astart = Astop then - begin { No gradient, just solid color} - canvas.SetColor(Astart); - canvas.FillArc(X, Y, W, H, a1, a2); - Exit; //==> - end; - - RGBStart := fpgColorToRGBTriple(fpgColorToRGB(AStart)); - RGBStop := fpgColorToRGBTriple(fpgColorToRGB(AStop)); - - count := min(H,W); - count := count div 2; - count := count -2 ; - - RDiff := RGBStop.Red - RGBStart.Red; - GDiff := RGBStop.Green - RGBStart.Green; - BDiff := RGBStop.Blue - RGBStart.Blue; - - - { X11 draws arcs at one pixel distance without leaving out pixels, so Line Width - of 1 would be appropriate, but GDI doesn't, and therefore Line Width 2 is - required to make both work} - - //canvas.SetLineStyle(1,lsSolid); - canvas.SetLineStyle(2,lsSolid); - for i := 0 to count do - begin - X := X + 1; - Y := Y + 1; - W := W - 2; - H := H - 2; - newcolor.Red := RGBStart.Red + (i * RDiff) div count; - newcolor.Green := RGBStart.Green + (i * GDiff) div count; - newcolor.Blue := RGBStart.Blue + (i * BDiff) div count; - canvas.SetColor(RGBTripleTofpgColor(newcolor)); - canvas.DrawArc(X, Y, W, H, a1, a2); - end; -end; - -function CreateGauge(AOwner: TComponent; ALeft, ATop, AWidth, AHeight: TfpgCoord; - AKind: TGaugeKind): TfpgGauge; -begin - Result := TfpgGauge.Create(AOwner); - Result.Left := ALeft; - Result.Top := ATop; - Result.Width := AWidth; - Result.Height := AHeight; - Result.Kind := AKind; -end; - -{ TfpgGauge } - -{ Drawing procedures - they're called from HandlePaint, which takes care of - Canvas.BeginDraw and Canvas.EndDraw - Shouldn't be used otherwise. } -procedure TfpgGauge.BackgroundDraw; -begin - {common Background for all kinds } - - {Client area is Widget area, to start with} - FClientRect.SetRect(0, 0, Width, Height); - Canvas.ClearClipRect; - Canvas.Clear(Color); - { This must be adjusted according the selected style } - Canvas.SetColor(TfpgColor($999999)); - Canvas.SetLineStyle(1, lsSolid); - Canvas.DrawRectangle(FClientRect); - { This must be completed and adjusted with border style } - InflateRect(FClientRect, -1, -1); - with FClientRect do - begin - { Kind specific Bacground } - case FKind of - { Currently Text doesn't require additional Bacground } - { And so horizontal and vertical bar - Unless style requires it} - gkHorizontalBar, - gkVerticalBar: - begin - Canvas.SetLineStyle(1, lsSolid); // just in case background changed that - end; - gkPie: - begin - { Round frame for the Pie } - Canvas.SetLineStyle(2, lsSolid); - Canvas.SetColor(TfpgColor($98b2ed)); - Canvas.DrawArc(Left, Top, Width, Height, 0, 360); - end; - gkNeedle: - begin - { Half a filled circle background for needle } - FillArcGradient(Canvas,Left, Top, Width, Height * 2 -1, 0, 180,TfpgColor($425d9b),TfpgColor($98b2ed)); - Canvas.SetLineStyle(2, lsSolid); - //Canvas.SetColor(TfpgColor($3b4c71)); - Canvas.SetColor(TfpgColor($98b2ed)); - Canvas.DrawArc(Left, Top, Width, Height * 2 - 1, 0, 180); - Canvas.SetLineStyle(1, lsSolid); - Canvas.SetColor(TfpgColor($3b4c71)); - Canvas.DrawLine(Left, Bottom,Left + Width, Bottom); - end; - gkDial: - begin - { 270° pie shaped background for Dial } - FillArcGradient (Canvas,Left, Top, Width, Height , 225, -270 ,TfpgColor($425d9b),TfpgColor($98b2ed)); - Canvas.SetLineStyle(2, lsSolid); - //Canvas.SetColor(TfpgColor($3b4c71)); - Canvas.SetColor(TfpgColor($98b2ed)); - Canvas.DrawArc(Left,Top,Width,Height,225,-270); - end; - end; - end; { with } -end; - -procedure TfpgGauge.TextDraw; -var - S: string; - X, Y: Integer; -begin - S := Format('%d%%', [Percentage]); - with FClientRect do - begin - X := (Width - FFont.TextWidth(S)) div 2; - Y := (Height - FFont.Height) div 2; - if Kind = gkDial then - Y := Y + (Y div 2); - end; -{ If contrast is poor we might use a Xor function } - Canvas.SetTextColor(FirstColor); - Canvas.Font := FFont; - Canvas.DrawString(x, y, S); -end; - -procedure TfpgGauge.BarDraw; -var - BarLength: Longint; - SavedRect: TfpgRect; -begin - SavedRect := FClientRect; // save client rect for text !! - with FClientRect do - begin - case FKind of - gkHorizontalBar: - begin - BarLength := Longint(Trunc( (Width * Percentage) / 100.0 ) ); - if BarLength > 0 then - begin - if BarLength > Width then - BarLength := Width; - Width := BarLength; - // left top - Canvas.SetColor(TfpgColor($98b2ed)); - Canvas.DrawLine(Left, Bottom, Left, Top); // left - Canvas.DrawLine(Left, Top, Right, Top); // top - // right bottom - Canvas.SetColor(TfpgColor($3b4c71)); - Canvas.DrawLine(Right, Top, Right, Bottom); // right - Canvas.DrawLine(Right, Bottom, Left, Bottom); // bottom - // inside gradient fill - InflateRect(FClientRect, -1, -1); - Canvas.GradientFill(FClientRect, TfpgColor($425d9b), TfpgColor($97b0e8), gdVertical); - end; { if } - end; - gkVerticalBar: - begin - BarLength := Longint(Trunc( (Height * Percentage) / 100.0 ) ); - if BarLength > 0 then - begin - if BarLength > Height then - BarLength := Height; - Top := Height - BarLength+1; - Height := BarLength; - // left top - Canvas.SetColor(TfpgColor($98b2ed)); - Canvas.DrawLine(Left, Bottom, Left, Top); // left - Canvas.DrawLine(Left, Top, Right, Top); // top - // right bottom - Canvas.SetColor(TfpgColor($3b4c71)); - Canvas.DrawLine(Right, Top, Right, Bottom); // right - Canvas.DrawLine(Right, Bottom, Left, Bottom); // bottom - // inside gradient fill - InflateRect(FClientRect, -1, -1); - Canvas.GradientFill(FClientRect, TfpgColor($425d9b), TfpgColor($97b0e8), gdHorizontal); - end; - end; { if } - end; { case } - end; { with } - FClientRect := SavedRect; -end; - -procedure TfpgGauge.PieDraw; -var - Angle: Double; -begin - with FClientRect do - begin - Angle := Percentage; - Angle := Angle * 3.6; // Percentage to degrees - Canvas.SetColor(TfpgColor($425d9b)); - FillArcGradient (Canvas,Left, Top, Width, Height , 90, -Angle,TfpgColor($425d9b),TfpgColor($98b2ed)); - end; -end; - -procedure TfpgGauge.NeedleDraw; -var - Center: TPoint; - Radius: TPoint; - Angle: Double; -begin - with FClientRect do - begin - if Percentage > 0 then - begin - { Compute the center } - Center := CenterPoint(Rect(Left,Top,Width,Height)); - { Make needle 4 pixel shorter than gauge radius to accomodate border } - Radius.X := Center.X - 4; - Radius.Y := (Bottom - 4); - Canvas.SetLineStyle(2,lsSolid); - Angle := (Pi * ((Percentage / 100.0))); // percentage to radiants - Canvas.SetColor(TfpgColor($3b4c71)); - Canvas.SetLineStyle(2,lsSolid); - //Canvas.DrawLine(Center.X, FClientRect.Bottom, - //Integer(round(Center.X - (Radius.X * Cos(Angle)))), - //Integer(round((FClientRect.Bottom) - (Radius.Y * Sin(Angle))))); - - { *** Experimental *** } - WuLine(Canvas, - Point(Center.X, FClientRect.Bottom), - Point(Integer(round(Center.X - (Radius.X * Cos(Angle)))), - Integer(round((FClientRect.Bottom) - (Radius.Y * Sin(Angle))))), - Canvas.Color); - WuLine(Canvas, - Point(Center.X+1, FClientRect.Bottom), - Point(Integer(round(Center.X+1 - (Radius.X * Cos(Angle)))), - Integer(round((FClientRect.Bottom) - (Radius.Y * Sin(Angle))))), - Canvas.Color); - end; - end; -end; - -procedure TfpgGauge.DialDraw; -var - Center: TPoint; - Radius: TPoint; - Angle: Double; - CenterDot: Integer; -begin - with FClientRect do - begin - if Percentage >= 0 then - begin - { Compute the center } - Center := CenterPoint(Rect(Left,Top,Width,Height)); - { Make needle 3 pixel shorter than gauge radius } - Radius.X := Center.X -3; - Radius.Y := Center.Y -3; - {compute centre circle size} - CenterDot := (Width + Height) div 40; // approx. scaled to 1/10 of widget size: - if CenterDot < 2 then - CenterDot := 2; - { draw needle centre circle } - Canvas.SetColor(TfpgColor($3b4c71)); - Canvas.FillArc(Center.X - CenterDot, Center.Y - CenterDot,CenterDot * 2, CenterDot * 2,0,360); - { draw needle } - Angle := (Pi * ((Percentage / (100 * 2 / 3)) + -0.25)); - Canvas.SetLineStyle(2,lsSolid); - //Canvas.DrawLine(Center.X, Center.Y, - //Integer(round(Center.X - ( Radius.X * cos(Angle)))), - //Integer(round((Center.Y) - (Radius.Y * Sin(Angle))))); - - { *** Experimental *** } - WuLine(Canvas, - Point(Center.X, Center.Y), - Point(Integer(round(Center.X - ( Radius.X * cos(Angle)))), - Integer(round((Center.Y) - (Radius.Y * Sin(Angle))))), - Canvas.Color); - WuLine(Canvas, - Point(Center.X+1, Center.Y), - Point(Integer(round(Center.X+1 - ( Radius.X * cos(Angle)))), - Integer(round((Center.Y) - (Radius.Y * Sin(Angle))))), - Canvas.Color); - end; { if } - end; { with } -end; - -procedure TfpgGauge.HandlePaint; -begin - inherited HandlePaint; -// Canvas.BeginDraw(True); - {Paint Background and adjust FClientRect according style and BorderStyle} - BackgroundDraw; - {Paint foreground according selected Kind} - case FKind of - gkHorizontalBar, - gkVerticalBar: - BarDraw; - gkPie: - PieDraw; - gkNeedle: - NeedleDraw; - gkDial: - DialDraw; - end; - {Add Text if required} - if ShowText then - TextDraw; -// Canvas.EndDraw; -end; - -procedure TfpgGauge.SetGaugeKind(AValue: TGaugeKind); -begin - if AValue <> FKind then - begin - FKind := AValue; - RePaint; - end; -end; - -procedure TfpgGauge.SetShowText(AValue: Boolean); -begin - if AValue <> FShowText then - begin - FShowText := AValue; - RePaint; - end; -end; - -procedure TfpgGauge.SetBorderStyle(AValue: TBorderStyle); -begin - if AValue <> FBorderStyle then - begin - FBorderStyle := AValue; - { TODO: Implement Border style } - // Graeme: Wouldn't descending from TfpgBevel give you this functionality already? - // It could be a option. - //RePaint; - end; -end; - -procedure TfpgGauge.SetFirstColor(AValue: TfpgColor); -begin - if AValue <> FFirstColor then - begin - FFirstColor := AValue; - { TODO: allow user colors} - //RePaint; - end; -end; - -procedure TfpgGauge.SetSecondColor(AValue: TfpgColor); -begin - if AValue <> FSecondColor then - begin - FSecondColor := AValue; - { TODO: allow user colors} - //RePaint; - end; -end; - -procedure TfpgGauge.SetMin(AValue: Longint); -begin - if AValue <> FMin then - begin - // correct input errors - if AValue > FMax then - if not (csLoading in ComponentState) then - FMax := AValue + 1; - if FPosition < AValue then - FPosition := AValue; - // then update - FMin := AValue; - RePaint; - end; -end; - -procedure TfpgGauge.SetMax(AValue: Longint); -begin - if AValue <> FMax then - begin - // correct input errors - if AValue < FMin then - if not (csLoading in ComponentState) then - FMin := AValue - 1; - if FPosition > AValue then - FPosition := AValue; - // then update - FMax := AValue; - RePaint; - end; -end; - -procedure TfpgGauge.SetProgress(AValue: Longint); -var - CurrPercentage: Longint; - MustRepaint: Boolean; -begin - CurrPercentage := GetPercentage; - MustRepaint := False; - - if AValue < FMin then - AValue := FMin - else if AValue > FMax then - AValue := FMax; - - if FPosition <> AValue then - begin // Value has changed - FPosition := AValue; - if CurrPercentage <> Percentage then // Visible value has changed - MustRepaint := True; - { TODO: Check against low and high watermarks } - end; - if MustRepaint then - RePaint; -end; - -function TfpgGauge.GetPercentage: Longint; -Var - V,T: Longint; -begin - T := FMax - FMin; - V := FPosition - FMin; - if T = 0 then - Result := 0 - else - Result := Longint(Trunc( (V * 100.0) / T )); -end; - -constructor TfpgGauge.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - Focusable := False; - FWidth := 100; - FHeight := 25; - FKind := gkHorizontalBar; - FSecondColor := clWhite; - FFirstColor := clBlack; - FColor := TfpgColor($c4c4c4); //clInactiveWgFrame; - FMax := 100; - FMin := 0; - FPosition := 0; - FShowText := True; - FBorderStyle := bsNone; - FFont := fpgStyle.DefaultFont; -end; - -procedure TfpgGauge.AddProgress(AValue: Longint); -begin - Progress := FPosition + AValue; -end; - -end. - diff --git a/src/gui/gui_grid.pas b/src/gui/gui_grid.pas deleted file mode 100644 index 41b19402..00000000 --- a/src/gui/gui_grid.pas +++ /dev/null @@ -1,517 +0,0 @@ -{ - fpGUI - Free Pascal GUI Toolkit - - Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this - distribution, for details of the copyright. - - See the file COPYING.modifiedLGPL, included in this distribution, - for details about redistributing fpGUI. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - - Description: - Defines a File Grid and String Grid. Both are decendants of Custom Grid. -} - -unit gui_grid; - -{$mode objfpc}{$H+} - -{ - TODO: - * TCustomStringGrid: Col[] and Row[] properties need to be implemented, - returning a TStrings with all related text inserted. - * File Grid: Introduce support for images based on file types. User must - be able to override the default images with their own. - * Remove the usage of libc unit. libc is linux/x86 specific. -} - -interface - -uses - Classes, - SysUtils, - fpg_base, - fpg_main, - gui_basegrid, - gui_customgrid; - -type - - TfpgFileGrid = class(TfpgCustomGrid) - private - FFileList: TfpgFileList; - FFixedFont: TfpgFont; - protected - function GetRowCount: Integer; override; - procedure DrawCell(ARow, ACol: Integer; ARect: TfpgRect; AFlags: TfpgGridDrawState); override; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - function CurrentEntry: TFileEntry; - property FixedFont: TfpgFont read FFixedFont; - property FileList: TfpgFileList read FFileList; - property DefaultRowHeight; - property Font; - property HeaderFont; - published - property FontDesc; - property HeaderFontDesc; - property RowCount; - property ColumnCount; - property Columns; - property FocusRow; - property ScrollBarStyle; - property TabOrder; - property OnRowChange; - property OnDoubleClick; - end; - - - TfpgStringColumn = class(TfpgGridColumn) - private - FCells: TStringList; - public - constructor Create; override; - destructor Destroy; override; - property Cells: TStringList read FCells write FCells; - end; - - - { TfpgCustomStringGrid } - - TfpgCustomStringGrid = class(TfpgCustomGrid) - private - function GetCell(ACol, ARow: Integer): string; - function GetColumnAlignment(ACol: Integer): TAlignment; - function GetColumnTitle(ACol: Integer): string; - function GetObjects(ACol, ARow: Integer): TObject; - procedure SetCell(ACol, ARow: Integer; const AValue: string); - procedure SetColumnAlignment(ACol: Integer; const AValue: TAlignment); - procedure SetColumnTitle(ACol: Integer; const AValue: string); - procedure SetObjects(ACol, ARow: Integer; const AValue: TObject); - protected - function GetColumnWidth(ACol: Integer): integer; override; - procedure SetColumnWidth(ACol: Integer; const AValue: integer); override; - function GetColumns(AIndex: Integer): TfpgStringColumn; reintroduce; - procedure DoDeleteColumn(ACol: integer); override; - procedure DoSetRowCount(AValue: integer); override; - procedure DoAfterAddColumn(ACol: integer); override; - function DoCreateColumnClass: TfpgStringColumn; reintroduce; override; - procedure DrawCell(ARow, ACol: Integer; ARect: TfpgRect; AFlags: TfpgGridDrawState); override; - property Columns[AIndex: Integer]: TfpgStringColumn read GetColumns; - public - constructor Create(AOwner: TComponent); override; - function AddColumn(ATitle: string; AWidth: integer; AAlignment: TAlignment = taLeftJustify; - AbackgroundColor: TfpgColor = clDefault; ATextColor: TfpgColor = clDefault): TfpgStringColumn; overload; - property Cells[ACol, ARow: Integer]: string read GetCell write SetCell; - property Objects[ACol, ARow: Integer]: TObject read GetObjects write SetObjects; - property ColumnTitle[ACol: Integer]: string read GetColumnTitle write SetColumnTitle; - property ColumnWidth[ACol: Integer]: integer read GetColumnWidth write SetColumnWidth; - property ColumnAlignment[ACol: Integer]: TAlignment read GetColumnAlignment write SetColumnAlignment; - property ColumnBackgroundColor; - property ColumnTextColor; -// property Cols[index: Integer]: TStrings read GetCols write SetCols; -// property Rows[index: Integer]: TStrings read GetRows write SetRows; - end; - - - TfpgStringGrid = class(TfpgCustomStringGrid) - published - property BackgroundColor; -// property ColResizing; - property ColumnCount; - property Columns; - property ColumnWidth; - property DefaultColWidth; - property DefaultRowHeight; - property FocusCol; - property FocusRow; - property FontDesc; - property HeaderFontDesc; - property HeaderHeight; - property Options; - property ParentShowHint; - property RowCount; - property RowSelect; - property ScrollBarStyle; - property ShowGrid; - property ShowHeader; - property ShowHint; - property TabOrder; - property TopRow; - property VisibleRows; - property OnCanSelectCell; - property OnDrawCell; - property OnDoubleClick; - property OnFocusChange; - property OnKeyPress; - property OnRowChange; - end; - -function CreateStringGrid(AOwner: TComponent; x, y, w, h: TfpgCoord; AColumnCount: integer = 0): TfpgStringGrid; - - -implementation - -uses - fpg_constants; - -function CreateStringGrid(AOwner: TComponent; x, y, w, h: TfpgCoord; AColumnCount: integer = 0): TfpgStringGrid; -begin - Result := TfpgStringGrid.Create(AOwner); - Result.Left := x; - Result.Top := y; - Result.Width := w; - Result.Height := h; - Result.ColumnCount := AColumnCount; -end; - -{ TfpgFileGrid } - -function TfpgFileGrid.GetRowCount: Integer; -begin - Result := FFileList.Count; -end; - -procedure TfpgFileGrid.DrawCell(ARow, ACol: Integer; ARect: TfpgRect; AFlags: TfpgGridDrawState); -const - picture_width = 20; -var - e: TFileEntry; - x: integer; - y: integer; - s: string; - img: TfpgImage; -begin - e := FFileList.Entry[ARow]; - if e = nil then - Exit; //==> - - x := ARect.Left + 2; - y := ARect.Top;// + 1; - s := ''; - - if (e.EntryType = etDir) and (ACol = 0) then - Canvas.SetFont(HeaderFont) - else - Canvas.SetFont(Font); - - case ACol of - 0: begin - if e.EntryType = etDir then - img := fpgImages.GetImage('stdimg.folder') // Do NOT localize - else if e.IsExecutable then - img := fpgImages.GetImage('stdimg.executable') // Do NOT localize - else - img := fpgImages.GetImage('stdimg.document'); // Do NOT localize - - if img <> nil then - Canvas.DrawImage(ARect.Left + (picture_width - img.Width) div 2, - y + (ARect.Height - img.Height) div 2, img); - if e.IsLink then // paint shortcut link symbol over existing image - Canvas.DrawImage(ARect.Left+1, ARect.Top+1, fpgImages.GetImage('stdimg.link')); - x := ARect.Left + picture_width; - s := e.Name; - end; - - 1: begin - if e.EntryType = etDir then - s := '' - else - s := FormatFloat('###,###,###,##0', e.Size); - x := ARect.Right - Font.TextWidth(s) - 1; - if x < (ARect.Left + 2) then - x := ARect.Left + 2; - end; - - 2: s := FormatDateTime('yyyy-mm-dd hh:nn', e.ModTime); - - 3: begin - if FFileList.HasFileMode then // on unix - s := e.Mode - else // on windows - s := e.Attributes; - - Canvas.SetFont(FixedFont); - end; - end; - - if FFileList.HasFileMode then // unix - case ACol of - 4: s := e.Owner; - 5: s := e.Group; - end; - - // centre text in row height - y := y + ((DefaultRowHeight - Canvas.Font.Height) div 2); - Canvas.DrawString(x, y, s); -end; - -constructor TfpgFileGrid.Create(AOwner: TComponent); -begin - FFileList := TfpgFileList.Create; - inherited Create(AOwner); - ColumnCount := 0; - RowCount := 0; - FFixedFont := fpgGetFont('Courier New-9'); - - if FFileList.HasFileMode then - AddColumn(rsName, 220) // save space for file mode, owner and group - else - AddColumn(rsName, 320); // more space to filename - - AddColumn(rsSize, 80); - AddColumn(rsFileModifiedTime, 108); - - if FFileList.HasFileMode then - begin - AddColumn(rsFileRights, 78); - AddColumn(rsFileOwner, 54); - AddColumn(rsFileGroup, 54); - end - else - AddColumn(rsFileAttributes, 78); - - RowSelect := True; - DefaultRowHeight := fpgImages.GetImage('stdimg.document').Height + 2; -end; - -destructor TfpgFileGrid.Destroy; -begin - OnRowChange := nil; - FFixedFont.Free; - FFileList.Free; - inherited Destroy; -end; - -function TfpgFileGrid.CurrentEntry: TFileEntry; -begin - Result := FFileList.Entry[FocusRow]; -end; - -{ TfpgStringColumn } - -constructor TfpgStringColumn.Create; -begin - inherited Create; - FCells := TStringList.Create; -end; - -destructor TfpgStringColumn.Destroy; -begin - FCells.Free; - inherited Destroy; -end; - -{ TfpgCustomStringGrid } - -function TfpgCustomStringGrid.GetCell(ACol, ARow: Integer): string; -begin - if ACol > ColumnCount-1 then - Exit; //==> - if ARow > RowCount-1 then - Exit; //==> - Result := TfpgStringColumn(FColumns.Items[ACol]).Cells[ARow]; -end; - -function TfpgCustomStringGrid.GetColumnAlignment(ACol: Integer): TAlignment; -begin - if ACol > ColumnCount-1 then - Exit; //==> - Result := TfpgStringColumn(FColumns.Items[ACol]).Alignment; -end; - -function TfpgCustomStringGrid.GetColumnTitle(ACol: Integer): string; -begin - if ACol > ColumnCount-1 then - Exit; //==> - Result := TfpgStringColumn(FColumns.Items[ACol]).Title; -end; - -function TfpgCustomStringGrid.GetObjects(ACol, ARow: Integer): TObject; -begin - if ACol > ColumnCount-1 then - Exit; //==> - if ARow > RowCount-1 then - Exit; //==> - Result := TfpgStringColumn(FColumns.Items[ACol]).Cells.Objects[ARow]; -end; - -function TfpgCustomStringGrid.GetColumnWidth(ACol: Integer): integer; -begin - if ACol > ColumnCount-1 then - Exit; //==> - Result := TfpgStringColumn(FColumns.Items[ACol]).Width; -end; - -procedure TfpgCustomStringGrid.SetCell(ACol, ARow: Integer; - const AValue: string); -begin - if ACol > ColumnCount-1 then - Exit; //==> - if ARow > RowCount-1 then - Exit; //==> - if TfpgStringColumn(FColumns.Items[ACol]).Cells[ARow] <> AValue then - begin - BeginUpdate; - TfpgStringColumn(FColumns.Items[ACol]).Cells[ARow] := AValue; - EndUpdate; - end; -end; - -procedure TfpgCustomStringGrid.SetColumnAlignment(ACol: Integer; - const AValue: TAlignment); -begin - if ACol > ColumnCount-1 then - Exit; //==> - BeginUpdate; - TfpgStringColumn(FColumns.Items[ACol]).Alignment := AValue; - EndUpdate; -end; - -procedure TfpgCustomStringGrid.SetColumnTitle(ACol: Integer; const AValue: string); -begin - if ACol > ColumnCount-1 then - Exit; //==> - BeginUpdate; - TfpgStringColumn(FColumns.Items[ACol]).Title := AValue; - EndUpdate; -end; - -procedure TfpgCustomStringGrid.SetObjects(ACol, ARow: Integer; - const AValue: TObject); -begin - if ACol > ColumnCount-1 then - Exit; //==> - if ARow > RowCount-1 then - Exit; //==> - TfpgStringColumn(FColumns.Items[ACol]).Cells.Objects[ARow] := AValue; -end; - -procedure TfpgCustomStringGrid.SetColumnWidth(ACol: Integer; const AValue: integer); -begin - if ACol > ColumnCount-1 then - Exit; //==> - BeginUpdate; - TfpgStringColumn(FColumns.Items[ACol]).Width := AValue; - EndUpdate; -end; - -function TfpgCustomStringGrid.GetColumns(AIndex: Integer): TfpgStringColumn; -begin - if (AIndex < 0) or (AIndex > ColumnCount-1) then - Result := nil - else - Result := TfpgStringColumn(FColumns.Items[AIndex]); -end; - -procedure TfpgCustomStringGrid.DoDeleteColumn(ACol: integer); -begin - TfpgStringColumn(FColumns.Items[ACol]).Free; - FColumns.Delete(ACol); -end; - -procedure TfpgCustomStringGrid.DoSetRowCount(AValue: integer); -var - diff: integer; - c: integer; -begin - inherited DoSetRowCount(AValue); - if FColumns.Count = 0 then - Exit; //==> - - diff := AValue - TfpgStringColumn(FColumns.Items[0]).Cells.Count; - if diff > 0 then // We need to add rows - begin - for c := 0 to FColumns.Count - 1 do - begin - while TfpgStringColumn(FColumns[c]).Cells.Count <> AValue do - TfpgStringColumn(FColumns[c]).Cells.Append(''); - end; - end; -end; - -procedure TfpgCustomStringGrid.DoAfterAddColumn(ACol: integer); -var - r: integer; -begin - inherited DoAfterAddColumn(ACol); - // initialize cells for existing rows - for r := 0 to RowCount-1 do - TfpgStringColumn(FColumns.Items[ACol]).Cells.Append(''); -end; - -function TfpgCustomStringGrid.DoCreateColumnClass: TfpgStringColumn; -begin - Result := TfpgStringColumn.Create; -end; - -procedure TfpgCustomStringGrid.DrawCell(ARow, ACol: Integer; ARect: TfpgRect; - AFlags: TfpgGridDrawState); -var - Flags: TFTextFlags; - txt: string; -begin - if Cells[ACol, ARow] <> '' then - begin - txt := Cells[ACol, ARow]; - Flags:= []; - if not Enabled then - Include(Flags,txtDisabled); - - case Columns[ACol].Alignment of - taLeftJustify: - Include(Flags,txtLeft); - taCenter: - Include(Flags,txtHCenter); - taRightJustify: - Include(Flags,txtRight); - end; { case } - - case Columns[ACol].Layout of - tlTop: - Include(Flags,txtTop); - tlCenter: - Include(Flags,txtVCenter); - tlBottom: - Include(Flags,txtBottom); - end; { case } - - with ARect,Columns[ACol] do - Canvas.DrawText(Left+HMargin,Top,Right-Left-HMargin,Bottom-Top, txt, Flags); - end; -end; - -constructor TfpgCustomStringGrid.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - ColumnCount := 0; - RowCount := 0; -end; - -function TfpgCustomStringGrid.AddColumn(ATitle: string; AWidth: integer; - AAlignment: TAlignment; ABackgroundColor: TfpgColor; ATextColor: TfpgColor): TfpgStringColumn; -begin - Updating; - Result := TfpgStringColumn(inherited AddColumn(ATitle, AWidth)); - Result.Alignment := AAlignment; - - if ABackgroundColor = clDefault then - Result.BackgroundColor := clBoxColor - else - Result.BackgroundColor:= ABackgroundColor; - - if ATextColor = clDefault then - Result.TextColor := TextColor - else - Result.TextColor:= ATextColor; - - if UpdateCount = 0 then - Updated; // if we called .BeginUpdate then don't clear csUpdating here -end; - -end. - diff --git a/src/gui/gui_hint.pas b/src/gui/gui_hint.pas deleted file mode 100644 index 58e0441f..00000000 --- a/src/gui/gui_hint.pas +++ /dev/null @@ -1,226 +0,0 @@ -{ - fpGUI - Free Pascal GUI Toolkit - - Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this - distribution, for details of the copyright. - - See the file COPYING.modifiedLGPL, included in this distribution, - for details about redistributing fpGUI. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - - Description: - Defines a window that gets used to display help hints (aka a HintWindow) -} - -unit gui_hint; - -{$mode objfpc}{$H+} - -{.$Define Debug} - -interface - -uses - Classes, - SysUtils, - fpg_base, - fpg_main, - gui_form, - gui_label; - -type - TfpgHintWindow = class(TfpgForm) - private - FFont: TfpgFont; - FTime: Integer; - FShadow: Integer; - FBorder: Integer; - FMargin: Integer; - L_Hint: TfpgLabel; - T_Chrono: TfpgTimer; - procedure FormShow(Sender: TObject); - procedure FormHide(Sender: TObject); - function GetText: TfpgString; - procedure SetText(const AValue: TfpgString); - procedure T_ChronoFini(Sender: TObject); - procedure SetShadow(AValue: Integer); - procedure SetBorder(AValue: Integer); - procedure SetTime(AValue: Integer); - procedure SetLTextColor(AValue: Tfpgcolor); - procedure SetLBackgroundColor(AValue: Tfpgcolor); - procedure SetShadowColor(AValue: TfpgColor); - protected - procedure HandleShow; override; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - procedure SetPosition(aleft, atop, awidth, aheight: TfpgCoord); override; - property Font: TfpgFont read FFont; - property Text: TfpgString read GetText write SetText; - property Shadow: Integer read FShadow write SetShadow default 5; - property Border: Integer read FBorder write SetBorder default 1; - property Margin: Integer read FMargin write FMargin default 3; - property LTextColor: TfpgColor write SetLTextColor default clBlack; - property LBackgroundColor: TfpgColor write SetLBackgroundColor default clHintWindow; - property ShadowColor: TfpgColor write SetShadowColor default clGray; - property Time: Integer write SetTime default 5000; - end; - - - TfpgHintWindowClass = class of TfpgHintWindow; - - -var - HintWindowClass: TfpgHintWindowClass = TfpgHintWindow; - - -implementation - -type - TfpgHintShadow = class(TfpgForm) - public - constructor Create(AOwner: TComponent); override; - end; - - -var - uShadowForm: TfpgHintShadow; - - -{ TfpgHintWindow } - -procedure TfpgHintWindow.FormShow(Sender: TObject); -begin - T_Chrono.Enabled:= True; -end; - -procedure TfpgHintWindow.FormHide(Sender: TObject); -begin - T_Chrono.Enabled := False; - if Assigned(uShadowForm) then - uShadowForm.Hide; -end; - -function TfpgHintWindow.GetText: TfpgString; -begin - Result := L_Hint.Text; -end; - -procedure TfpgHintWindow.SetText(const AValue: TfpgString); -begin - L_Hint.Text := AValue; -end; - -procedure TfpgHintWindow.T_ChronoFini(Sender: TObject); -begin - {$IFDEF DEBUG} - writeln('TF_Hint.T_ChronoFini timer fired'); - {$ENDIF} - Hide; -end; - -procedure TfpgHintWindow.SetShadow(AValue: Integer); -begin - if FShadow <> AValue then - FShadow := AValue; -end; - -procedure TfpgHintWindow.SetBorder(AValue: Integer); -begin - if FBorder <> AValue then - FBorder := AValue; -end; - -procedure TfpgHintWindow.SetTime(AValue: Integer); -begin - if FTime <> AValue then - begin - FTime := AValue; - T_Chrono.Interval := FTime; - end; -end; - -procedure TfpgHintWindow.SetLTextColor(AValue: Tfpgcolor); -begin - if L_Hint.TextColor <> AValue then - L_Hint.TextColor := AValue -end; - -procedure TfpgHintWindow.SetLBackgroundColor(AValue: Tfpgcolor); -begin - if L_Hint.BackgroundColor <> AValue then - L_Hint.BackgroundColor := AValue -end; - -procedure TfpgHintWindow.SetShadowColor(AValue: Tfpgcolor); -begin - if uShadowForm.BackgroundColor <> AValue then - uShadowForm.BackgroundColor := AValue; -end; - -procedure TfpgHintWindow.HandleShow; -begin - // This is so the Shadow Window is below the Hint Window. - if Shadow > 0 then - begin - uShadowForm.SetPosition(Left+Shadow, Top+Shadow, Width, Height); - uShadowForm.Show; - end; - inherited HandleShow; -end; - -constructor TfpgHintWindow.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - Name := 'F_Hint'; - WindowPosition := wpUser; - WindowType := wtPopup; - Sizeable := False; - BackgroundColor:= clBlack; - FFont := fpgGetFont('#Label1'); - FMargin := 3; - FBorder := 1; - FShadow := 5; - FTime := 5000; - L_Hint := CreateLabel(Self, FBorder, FBorder, '', Width - FBorder * 2, Height - FBorder * 2, taCenter, tlCenter); - L_Hint.BackgroundColor := clHintWindow; - L_Hint.OnClick := @T_ChronoFini; - T_Chrono := TfpgTimer.Create(FTime); - T_Chrono.OnTimer := @T_ChronoFini; - uShadowForm:= TfpgHintShadow.Create(nil); - OnShow := @FormShow; - OnHide := @FormHide; -end; - -destructor TfpgHintWindow.Destroy; -begin - T_Chrono.Free; - FFont.Free; - inherited Destroy; -end; - -procedure TfpgHintWindow.SetPosition(aleft, atop, awidth, aheight: TfpgCoord); -begin - inherited SetPosition(aleft, atop, awidth, aheight); - L_Hint.SetPosition(Border, Border, Width - (Border * 2), Height - (Border * 2)); -end; - -constructor TfpgHintShadow.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - Name := 'F_Shadow'; - WindowPosition := wpUser; - WindowType := wtPopup; - Sizeable := False; - BackgroundColor := clGray; -end; - -initialization -finalization - FreeAndNil(uShadowForm); - -end. - diff --git a/src/gui/gui_hyperlink.pas b/src/gui/gui_hyperlink.pas deleted file mode 100644 index 48efdf9e..00000000 --- a/src/gui/gui_hyperlink.pas +++ /dev/null @@ -1,138 +0,0 @@ -{ - fpGUI - Free Pascal GUI Toolkit - - Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this - distribution, for details of the copyright. - - See the file COPYING.modifiedLGPL, included in this distribution, - for details about redistributing fpGUI. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - - Description: - A hyperlink label component. When the user clicks the label, a - web browser is opened with the URL specified. -} - - -unit gui_hyperlink; - -{$mode objfpc}{$H+} - -interface - -uses - Classes, - Sysutils, - fpg_base, - fpg_main, - gui_label; - -type - - TfpgHyperlink = class(TfpgCustomLabel) - private - fHotTrackColor: TfpgColor; - fOldColor: TfpgColor; - fOldFont: TfpgString; - fHTFont: TfpgString; - fUrl: TfpgString; - procedure SetHotTrackColor(const AValue: TfpgColor); - procedure SetHotTrackFont(const AValue: TfpgString); - procedure SetURL(const Value: TfpgString); - protected - procedure HandleMouseEnter; override; - procedure HandleMouseExit; override; - procedure HandleLMouseDown(x, y: integer; shiftstate: TShiftState); override; - public - constructor Create(AOwner: TComponent); override; - procedure GoHyperLink; - published - property Autosize; - property FontDesc; - property HotTrackColor: TfpgColor read fHotTrackColor write SetHotTrackColor; - property HotTrackFont: TfpgString read fHTFont write SetHotTrackFont; - property Text; - property TextColor; - property URL: TfpgString read FUrl write SetURL; - property OnClick; -end; - - - -implementation - -uses - fpg_utils; - - -{ TfpgHyperlink } - -constructor TfpgHyperlink.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - fHotTrackColor := clBlue; - TextColor := clBlue; - fUrl := 'http://opensoft.homeip.net/fpgui/'; - Text := 'fpGUI website'; - fHTFont := 'Arial-8:antialias=true:underline:bold'; - FontDesc := 'Arial-8:antialias=true:underline'; - AutoSize := True; -end; - -procedure TfpgHyperlink.SetURL(const Value: TfpgString); -begin - if fUrl <> Value then - fUrl := Value; -end; - -procedure TfpgHyperlink.SetHotTrackFont(const AValue: TfpgString); -begin - if fHTFont = AValue then - Exit; - fHTFont := AValue; -end; - -procedure TfpgHyperlink.SetHotTrackColor(const AValue: TfpgColor); -begin - if fHotTrackColor = AValue then - Exit; - fHotTrackColor := AValue; -end; - -procedure TfpgHyperlink.GoHyperLink; -begin - if URL <> '' then - fpgOpenURL(URL); -end; - -procedure TfpgHyperlink.HandleMouseEnter; -begin - inherited HandleMouseEnter; - fOldColor := TextColor; - TextColor := fHotTrackColor; - fOldFont := FontDesc; - FontDesc := fHTFont; - MouseCursor := mcHand; -end; - -procedure TfpgHyperlink.HandleMouseExit; -begin - inherited HandleMouseExit; - TextColor := fOldColor; - MouseCursor := mcDefault; - FontDesc := fOldFont; -end; - -procedure TfpgHyperlink.HandleLMouseDown(x, y: integer; shiftstate: TShiftState); -begin - inherited HandleLMouseDown(x, y, shiftstate); - if not Assigned(OnClick) then - GoHyperlink; -end; - - -end. - diff --git a/src/gui/gui_iniutils.pas b/src/gui/gui_iniutils.pas deleted file mode 100644 index b961cbb4..00000000 --- a/src/gui/gui_iniutils.pas +++ /dev/null @@ -1,245 +0,0 @@ -{ - fpGUI - Free Pascal GUI Toolkit - - Copyright (C) 2006 - 2007 See the file AUTHORS.txt, included in this - distribution, for details of the copyright. - - See the file COPYING.modifiedLGPL, included in this distribution, - for details about redistributing fpGUI. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - - Description: - This descendant adds ReadOnly support and can read/write Form state - information. -} - -unit gui_iniutils; - -{$mode objfpc}{$H+} - -interface - -uses - Classes, - SysUtils, - IniFiles, - gui_form; - -type - - TfpgINIFile = class(TINIFile) - private - FReadOnly: Boolean; - public - constructor CreateExt(const AFileName: string = ''; AReadOnly: Boolean = False); - function ReadString(const ASection, AIdent, ADefault: string): string; override; - function ReadInteger(const ASection, AIdent: string; ADefault: longint): longint; override; - function ReadBool(const ASection, AIdent: string; ADefault: Boolean): Boolean; override; - function ReadDate(const ASection, AName: string; ADefault: TDateTime): TDateTime; override; - function ReadDateTime(const ASection, AName: string; ADefault: TDateTime): TDateTime; override; - function ReadFloat(const ASection, AName: string; ADefault: double): double; override; - function ReadTime(const ASection, AName: string; ADefault: TDateTime): TDateTime; override; - procedure ReadFormState(AForm: TfpgForm; AHeight: integer = -1; AWidth: integer = -1); - procedure WriteFormState(AForm: TfpgForm); - end; - -// singleton -function gINI(const AFileName: string = ''): TfpgINIFile; - -implementation - -uses - fpg_main, - fpg_constants; - -var - uINI: TfpgINIFile; - - -function gINI(const AFileName: string): TfpgINIFile; -begin - if uINI = nil then - uINI := TfpgINIFile.CreateExt(AFileName); - Result := uINI; -end; - -{ TfpgINIFile } - -constructor TfpgINIFile.CreateExt(const AFileName: string; AReadOnly: Boolean); -var - lDir: string; - lFileName: string; -begin - FReadOnly := AReadOnly; - lDir := ExtractFileDir(AFileName); - lFileName := ExtractFileName(AFileName); - - if lDir = '' then - lDir := GetAppConfigDir(False); - if not (lDir[Length(lDir)] = PathDelim) then - lDir := lDir + PathDelim; - - { We used a non-Global config dir, so should be able to create the dir } - if not ForceDirectories(lDir) then - raise Exception.CreateFmt(rsErrFailedToCreateDir, [lDir]); - - - if lFileName = '' then - lFileName := ApplicationName + '.ini' - else if ExtractFileExt(lFileName) = '' then - lFileName := lFileName + '.ini'; - - lFileName := lDir + lFileName; - Create(lFileName); -end; - -function TfpgINIFile.ReadString(const ASection, AIdent, ADefault: string): string; -begin - Result := inherited ReadString(ASection, AIdent, ADefault); - if (not ValueExists(ASection, AIdent)) and - (not FReadOnly) then - WriteString(ASection, AIdent, ADefault); -end; - -function TfpgINIFile.ReadInteger(const ASection, AIdent: string; ADefault: longint): longint; -begin - if (not ValueExists(ASection, AIdent)) and - (not FReadOnly) then - WriteInteger(ASection, AIdent, ADefault); - Result := inherited ReadInteger(ASection, AIdent, ADefault); -end; - -function TfpgINIFile.ReadBool(const ASection, AIdent: string; ADefault: Boolean): Boolean; -var - lValueExists: Boolean; -begin - lValueExists := ValueExists(ASection, AIdent); - if (not lValueExists) and - (not FReadOnly) then - WriteBool(ASection, AIdent, ADefault); - Result := inherited ReadBool(ASection, AIdent, ADefault); -end; - -function TfpgINIFile.ReadDate(const ASection, AName: string; ADefault: TDateTime): TDateTime; -begin - if (not ValueExists(ASection, AName)) and - (not FReadOnly) then - WriteDate(ASection, AName, ADefault); - Result := inherited ReadDate(ASection, AName, ADefault); -end; - -function TfpgINIFile.ReadDateTime(const ASection, AName: string; ADefault: TDateTime): TDateTime; -begin - if (not ValueExists(ASection, AName)) and - (not FReadOnly) then - WriteDateTime(ASection, AName, ADefault); - Result := inherited ReadDateTime(ASection, AName, ADefault); -end; - -function TfpgINIFile.ReadFloat(const ASection, AName: string; ADefault: double): double; -begin - if (not ValueExists(ASection, AName)) and - (not FReadOnly) then - WriteFloat(ASection, AName, ADefault); - Result := inherited ReadFloat(ASection, AName, ADefault); -end; - -function TfpgINIFile.ReadTime(const ASection, AName: string; ADefault: TDateTime): TDateTime; -begin - if (not ValueExists(ASection, AName)) and - (not FReadOnly) then - WriteTime(ASection, AName, ADefault); - Result := inherited ReadTime(ASection, AName, ADefault); -end; - -// Do NOT localize -procedure TfpgINIFile.ReadFormState(AForm: TfpgForm; AHeight: integer; AWidth: integer); -var - LINISection: string; - LTop: integer; - LLeft: integer; - LHeight: integer; - LWidth: integer; -begin - Assert(AForm <> nil, Format(rsErrNotAssigned, ['pForm'])); - LINISection := AForm.Name + 'State'; - // Read form position, -1 if not stored in registry - LTop := readInteger(LINISection, 'Top', -1); - LLeft := readInteger(LINISection, 'Left', -1); - // The form pos was found in the registr - if (LTop <> -1) and (LLeft <> -1) then - begin - AForm.Top := readInteger(LINISection, 'Top', AForm.Top); - AForm.Left := readInteger(LINISection, 'Left', AForm.Left); - AForm.WindowPosition := wpUser; - // No form pos in the registry, so default to screen center - end - else if Assigned(fpgApplication.MainForm) and (fpgApplication.MainForm <> AForm) then - AForm.WindowPosition := wpAuto - else - AForm.WindowPosition := wpScreenCenter; - // Only set the form size if a bsSizable window - if AForm.Sizeable then - begin - if AHeight = -1 then - LHeight := AForm.Height - else - LHeight := AHeight; - if AWidth = -1 then - LWidth := AForm.Width - else - LWidth := AWidth; - AForm.Height := readInteger(LINISection, 'Height', LHeight); - AForm.Width := readInteger(LINISection, 'Width', LWidth); - end; - // AForm.WindowState := TWindowState(ReadInteger(LINISection, 'WindowState', ord(wsNormal))); - - // If the form is off screen (positioned outside all monitor screens) then - // center the form on screen. - //{$IFDEF MSWINDOWS} - //if (AForm.FormStyle <> fsMDIChild) {$IFNDEF FPC} and tiFormOffScreen(AForm) {$ENDIF} then - //begin - //if Assigned(Application.MainForm) and (Application.MainForm <> AForm) then - //AForm.Position := poMainFormCenter - //else - //AForm.Position:= poScreenCenter; - //end; - //{$ENDIF MSWINDOWS} -end; - -// Do NOT localize -procedure TfpgINIFile.WriteFormState(AForm: TfpgForm); -var - LINISection: string; -begin - LINISection := AForm.Name + 'State'; - // writeInteger(LINISection, 'WindowState', ord(AForm.WindowState)); - // if AForm.WindowState = wsNormal then - // begin - - // A work-around while WindowState is not implemented - if (AForm.Top >= 0) or (AForm.Left >= 0) then - begin - writeInteger(LINISection, 'Top', AForm.Top); - writeInteger(LINISection, 'Left', AForm.Left); - end; - if AForm.Sizeable then - begin - writeInteger(LINISection, 'Height', AForm.Height); - WriteInteger(LINISection, 'Width', AForm.Width); - end; - // end; -end; - - -initialization - uINI := nil; - -finalization - uINI.Free; - -end. - diff --git a/src/gui/gui_label.pas b/src/gui/gui_label.pas deleted file mode 100644 index c4c2d271..00000000 --- a/src/gui/gui_label.pas +++ /dev/null @@ -1,255 +0,0 @@ -{ - fpGUI - Free Pascal GUI Toolkit - - Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this - distribution, for details of the copyright. - - See the file COPYING.modifiedLGPL, included in this distribution, - for details about redistributing fpGUI. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - - Description: - Defines a basic Label control. Also known as a Caption component. -} - -unit gui_label; - -{$mode objfpc}{$H+} - -interface - -uses - Classes, - SysUtils, - fpg_base, - fpg_main, - fpg_widget; - -type - - - TfpgCustomLabel = class(TfpgWidget) - private - FAutoSize: boolean; - FAlignment: TAlignment; - FLayout: TLayout; - FWrapText: boolean; - FLineSpace: integer; - procedure SetWrapText(const AValue: boolean); - procedure SetAlignment(const AValue: TAlignment); - procedure SetLayout(const AValue: TLayout); - function GetFontDesc: string; - procedure SetAutoSize(const AValue: boolean); - procedure SetFontDesc(const AValue: string); - procedure SetText(const AValue: TfpgString); - procedure ResizeLabel; - protected - FText: TfpgString; - FFont: TfpgFont; - FTextHeight: integer; - procedure HandlePaint; override; - property WrapText: boolean read FWrapText write SetWrapText default False; - property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify; - property AutoSize: boolean read FAutoSize write SetAutoSize default False; - property Layout: TLayout read FLayout write SetLayout default tlTop; - property FontDesc: string read GetFontDesc write SetFontDesc; - property Text: TfpgString read FText write SetText; - property LineSpace: integer read FLineSpace write FLineSpace default 2; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - property Font: TfpgFont read FFont; - property TextHeight: integer read FTextHeight; - end; - - - TfpgLabel = class(TfpgCustomLabel) - published - property Alignment; - property AutoSize; - property BackgroundColor; - property FontDesc; - property Hint; - property Layout; - property LineSpace; - property ParentShowHint; - property ShowHint; - property Text; - property TextColor; - property Width; - property WrapText; - property OnClick; - property OnDoubleClick; - property OnMouseDown; - property OnMouseEnter; - property OnMouseExit; - property OnMouseMove; - property OnMouseUp; - end; - - -// A convenience function to create a TfpgLabel instance -function CreateLabel(AOwner: TComponent; x, y: TfpgCoord; AText: string; w: TfpgCoord= 0; h: TfpgCoord= 0; - HAlign: TAlignment= taLeftJustify; VAlign: TLayout= tlTop; ALineSpace: integer= 2): TfpgLabel; overload; - -implementation - - -function CreateLabel(AOwner: TComponent; x, y: TfpgCoord; AText: string; w: TfpgCoord; h: TfpgCoord; - HAlign: TAlignment; VAlign: TLayout; ALineSpace: integer): TfpgLabel; -begin - Result := TfpgLabel.Create(AOwner); - Result.Left := x; - Result.Top := y; - Result.Text := AText; - Result.LineSpace := ALineSpace; - if w = 0 then - begin - Result.Width := Result.Font.TextWidth(Result.Text); - Result.FAutoSize := True; - end - else - Result.Width := w; - if h < Result.Font.Height then - Result.Height:= Result.Font.Height - else - Result.Height:= h; - Result.Alignment:= HAlign; - Result.Layout:= VAlign; -end; - -{ TfpgCustomLabel } - -procedure TfpgCustomLabel.SetWrapText(const AValue: boolean); -begin - if FWrapText <> AValue then - begin - FWrapText := AValue; - ResizeLabel; - end; -end; - -procedure TfpgCustomLabel.SetAlignment(const AValue: TAlignment); -begin - if FAlignment <> AValue then - begin - FAlignment := AValue; - ResizeLabel; - end; -end; - -procedure TfpgCustomLabel.SetLayout(const AValue: TLayout); -begin - if FLayout <> AValue then - begin - FLayout := AValue; - ResizeLabel; - end; -end; - -function TfpgCustomLabel.GetFontDesc: string; -begin - Result := FFont.FontDesc; -end; - -procedure TfpgCustomLabel.SetAutoSize(const AValue: boolean); -begin - if FAutoSize <> AValue then - begin - FAutoSize := AValue; - ResizeLabel; - end; -end; - -procedure TfpgCustomLabel.SetFontDesc(const AValue: string); -begin - FFont.Free; - FFont := fpgGetFont(AValue); - ResizeLabel; -end; - -procedure TfpgCustomLabel.SetText(const AValue: TfpgString); -begin - if FText <> AValue then - begin - FText := AValue; - ResizeLabel; - end; -end; - -procedure TfpgCustomLabel.ResizeLabel; -begin - if FAutoSize and not FWrapText then - Width:= FFont.TextWidth(FText); - UpdateWindowPosition; - RePaint; -end; - -constructor TfpgCustomLabel.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - FText := 'Label'; - FFont := fpgGetFont('#Label1'); - FHeight := FFont.Height; - FWidth := 80; - FTextColor := Parent.TextColor; - FBackgroundColor := Parent.BackgroundColor; - FAutoSize := False; - FLayout := tlTop; - FAlignment := taLeftJustify; - FWrapText := False; - FLineSpace := 2; -end; - -destructor TfpgCustomLabel.Destroy; -begin - FText := ''; - FFont.Free; - inherited Destroy; -end; - -procedure TfpgCustomLabel.HandlePaint; -var - r: TfpgRect; - lTxtFlags: TFTextFlags; -begin - inherited HandlePaint; - Canvas.ClearClipRect; - r.SetRect(0, 0, Width, Height); - Canvas.Clear(FBackgroundColor); - Canvas.SetFont(Font); - if Enabled then - Canvas.SetTextColor(FTextColor) - else - Canvas.SetTextColor(clShadow1); - - lTxtFlags:= []; - if not Enabled then - Include(lTxtFlags, txtDisabled); - - if FWrapText then - Include(lTxtFlags, txtWrap); - case FAlignment of - taLeftJustify: - Include(lTxtFlags, txtLeft); - taRightJustify: - Include(lTxtFlags, txtRight); - taCenter: - Include(lTxtFlags, txtHCenter); - end; - case FLayout of - tlTop: - Include(lTxtFlags, txtTop); - tlBottom: - Include(lTxtFlags, txtBottom); - tlCenter: - Include(lTxtFlags, txtVCenter); - end; - FTextHeight := Canvas.DrawText(0, 0, Width, Height, FText, lTxtFlags); -end; - -end. - diff --git a/src/gui/gui_listbox.pas b/src/gui/gui_listbox.pas deleted file mode 100644 index 5dd626ff..00000000 --- a/src/gui/gui_listbox.pas +++ /dev/null @@ -1,1142 +0,0 @@ -{ - fpGUI - Free Pascal GUI Toolkit - - Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this - distribution, for details of the copyright. - - See the file COPYING.modifiedLGPL, included in this distribution, - for details about redistributing fpGUI. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - - Description: - Defines various ListBox controls. A basic text (string) listbox - control has been implemented. -} - -unit gui_listbox; - -{$mode objfpc}{$H+} - -{ - TODO: - * Refactor these to have a better hierarchy - * Only surface properties as published in TfpgListBox - * Implement .BeginUpdate and .EndUpdate methods so we know when to refresh - the items list. - * Color Listbox: User Defined color palette support. -} - -interface - -uses - Classes, - SysUtils, - fpg_base, - fpg_main, - fpg_widget, - gui_scrollbar; - -type - - // My thinking was that we could use this class as the base class for anything - // that contains a list and needs to be presented like a normal listBox. - // Not sure if it is actually going to work. - TfpgBaseListBox = class(TfpgWidget) - private - FHotTrack: boolean; - FOnChange: TNotifyEvent; - FOnScroll: TNotifyEvent; - FOnSelect: TNotifyEvent; - FPopupFrame: boolean; - FAutoHeight: boolean; - FUpdateCount: Integer; - function GetFontDesc: string; - procedure SetFocusItem(const AValue: integer); - procedure SetFontDesc(const AValue: string); - procedure SetPopupFrame(const AValue: boolean); - procedure UpdateScrollbarCoords; - procedure SetAutoHeight(const AValue: boolean); - protected - FFont: TfpgFont; - FScrollBar: TfpgScrollBar; - FFocusItem: integer; - FMouseDragging: boolean; - FFirstItem: integer; - FMargin: integer; - procedure MsgPaint(var msg: TfpgMessageRec); message FPGM_PAINT; - procedure UpdateScrollBar; - procedure FollowFocus; - function ListHeight: TfpgCoord; - function ScrollBarWidth: TfpgCoord; - function PageLength: integer; - procedure ScrollBarMove(Sender: TObject; APosition: integer); - procedure DrawItem(num: integer; rect: TfpgRect; flags: integer); virtual; - procedure DoChange; - procedure DoSelect; - procedure HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed : boolean); override; - procedure HandleLMouseDown(x, y: integer; shiftstate: TShiftState); override; - procedure HandleLMouseUp(x, y: integer; shiftstate: TShiftState); override; - procedure HandleMouseMove(x, y: integer; btnstate: word; shiftstate: TShiftState); override; - procedure HandleMouseScroll(x, y: integer; shiftstate: TShiftState; delta: smallint); override; - procedure HandleResize(awidth, aheight: TfpgCoord); override; - procedure HandleShow; override; - procedure HandlePaint; override; - property AutoHeight: boolean read FAutoHeight write SetAutoHeight default False; - property FocusItem: integer read FFocusItem write SetFocusItem; - property FontDesc: string read GetFontDesc write SetFontDesc; - property HotTrack: boolean read FHotTrack write FHotTrack; - property PopupFrame: boolean read FPopupFrame write SetPopupFrame; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - procedure BeginUpdate; - procedure EndUpdate; - procedure Update; - function ItemCount: integer; virtual; - function RowHeight: integer; virtual; - procedure SetFirstItem(item: integer); - property Font: TfpgFont read FFont; - property OnChange: TNotifyEvent read FOnChange write FOnChange; - property OnKeyPress; // to allow to detect return or tab key has been pressed - property OnScroll: TNotifyEvent read FOnScroll write FOnScroll; - property OnSelect: TNotifyEvent read FOnSelect write FOnSelect; - end; - - - // Listbox containg strings - the normal listbox as we know it. Used by - // component developers. - TfpgTextListBox = class(TfpgBaseListBox) - protected - FItems: TStringList; - procedure DrawItem(num: integer; rect: TfpgRect; flags: integer); override; - procedure HandleKeyChar(var AText: TfpgChar; var shiftstate: TShiftState; var consumed: boolean); override; - property Items: TStringList read FItems; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - function ItemCount: integer; override; - function Text: string; - end; - - - // The standard strings listbox we will actually use in a GUI. - TfpgListBox = class(TfpgTextListBox) - published - property AutoHeight; - property BackgroundColor default clListBox; - property FocusItem; - property FontDesc; - property HotTrack; - property Items; - property ParentShowHint; - property PopupFrame; - property ShowHint; - property TabOrder; - property TextColor; - end; - - - // simple data class containing color information - TColorItem = class(TObject) - public - constructor Create(const AColorName: string; const AColorValue: TfpgColor); - ColorName: string; - ColorValue: TfpgColor; - end; - - - TfpgColorPalette = (cpStandardColors, cpSystemColors, cpWebColors, cpUserDefined); - - - TfpgBaseColorListBox = class(TfpgBaseListBox) - private - FColorBoxWidth: TfpgCoord; - FColorBoxHeight: TfpgCoord; - FColorPalette: TfpgColorPalette; - FShowColorNames: Boolean; - function GetColor: TfpgColor; - procedure SetColor(const AValue: TfpgColor); - procedure SetColorPalette(const AValue: TfpgColorPalette); - procedure SetShowColorNames (const AValue: Boolean ); - procedure SetupColorPalette; - procedure FreeAndClearColors; - protected - FItems: TList; - procedure DrawItem(num: integer; rect: TfpgRect; flags: integer); override; -// procedure HandleKeyChar(var AText: TfpgChar; var shiftstate: TShiftState; var consumed: boolean); override; - property Items: TList read FItems; - property Color: TfpgColor read GetColor write SetColor; - property ColorPalette: TfpgColorPalette read FColorPalette write SetColorPalette; - property ShowColorNames: Boolean read FShowColorNames write SetShowColorNames default True; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - function ItemCount: integer; override; - - end; - - - TfpgColorListBox = class(TfpgBaseColorListBox) - published - property AutoHeight; - property BackgroundColor default clListBox; - property Color; - property ColorPalette; - property FocusItem; - property FontDesc; - property HotTrack; - property Items; - property PopupFrame; - property ShowColorNames; - property TabOrder; - property TextColor; - end; - - -function CreateListBox(AOwner: TComponent; x, y, w, h: TfpgCoord): TfpgListBox; - - -implementation - - -type - // custom stringlist that will notify listbox of item changes - TfpgListBoxStrings = class(TStringList) - protected - ListBox: TfpgTextListBox; - procedure SetUpdateState(Updating: Boolean); override; - public - constructor Create(AListBox: TfpgTextListBox); - destructor Destroy; override; - function Add(const s: String): Integer; override; - procedure Delete(Index: Integer); override; - procedure Clear; override; - end; - - -function CreateListBox(AOwner: TComponent; x, y, w, h: TfpgCoord): TfpgListBox; -begin - Result := TfpgListBox.Create(AOwner); - Result.Left := x; - Result.Top := y; - Result.Width := w; - if h > 0 then - Result.Height := h; -end; - - -{ TfpgListBoxStrings } - -procedure TfpgListBoxStrings.SetUpdateState(Updating: Boolean); -begin - inherited SetUpdateState(Updating); - // do nothing extra for now -end; - -constructor TfpgListBoxStrings.Create(AListBox: TfpgTextListBox); -begin - inherited Create; - ListBox := AListBox; -end; - -destructor TfpgListBoxStrings.Destroy; -begin - ListBox := nil; - inherited Destroy; -end; - -function TfpgListBoxStrings.Add(const s: String): Integer; -begin - Result := inherited Add(s); - if Assigned(ListBox) and (ListBox.HasHandle) then - begin - ListBox.UpdateScrollBar; - ListBox.Invalidate; - end; -end; - -procedure TfpgListBoxStrings.Delete(Index: Integer); -begin - inherited Delete(Index); - if Assigned(ListBox) and (ListBox.HasHandle) then - begin - ListBox.UpdateScrollBar; - ListBox.Invalidate; - end; -end; - -procedure TfpgListBoxStrings.Clear; -begin - inherited Clear; - ListBox.FocusItem := -1; - ListBox.UpdateScrollBar; - ListBox.Invalidate; -end; - - -{ TfpgBaseListBox } - -function TfpgBaseListBox.GetFontDesc: string; -begin - result := FFont.FontDesc; -end; - -procedure TfpgBaseListBox.SetFocusItem(const AValue: integer); -var - old: integer; -begin - if FFocusItem = AValue then - Exit; //==> - - old := FFocusItem; - // do some sanity checks - if AValue < -1 then // -1 is a valid focusitem (no selection) - FFocusItem := -1 - else if AValue > ItemCount-1 then - FFocusItem := ItemCount-1 - else - FFocusItem := AValue; - - if FFocusItem = old then - Exit; //==> - - if FFocusItem <= 0 then - FFirstItem := 0; - - FollowFocus; - UpdateScrollbar; - RePaint; - DoChange; -end; - -procedure TfpgBaseListBox.SetFontDesc(const AValue: string); -begin - FFont.Free; - FFont := fpgGetFont(AValue); - if FAutoHeight then - Height:= ((Height - 6) div RowHeight) * RowHeight + 6; - RePaint; -end; - -procedure TfpgBaseListBox.SetPopupFrame(const AValue: boolean); -begin - if FPopupFrame = AValue then - Exit; //==> - FPopupFrame := AValue; - RePaint; -end; - -procedure TfpgBaseListBox.UpdateScrollbarCoords; -var - HWidth: integer; - VHeight: integer; -begin - VHeight := Height - 4; - HWidth := Width - 4; - - if FScrollBar.Visible then - Dec(HWidth, FScrollBar.Width); - - FScrollBar.Top := 2; - FScrollBar.Left := Width - FScrollBar.Width - 2; - FScrollBar.Height := VHeight; - FScrollBar.UpdateWindowPosition; -end; - -procedure TfpgBaseListBox.SetAutoHeight(const AValue: boolean); -begin - if FAutoHeight= AValue then - Exit; //==> - FAutoHeight := AValue; - Height := (PageLength * RowHeight) + (2 * FMargin); -end; - -procedure TfpgBaseListBox.MsgPaint(var msg: TfpgMessageRec); -begin - // Optimising painting and preventing OnPaint from firing if not needed - if FUpdateCount = 0 then - inherited MsgPaint(msg); -end; - -procedure TfpgBaseListBox.SetFirstItem(item: integer); -begin - FFirstItem := item; - UpdateScrollBar; -end; - -procedure TfpgBaseListBox.UpdateScrollBar; -var - pn : integer; -begin - if not HasHandle then - Exit; //==> - pn := PageLength; - FScrollBar.Visible := PageLength < ItemCount-1; - - if FScrollBar.Visible then - begin - FScrollBar.Min := 0; - if ItemCount <> 0 then - FScrollBar.SliderSize := pn / ItemCount - else - FScrollBar.SliderSize := 1; - FScrollBar.Max := ItemCount-1-pn; - FScrollBar.Position := FFirstItem; - FScrollBar.RepaintSlider; - end; -end; - -procedure TfpgBaseListBox.FollowFocus; -var - n: integer; - h: TfpgCoord; -begin - if FFocusItem < FFirstItem then - FFirstItem := FFocusItem - else - begin - h := 0; - for n := FFocusItem downto FFirstItem do - begin - h := h + RowHeight; - if h > ListHeight then - begin - FFirstItem := n+1; - Break; - end; - end; - end; - - if FFirstItem < 0 then - FFirstItem := 0; - UpdateScrollBar; -end; - -function TfpgBaseListBox.ListHeight: TfpgCoord; -begin - result := height - (2*FMargin); -end; - -function TfpgBaseListBox.ScrollBarWidth: TfpgCoord; -begin - if FScrollBar.Visible then - result := FScrollBar.Width - else - result := 0; -end; - -function TfpgBaseListBox.PageLength: integer; -begin - result := (ListHeight div RowHeight)-1; // component height minus 1 line -end; - -procedure TfpgBaseListBox.ScrollBarMove(Sender: TObject; APosition: integer); -begin - FFirstItem := APosition; - Repaint; - if Assigned(FOnScroll) then - FOnScroll(self); -end; - -procedure TfpgBaseListBox.DoChange; -begin - if Assigned(OnChange) then - FOnChange(self); -end; - -procedure TfpgBaseListBox.DoSelect; -begin - if Assigned(OnSelect) then - FOnSelect(self); -end; - -procedure TfpgBaseListBox.HandleKeyPress(var keycode: word; - var shiftstate: TShiftState; var consumed: boolean); -begin - consumed := true; - - case keycode of - keyUp: - begin - if FFocusItem > 0 then - FocusItem := FFocusItem - 1; - end; - - keyDown: - begin - if FFocusItem < (ItemCount-1) then - FocusItem := FFocusItem + 1; - end; - - keyPageUp: - begin - if ItemCount > 0 then - begin - if ((FFocusItem - PageLength) < 0) then - FocusItem := 0 - else - FocusItem := FFocusItem - PageLength; - end; - end; - - keyPageDown: - begin - if ItemCount > 0 then - begin - if (FFocusItem + PageLength) > ItemCount-1 then - FocusItem := ItemCount - 1 - else - FocusItem := FFocusItem + PageLength; - end; - end; - - keyHome: - begin - FocusItem := 0; - end; - - keyEnd: - begin - FocusItem := ItemCount-1; - end; - - keyReturn, keyPEnter: - begin - if FocusItem > -1 then - DoSelect; - consumed := false; // to allow the forms to detect it - end; - else - consumed := false; - end; - inherited HandleKeyPress(keycode, shiftstate, consumed); -end; - -procedure TfpgBaseListBox.HandleLMouseDown(x, y: integer; shiftstate: TShiftState); -begin - inherited HandleLMouseDown(x, y, shiftstate); - - if ItemCount < 1 then - Exit; //==> - - FocusItem := FFirstItem + Trunc((y - FMargin) / RowHeight); - FMouseDragging := True; -end; - -procedure TfpgBaseListBox.HandleLMouseUp(x, y: integer; shiftstate: TShiftState); -begin - inherited HandleLMouseUp(x, y, shiftstate); - if ItemCount < 1 then - Exit; //==> - - FMouseDragging := False; - DoSelect; -end; - -procedure TfpgBaseListBox.HandleMouseMove(x, y: integer; btnstate: word; shiftstate: TShiftState); -var - NewFocus: Integer; -begin - inherited HandleMouseMove(x, y, btnstate, shiftstate); - - if ItemCount < 1 then - Exit; //==> - - if ((not FMouseDragging) or (btnstate and 1 = 0)) and (not HotTrack) then - Exit; //==> - - NewFocus := FFirstItem + Trunc((y - FMargin) / RowHeight); - if NewFocus < 0 then - NewFocus := 0; - - FocusItem := NewFocus; -end; - -procedure TfpgBaseListBox.HandleMouseScroll(x, y: integer; shiftstate: TShiftState; delta: smallint); -var - pfi: integer; -begin - pfi := FFirstItem; - if delta > 0 then // scroll down - FFirstItem := FFirstItem + abs(delta) - else // scroll up - FFirstItem := FFirstItem - abs(delta); - - if FFirstItem + PageLength > (ItemCount-1) then - FFirstItem := ItemCount - 1 - PageLength; - if FFirstItem < 0 then - FFirstItem := 0; - if pfi <> FFirstItem then - begin - UpdateScrollBar; - Repaint; - end; -end; - -procedure TfpgBaseListBox.HandleResize(awidth, aheight: TfpgCoord); -begin - inherited HandleResize(awidth, aheight); - if (csLoading in ComponentState) then - Exit; - UpdateScrollbarCoords; - UpdateScrollBar; -end; - -procedure TfpgBaseListBox.HandleShow; -begin - inherited HandleShow; - if (csLoading in ComponentState) then - Exit; - UpdateScrollBarCoords; - UpdateScrollBar; -end; - -procedure TfpgBaseListBox.HandlePaint; -var - n: integer; - r: TfpgRect; -begin - //if FUpdateCount > 0 then - //Exit; //==> - - inherited HandlePaint; - Canvas.ClearClipRect; - - r.SetRect(0, 0, Width, Height); - - if popupframe then - begin - Canvas.SetLineStyle(1, lsSolid); - Canvas.SetColor(clWidgetFrame); - Canvas.DrawRectangle(r); - InflateRect(r, -1, -1); - end - else - begin - Canvas.DrawControlFrame(r); - InflateRect(r, -2, -2); - end; - - Canvas.SetClipRect(r); - Canvas.SetColor(FBackgroundColor); - Canvas.FillRectangle(r); - Canvas.SetFont(FFont); - - r.SetRect(0, 0, Width-ScrollBarWidth, Height); - InflateRect(r, -FMargin, -FMargin); -// r.SetRect(FMargin, FMargin, Width-ScrollBarWidth-(FMargin*2), Height - (FMargin*2)); - Canvas.SetClipRect(r); - - r.Height := RowHeight; - - if ItemCount = 0 then - Exit; //==> - if FFirstItem = -1 then - FFirstItem := 0; - for n := FFirstItem to ItemCount-1 do - begin - if n = FFocusItem then - begin - if FFocused then - begin - Canvas.SetColor(clSelection); - Canvas.SetTextColor(clSelectionText); - end - else - begin - Canvas.SetColor(clInactiveSel); - Canvas.SetTextColor(clInactiveSelText); - end; - end - else - begin - Canvas.SetColor(FBackgroundColor); - Canvas.SetTextColor(FTextColor); - end; { if/else } - Canvas.FillRectangle(r); - - // This is just a test. - // Bluecurve theme :) - if (n = FFocusItem) and FFocused then - begin - // outer dark border - Canvas.SetColor(TfpgColor($3b4c71)); - Canvas.SetLineStyle(1, lsSolid); - Canvas.DrawRectangle(r); - InflateRect(r, -1, -1); - // left top - Canvas.SetColor(TfpgColor($98b2ed)); - Canvas.DrawLine(r.Left, r.Bottom, r.Left, r.Top); // left - Canvas.DrawLine(r.Left, r.Top, r.Right, r.Top); // top - // right bottom - Canvas.SetColor(TfpgColor($4468b8)); - Canvas.DrawLine(r.Right, r.Top, r.Right, r.Bottom); // right - Canvas.DrawLine(r.Right, r.Bottom, r.Left-1, r.Bottom); // bottom - // inside gradient fill - InflateRect(r, -1, -1); - Canvas.GradientFill(r, TfpgColor($435e9a), TfpgColor($5476c4), gdVertical); - // reset rectangle - InflateRect(r, 2, 2); - end; - - DrawItem(n, r, 0); - inc(r.Top, RowHeight); - - if r.Top >= Height then - Break; - end; { for } - - // clearing after the last row - if r.Top <= Height then - begin - Canvas.SetColor(FBackgroundColor); - r.SetBottom(Height - FMargin); - Canvas.FillRectangle(r); - end; -end; - -constructor TfpgBaseListBox.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - FFont := fpgGetFont('#List'); - FBackgroundColor := clListBox; - FTextColor := Parent.TextColor; - - FFocusable := True; - FFocusItem := -1; - FFirstItem := 0; - FWidth := 80; - FHeight := 80; - FMargin := 2; - FUpdateCount := 0; - FMouseDragging := False; - FPopupFrame := False; - FHotTrack := False; - FAutoHeight := False; - - FScrollBar := TfpgScrollBar.Create(self); - FScrollBar.OnScroll := @ScrollBarMove; - - FOnChange := nil; - FOnSelect := nil; - FOnScroll := nil; -end; - -destructor TfpgBaseListBox.Destroy; -begin - FFont.Free; - inherited Destroy; -end; - -procedure TfpgBaseListBox.BeginUpdate; -begin - Inc(FUpdateCount); -end; - -procedure TfpgBaseListBox.EndUpdate; -begin - if FUpdateCount = 0 then - Exit; //==> - Dec(FUpdateCount); - if FUpdateCount = 0 then - Repaint; -end; - -procedure TfpgBaseListBox.Update; -begin - FFirstItem := -1; - FFocusItem := -1; - UpdateScrollBar; - Repaint; -end; - -function TfpgBaseListBox.ItemCount: integer; -begin - // This must be overridden in descendant classes! - result := 17; -end; - -function TfpgBaseListBox.RowHeight: integer; -begin - result := FFont.Height+2; -end; - -procedure TfpgBaseListBox.DrawItem(num: integer; rect: TfpgRect; flags: integer); -var - s: string; -begin - // This must be overridden in descendant classes! - s := 'Item' + IntToStr(num); - Canvas.DrawString(rect.left+2, rect.top+1, s); -end; - -{ TfpgTextListBox } - -procedure TfpgTextListBox.DrawItem(num: integer; rect: TfpgRect; flags: integer); -begin - //if num < 0 then - //Exit; //==> - fpgStyle.DrawString(Canvas, rect.left+2, rect.top+1, FItems.Strings[num], Enabled); -end; - -procedure TfpgTextListBox.HandleKeyChar(var AText: TfpgChar; - var shiftstate: TShiftState; var consumed: boolean); -var - i: integer; -begin - // If the user pressed a key then it will search the stringlist for a word - // beginning with that letter - if (Ord(AText[1]) > 31) and (Ord(AText[1]) < 127) or (Length(AText) > 1 ) then - if FFocusItem > -1 then - for i := FFocusItem to FItems.Count-1 do - begin - if SameText(LeftStr(FItems.Strings[i], Length(AText)), AText) then - begin - FocusItem := i; - break; - end; - end; { for } - inherited HandleKeyChar(AText, shiftstate, consumed); -end; - -constructor TfpgTextListBox.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - FItems := TfpgListBoxStrings.Create(self); - FFocusItem := -1; -end; - -destructor TfpgTextListBox.Destroy; -begin - TfpgListBoxStrings(FItems).Free; - inherited Destroy; -end; - -function TfpgTextListBox.ItemCount: integer; -begin - result := FItems.Count; -end; - -function TfpgTextListBox.Text: string; -begin - if (ItemCount > 0) and (FocusItem <> -1) then - result := FItems[FocusItem] - else - result := ''; -end; - -{ TColorItem } - -constructor TColorItem.Create (const AColorName: string; const AColorValue: TfpgColor); -begin - inherited Create; - ColorName := AColorName; - ColorValue := AColorValue; -end; - -{ TfpgBaseColorListBox } - -procedure TfpgBaseColorListBox.SetColorPalette (const AValue: TfpgColorPalette ); -begin - if FColorPalette = AValue then - Exit; - FColorPalette := AValue; - SetupColorPalette; - RePaint; -end; - -procedure TfpgBaseColorListBox.SetShowColorNames (const AValue: Boolean ); -begin - if FShowColorNames = AValue then - Exit; - FShowColorNames := AValue; - Repaint; -end; - -function TfpgBaseColorListBox.GetColor: TfpgColor; -begin - Result := TColorItem(FItems.Items[FocusItem]).ColorValue; -end; - -procedure TfpgBaseColorListBox.SetColor(const AValue: TfpgColor); -var - i: integer; -begin - if GetColor = AValue then - Exit; //==> - for i := 0 to FItems.Count-1 do - begin - if TColorItem(FItems.Items[i]).ColorValue = AValue then - begin - FocusItem := i; - Exit; - end; - end; -end; - -procedure TfpgBaseColorListBox.SetupColorPalette; -begin - FreeAndClearColors; - - case FColorPalette of - cpStandardColors: - begin - FItems.Add(TColorItem.Create('clAqua', clAqua)); - FItems.Add(TColorItem.Create('clBlack', clBlack)); - FItems.Add(TColorItem.Create('clBlue', clBlue)); - FItems.Add(TColorItem.Create('clCream', clCream)); - FItems.Add(TColorItem.Create('clDkGray', clDkGray)); - FItems.Add(TColorItem.Create('clFuchsia', clFuchsia)); - FItems.Add(TColorItem.Create('clGray', clGray)); - FItems.Add(TColorItem.Create('clGreen', clGreen)); - FItems.Add(TColorItem.Create('clLime', clLime)); - FItems.Add(TColorItem.Create('clLtGray', clLtGray)); - FItems.Add(TColorItem.Create('clMaroon', clMaroon)); - FItems.Add(TColorItem.Create('clNavy', clNavy)); - FItems.Add(TColorItem.Create('clOlive', clOlive)); - FItems.Add(TColorItem.Create('clPurple', clPurple)); - FItems.Add(TColorItem.Create('clRed', clRed)); - FItems.Add(TColorItem.Create('clSilver', clSilver)); - FItems.Add(TColorItem.Create('clTeal', clTeal)); - FItems.Add(TColorItem.Create('clWhite', clWhite)); - FItems.Add(TColorItem.Create('clYellow', clYellow)); - FItems.Add(TColorItem.Create('clMoneyGreen', clMoneyGreen)); - FItems.Add(TColorItem.Create('clSkyBlue', clSkyBlue)); - FItems.Add(TColorItem.Create('clMedGray', clMedGray)); - end; - cpSystemColors: - begin - FItems.Add(TColorItem.Create('clWindowBackground', clWindowBackground)); - FItems.Add(TColorItem.Create('clBoxColor', clBoxColor)); - FItems.Add(TColorItem.Create('clButtonFace', clButtonFace)); - FItems.Add(TColorItem.Create('clShadow1', clShadow1)); - FItems.Add(TColorItem.Create('clShadow2', clShadow2)); - FItems.Add(TColorItem.Create('clHilite1', clHilite1)); - FItems.Add(TColorItem.Create('clHilite2', clHilite2)); - FItems.Add(TColorItem.Create('clText1', clText1)); - FItems.Add(TColorItem.Create('clText2', clText2)); - FItems.Add(TColorItem.Create('clText3', clText3)); - FItems.Add(TColorItem.Create('clText4', clText4)); - FItems.Add(TColorItem.Create('clSelection', clSelection)); - FItems.Add(TColorItem.Create('clSelectionText', clSelectionText)); - FItems.Add(TColorItem.Create('clInactiveSel', clInactiveSel)); - FItems.Add(TColorItem.Create('clInactiveSelText', clInactiveSelText)); - FItems.Add(TColorItem.Create('clScrollBar', clScrollBar)); - FItems.Add(TColorItem.Create('clListBox', clListBox)); - FItems.Add(TColorItem.Create('clGridLines', clGridLines)); - FItems.Add(TColorItem.Create('clGridHeader', clGridHeader)); - FItems.Add(TColorItem.Create('clWidgetFrame', clWidgetFrame)); - FItems.Add(TColorItem.Create('clInactiveWgFrame', clInactiveWgFrame)); - FItems.Add(TColorItem.Create('clTextCursor', clTextCursor)); - FItems.Add(TColorItem.Create('clChoiceListBox', clChoiceListBox)); - FItems.Add(TColorItem.Create('clUnset', clUnset)); - FItems.Add(TColorItem.Create('clMenuText', clMenuText)); - FItems.Add(TColorItem.Create('clMenuDisabled', clMenuDisabled)); - end; - cpWebColors: - begin - { TODO : Need to add the web colors } - FItems.Add(TColorItem.Create('clAliceBlue', clAliceBlue)); - FItems.Add(TColorItem.Create('clAntiqueWhite', clAntiqueWhite)); - FItems.Add(TColorItem.Create('clAqua', clAqua)); - FItems.Add(TColorItem.Create('clAquamarine', clAquamarine)); - FItems.Add(TColorItem.Create('clAzure', clAzure)); - FItems.Add(TColorItem.Create('clBeige', clBeige)); - FItems.Add(TColorItem.Create('clBisque', clBisque)); - FItems.Add(TColorItem.Create('clBlack', clBlack)); - FItems.Add(TColorItem.Create('clBlanchedAlmond', clBlanchedAlmond)); - FItems.Add(TColorItem.Create('clBlue', clBlue)); - FItems.Add(TColorItem.Create('clBlueViolet', clBlueViolet)); - FItems.Add(TColorItem.Create('clBrown', clBrown)); - FItems.Add(TColorItem.Create('clBurlyWood', clBurlyWood)); - FItems.Add(TColorItem.Create('clCadetBlue', clCadetBlue)); - FItems.Add(TColorItem.Create('clChartreuse', clChartreuse)); - FItems.Add(TColorItem.Create('clChocolate', clChocolate)); - FItems.Add(TColorItem.Create('clCoral', clCoral)); - FItems.Add(TColorItem.Create('clCornflowerBlue', clCornflowerBlue)); - FItems.Add(TColorItem.Create('clCornsilk', clCornsilk)); - FItems.Add(TColorItem.Create('clCrimson', clCrimson)); - FItems.Add(TColorItem.Create('clCyan', clCyan)); - FItems.Add(TColorItem.Create('clDarkBlue', clDarkBlue)); - FItems.Add(TColorItem.Create('clDarkCyan', clDarkCyan)); - FItems.Add(TColorItem.Create('clDarkGoldenrod', clDarkGoldenrod)); - FItems.Add(TColorItem.Create('clDarkGray', clDarkGray)); - FItems.Add(TColorItem.Create('clDarkGreen', clDarkGreen)); - FItems.Add(TColorItem.Create('clDarkKhaki', clDarkKhaki)); - FItems.Add(TColorItem.Create('clDarkMagenta', clDarkMagenta)); - FItems.Add(TColorItem.Create('clDarkOliveGreen', clDarkOliveGreen)); - FItems.Add(TColorItem.Create('clDarkOrange', clDarkOrange)); - FItems.Add(TColorItem.Create('clDarkOrchid', clDarkOrchid)); - FItems.Add(TColorItem.Create('clDarkRed', clDarkRed)); - FItems.Add(TColorItem.Create('clDarkSalmon', clDarkSalmon)); - FItems.Add(TColorItem.Create('clDarkSeaGreen', clDarkSeaGreen)); - FItems.Add(TColorItem.Create('clDarkSlateBlue', clDarkSlateBlue)); - FItems.Add(TColorItem.Create('clDarkSlateGray', clDarkSlateGray)); - FItems.Add(TColorItem.Create('clDarkTurquoise', clDarkTurquoise)); - FItems.Add(TColorItem.Create('clDarkViolet', clDarkViolet)); - FItems.Add(TColorItem.Create('clDeepPink', clDeepPink)); - FItems.Add(TColorItem.Create('clDeepSkyBlue', clDeepSkyBlue)); - FItems.Add(TColorItem.Create('clDimGray',clDimGray )); - FItems.Add(TColorItem.Create('clDodgerBlue', clDodgerBlue)); - FItems.Add(TColorItem.Create('clFireBrick', clFireBrick)); - FItems.Add(TColorItem.Create('clFloralWhite', clFloralWhite)); - FItems.Add(TColorItem.Create('clForestGreen', clForestGreen)); - FItems.Add(TColorItem.Create('clFuchsia', clFuchsia)); - FItems.Add(TColorItem.Create('clGainsboro', clGainsboro)); - FItems.Add(TColorItem.Create('clGhostWhite', clGhostWhite)); - FItems.Add(TColorItem.Create('clGold', clGold)); - FItems.Add(TColorItem.Create('clGoldenrod', clGoldenrod)); - FItems.Add(TColorItem.Create('clGray', clGray)); - FItems.Add(TColorItem.Create('clGreen', clGreen)); - FItems.Add(TColorItem.Create('clGreenYellow', clGreenYellow)); - FItems.Add(TColorItem.Create('clHoneydew', clHoneydew)); - FItems.Add(TColorItem.Create('clHotPink', clHotPink)); - FItems.Add(TColorItem.Create('clIndianRed', clIndianRed)); - FItems.Add(TColorItem.Create('clIndigo', clIndigo)); - FItems.Add(TColorItem.Create('clIvory', clIvory)); - FItems.Add(TColorItem.Create('clKhaki', clKhaki)); - FItems.Add(TColorItem.Create('clLavender', clLavender)); - FItems.Add(TColorItem.Create('clLavenderBlush', clLavenderBlush)); - FItems.Add(TColorItem.Create('clLawnGreen', clLawnGreen)); - FItems.Add(TColorItem.Create('clLemonChiffon', clLemonChiffon)); - FItems.Add(TColorItem.Create('clLightBlue', clLightBlue)); - FItems.Add(TColorItem.Create('clLightCoral', clLightCoral)); - FItems.Add(TColorItem.Create('clLightCyan', clLightCyan)); - FItems.Add(TColorItem.Create('clLightGoldenrodYellow', clLightGoldenrodYellow)); - FItems.Add(TColorItem.Create('clLightGreen', clLightGreen)); - FItems.Add(TColorItem.Create('clLightGray', clLightGray)); - FItems.Add(TColorItem.Create('clLightPink', clLightPink)); - FItems.Add(TColorItem.Create('clLightSalmon', clLightSalmon)); - FItems.Add(TColorItem.Create('clLightSeaGreen', clLightSeaGreen)); - FItems.Add(TColorItem.Create('clLightSkyBlue', clLightSkyBlue)); - FItems.Add(TColorItem.Create('clLightSlateGray', clLightSlateGray)); - FItems.Add(TColorItem.Create('clLightSteelBlue', clLightSteelBlue)); - FItems.Add(TColorItem.Create('clLightYellow', clLightYellow)); - FItems.Add(TColorItem.Create('clLime', clLime)); - FItems.Add(TColorItem.Create('clLimeGreen', clLimeGreen)); - FItems.Add(TColorItem.Create('clLinen', clLinen)); - FItems.Add(TColorItem.Create('clMagenta', clMagenta)); - FItems.Add(TColorItem.Create('clMaroon', clMaroon)); - FItems.Add(TColorItem.Create('clMediumAquamarine', clMediumAquamarine)); - FItems.Add(TColorItem.Create('clMediumBlue', clMediumBlue)); - FItems.Add(TColorItem.Create('clMediumOrchid', clMediumOrchid)); - FItems.Add(TColorItem.Create('clMediumPurple', clMediumPurple)); - FItems.Add(TColorItem.Create('clMediumSeaGreen', clMediumSeaGreen)); - FItems.Add(TColorItem.Create('clMediumSlateBlue', clMediumSlateBlue)); - FItems.Add(TColorItem.Create('clMediumSpringGreen', clMediumSpringGreen)); - FItems.Add(TColorItem.Create('clMediumTurquoise', clMediumTurquoise)); - FItems.Add(TColorItem.Create('clMediumVioletRed', clMediumVioletRed)); - FItems.Add(TColorItem.Create('clMidnightBlue', clMidnightBlue)); - FItems.Add(TColorItem.Create('clMintCream', clMintCream)); - FItems.Add(TColorItem.Create('clMistyRose', clMistyRose)); - FItems.Add(TColorItem.Create('clMoccasin', clMoccasin)); - FItems.Add(TColorItem.Create('clNavajoWhite', clNavajoWhite)); - FItems.Add(TColorItem.Create('clNavy', clNavy)); - FItems.Add(TColorItem.Create('clOldLace', clOldLace)); - FItems.Add(TColorItem.Create('clOlive', clOlive)); - FItems.Add(TColorItem.Create('clOliveDrab', clOliveDrab)); - FItems.Add(TColorItem.Create('clOrange', clOrange)); - FItems.Add(TColorItem.Create('clOrangeRed', clOrangeRed)); - FItems.Add(TColorItem.Create('clOrchid', clOrchid)); - FItems.Add(TColorItem.Create('clPaleGoldenrod', clPaleGoldenrod)); - FItems.Add(TColorItem.Create('clPaleGreen', clPaleGreen)); - FItems.Add(TColorItem.Create('clPaleTurquoise', clPaleTurquoise)); - FItems.Add(TColorItem.Create('clPaleVioletRed', clPaleVioletRed)); - FItems.Add(TColorItem.Create('clPaleBlue',clPaleBlue )); - FItems.Add(TColorItem.Create('clPapayaWhip', clPapayaWhip)); - FItems.Add(TColorItem.Create('clPeachPuff',clPeachPuff )); - FItems.Add(TColorItem.Create('clPeru', clPeru)); - FItems.Add(TColorItem.Create('clPink', clPink)); - FItems.Add(TColorItem.Create('clPlum', clPlum)); - FItems.Add(TColorItem.Create('clPowderBlue', clPowderBlue)); - FItems.Add(TColorItem.Create('clPurple', clPurple)); - FItems.Add(TColorItem.Create('clRed', clRed)); - FItems.Add(TColorItem.Create('clRosyBrown', clRosyBrown)); - FItems.Add(TColorItem.Create('clRoyalBlue', clRoyalBlue)); - FItems.Add(TColorItem.Create('clSaddleBrown', clSaddleBrown)); - FItems.Add(TColorItem.Create('clSalmon', clSalmon)); - FItems.Add(TColorItem.Create('clSandyBrown', clSandyBrown)); - FItems.Add(TColorItem.Create('clSeaGreen', clSeaGreen)); - FItems.Add(TColorItem.Create('clSeashell', clSeashell)); - FItems.Add(TColorItem.Create('clSienna', clSienna)); - FItems.Add(TColorItem.Create('clSilver', clSilver)); - FItems.Add(TColorItem.Create('clSkyBlue2', clSkyBlue2)); - FItems.Add(TColorItem.Create('clSlateBlue', clSlateBlue)); - FItems.Add(TColorItem.Create('clSlateGray', clSlateGray)); - FItems.Add(TColorItem.Create('clSnow', clSnow)); - FItems.Add(TColorItem.Create('clSpringGreen', clSpringGreen)); - FItems.Add(TColorItem.Create('clSteelBlue', clSteelBlue)); - FItems.Add(TColorItem.Create('clTan', clTan)); - FItems.Add(TColorItem.Create('clTeal', clTeal)); - FItems.Add(TColorItem.Create('clThistle', clThistle)); - FItems.Add(TColorItem.Create('clTomato', clTomato)); - FItems.Add(TColorItem.Create('clTurquoise', clTurquoise)); - FItems.Add(TColorItem.Create('clViolet', clViolet)); - FItems.Add(TColorItem.Create('clWheat', clWheat)); - FItems.Add(TColorItem.Create('clWhite', clWhite)); - FItems.Add(TColorItem.Create('clWhiteSmoke', clWhiteSmoke)); - FItems.Add(TColorItem.Create('clYellow', clYellow)); - FItems.Add(TColorItem.Create('clYellowGreen', clYellowGreen)); - end; - end; - FocusItem := 0; - FollowFocus; - UpdateScrollbar; -end; - -procedure TfpgBaseColorListBox.FreeAndClearColors; -var - i: integer; -begin - for i := 0 to FItems.Count-1 do - TColorItem(FItems.Items[i]).Free; - FItems.Clear; -end; - -procedure TfpgBaseColorListBox.DrawItem(num: integer; rect: TfpgRect; flags: integer); -var - itm: TColorItem; -begin - if num < 0 then - Exit; //==> - itm := TColorItem(FItems.Items[num]); - // color box - Canvas.SetColor(itm.ColorValue); - Canvas.FillRectangle(rect.Left + 2, rect.Top + 4, FColorBoxWidth, FColorboxHeight); - Canvas.SetColor(clBlack); - Canvas.DrawRectangle(rect.Left + 2, rect.Top + 4, FColorBoxWidth, FColorboxHeight); - // color text - if FShowColorNames then - fpgStyle.DrawString(Canvas, FColorboxWidth + 8 + rect.left, rect.top+1, itm.ColorName, Enabled); -end; - -constructor TfpgBaseColorListBox.Create(AOwner: TComponent); -begin - inherited Create (AOwner ); - FColorBoxWidth := 35; - FColorBoxHeight := 10; - FShowColorNames := True; - - FItems := TList.Create; - // default Delphi colors - FColorPalette := cpStandardColors; - SetupColorPalette; -end; - -destructor TfpgBaseColorListBox.Destroy; -begin - FreeAndClearColors; - FItems.Free; - inherited Destroy; -end; - -function TfpgBaseColorListBox.ItemCount: integer; -begin - result := FItems.Count; -end; - -end. - diff --git a/src/gui/gui_listview.pas b/src/gui/gui_listview.pas deleted file mode 100644 index 948038fe..00000000 --- a/src/gui/gui_listview.pas +++ /dev/null @@ -1,1753 +0,0 @@ -{ - fpGUI - Free Pascal GUI Toolkit - - Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this - distribution, for details of the copyright. - - See the file COPYING.modifiedLGPL, included in this distribution, - for details about redistributing fpGUI. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - - Description: - Defines a Listview control. -} - -unit gui_listview; - -{$mode objfpc}{$H+} - -interface - -uses - Classes, - SysUtils, - fpg_base, - fpg_main, - fpg_widget, - gui_scrollbar; - -type - TfpgListView = class; - TfpgLVItem = class; - TfpgLVColumns = class; - TfpgLVColumn = class; - - TfpgLVColumnClickEvent = procedure(Listview: TfpgListView; Column: TfpgLVColumn; Button: Integer) of object; - - - TfpgLVColumn = class(TComponent) - private - FAlignment: TAlignment; - FCaptionAlignment: TAlignment; - FDown: Boolean; - FAutoSize: Boolean; - FCaption: String; - FClickable: Boolean; - FColumnIndex: Integer; - FColumns: TfpgLVColumns; - FHeight: Integer; - FResizable: Boolean; - FVisible: Boolean; - FWidth: Integer; - procedure SetAlignment(const AValue: TAlignment); - procedure SetAutoSize(const AValue: Boolean); - procedure SetCaption(const AValue: String); - procedure SetCaptionAlignment(const AValue: TAlignment); - procedure SetColumnIndex(const AValue: Integer); - procedure SetHeight(const AValue: Integer); - procedure SetResizable(const AValue: Boolean); - procedure SetVisible(const AValue: Boolean); - procedure SetWidth(const AValue: Integer); - public - constructor Create(AColumns: TfpgLVColumns); reintroduce; - destructor Destroy; override; - property Caption: String read FCaption write SetCaption; - property CaptionAlignment: TAlignment read FCaptionAlignment write SetCaptionAlignment; - property Alignment: TAlignment read FAlignment write SetAlignment; - property AutoSize: Boolean read FAutoSize write SetAutoSize; - property Width: Integer read FWidth write SetWidth; - property Height: Integer read FHeight write SetHeight; - property Visible: Boolean read FVisible write SetVisible; - property ColumnIndex: Integer read FColumnIndex write SetColumnIndex; - property Clickable: Boolean read FClickable write FClickable; - property Resizable: Boolean read FResizable write SetResizable; - end; - - - TfpgLVColumns = class(TPersistent) - private - FListView: TfpgListView; - FColumns: TList; - function GetColumn(AIndex: Integer): TfpgLVColumn; - procedure SetColumn(AIndex: Integer; const AValue: TfpgLVColumn); - public - constructor Create(AListView: TfpgListView); - destructor Destroy; override; - function Add(AColumn: TfpgLVColumn): Integer; - procedure Clear; - procedure Delete(AIndex: Integer); - procedure Insert(AColumn: TfpgLVColumn; AIndex: Integer); - function Count: Integer; - property Column[AIndex: Integer]: TfpgLVColumn read GetColumn write SetColumn; - end; - - - TfpgLVItemState = set of (lisFocused, lisSelected, lisHotTrack); - - TfpgLVItemPaintPart = set of (lvppBackground, lvppIcon, lvppText, lvppFocused); - - TfpgLVPaintColumnEvent = procedure(ListView: TfpgListView; Canvas: TfpgCanvas; Column: TfpgLVColumn; - ColumnIndex: Integer; Area: TfpgRect; var PaintPart: TfpgLVItemPaintPart) of object; - TfpgLVPaintItemEvent = procedure(ListView: TfpgListView; Canvas: TfpgCanvas; Item: TfpgLVItem; - ItemIndex: Integer; Area:TfpgRect; var PaintPart: TfpgLVItemPaintPart) of object; - TfpgLVItemSelectEvent = procedure(ListView: TfpgListView; Item: TfpgLVItem; - ItemIndex: Integer; Selected: Boolean) of object; - - - IfpgLVItemViewer = interface - procedure ItemDeleted(AIndex: Integer); - procedure ItemAdded(AIndex: Integer); - procedure ItemChanged(AIndex: Integer); - procedure ItemsUpdated; - end; - - - TfpgLVItems = class(TObject) - private - FUpdateCount: Integer; - FColumns: TfpgLVColumns; - FCurrentIndexOf: Integer; - FViewers: TList; - FItems: TList; - function GetCapacity: Integer; - function GetItem(AIndex: Integer): TfpgLVItem; - procedure SetCapacity(const AValue: Integer); - procedure SetItem(AIndex: Integer; const AValue: TfpgLVItem); - procedure AddViewer(AValue: IfpgLVItemViewer); - procedure DeleteViewer(AValue: IfpgLVItemViewer); - // interface method triggers - procedure DoChange(AItem: TfpgLVItem); - procedure DoAdd(AItem: TfpgLVItem); - procedure DoDelete(AItem: TfpgLVItem); - procedure DoEndUpdate; - public - constructor Create(AViewer: IfpgLVItemViewer); - destructor Destroy; override; - function Add(AItem: TfpgLVItem): Integer; - function Count: Integer; - procedure Clear; - procedure Delete(AIndex: Integer); - function IndexOf(AItem: TfpgLVItem): Integer; - procedure InsertItem(AItem: TfpgLVItem; AIndex: Integer); - procedure BeginUpdate; - procedure EndUpdate; - property Capacity: Integer read GetCapacity write SetCapacity; - property Columns: TfpgLVColumns read FColumns; - property Item[AIndex: Integer]: TfpgLVItem read GetItem write SetItem; - end; - - - TfpgLVItem = class(TObject) - private - FCaption: String; - FItems: TfpgLVItems; - FSubItems: TStrings; - FUserData: Pointer; - function GetSelected(ListView: TfpgListView): Boolean; - procedure SetCaption(const AValue: String); - procedure SetSelected(ListView: TfpgListView; const AValue: Boolean); - procedure SubItemsChanged(Sender: TObject); - public - constructor Create(Items: TfpgLVItems); virtual; - destructor Destroy; override; - property Caption: String read FCaption write SetCaption; - property UserData: Pointer read FUserData write FUserData; - property SubItems: TStrings read FSubItems; - property Selected[ListView: TfpgListView]: Boolean read GetSelected write SetSelected; - end; - - - TfpgListView = class(TfpgWidget, IfpgLVItemViewer) - private - FItemIndex: Integer; - FMultiSelect: Boolean; - FOnPaintColumn: TfpgLVPaintColumnEvent; - FOnSelectionChanged: TfpgLVItemSelectEvent; - FShiftCount: Integer; - FSelectionFollowsFocus: Boolean; - FSelectionShiftStart: Integer; - FOnColumnClick: TfpgLVColumnClickEvent; - FSelected: TList; - FOldSelected: TList; - FUpdateCount: Integer; - FVScrollBar: TfpgScrollBar; - FHScrollBar: TfpgScrollBar; - FColumns: TfpgLVColumns; - FItems: TfpgLVItems; - FOnPaintItem: TfpgLVPaintItemEvent; - FShowHeaders: Boolean; - FResizingColumn: TfpgLVColumn; - FMouseDownPoint: TPoint; - FScrollBarNeedsUpdate: Boolean; - function GetItemHeight: Integer; - procedure SetItemIndex(const AValue: Integer); - procedure SetItems(const AValue: TfpgLVItems); - procedure SetMultiSelect(const AValue: Boolean); - procedure SetOnColumnClick(const AValue: TfpgLVColumnClickEvent); - procedure SetShowHeaders(const AValue: Boolean); - procedure VScrollChange(Sender: TObject; Position: Integer); - procedure HScrollChange(Sender: TObject; Position: Integer); - // interface methods - procedure ItemDeleted(AIndex: Integer); - procedure ItemAdded(AIndex: Integer); - procedure ItemChanged(AIndex: Integer); - procedure ItemsUpdated; - // - function GetVisibleColumnsWidth: Integer; - function GetItemAreaHeight: Integer; - procedure StartShiftSelection; - procedure EndShiftSelection; - procedure SelectionSetRangeEnabled(AStart, AEnd: Integer; AValue: Boolean); - procedure SelectionToggleRange(AStart, AEnd: Integer; const ShiftState: TShiftState; IgnoreStartIndex: Boolean); - procedure SelectionClear; - function ItemGetSelected(const AItem: TfpgLVItem): Boolean; - procedure ItemSetSelected(const AItem: TfpgLVItem; const AValue: Boolean); - function ItemGetFromPoint(const X, Y: Integer): TfpgLVItem; - function ItemGetRect(AIndex: Integer): TfpgRect; - function ItemIndexFromY(Y: Integer): Integer; - function HeaderHeight: Integer; - procedure DoRepaint; - procedure DoColumnClick(Column: TfpgLVColumn; Button: Integer); - procedure HandleHeaderMouseMove(x, y: Integer; btnstate: word; Shiftstate: TShiftState); - protected - procedure MsgPaint(var msg: TfpgMessageRec); message FPGM_PAINT; - procedure HandleMouseScroll(x, y: integer; shiftstate: TShiftState; delta: smallint); override; - procedure HandleLMouseDown(x, y: integer; shiftstate: TShiftState); override; - procedure HandleRMouseDown(x, y: integer; shiftstate: TShiftState); override; - procedure HandleLMouseUp(x, y: integer; shiftstate: TShiftState); override; - procedure HandleRMouseUp(x, y: integer; shiftstate: TShiftState); override; - procedure HandleMouseMove(x, y: integer; btnstate: word; shiftstate: TShiftState); override; - procedure HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override; - procedure HandleKeyRelease(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override; - procedure HandlePaint; override; - procedure HandleResize(awidth, aheight: TfpgCoord); override; - procedure PaintHeaders; virtual; - procedure PaintItems; virtual; - procedure UpdateScrollBarPositions; virtual; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - function GetClientRect: TfpgRect; override; - procedure BeginUpdate; - procedure EndUpdate; - procedure MakeItemVisible(AIndex: Integer; PartialOK: Boolean = False); - function ItemAdd: TfpgLVItem; - published - property Columns: TfpgLVColumns read FColumns; - property HScrollBar: TfpgScrollBar read FHScrollBar; - property ItemHeight: Integer read GetItemHeight; - property ItemIndex: Integer read FItemIndex write SetItemIndex; - property Items: TfpgLVItems read FItems write SetItems; - property MultiSelect: Boolean read FMultiSelect write SetMultiSelect; - property ParentShowHint; - property SelectionFollowsFocus: Boolean read FSelectionFollowsFocus write FSelectionFollowsFocus; - property ShowHeaders: Boolean read FShowHeaders write SetShowHeaders; - property ShowHint; - property TabOrder; - property VScrollBar: TfpgScrollBar read FVScrollBar; - property OnColumnClick: TfpgLVColumnClickEvent read FOnColumnClick write SetOnColumnClick; - property OnPaintColumn: TfpgLVPaintColumnEvent read FOnPaintColumn write FOnPaintColumn; - property OnPaintItem: TfpgLVPaintItemEvent read FOnPaintItem write FOnPaintItem; - property OnSelectionChanged: TfpgLVItemSelectEvent read FOnSelectionChanged write FOnSelectionChanged; - end; - - -implementation - -uses - fpg_constants; - - -type - // used to access protected methods - TfpgScrollbarFriend = class(TfpgScrollbar) - end; - -{ TfpgLVItems } - -function Min(AInt, BInt: Integer): Integer; -begin - if AInt < Bint then - Result := AInt - else Result := BInt; -end; - -function Max(AInt, BInt: Integer): INteger; -begin - if AInt > Bint then - Result := AInt - else Result := BInt; -end; - -function TfpgLVItems.GetItem(AIndex: Integer): TfpgLVItem; -begin - Result := TfpgLVItem(FItems.Items[AIndex]); -end; - -function TfpgLVItems.GetCapacity: Integer; -begin - Result := FItems.Capacity; -end; - -procedure TfpgLVItems.SetCapacity(const AValue: Integer); -begin - FItems.Capacity := AValue; -end; - -procedure TfpgLVItems.SetItem(AIndex: Integer; const AValue: TfpgLVItem); -begin - FItems.Items[AIndex] := AValue; -end; - -procedure TfpgLVItems.AddViewer(AValue: IfpgLVItemViewer); -begin - if AValue <> nil then - FViewers.Add(AValue); -end; - -procedure TfpgLVItems.DeleteViewer(AValue: IfpgLVItemViewer); -var - AIndex: Integer; -begin - AIndex := FViewers.IndexOf(AValue); - if AIndex > -1 then - begin - FViewers.Delete(AIndex); - end; - if FViewers.Count = 0 then - Free; -end; - -procedure TfpgLVItems.DoChange(AItem: TfpgLVItem); -var - I: Integer; - AIndex: Integer; -begin - if FUpdateCount > 0 then - Exit; - AIndex := IndexOf(AItem); - for I := 0 to FViewers.Count -1 do - begin - IfpgLVItemViewer(FViewers.Items[I]).ItemChanged(AIndex); - end; -end; - -procedure TfpgLVItems.DoAdd(AItem: TfpgLVItem); -var - I: Integer; - AIndex: Integer; -begin - if FUpdateCount > 0 then - Exit; - AIndex := IndexOf(AItem); - for I := 0 to FViewers.Count -1 do - begin - IfpgLVItemViewer(FViewers.Items[I]).ItemAdded(AIndex); - end; -end; - -procedure TfpgLVItems.DoDelete(AItem: TfpgLVItem); -var - I: Integer; - AIndex: Integer; -begin - if FUpdateCount > 0 then - Exit; - AIndex := IndexOf(AItem); - for I := 0 to FViewers.Count -1 do - begin - IfpgLVItemViewer(FViewers.Items[I]).ItemDeleted(AIndex); - end; -end; - -procedure TfpgLVItems.DoEndUpdate; -var - I: Integer; -begin - if FUpdateCount > 0 then - Exit; - for I := 0 to FViewers.Count -1 do - begin - IfpgLVItemViewer(FViewers.Items[I]).ItemsUpdated; - end; -end; - -constructor TfpgLVItems.Create(AViewer: IfpgLVItemViewer); -begin - FItems := TList.Create; - FViewers := TList.Create; - AddViewer(AViewer); -end; - -destructor TfpgLVItems.Destroy; -begin - FItems.Free; - FViewers.Free; - inherited Destroy; -end; - -function TfpgLVItems.Add(AItem: TfpgLVItem): Integer; -begin - Result := Count; - InsertItem(AItem, Count); - DoAdd(AItem); -end; - -function TfpgLVItems.Count: Integer; -begin - Result := FItems.Count; -end; - -procedure TfpgLVItems.Clear; -var - i: integer; -begin - for i := FItems.Count-1 downto 0 do - Delete(i); - FItems.Clear; -end; - -procedure TfpgLVItems.Delete(AIndex: Integer); -begin - DoDelete(GetItem(AIndex)); - FItems.Delete(AIndex); -end; - -function TfpgLVItems.IndexOf(AItem: TfpgLVItem): Integer; -begin - Result := -1; - // this checks for a index close to the old one whic can speed up - // search significantly when we are using indexof in a for loop - if (FCurrentIndexOf > 100) and (FCurrentIndexOf < Count-2) then - begin - if FItems.Items[FCurrentIndexOf] = Pointer(AItem) then - Result := FCurrentIndexOf - else if FItems.Items[FCurrentIndexOf+1] = Pointer(AItem) then - Result := FCurrentIndexOf+1 - else if FItems.Items[FCurrentIndexOf-1] = Pointer(AItem) then - Result := FCurrentIndexOf-1 - end; - if Result = -1 then - Result := FItems.IndexOf(AItem); - FCurrentIndexOf := Result; -end; - -procedure TfpgLVItems.InsertItem(AItem: TfpgLVItem; AIndex: Integer); -begin - if AItem.InheritsFrom(TfpgLVItem) then - FItems.Insert(AIndex, AItem) - else - raise Exception.CreateFmt(rsErrItemOfWrongType, ['TfpgLVItem']); -end; - -procedure TfpgLVItems.BeginUpdate; -begin - Inc(FUpdateCount); -end; - -procedure TfpgLVItems.EndUpdate; -begin - Dec(FUpdateCount); - if FUpdateCount < 0 then - FUpdateCount := 0; - if FUpdateCount = 0 then - DoEndUpdate; -end; - -{ TfpgLVItem } - -procedure TfpgLVItem.SetCaption(const AValue: String); -begin - if FCaption=AValue then - Exit; - FCaption:=AValue; - if Assigned(FItems) then - FItems.DoChange(Self); -end; - -function TfpgLVItem.GetSelected(ListView: TfpgListView): Boolean; -begin - Result := ListView.ItemGetSelected(Self); -end; - -procedure TfpgLVItem.SetSelected(ListView: TfpgListView; const AValue: Boolean); -begin - ListView.ItemSetSelected(Self, AValue); -end; - -procedure TfpgLVItem.SubItemsChanged(Sender: TObject); -begin - if Assigned(FItems) then - FItems.DoChange(Self); -end; - -constructor TfpgLVItem.Create(Items: TfpgLVItems); -begin - FItems := Items; - FSubItems := TStringList.Create; - TStringList(FSubItems).OnChange := @SubItemsChanged; -end; - -destructor TfpgLVItem.Destroy; -begin - FSubItems.Free; - inherited Destroy; -end; - -{ TfpgListView } - - -procedure TfpgListView.SetShowHeaders(const AValue: Boolean); -begin - if FShowHeaders=AValue then - Exit; - FShowHeaders:=AValue; - DoRePaint; -end; - - -procedure TfpgListView.VScrollChange(Sender: TObject; Position: Integer); -begin - DoRepaint; -end; - -procedure TfpgListView.HScrollChange(Sender: TObject; Position: Integer); -begin - DoRepaint; -end; - -procedure TfpgListView.SetItems(const AValue: TfpgLVItems); -begin - if AValue = FItems then - Exit; - AValue.AddViewer(Self); - FItems.DeleteViewer(Self); - Fitems := AValue; -end; - -procedure TfpgListView.SetMultiSelect(const AValue: Boolean); -begin - if FMultiSelect=AValue then - Exit; - FMultiSelect:=AValue; -end; - -procedure TfpgListView.SetOnColumnClick(const AValue: TfpgLVColumnClickEvent); -begin - if FOnColumnClick=AValue then - Exit; - FOnColumnClick:=AValue; -end; - -function TfpgListView.GetItemHeight: Integer; -begin - Result := Canvas.Font.Height + 4; -end; - -procedure TfpgListView.SetItemIndex(const AValue: Integer); -begin - if FItemIndex=AValue then - Exit; - if (AValue >= -1) and (AValue < FItems.Count) then - FItemIndex:=AValue; -end; - -procedure TfpgListView.ItemDeleted(AIndex: Integer); -begin - if FUpdateCount = 0 then - DoRePaint; -end; - -procedure TfpgListView.ItemAdded(AIndex: Integer); -begin - if FUpdateCount = 0 then - DoRePaint; -end; - -procedure TfpgListView.ItemChanged(AIndex: Integer); -begin - if FUpdateCount = 0 then - DoRePaint; -end; - -procedure TfpgListView.ItemsUpdated; -begin - DoRepaint; -end; - -function TfpgListView.GetClientRect: TfpgRect; -begin - Result.Top := 2; - Result.Left := 2; - Result.SetRight(Width - 2); - Result.SetBottom(Height - 2); -end; - -function TfpgListView.GetVisibleColumnsWidth: Integer; -var - I: Integer; -begin - Result := 0; - for I := 0 to FColumns.Count-1 do - if FColumns.Column[I].Visible then - Inc(Result, FColumns.Column[I].Width); -end; - -function TfpgListView.GetItemAreaHeight: Integer; -begin - Result := Height - 4; - if ShowHeaders then - Dec(Result, HeaderHeight); - if FHScrollBar.Visible then - Dec(Result,FHScrollBar.Height); -end; - -procedure TfpgListView.StartShiftSelection; -var - I: Integer; -begin - Inc(FShiftCount); - if FItems.Count = 0 then - Exit; - if FShiftCount> 1 then - Exit; - FSelectionShiftStart := FItemIndex; - if FSelectionShiftStart = -1 then - Inc(FSelectionShiftStart); - FOldSelected.Clear; - FOldSelected.Capacity := FSelected.Capacity; - for I := 0 to FSelected.Count-1 do - begin - FOldSelected.Add(FSelected.Items[I]); - end; -end; - -procedure TfpgListView.EndShiftSelection; -begin - Dec(FShiftCount); - if FShiftCount > 0 then - Exit; - FSelectionShiftStart := -1; - FOldSelected.Clear; -end; - -procedure TfpgListView.SelectionSetRangeEnabled(AStart, AEnd: Integer; AValue: Boolean); -var - TmpI: LongInt; - I: LongInt; - ShouldShow: Boolean; -begin - if AStart > AEnd then - begin - TmpI := AStart; - AStart := AEnd; - AEnd := TmpI; - end; - FSelected.Clear; - FSelected.Capacity := FOldSelected.Capacity; - for I := 0 to FOldSelected.Count-1 do - begin - FSelected.Add(FOldSelected.Items[I]); - end; - if (AStart < 0) or (AEnd > FItems.Count-1) then - Exit; - for I := AStart to AEnd do - begin - ShouldShow := AValue; - if FOldSelected.IndexOf(FItems.Item[I]) > -1 then - ShouldShow := not AValue; - - if I <> FSelectionShiftStart then - ItemSetSelected(FItems.Item[I], ShouldShow); - end; -end; - -procedure TfpgListView.SelectionToggleRange(AStart, AEnd: Integer; - const ShiftState: TShiftState; IgnoreStartIndex: Boolean); -var - TmpI: Integer; - I: LongInt; -begin - TmpI := AStart; - if AStart > AEnd then - begin - AStart := AEnd; - AEnd := TmpI; - end; - if not FMultiSelect then - begin - SelectionClear; - ItemSetSelected(FItems.Item[TmpI], True); - Exit; - end; - if ssShift in ShiftState then - for I := AStart to AEnd do - begin - if not(IgnoreStartIndex and (I = TmpI)) - then ItemSetSelected(FItems.Item[I], not ItemGetSelected(FItems.Item[I])); - end; -end; - -procedure TfpgListView.SelectionClear; -var - Item: TfpgLVItem; - I: Integer; -begin - for I := FSelected.Count-1 downto 0 do - begin - Item := TfpgLVItem(FSelected.Items[I]); - FSelected.Delete(I); - if Assigned(FOnSelectionChanged) then - FOnSelectionChanged(Self, Item, Items.IndexOf(Item), False); - end; - -end; - - -function TfpgListView.ItemGetSelected(const AItem: TfpgLVItem): Boolean; -begin - Result := FSelected.IndexOf(AItem) > -1; -end; - -procedure TfpgListView.ItemSetSelected(const AItem: TfpgLVItem; const AValue: Boolean); -var - Index: Integer; -begin - Index := FSelected.IndexOf(AItem); - - if AValue and (Index = -1) then - FSelected.Add(AItem); - if (AValue = False) and (Index <> -1) then - FSelected.Delete(Index); - if Assigned(FOnSelectionChanged) then - FOnSelectionChanged(Self, AItem, Items.IndexOf(AItem), AValue); -end; - -function TfpgListView.ItemGetFromPoint(const X, Y: Integer): TfpgLVItem; -var - Index: Integer; - ItemTop: Integer; -begin - Result := nil; - ItemTop := (FVScrollBar.Position + Y) -2; - if ShowHeaders then - Dec(ItemTop, HeaderHeight); - Index := ItemTop div ItemHeight; - if Index < 0 then - Exit; - if Index >= FItems.Count then - Exit; - if FHScrollBar.Position - 2 + X > GetVisibleColumnsWidth then - Exit; - - Result := FItems.Item[Index]; -end; - -function TfpgListView.ItemGetRect(AIndex: Integer): TfpgRect; -begin - Result.Top := 2 + (AIndex * ItemHeight) - FVScrollBar.Position; - if ShowHeaders then - Inc(Result.Top, HeaderHeight); - Result.Height := ItemHeight; - Result.Left := 2 - FHScrollBar.Position; - Result.Width := GetVisibleColumnsWidth; -end; - -function TfpgListView.ItemIndexFromY(Y: Integer): Integer; -var - TopPos: Integer; -begin - if ShowHeaders and (Y < HeaderHeight) then - Exit(-1); - - TopPos := (FVScrollBar.Position + Y) - 2; - if ShowHeaders then - Dec(TopPos, HeaderHeight); - Result := TopPos div ItemHeight; - if Result > Fitems.Count-1 then - Result := -1; -end; - -function TfpgListView.HeaderHeight: Integer; -begin - Result := Canvas.Font.Height + 10; -end; - -procedure TfpgListView.DoRepaint; -begin - if FUpdateCount = 0 then - RePaint; -end; - -procedure TfpgListView.DoColumnClick(Column: TfpgLVColumn; Button: Integer); -begin - if not Column.Clickable then - Exit; - if Assigned(FOnColumnClick) then - FOnColumnClick(Self, Column, Button); - - Column.FDown := True; - - if FUpdateCount = 0 then - begin - Canvas.BeginDraw(False); - PaintHeaders; - Canvas.EndDraw;//(2,2, width-4, Height-4); - end; -end; - -procedure TfpgListView.HandleHeaderMouseMove(x, y: Integer; btnstate: word; - Shiftstate: TShiftState); -var - I: Integer; - curLeft: Integer; - curRight: Integer; - Column: TfpgLVColumn; - LastColumn: TfpgLVColumn; - HeaderX: Integer; // this is X from the headers point of view - NewMouseCursor: TMouseCursor; -begin - curLeft := 0; - - HeaderX := FHScrollBar.Position - 2 + X; - NewMouseCursor := MouseCursor; - LastColumn := nil; - for I := 0 to FColumns.Count-1 do - begin - Column := FColumns.Column[I]; - if not Column.Visible then - Continue; - curRight := curLeft + Column.Width-1; - if Column.Resizable or (Assigned(LastColumn) and LastColumn.Resizable) then - begin - if (FResizingColumn <> nil) and (FResizingColumn = Column) then - begin - FResizingColumn.Width := (x + FHScrollBar.Position)- curLeft; - DoRepaint; - Break; - end - else begin - if (HeaderX >= curLeft) and (HeaderX <= curRight) then // we are within this columns space - begin - if ((LastColumn <> nil) and (LastColumn.Resizable) and (HeaderX - curLeft < 5)) - or (Column.Resizable) and (curRight - HeaderX < 5) - then - begin - NewMouseCursor := mcSizeEW; - Break; - end; - end - else - NewMouseCursor := mcDefault; - end; - end; - LastColumn := Column; - Inc(curLeft, Column.Width); - end; - if not Assigned(FResizingColumn) and Assigned(LastColumn) and LastColumn.Resizable then - if (HeaderX - curLeft < 5) and (HeaderX - curLeft >= 0) then - NewMouseCursor := mcSizeEW; - - if FResizingColumn <> nil then - NewMouseCursor := mcSizeEW; - - if NewMouseCursor <> MouseCursor then - MouseCursor := NewMouseCursor; - -end; - -procedure TfpgListView.MsgPaint(var msg: TfpgMessageRec); -begin - // Optimises painting and prevents Begin[End]Draw and OnPaint event firing - // in not needed. - if FUpdateCount = 0 then - inherited MsgPaint(msg); -end; - -procedure TfpgListView.HandleMouseScroll(x, y: integer; - shiftstate: TShiftState; delta: smallint); -var - cRect: TfpgRect; -begin - cRect := GetClientRect; - if FShowHeaders then - Inc(cRect.Top, HeaderHeight); - if FHScrollBar.Visible then - Dec(cRect.Height, FHScrollBar.Height); - if FVScrollBar.Visible then - Dec(cRect.Width, FVScrollBar.Width); - - - if not PtInRect(cRect, Point(X,Y)) then - Exit; - - TfpgScrollbarFriend(FVScrollBar).HandleMouseScroll(x, y, shiftstate, delta); -end; - -procedure TfpgListView.HandleLMouseDown(x, y: integer; shiftstate: TShiftState); -var - Item: TfpgLVItem; - cRect: TfpgRect; - curLeft, curRight: Integer; - I: Integer; - Column: TfpgLVColumn; - LastColumn: TfpgLVColumn; - HeaderX: Integer; -begin - inherited HandleLMouseDown(x, y, shiftstate); - - cRect := GetClientRect; - - FMouseDownPoint := Point(X,Y); - - if not PtInRect(cRect, Point(X,Y)) then - Exit; - - if FShowHeaders then - begin - if (Y < HeaderHeight + cRect.Top) then - begin - LastColumn := nil; - HeaderX := FHScrollBar.Position - 2 + x; - - curLeft := 0; - for I := 0 to FColumns.Count-1 do - begin - Column := FColumns.Column[I]; - if Column.Visible then - begin - curRight := curLeft + Column.Width-1; - if (HeaderX <= curRight) and (HeaderX >= curLeft) then - begin - if (MouseCursor = mcSizeEW) then - begin - if Column.Resizable and (curRight - HeaderX < 5) then - FResizingColumn := Column - else - if Assigned(LastColumn) and LastColumn.Resizable and (HeaderX - curLeft < 5) then - FResizingColumn := LastColumn - end - else // only perform a mouse click if we aren't resizing - DoColumnClick(Column, 1); - end; - Inc(curLeft, Column.Width); - end; - LastColumn := Column; - end; - if not Assigned(FResizingColumn) and Assigned(LastColumn) and LastColumn.Resizable then - if (HeaderX - curLeft < 5) and (HeaderX - curLeft >= 0) then - FResizingColumn := LastColumn; - end; - - Inc(cRect.Top, HeaderHeight); - end; - - if FHScrollBar.Visible then - Dec(cRect.Height, FHScrollBar.Height); - if FVScrollBar.Visible then - Dec(cRect.Width, FVScrollBar.Width); - - if not PtInRect(cRect, Point(X,Y)) then - Exit; - - Item := ItemGetFromPoint(X, Y); - if not FMultiSelect then - SelectionClear; - if Item <> nil then - begin - FItemIndex := ItemIndexFromY(Y); - MakeItemVisible(FItemIndex); - if FMultiSelect then - begin - if not ((ssCtrl in shiftstate) or (ssShift in shiftstate)) then - begin - SelectionClear; - ItemSetSelected(Item, True); - end - else begin - if ssCtrl in shiftstate then - ItemSetSelected(Item, not ItemGetSelected(Item)); - if ssShift in shiftstate then - SelectionSetRangeEnabled(FSelectionShiftStart, FItemIndex, True); - end - end - else ItemSetSelected(Item, True); - end; - DoRepaint; -end; - -procedure TfpgListView.HandleRMouseDown(x, y: integer; shiftstate: TShiftState); -var - I: Integer; - cLeft, cRight: Integer; - cRect: TfpgRect; - Column: TfpgLVColumn; -begin - inherited HandleRMouseDown(x, y, shiftstate); - - cRect := GetClientRect; - - if not PtInRect(cRect, Point(X,Y)) then - Exit; - - if FShowHeaders then - begin - if (Y < HeaderHeight + cRect.Top) then - begin - cLeft := cRect.Left - FHScrollBar.Position; - for I := 0 to FColumns.Count-1 do - begin - Column := FColumns.Column[I]; - if Column.Visible then - begin - cRight := cLeft + Column.Width-1; - if (X <= cRight) and (X >= cLeft) then - DoColumnClick(Column, 3); - Inc(cLeft, Column.Width); - end; - end; - end; - Inc(cRect.Top, HeaderHeight); - end; - - if FVScrollBar.Visible then - Dec(cRect.Width, FVScrollBar.Width); - if FHScrollBar.Visible then - Dec(cRect.Height, FHScrollBar.Height); -end; - -procedure TfpgListView.HandleLMouseUp(x, y: integer; shiftstate: TShiftState); -var - I: Integer; -begin - inherited HandleLMouseUp(x, y, shiftstate); - for I := 0 to FColumns.Count-1 do - begin - FColumns.Column[I].FDown := False; - end; - - FResizingColumn := nil; - DoRepaint; -end; - -procedure TfpgListView.HandleRMouseUp(x, y: integer; shiftstate: TShiftState); -var - I: Integer; -begin - inherited HandleRMouseUp(x, y, shiftstate); - for I := 0 to FColumns.Count-1 do - begin - FColumns.Column[I].FDown := False; - end; - DoRepaint; -end; - -procedure TfpgListView.HandleMouseMove(x, y: integer; btnstate: word; - shiftstate: TShiftState); -var - cRect: TfpgRect; -begin - inherited HandleMouseMove(x, y, btnstate, shiftstate); - - cRect := GetClientRect; - - if not PtInRect(cRect, Point(X,Y)) and (FResizingColumn = nil) then - Exit; - - if ((Y < (cRect.Top + HeaderHeight)) and ShowHeaders) or (FResizingColumn <> nil) then - begin - HandleHeaderMouseMove(x, y, btnstate, shiftstate); - end - else - if (MouseCursor <> mcDefault) and (FResizingColumn = nil) then - MouseCursor := mcDefault; - - //if FVScrollBar.Visible then Dec(cRect.Width, FVScrollBar.Width); - //if FHScrollBar.Visible then Dec(cRect.Height, FHScrollBar.Height); -end; - -procedure TfpgListView.HandleKeyPress(var keycode: word; - var shiftstate: TShiftState; var consumed: boolean); -var - iIndex: Integer; - OldIndex: Integer; - procedure CheckMultiSelect; - begin - if FMultiSelect then begin - if (ssShift in shiftstate) or (FSelectionShiftStart > -1) then - begin - SelectionSetRangeEnabled(FSelectionShiftStart, FItemIndex, True); - end - else if ssCtrl in shiftstate then - begin - SelectionToggleRange(FItemIndex, FItemIndex, shiftstate, False); - end; - end; - end; - procedure CheckSelectionFocus; - begin - if ((ssShift in shiftstate) or (ssCtrl in shiftstate)) then - Exit; - SelectionClear; - if FSelectionFollowsFocus and (FItemIndex > -1) then - ItemSetSelected(FItems.Item[FItemIndex], True); - end; -begin - consumed := True; - OldIndex := FItemIndex; - //WriteLn('Got key: ',IntToHex(keycode, 4)); - case keycode of - keyShift, keyShiftR: - begin - if FMultiSelect then - StartShiftSelection; - end; - keyUp: - begin - if ItemIndex > 0 then - ItemIndex := ItemIndex-1; - MakeItemVisible(ItemIndex); - if OldIndex <> ItemIndex then - CheckSelectionFocus; - CheckMultiSelect; - end; - keyDown: - begin - ItemIndex := ItemIndex+1; - MakeItemVisible(ItemIndex); - if OldIndex <> ItemIndex then - CheckSelectionFocus; - CheckMultiSelect; - end; - keyLeft: - begin - FHScrollBar.Position := FHScrollBar.Position - FHScrollBar.ScrollStep; - end; - keyRight: - begin - FHScrollBar.Position := FHScrollBar.Position + FHScrollBar.ScrollStep; - end; - keyHome: - begin - ItemIndex := 0; - MakeItemVisible(ItemIndex); - if OldIndex <> ItemIndex then - CheckSelectionFocus; - CheckMultiSelect; - end; - keyEnd: - begin - ItemIndex := FItems.Count-1; - MakeItemVisible(ItemIndex); - if OldIndex <> ItemIndex then - CheckSelectionFocus; - CheckMultiSelect; - end; - keyPageUp: - begin - iIndex := ItemIndex - (GetItemAreaHeight div ItemHeight); - if iIndex < 0 then - iIndex := 0; - ItemIndex := iIndex; - MakeItemVisible(ItemIndex); - if OldIndex <> ItemIndex then - CheckSelectionFocus; - CheckMultiSelect; - end; - keyPageDown: - begin - iIndex := ItemIndex + (GetItemAreaHeight div ItemHeight); - if iIndex > FItems.Count-1 then - iIndex := FItems.Count-1; - ItemIndex := iIndex; - MakeItemVisible(ItemIndex); - if OldIndex <> ItemIndex then - CheckSelectionFocus; - CheckMultiSelect - end; - else - consumed := False; - inherited HandleKeyPress(keycode, shiftstate, consumed); - Exit; - end; - DoRepaint; - -end; - -procedure TfpgListView.HandleKeyRelease(var keycode: word; - var shiftstate: TShiftState; var consumed: boolean); -begin - consumed := True; - case keycode of - keyShift, keyShiftR: - begin - EndShiftSelection; - end; - else - consumed := False; - inherited HandleKeyRelease(keycode, shiftstate, consumed); - end; - -end; - -procedure TfpgListView.HandlePaint; -var - ClipRect: TfpgRect; -begin - //if FScrollBarNeedsUpdate then - UpdateScrollBarPositions; - fpgStyle.DrawControlFrame(Canvas, 0, 0, Width, Height); - - ClipRect.Top := 2; - ClipRect.Left := 2; - ClipRect.Width := Width -4; - ClipRect.Height := Height -4; - - if ShowHeaders then - begin - PaintHeaders; - Inc(ClipRect.Top, HeaderHeight); - Dec(ClipRect.Height, HeaderHeight); - end; - - Canvas.SetClipRect(ClipRect); - - // this paints the small square remaining below the vscrollbar and to the right of the hscrollbar - if FVScrollBar.Visible and FHScrollBar.Visible then - begin - Canvas.Color := clButtonFace; - Canvas.FillRectangle(Width - 2 - FVScrollBar.Width, - Height - 2 - FHScrollBar.Height, - Width - 2, - Height - 2); - end; - - if FVScrollBar.Visible then - Dec(ClipRect.Width, FVScrollBar.Width); - if FHScrollBar.Visible then - Dec(ClipRect.Height, FhScrollBar.Height); - - Canvas.SetClipRect(ClipRect); - PaintItems; -end; - -procedure TfpgListView.HandleResize(awidth, aheight: TfpgCoord); -begin - inherited HandleResize(awidth, aheight); - FScrollBarNeedsUpdate := FScrollBarNeedsUpdate or FSizeIsDirty; -end; - -procedure TfpgListView.PaintHeaders; -var - I: Integer; - cLeft, - cTop: Integer; - Column: TfpgLVColumn; - Flags: TFButtonFlags; - ClipRect: TfpgRect; - cRect: TfpgRect; - PaintPart: TfpgLVItemPaintPart; - tWidth, - tLeft: Integer; -begin - cLeft := 2; - ClipRect.Top := 2; - ClipRect.Left := 2; - ClipRect.Height := HeaderHeight; - ClipRect.Width := Width -4; - Canvas.SetClipRect(ClipRect); - - if FHScrollBar.Visible then Dec(cLeft, FHScrollBar.Position); - cTop := 2; - for I := 0 to Columns.Count-1 do - begin - Column := Columns.Column[I]; - if Column.Visible then - begin - Flags := [btfIsEmbedded]; - if Column.FDown then Flags := Flags + [btfIsPressed]; - cRect.Top := cTop; - cRect.Left := cLeft; - cRect.Width := Column.Width; - cRect.Height := HeaderHeight; - fpgStyle.DrawButtonFace(Canvas,cLeft, cRect.Top, cRect.Width, cRect.Height, Flags); - PaintPart := [lvppText]; - - if Assigned(FOnPaintColumn) then - FOnPaintColumn(Self, Canvas, Column, I, cRect, PaintPart); - - if lvppText in PaintPart then - begin - tLeft := cLeft; - tWidth := Canvas.Font.TextWidth(Column.Caption); - case Column.CaptionAlignment of - taRightJustify: Inc(tLeft, Column.Width - tWidth - 5); - taCenter: Inc(tLeft, (Column.Width - tWidth - 5) div 2); - taLeftJustify: Inc(tLeft, 5); - end; - fpgStyle.DrawString(Canvas, tLeft, cTop+5, Column.Caption, Enabled); - end; - Inc(cLeft, Column.Width); - end; - end; - if cLeft < FWidth-2 then - begin - Canvas.SetColor(clButtonFace); - Canvas.FillRectangle(cLeft, cTop, cLeft+(Width-3-cLeft), Canvas.Font.Height+10); - end; -end; - -procedure TfpgListView.PaintItems; -var - FirstIndex, - LastIndex: Integer; - I, J : Integer; - PaintPart: TfpgLVItemPaintPart; - ItemRect: TfpgRect; - ItemState: TfpgLVItemState; - Item: TfpgLVItem; - TheText: String; - TheTextColor: TfpgColor; - oClipRect: TfpgRect; - iColumnClipRect: TfpgRect; - ColumnIndex: Integer; - cBottom: Integer; - vBottom: Integer; - tLeft, - tWidth: Integer; -begin - FirstIndex := (FVScrollBar.Position) div ItemHeight; - LastIndex := (FVScrollBar.Position+GetItemAreaHeight) div ItemHeight; - - if LastIndex > FItems.Count-1 then - LastIndex := FItems.Count-1; - - cBottom := 2 + ((LastIndex+1 - FirstIndex) * ItemHeight); - - if ShowHeaders then - Inc(cBottom, HeaderHeight); - - oClipRect := Canvas.GetClipRect; - - for I := FirstIndex to LastIndex do - begin - ItemState := []; - PaintPart := [lvppBackground, lvppIcon, lvppText]; - ItemRect := ItemGetRect(I); - - if (I = FirstIndex) - and (ShowHeaders) - and (ItemRect.Top < 2 + HeaderHeight) then - Dec(cBottom, (2 + HeaderHeight) - ItemRect.Top); - - Item := FItems.Item[I]; - if Item.Selected[Self] then - Include(ItemState, lisSelected); - if FItemIndex = I then - begin - Include(ItemState, lisFocused); - Include(PaintPart, lvppFocused); - end; - - if lisSelected in (ItemState) then - begin - if Focused then - Canvas.Color := clSelection - else - Canvas.Color := clInactiveSel; - end - else Canvas.Color := clListBox; - - Canvas.FillRectangle(ItemRect); - Exclude(PaintPart, lvppBackground); - TheTextColor := Canvas.TextColor; - if Assigned(FOnPaintItem) then - FOnPaintItem(Self, Canvas, Item, I, ItemRect, PaintPart); - - if lvppIcon in PaintPart then - begin - { TODO: paint icon } - end; - - if lvppFocused in PaintPart then - begin - Canvas.Color := clBlack; - Canvas.SetLineStyle(1, lsDot); - Canvas.DrawRectangle(ItemRect); - end; - - if lvppText in PaintPart then - begin - if lisSelected in ItemState then - Canvas.TextColor := clSelectionText; - for J := 0 to FColumns.Count-1 do - begin - if FColumns.Column[J].Visible then - begin - iColumnClipRect.Left := Max(ItemRect.Left, oClipRect.Left); - iColumnClipRect.Top := Max(ItemRect.Top, oClipRect.Top); - iColumnClipRect.SetRight(Min(ItemRect.Left+FColumns.Column[J].Width, oClipRect.Right)); - iColumnClipRect.SetBottom(Min(ItemRect.Bottom, oClipRect.Bottom)); - Canvas.SetClipRect(iColumnClipRect); - if FColumns.Column[J].ColumnIndex <> -1 then - ColumnIndex := FColumns.Column[J].ColumnIndex - else - ColumnIndex := J; - if ColumnIndex = 0 then - TheText := Item.Caption - else if Item.SubItems.Count >= ColumnIndex then - TheText := Item.SubItems.Strings[ColumnIndex-1] - else - TheText := ''; - - tLeft := ItemRect.Left; - tWidth := Canvas.Font.TextWidth(TheText); - case FColumns.Column[J].Alignment of - taRightJustify: Inc(tLeft, FColumns.Column[J].Width - tWidth - 5); - taCenter: Inc(tLeft, (FColumns.Column[J].Width - tWidth - 5) div 2); - taLeftJustify: Inc(tLeft, 5); - end; - - fpgStyle.DrawString(Canvas, tLeft, ItemRect.Top+2, TheText, Enabled); - Inc(ItemRect.Left, FColumns.Column[J].Width); - //WriteLn(ItemRect.Left,' ', ItemRect.Top, ' ', ItemRect.Right, ' ', ItemRect.Bottom); - end; - end; - end; - - Canvas.SetClipRect(oClipRect); - - Canvas.TextColor := TheTextColor; - end; - - vBottom := Height - 2; - if FHScrollBar.Visible then - Dec(vBottom, FHScrollBar.Height); - - // the painted items haven't fully covered the visible area - if vBottom > cBottom then begin - ItemRect.Left := 2; - ItemRect.Top := cBottom; - ItemRect.SetBottom(vBottom); - ItemRect.Width := Width - 4; - Canvas.SetColor(clListBox); - Canvas.FillRectangle(ItemRect); - end; - if GetVisibleColumnsWidth < oClipRect.Width then - begin - ItemRect.Left := GetVisibleColumnsWidth+2; - ItemRect.SetRight(oClipRect.Right); - ItemRect.Top := oClipRect.Top; - ItemRect.Height := oClipRect.Height; - Canvas.SetColor(clListBox); - Canvas.FillRectangle(ItemRect); - end; -end; - -procedure TfpgListView.UpdateScrollBarPositions; -var - BevelSize: Integer; - I: Integer; - MaxH, - MaxV: Integer; -begin - MaxH := 0; - MaxV := 0; - BevelSize := 2; - - for I := 0 to Columns.Count -1 do - begin - if Columns.Column[I].Visible then - Inc(MaxH, Columns.Column[I].Width); - end; - - MaxV := (FItems.Count+2) * ItemHeight - (Height); - if ShowHeaders then - Inc(MaxV, HeaderHeight); - if FVScrollBar.Visible then - Inc(MaxH, FVScrollBar.Width); - - FHScrollBar.Top := Height - FHScrollBar.Height - (BevelSize ); - FHScrollBar.Left := BevelSize; - FHScrollBar.Width := Width - (BevelSize * 2); - - - FVScrollBar.Top := BevelSize; - FVScrollBar.Left := Width - FVScrollBar.Width - (BevelSize ); - FVScrollBar.Height := Height - FVScrollBar.Top - BevelSize; - - if FVScrollBar.Visible and FHScrollBar.Visible then - begin - FHScrollBar.Width := FHScrollBar.Width - FVScrollBar.Width; - FVScrollBar.Height := FVScrollBar.Height - FHScrollBar.Height; - end; - - FHScrollBar.Max := MaxH-(Width-(BevelSize * 2)); - FVScrollBar.Max := MaxV; - - if FVScrollBar.Max = 0 then - FVScrollBar.SliderSize := 1 - else - begin - if (FVScrollBar.Max + FVScrollBar.Height) > 0 then - FVScrollBar.SliderSize := FVScrollBar.Height / (FVScrollBar.Max + FVScrollBar.Height) - else - FVScrollBar.SliderSize := 0.5; - end; - FVScrollBar.RepaintSlider; - - if FHScrollBar.Max = 0 then - FHScrollBar.SliderSize := 1 - else - begin - if (FHScrollBar.Max + FHScrollBar.Width) > 0 then - FHScrollBar.SliderSize := FHScrollBar.Width / (FHScrollBar.Max + FHScrollBar.Width) - else - FHScrollBar.SliderSize := 0.5; - end; - FHScrollBar.RepaintSlider; - - - if FHScrollBar.Visible then - FHScrollBar.UpdateWindowPosition; - if FVScrollBar.Visible then - FVScrollBar.UpdateWindowPosition; - - FScrollBarNeedsUpdate := False; -end; - -constructor TfpgListView.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - FWidth := 120; - FHeight := 80; - Focusable := True; - FShowHeaders := True; - - FVScrollBar := TfpgScrollBar.Create(Self); - FVScrollBar.Orientation := orVertical; - FVScrollBar.OnScroll := @VScrollChange; - FVScrollBar.ScrollStep := 18; - FVScrollBar.Position := 0; - - FHScrollBar := TfpgScrollBar.Create(Self); - FHScrollBar.Orientation := orHorizontal; - FHScrollBar.OnScroll := @HScrollChange; - FHScrollBar.ScrollStep := 18; - FHScrollBar.Position := 0; - - FColumns := TfpgLVColumns.Create(Self); - - FItems := TfpgLVItems.Create(Self); - FSelected := TList.Create; - FOldSelected := TList.Create;; - FSelectionShiftStart := -1; - FSelectionFollowsFocus := True; - FItemIndex := -1; - FScrollBarNeedsUpdate := True; -end; - -destructor TfpgListView.Destroy; -begin - FItems.DeleteViewer(Self); - FSelected.Free; - FOldSelected.Free; - inherited Destroy; -end; - -procedure TfpgListView.BeginUpdate; -begin - Inc(FUpdateCount); - FItems.BeginUpdate; -end; - -procedure TfpgListView.EndUpdate; -begin - FItems.EndUpdate; - Dec(FUpdateCount); - if FUpdateCount < 0 then - FUpdateCount := 0; - if FUpdateCount = 0 then - DoRePaint; -end; - -procedure TfpgListView.MakeItemVisible(AIndex: Integer; PartialOK: Boolean); -var - iTop, - iBottom: integer; - tVisible, bVisible: Boolean; -begin - if AIndex = -1 then - Exit; - iTop := AIndex * ItemHeight; - iBottom := iTop + ItemHeight; - - tVisible := (iTop >= FVScrollBar.Position) and (iTop < FVScrollBar.Position + GetItemAreaHeight); - bVisible := (iBottom >= FVScrollBar.Position) and (iBottom < FVScrollBar.Position + GetItemAreaHeight); - - if PartialOK and (bVisible or tVisible) then - Exit; - - if bVisible and tVisible then - Exit; - - if (iBottom >= FVScrollBar.Position + GetItemAreaHeight) then - FVScrollBar.Position := iBottom - GetItemAreaHeight - else - FVScrollBar.Position := iTop; -end; - -function TfpgListView.ItemAdd: TfpgLVItem; -begin - Result := TfpgLVItem.Create(FItems); - FItems.Add(Result); -end; - -{ TfpgLVColumns } - -function TfpgLVColumns.GetColumn(AIndex: Integer): TfpgLVColumn; -begin - Result := TfpgLVColumn(FColumns.Items[AIndex]); -end; - -procedure TfpgLVColumns.SetColumn(AIndex: Integer; const AValue: TfpgLVColumn); -begin - FColumns.Items[AIndex] := AValue; -end; - -constructor TfpgLVColumns.Create(AListView: TfpgListView); -begin - FListView := AListView; - FColumns := TList.Create; -end; - -destructor TfpgLVColumns.Destroy; -begin - FColumns.Free; - inherited Destroy; -end; - -function TfpgLVColumns.Add(AColumn: TfpgLVColumn): Integer; -begin - Result := Count; - Insert(AColumn, Count); -end; - -procedure TfpgLVColumns.Clear; -var - i: integer; -begin - for i := FColumns.Count-1 downto 0 do - Delete(i); - FColumns.Clear; -end; - -procedure TfpgLVColumns.Delete(AIndex: Integer); -begin - FColumns.Delete(AIndex); -end; - -procedure TfpgLVColumns.Insert(AColumn: TfpgLVColumn; AIndex: Integer); -begin - FColumns.Insert(AIndex, AColumn); -end; - -function TfpgLVColumns.Count: Integer; -begin - Result := FColumns.Count; -end; - -{ TfpgLVColumn } - -procedure TfpgLVColumn.SetCaption(const AValue: String); -begin - if FCaption=AValue then - Exit; - FCaption:=AValue; -end; - -procedure TfpgLVColumn.SetCaptionAlignment(const AValue: TAlignment); -begin - if FCaptionAlignment=AValue then exit; - FCaptionAlignment:=AValue; - if Assigned(FColumns) and Assigned(FColumns.FListView) then - FColumns.FListView.DoRepaint; - -end; - -procedure TfpgLVColumn.SetColumnIndex(const AValue: Integer); -begin - if FColumnIndex=AValue then - Exit; - FColumnIndex:=AValue; -end; - -procedure TfpgLVColumn.SetHeight(const AValue: Integer); -begin - if FHeight=AValue then Exit; - FHeight:=AValue; -end; - -procedure TfpgLVColumn.SetResizable(const AValue: Boolean); -begin - if FResizable=AValue then exit; - FResizable:=AValue; -end; - -procedure TfpgLVColumn.SetVisible(const AValue: Boolean); -begin - if FVisible=AValue then exit; - FVisible:=AValue; -end; - -procedure TfpgLVColumn.SetAutoSize(const AValue: Boolean); -begin - if FAutoSize=AValue then exit; - FAutoSize:=AValue; -end; - -procedure TfpgLVColumn.SetAlignment(const AValue: TAlignment); -begin - if FAlignment=AValue then exit; - FAlignment:=AValue; - if Assigned(FColumns)and Assigned(FColumns.FListView) then - FColumns.FListView.DoRepaint; -end; - -procedure TfpgLVColumn.SetWidth(const AValue: Integer); -begin - if FWidth=AValue then exit; - FWidth:=AValue; - if FWidth < 1 then - FWidth := 1; -end; - -constructor TfpgLVColumn.Create(AColumns: TfpgLVColumns); -begin - FVisible := True; - FColumnIndex := -1; - FColumns := AColumns; - FClickable := True; - FAlignment := taLeftJustify; - FCaptionAlignment := taLeftJustify; -end; - -destructor TfpgLVColumn.Destroy; -begin - inherited Destroy; -end; - -end. diff --git a/src/gui/gui_memo.pas b/src/gui/gui_memo.pas deleted file mode 100644 index b9780779..00000000 --- a/src/gui/gui_memo.pas +++ /dev/null @@ -1,1459 +0,0 @@ -{ - fpGUI - Free Pascal GUI Toolkit - - Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this - distribution, for details of the copyright. - - See the file COPYING.modifiedLGPL, included in this distribution, - for details about redistributing fpGUI. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - - Description: - Defines a Memo control. Also known as a multi-line text edit control. -} - -unit gui_memo; - -{$mode objfpc}{$H+} - - { TODO : Started a implementation for Tab support. It is still very experimental and should not be used yet. } - -interface - -uses - Classes, - SysUtils, - fpg_base, - fpg_main, - fpg_widget, - gui_scrollbar, - gui_menu; - -type - - TfpgMemo = class(TfpgWidget) - private - FLines: TStringList; - FMaxLength: integer; - FCursorPos: integer; - FCursorLine: integer; - FOnChange: TNotifyEvent; - FSideMargin: integer; - FSelStartLine: integer; - FSelEndLine: integer; - FSelStartPos: integer; - FSelEndPos: integer; - FSelecting: boolean; - FMouseDragging: boolean; - FMouseDragPos: integer; - FFont: TfpgFont; - FDrawOffset: integer; - FLineHeight: integer; - FFirstLine: integer; - FTabWidth: integer; - FUseTabs: boolean; - FVScrollBar: TfpgScrollBar; - FHScrollBar: TfpgScrollBar; - FWrapping: boolean; - FLongestLineWidth: TfpgCoord; - FPopupMenu: TfpgPopupMenu; - function GetFontDesc: string; - procedure SetFontDesc(const AValue: string); - procedure RecalcLongestLine; - procedure DeleteSelection; - procedure DoCopy; - procedure DoPaste; - procedure AdjustCursor; - function LineCount: integer; - function GetLineText(linenum: integer): string; - procedure SetLineText(linenum: integer; Value: string); - function GetCursorX: integer; - procedure SetCPByX(x: integer); - function CurrentLine: string; - function VisibleLines: integer; - function VisibleWidth: integer; - procedure VScrollBarMove(Sender: TObject; position: integer); - procedure HScrollBarMove(Sender: TObject; position: integer); - procedure SetText(const AValue: TfpgString); - function GetText: TfpgString; - procedure SetCursorLine(aValue: integer); - procedure UpdateScrollBarCoords; - protected - procedure HandleKeyChar(var AText: TfpgChar; var shiftstate: TShiftState; var consumed: boolean); override; - procedure HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override; - procedure HandleLMouseDown(x, y: integer; shiftstate: TShiftState); override; - procedure HandleRMouseUp(x, y: integer; shiftstate: TShiftState); override; - procedure HandleMouseMove(x, y: integer; btnstate: word; shiftstate: TShiftState); override; - procedure HandleResize(dwidth, dheight: integer); override; - procedure HandleMouseScroll(x, y: integer; shiftstate: TShiftState; delta: smallint); override; - procedure HandlePaint; override; - procedure HandleShow; override; - procedure HandleMouseEnter; override; - procedure HandleMouseExit; override; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - procedure UpdateScrollBars; - function SelectionText: string; - property CursorLine: integer read FCursorLine write SetCursorLine; - property Font: TfpgFont read FFont; - property LineHeight: integer read FLineHeight; - property MaxLength: integer read FMaxLength write FMaxLength; - property TabWidth: integer read FTabWidth write FTabWidth; - property Text: TfpgString read GetText write SetText; - property UseTabs: boolean read FUseTabs write FUseTabs default False; - property PopupMenu: TfpgPopupMenu read FPopupMenu write FPopupMenu; - published - property BackgroundColor default clBoxColor; - property FontDesc: string read GetFontDesc write SetFontDesc; - property Lines: TStringList read FLines; - property ParentShowHint; - property ShowHint; - property TabOrder; - property TextColor; - property OnChange: TNotifyEvent read FOnChange write FOnChange; - property OnEnter; - property OnExit; - property OnKeyPress; - end; - - -function CreateMemo(AOwner: TComponent; x, y, w, h: TfpgCoord): TfpgMemo; - - -implementation - -uses - fpg_stringutils; - -type - // custom stringlist that will notify the memo of item changes - TfpgMemoStrings = class(TStringList) - protected - Memo: TfpgMemo; - procedure RefreshMemo; - public - constructor Create(AMemo: TfpgMemo); reintroduce; - destructor Destroy; override; - function Add(const s: String): Integer; override; - procedure Clear; override; - procedure Delete(Index: Integer); override; - procedure Insert(Index: Integer; const S: string); override; - end; - -{ TfpgMemoStrings } - -procedure TfpgMemoStrings.RefreshMemo; -begin - if Assigned(Memo) and (Memo.HasHandle) then - begin - Memo.Invalidate; - Memo.UpdateScrollBars; - end; -end; - -constructor TfpgMemoStrings.Create(AMemo: TfpgMemo); -begin - inherited Create; - Memo := AMemo; -end; - -destructor TfpgMemoStrings.Destroy; -begin - Memo := nil; - inherited Destroy; -end; - -function TfpgMemoStrings.Add(const s: String): Integer; -begin - Result := inherited Add(s); - RefreshMemo; -end; - -procedure TfpgMemoStrings.Delete(Index: Integer); -begin -// writeln('Delete''s Index = ', Index); - inherited Delete(Index); - RefreshMemo; -end; - -procedure TfpgMemoStrings.Insert(Index: Integer; const S: string); -begin -// writeln('Insert''s Index = ', Index); - inherited Insert(Index, S); - RefreshMemo; -end; - -procedure TfpgMemoStrings.Clear; -begin - inherited Clear; - RefreshMemo; -end; - - -{ TfpgMemo } - - -function CreateMemo(AOwner: TComponent; x, y, w, h: TfpgCoord): TfpgMemo; -begin - Result := TfpgMemo.Create(AOwner); - Result.Left := x; - Result.Top := y; - Result.Width := w; - if h > 0 then - Result.Height := h; -end; - - -procedure TfpgMemo.SetCursorLine(aValue: integer); -var - i: integer; - MaxLine: integer; - yp: integer; -begin - if (aValue < 0) or (aValue = FCursorLine) then - Exit; // wrong value - if aValue < FFirstLine then - begin - FFirstLine := aValue; // moves the selected line to the top of the displayed rectangle - FCursorLine := aValue; - FCursorPos := 0; - RePaint; - Exit; - end; - yp := 2; - MaxLine := 0; - for i := FFirstLine to LineCount-1 do - begin - yp := yp + LineHeight; - if yp > Height then - begin - MaxLine := i - 1; - break; - end; - end; - if MaxLine < aValue then - begin - FFirstLine := aValue; - FCursorLine := aValue; - FCursorPos := 0; - RePaint; - Exit; - end - else - begin - FCursorLine := aValue; - FCursorPos := 0; - RePaint; - Exit; - end; -end; - -procedure TfpgMemo.UpdateScrollBarCoords; -var - HWidth: integer; - VHeight: integer; -begin - VHeight := Height - 4; - HWidth := Width - 4; - - if FVScrollBar.Visible then - Dec(HWidth, FVScrollBar.Width); - if FHScrollBar.Visible then - Dec(VHeight, FHScrollBar.Height); - - FHScrollBar.Top := Height -FHScrollBar.Height - 2; - FHScrollBar.Left := 2; - FHScrollBar.Width := HWidth; - - FVScrollBar.Top := 2; - FVScrollBar.Left := Width - FVScrollBar.Width - 2; - FVScrollBar.Height := VHeight; - - FVScrollBar.UpdateWindowPosition; - FHScrollBar.UpdateWindowPosition; -end; - -constructor TfpgMemo.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - Focusable := True; - FFont := fpgGetFont('#Edit1'); - FHeight := FFont.Height * 3 + 4; - FWidth := 120; - FLineHeight := FFont.Height + 2; - FSelecting := False; - FSideMargin := 3; - FMaxLength := 0; - FWrapping := False; - FOnChange := nil; - FTextColor := Parent.TextColor; - FBackgroundColor := clBoxColor; - FUseTabs := False; - FTabWidth := 4; - FMinWidth := 20; - FMinHeight := 30; - - FLines := TfpgMemoStrings.Create(self); - FFirstLine := 0; - FCursorLine := 0; - - FCursorPos := 0; - FSelStartPos := FCursorPos; - FSelEndPos := 0; - FSelStartLine := -1; - FSelEndLine := -1; - - FDrawOffset := 0; - FMouseDragging := False; - - FVScrollBar := TfpgScrollBar.Create(self); - FVScrollBar.Orientation := orVertical; - FVScrollBar.OnScroll := @VScrollBarMove; - FVScrollBar.Visible := False; - - FHScrollBar := TfpgScrollBar.Create(self); - FHScrollBar.Orientation := orHorizontal; - FHScrollBar.OnScroll := @HScrollBarMove; - FHScrollBar.ScrollStep := 5; - FHScrollBar.Visible := False; -end; - -destructor TfpgMemo.Destroy; -begin - TfpgMemoStrings(FLines).Free; - FFont.Free; - inherited Destroy; -end; - -procedure TfpgMemo.RecalcLongestLine; -var - n: integer; - lw: TfpgCoord; -begin - FLongestLineWidth := 0; - for n := 0 to LineCount-1 do - begin - lw := FFont.TextWidth(getlinetext(n)); - if lw > FlongestLineWidth then - FlongestLineWidth := lw; - end; -end; - -function TfpgMemo.GetFontDesc: string; -begin - Result := FFont.FontDesc; -end; - -procedure TfpgMemo.DeleteSelection; -var - n: integer; - selsl: integer; - selsp: integer; - selel: integer; - selep: integer; - ls: string; - len: integer; - st: integer; -begin - if FSelEndLine < 0 then - Exit; - - if (FSelStartLine shl 16) + FSelStartPos <= (FSelEndLine shl 16) + FSelEndPos then - begin - selsl := FSelStartLine; - selsp := FSelStartPos; - selel := FSelEndLine; - selep := FSelEndPos; - end - else - begin - selel := FSelStartLine; - selep := FSelStartPos; - selsl := FSelEndLine; - selsp := FSelEndPos; - end; - - for n := selsl to selel do - begin - ls := GetLineText(n); - - if selsl < n then - st := 0 - else - st := selsp; - if selel > n then - len := UTF8Length(ls) - else - len := selep - st; - - UTF8Delete(ls, st + 1, len); - SetLineText(n, ls); - end; - - if selsl < selel then - begin - ls := GetlineText(selsl); - ls := ls + GetLineText(selel); - SetLineText(selsl, ls); - end; - - for n := selsl to selel do - FLines.Delete(n); - - FCursorPos := selsp; - FCursorLine := selsl; - FSelEndLine := -1; -end; - -procedure TfpgMemo.DoCopy; -var - n: integer; - selsl: integer; - selsp: integer; - selel: integer; - selep: integer; - ls: string; - len: integer; - st: integer; - s: string; -begin - if FSelEndLine < 0 then - Exit; - - if (FSelStartLine shl 16) + FSelStartPos <= (FSelEndLine shl 16) + FSelEndPos then - begin - selsl := FSelStartLine; - selsp := FSelStartPos; - selel := FSelEndLine; - selep := FSelEndPos; - end - else - begin - selel := FSelStartLine; - selep := FSelStartPos; - selsl := FSelEndLine; - selsp := FSelEndPos; - end; - - s := ''; - - for n := selsl to selel do - begin - if n > selsl then - s := s + #13#10; - - ls := GetLineText(n); - - if selsl < n then - st := 0 - else - st := selsp; - - if selel > n then - len := UTF8Length(ls) - else - len := selep - st; - - s := s + UTF8Copy(ls, st + 1, len); - end; - - //SetClipboardText(s); -end; - -procedure TfpgMemo.DoPaste; -{ -var - s: string; - si: string; - si8: string; - lineend: string; - n: integer; - l: integer; - lcnt: integer; -} -begin - Exit; - (* - DeleteSelection; - s := GetClipboardText; - - si := UTF8Copy(CurrentLine,1,FCursorPos); - lineend := UTF8Copy(CurrentLine,FCursorPos+1, UTF8Length(CurrentLine)); - l := FCursorLine; - n := 1; - lcnt := 0; - si8 := ''; - while n <= length(s) do - begin - if (s[n] = #13) or (s[n] = #10) then - begin - if lcnt = 0 then SetLineText(l, si + si8) - else FLines.Insert(l-1, si + si8); - - si := ''; - si8 := ''; - inc(lcnt); - inc(l); - - // skip multibyte line end: - if (s[n]=#13) and (n < length(s)) and (s[n+1]=#10) then inc(n); - end - else - begin - si8 := si8 + s[n]; - end; - inc(n); - end; - - si := si + si8; - - FCursorPos := UTF8Length(si); - si := si + lineend; - - if lcnt = 0 then - begin - SetLineText(l, si) - end - else - begin - FLines.Insert(l-1, si); - FCursorLine := l; - end; - - AdjustCursor; - Repaint; -*) -end; - -procedure TfpgMemo.AdjustCursor; -var - tw: integer; -begin - // horizontal adjust - RecalcLongestLine; - tw := FFont.TextWidth(UTF8Copy(CurrentLine, 1, FCursorPos)); - - if tw - FDrawOffset > VisibleWidth - 2 then - FDrawOffset := tw - VisibleWidth + 2 - else if tw - FDrawOffset < 0 then - begin - FDrawOffset := tw; - if tw <> 0 then - Dec(FDrawOffset, 2); - end; - - // vertical adjust - if FCursorLine < FFirstLine then - FFirstLine := FCursorLine; - if FCursorline - FFirstLine + 1 > VisibleLines then - FFirstLine := FCursorline - VisibleLines + 1; - - if (FFirstLine + VisibleLines) > LineCount then - begin - FFirstLine := LineCount - VisibleLines + 1; - if FFirstline < 0 then - FFirstLine := 0; - end; - - UpdateScrollbars; -end; - -procedure TfpgMemo.UpdateScrollBars; -var - vlines: integer; - vsbw: integer; - hsbwas: boolean; - vsbwas: boolean; - vsbvis: boolean; -begin - hsbwas := FHScrollBar.Visible; - vsbwas := FVScrollBar.Visible; - vlines := (Height - (FSideMargin shl 1)) div Lineheight; - vsbvis := (LineCount > vlines); - - if vsbvis then - vsbw := FVScrollBar.Width - else - vsbw := 0; - - FHScrollBar.Visible := FLongestLineWidth > (Width - vsbw - FSideMargin * 2) - 1; - - if FHScrollBar.Visible and not vsbvis then - begin - // recheck vertical scrollbar - vlines := (Height - (FSideMargin shl 1) - FHScrollBar.Height) div Lineheight; - vsbvis := (LineCount > vlines); - end; - - FVScrollBar.Visible := vsbvis; - - UpdateScrollBarCoords; - - if FHScrollBar.Visible then - begin - FHScrollBar.Min := 0; - FHScrollBar.Max := FLongestLineWidth - VisibleWidth - 1; - if (FLongestLineWidth <= 0) or (FLongestLineWidth <= VisibleWidth) then - FHScrollBar.SliderSize := 1 - else - FHScrollBar.SliderSize := VisibleWidth / FLongestLineWidth; - FHScrollBar.Position := FDrawOffset; - FHScrollBar.RepaintSlider; - end; - - if FVScrollBar.Visible then - begin - FVScrollBar.Min := 0; - // TODO: Look at calculation of vlines value to improve this! - if LineCount > 0 then - begin - FVScrollBar.SliderSize := VisibleLines / LineCount; - FVScrollBar.Max := LineCount - VisibleLines; - end - else - begin - FVScrollBar.SliderSize := 0.5; - FVScrollBar.Max := 10; - end; - FVScrollBar.Position := FFirstLine; - FVScrollBar.RepaintSlider; - end; - - if (hsbwas <> FHScrollBar.Visible) or (vsbwas <> FVScrollBar.Visible) then - AdjustCursor; -end; - -function TfpgMemo.LineCount: integer; -begin - Result := FLines.Count; -end; - -function TfpgMemo.GetLineText(linenum: integer): string; -begin - if LineCount = 0 then - FLines.Add(''); - if (linenum >= 0) and (linenum < LineCount) then - Result := FLines.Strings[linenum] - else - Result := ''; -end; - -procedure TfpgMemo.SetFontDesc(const AValue: string); -begin - FFont.Free; - FFont := fpgGetFont(AValue); - RePaint; -end; - -procedure TfpgMemo.SetLineText(linenum: integer; Value: string); -begin - FLines.Strings[linenum] := Value; -end; - -function TfpgMemo.GetCursorX: integer; -begin - Result := FFont.TextWidth(copy(CurrentLine, 1, FCursorPos)); -end; - -// Set cursor position by X -procedure TfpgMemo.SetCPByX(x: integer); -var - n: integer; - cpx: integer; - cp: integer; - cx: integer; - ls: string; -begin - // searching the appropriate character position - ls := CurrentLine; - cpx := FFont.TextWidth(UTF8Copy(ls, 1, FCursorPos)); // + FDrawOffset + FSideMargin; - cp := FCursorPos; - if cp > UTF8Length(ls) then - cp := UTF8Length(ls); - - for n := 0 to UTF8Length(ls) do - begin - cx := FFont.TextWidth(UTF8Copy(ls, 1, n)); // + FDrawOffset + FSideMargin; - if abs(cx - x) < abs(cpx - x) then - begin - cpx := cx; - cp := n; - end; - end; - - FCursorPos := cp; -end; - -function TfpgMemo.CurrentLine: string; -begin - Result := GetLineText(FCursorLine); -end; - -function TfpgMemo.VisibleLines: integer; -var - sh: integer; -begin - if FHScrollBar.Visible then - sh := 18 - else - sh := 0; - Result := (Height - (FSideMargin shl 1) - sh) div Lineheight; -end; - -function TfpgMemo.VisibleWidth: integer; -var - sw: integer; -begin - if FVScrollBar.Visible then - sw := FVScrollBar.Width - else - sw := 0; - Result := (Width - (FSideMargin shl 1) - sw); -end; - -procedure TfpgMemo.HandleShow; -begin - inherited HandleShow; - if (csLoading in ComponentState) then - Exit; - RecalcLongestLine; - UpdateScrollBars; - UpdateScrollBarCoords; -end; - -procedure TfpgMemo.HandleMouseEnter; -begin - inherited HandleMouseEnter; - MouseCursor := mcIBeam; -end; - -procedure TfpgMemo.HandleMouseExit; -begin - inherited HandleMouseExit; - MouseCursor := mcDefault; -end; - -procedure TfpgMemo.VScrollBarMove(Sender: TObject; position: integer); -begin - if FFirstLine <> position then - begin - FFirstLine := position; - repaint; - end; -end; - -procedure TfpgMemo.HScrollBarMove(Sender: TObject; position: integer); -begin - if position <> FDrawOffset then - begin - FDrawOffset := position; - Repaint; - end; -end; - -procedure TfpgMemo.HandlePaint; -var - n: integer; - tw, tw2, st, len: integer; - yp, xp: integer; - ls: string; - r: TfpgRect; - selsl, selsp, selel, selep: integer; - c: integer; - s: string; -begin - Canvas.ClearClipRect; - r.SetRect(0, 0, Width, Height); - Canvas.DrawControlFrame(r); - - InflateRect(r, -2, -2); - Canvas.SetClipRect(r); - - if Enabled then - Canvas.SetColor(FBackgroundColor) - else - Canvas.SetColor(clWindowBackground); - Canvas.FillRectAngle(r); - - Canvas.SetTextColor(FTextColor); - Canvas.SetFont(FFont); - - if (FSelStartLine shl 16) + FSelStartPos <= (FSelEndLine shl 16) + FSelEndPos then - begin - selsl := FSelStartLine; - selsp := FSelStartPos; - selel := FSelEndLine; - selep := FSelEndPos; - end - else - begin - selel := FSelStartLine; - selep := FSelStartPos; - selsl := FSelEndLine; - selsp := FSelEndPos; - end; - - yp := 3; - for n := FFirstline to LineCount-1 do - begin - ls := GetLineText(n); - if FUseTabs then - begin - xp := 0; - s := ''; - for c := 1 to Length(ls) do - begin - if ls[c] = #9 then - begin - if s <> '' then - Canvas.DrawString(-FDrawOffset + FSideMargin + xp, yp, s); - xp := xp + Canvas.Font.TextWidth(' ') * FTabWidth; - s := ''; - end - else - s := s + ls[c]; - end; - if s <> '' then - Canvas.DrawString(-FDrawOffset + FSideMargin + xp, yp, s); - end - else - Canvas.DrawString(-FDrawOffset + FSideMargin, yp, ls); - - if Focused then - begin - // drawing selection - if (FSelEndLine > -1) and (selsl <= n) and (selel >= n) then - begin - if selsl < n then - st := 0 - else - st := selsp; - if selel > n then - len := UTF8Length(ls) - else - len := selep - st; - - tw := FFont.TextWidth(UTF8Copy(ls, 1, st)); - tw2 := FFont.TextWidth(UTF8Copy(ls, 1, st + len)); - Canvas.XORFillRectangle(fpgColorToRGB(clSelection) xor $FFFFFF, -FDrawOffset + - FSideMargin + tw, yp, tw2 - tw, LineHeight); - end; - - //drawing cursor - if FCursorLine = n then - begin - // drawing cursor - tw := FFont.TextWidth(UTF8Copy(ls, 1, FCursorPos)); - fpgCaret.SetCaret(Canvas, -FDrawOffset + FSideMargin + tw, yp, fpgCaret.Width, FFont.Height); - end; - end; { if } - - yp := yp + LineHeight; - if yp > Height then - Break; - end; { for } - - if not Focused then - fpgCaret.UnSetCaret(Canvas); - - // The little square in the bottom right corner - if FHScrollBar.Visible and FVScrollBar.Visible then - begin - Canvas.SetColor(clButtonFace); - Canvas.FillRectangle(FHScrollBar.Left+FHScrollBar.Width, - FVScrollBar.Top+FVScrollBar.Height, - FVScrollBar.Width, - FHScrollBar.Height); - end; -end; - -procedure TfpgMemo.HandleKeyChar(var AText: TfpgChar; var shiftstate: TShiftState; var consumed: boolean); -var - prevval: string; - s: string; - ls: string; -begin - inherited; - prevval := Text; - s := AText; - - // Printable characters only - // Note: This is now UTF-8 compliant! - if (Ord(AText[1]) > 31) and (Ord(AText[1]) < 127) or (Length(AText) > 1) then - begin - if (FMaxLength <= 0) or (UTF8Length(FLines.Text) < FMaxLength) then - begin - if FCursorLine < 0 then - FCursorLine := 0; - DeleteSelection; - ls := GetLineText(FCursorLine); - UTF8Insert(s, ls, FCursorPos + 1); - SetLineText(FCursorLine, ls); - Inc(FCursorPos); - FSelStartPos := FCursorPos; - FSelStartLine := FCursorLine; - FSelEndLine := -1; - AdjustCursor; - end; - - consumed := True; - end; - - if prevval <> Text then - if Assigned(FOnChange) then - FOnChange(self); - - if consumed then - RePaint; -end; - -procedure TfpgMemo.HandleKeyPress(var keycode: word; - var shiftstate: TShiftState; var consumed: boolean); -var - cx: integer; - ls: string; - ls2: string; - hasChanged: boolean; - - procedure StopSelection; - begin - FSelStartLine := FCursorLine; - FSelStartPos := FCursorPos; - FSelEndLine := -1; - end; - -begin - Consumed := True; - hasChanged := False; - case CheckClipBoardKey(keycode, shiftstate) of - ckCopy: - begin - DoCopy; - end; - ckPaste: - begin - DoPaste; - hasChanged := True; - end; - ckCut: - begin - DoCopy; - DeleteSelection; - hasChanged := True; - end; - else - Consumed := False; - end; - - if not Consumed then - begin - // checking for movement keys: - consumed := True; - FSelecting := (ssShift in shiftstate); - - case keycode of - keyLeft: - if FCursorPos > 0 then - begin - Dec(FCursorPos); - - if (ssCtrl in shiftstate) then - // word search... - (* - while (FCursorPos > 0) and not pgfIsAlphaNum(copy(CurrentLine,FCursorPos,1)) - do Dec(FCursorPos); - - while (FCursorPos > 0) and pgfIsAlphaNum(copy(CurrentLine,FCursorPos,1)) - do Dec(FCursorPos); - *); - - end;// left - - keyRight: - if FCursorPos < UTF8Length(CurrentLine) then - begin - Inc(FCursorPos); - - if (ssCtrl in shiftstate) then - // word search... - (* - while (FCursorPos < length(CurrentLine)) and pgfIsAlphaNum(copy(CurrentLine,FCursorPos+1,1)) - do Inc(FCursorPos); - - while (FCursorPos < length(CurrentLine)) and not pgfIsAlphaNum(copy(CurrentLine,FCursorPos+1,1)) - do Inc(FCursorPos); - *); - - end;// right - - keyUp: - begin // up - cx := GetCursorX; - if FCursorLine > 0 then - begin - Dec(FCursorline); - SetCPByX(cx); - end; - end; - - keyDown: - begin - cx := GetCursorX; - if FCursorLine < (LineCount-1) then - begin - Inc(FCursorline); - SetCPByX(cx); - end; - end; - - keyHome: - begin - if (ssCtrl in shiftstate) then - FCursorLine := 0; - FCursorPos := 0; - end; - - keyEnd: - begin - if (ssCtrl in shiftstate) then - FCursorLine := LineCount-1; - FCursorPos := UTF8Length(CurrentLine); - end; - - keyPageUp: - if FCursorLine > 0 then - begin - cx := GetCursorX; - Dec(FCursorLine, VisibleLines); - if FCursorLine < 0 then - FCursorLine := 0; - SetCPByX(cx); - end; - - keyPageDown: - begin - cx := GetCursorX; - if FCursorLine < (LineCount-1) then - begin - Inc(FCursorline, VisibleLines); - if FCursorLine > (LineCount-1) then - FCursorLine := LineCount-1; - SetCPByX(cx); - end; - end; - - else - Consumed := False; - end; - - if Consumed then - begin - AdjustCursor; - - if FSelecting then - begin - FSelEndPos := FCursorPos; - FSelEndLine := FCursorLine; - end - else - StopSelection; - end; - end; - - if not Consumed then - begin - consumed := True; - - case keycode of - keyReturn, - keyPEnter: - begin - ls := UTF8Copy(FLines[FCursorline], 1, FCursorPos); - ls2 := UTF8Copy(FLines[FCursorline], FCursorPos + 1, UTF8Length(FLines[FCursorline])); - FLines.Insert(FCursorLine, ls); - Inc(FCursorLine); - SetLineText(FCursorLine, ls2); - FCursorPos := 0; - hasChanged := True; - end; - - keyBackSpace: - begin - if FCursorPos > 0 then - begin - ls := GetLineText(FCursorLine); - UTF8Delete(ls, FCursorPos, 1); - SetLineText(FCursorLine, ls); - Dec(FCursorPos); - end - else if FCursorLine > 0 then - begin - ls := CurrentLine; - FLines.Delete(FCursorLine); - Dec(FCursorLine); - FCursorPos := UTF8Length(FLines.Strings[FCursorLine]); - FLines.Strings[FCursorLine] := FLines.Strings[FCursorLine] + ls; - end; - hasChanged := True; - end; - - keyDelete: - begin - ls := GetLineText(FCursorLine); - if FSelEndLine > -1 then - DeleteSelection - else if FCursorPos < UTF8Length(ls) then - begin - UTF8Delete(ls, FCursorPos + 1, 1); - SetLineText(FCursorLine, ls); - end - else if FCursorLine < (LineCount-1) then - begin - ls2 := FLines.Strings[FCursorLine+1]; - FLines.Delete(FCursorLine); - FLines.Strings[FCursorLine] := ls + ls2; - end; - hasChanged := True; - end; - - keyTab: - begin - if FUseTabs then - begin - ls := GetLineText(FCursorLine); -{ if FSelEndLine > 0 then - DeleteSelection - else} if FCursorPos < UTF8Length(ls) then - begin - UTF8Insert(#9, ls, FCursorPos); - SetLineText(FCursorLine, ls); - end; -{ - else if FCursorLine < LineCount then - begin - ls2 := FLines.Strings[FCursorLine]; - FLines.Delete(FCursorLine); - FLines.Strings[FCursorLine - 1] := ls + ls2; - end; -} - hasChanged := True; - end - else - Consumed := False; - end; - else - Consumed := False; - end; - - if Consumed then - begin - StopSelection; - AdjustCursor; - end; - end; - - if Consumed then - RePaint - else - inherited; - - if hasChanged then - if Assigned(FOnChange) then - FOnChange(self); -end; - -procedure TfpgMemo.HandleLMouseDown(x, y: integer; shiftstate: TShiftState); -var - n: integer; - cpx: integer; - cp: integer; - cx: integer; - lnum: integer; - ls: string; -begin - inherited HandleLMouseDown(x, y, shiftstate); - - // searching the appropriate character position - lnum := FFirstLine + (y - FSideMargin) div LineHeight; - if lnum > (LineCount-1) then - lnum := LineCount-1; - - ls := GetLineText(lnum); - cpx := FFont.TextWidth(UTF8Copy(ls, 1, FCursorPos)) - FDrawOffset + FSideMargin; - cp := FCursorPos; - - for n := 0 to UTF8Length(ls) do - begin - cx := FFont.TextWidth(UTF8Copy(ls, 1, n)) - FDrawOffset + FSideMargin; - if abs(cx - x) < abs(cpx - x) then - begin - cpx := cx; - cp := n; - end; - end; - - FMouseDragging := True; - FMouseDragPos := cp; - FCursorPos := cp; - FCursorLine := lnum; - - if (ssShift in shiftstate) then - begin - FSelEndLine := lnum; - FSelEndpos := cp; - end - else - begin - FSelStartLine := lnum; - FSelStartPos := cp; - FSelEndLine := -1; - end; - Repaint; -end; - -procedure TfpgMemo.HandleRMouseUp(x, y: integer; shiftstate: TShiftState); -begin - inherited HandleRMouseUp(x, y, shiftstate); - if Assigned(PopupMenu) then - PopupMenu.ShowAt(self, x, y); -end; - -procedure TfpgMemo.HandleMouseMove(x, y: integer; btnstate: word; shiftstate: TShiftState); -var - n: integer; - cpx: integer; - cp: integer; - cx: integer; - lnum: integer; - ls: string; -begin - if not FMouseDragging or ((btnstate and 1) = 0) then - begin - FMouseDragging := False; - Exit; - end; - - // searching the appropriate character position - lnum := FFirstLine + (y - FSideMargin) div LineHeight; - if lnum > LineCount-1 then - lnum := LineCount-1; - - ls := GetLineText(lnum); - cpx := FFont.TextWidth(UTF8Copy(ls, 1, FCursorPos)) - FDrawOffset + FSideMargin; - cp := FCursorPos; - - for n := 0 to UTF8Length(ls) do - begin - cx := FFont.TextWidth(UTF8Copy(ls, 1, n)) - FDrawOffset + FSideMargin; - if abs(cx - x) < abs(cpx - x) then - begin - cpx := cx; - cp := n; - end; - end; - - if (cp <> FCursorPos) or (lnum <> FCursorLine) then - begin - FCursorLine := lnum; - FSelEndLine := lnum; - FSelEndPos := cp; - FCursorPos := cp; - Repaint; - end; - - - // searching the appropriate character position - { - cpx := FFont.TextWidth16(copy16(FText,1,FCursorPos)) + FDrawOffset + FSideMargin; - cp := FCursorPos; - - s := ''; - - for n := 0 to Length16(Text) do - begin - cx := FFont.TextWidth16(copy16(Text,1,n)) + FDrawOffset + FSideMargin; - if abs(cx - x) < abs(cpx - x) then - begin - cpx := cx; - cp := n; - end; - end; - - //FMouseDragPos := cp; - FSelOffset := cp-FSelStart; - if FCursorPos <> cp then - begin - FCursorPos := cp; - Repaint; - end; -} -end; - -(* -procedure TfpgMemo.HandleWindowScroll(direction, amount: integer); -var - pfl, pdo : integer; -begin - inherited HandleWindowScroll(direction, amount); - - pfl := FFirstLine; - pdo := FDrawOffset; - - if direction = 0 then - begin - dec(FFirstLine, amount); - end; - if direction = 1 then - begin - inc(FFirstLine, amount); - end; - if FFirstLine > LineCount - VisibleLines + 1 then FFirstLine := LineCount - VisibleLines + 1; - if FFirstLine < 1 then FFirstLine := 1; - - if FHScrollBar.Visible then - begin - if Direction = 2 then - begin - dec(FDrawOffset, amount*16); - end; - if Direction = 3 then - begin - inc(FDrawOffset, amount*16); - end; - - if FDrawOffset > FHScrollBar.Max then FDrawOffset := FHScrollBar.Max; - if FDrawOffset < 0 then FDrawOffset := 0; - end; - - if (pfl <> FFirstLine) or (pdo <> FDrawOffset) then - begin - UpdateScrollBars; - Repaint; - end; - -end; -*) - -procedure TfpgMemo.HandleResize(dwidth, dheight: integer); -begin - inherited HandleResize(dwidth, dheight); - if (csLoading in ComponentState) then - Exit; - UpdateScrollBarCoords; - UpdateScrollBars; -end; - -procedure TfpgMemo.HandleMouseScroll(x, y: integer; shiftstate: TShiftState; - delta: smallint); -var - pfl, pdo : integer; -begin - inherited HandleMouseScroll(x, y, shiftstate, delta); - - pfl := FFirstLine; - pdo := FDrawOffset; - - if delta < 0 then - dec(FFirstLine, abs(delta)) // scroll up - else - inc(FFirstLine, abs(delta)); // scroll down - - if FFirstLine > LineCount - VisibleLines{ + 1} then - FFirstLine := LineCount - VisibleLines {+ 1}; - if FFirstLine < 0 then - FFirstLine := 0; - - if FHScrollBar.Visible then - begin - if FDrawOffset > FHScrollBar.Max then - FDrawOffset := FHScrollBar.Max; - if FDrawOffset < 0 then - FDrawOffset := 0; - end; - - if (pfl <> FFirstLine) or (pdo <> FDrawOffset) then - begin - UpdateScrollBars; - Repaint; - end; -end; - -function TfpgMemo.SelectionText: string; -begin - { - if FSelOffset <> 0 then - begin - if FSelOffset < 0 then - begin - Result := Copy(FText,1+FSelStart + FSelOffset,-FSelOffset); - end - else - begin - result := Copy(FText,1+FSelStart,FSelOffset); - end; - end - else -} - Result := ''; -end; - -function TfpgMemo.GetText: TfpgString; -var - n: integer; - s: TfpgString; -begin - s := ''; - for n := 0 to LineCount-1 do - begin - if n > 0 then - s := s + #13#10; - s := s + GetLineText(n); - end; - Result := s; -end; - -procedure TfpgMemo.SetText(const AValue: TfpgString); -var - n: integer; - c: TfpgChar; - s: TfpgString; -begin - FLines.Clear; - s := ''; - n := 1; - while n <= UTF8Length(AValue) do - begin - c := UTF8Copy(AValue, n, 1); - if (c[1] = #13) or (c[1] = #10) then - begin - FLines.Add(s); - s := ''; - c := UTF8Copy(AValue, n + 1, 1); - if c[1] = #10 then - Inc(n); - end - else - s := s + c; - Inc(n); - end; - - if s <> '' then - FLines.Add(s); - - FDrawOffset := 0; - FCursorPos := 0; - FCursorLine := 0; - FSelStartLine := FCursorLine; - FSelStartPos := FCursorPos; - FSelEndLine := -1; - - AdjustCursor; - Repaint; -end; - -end. - diff --git a/src/gui/gui_menu.pas b/src/gui/gui_menu.pas deleted file mode 100644 index 4c415345..00000000 --- a/src/gui/gui_menu.pas +++ /dev/null @@ -1,1325 +0,0 @@ -{ - fpGUI - Free Pascal GUI Toolkit - - Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this - distribution, for details of the copyright. - - See the file COPYING.modifiedLGPL, included in this distribution, - for details about redistributing fpGUI. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - - Description: - Defines a MainMenu Bar, Popup Menu and Menu Item controls. -} - -unit gui_menu; - -{$mode objfpc}{$H+} - -{.$Define DEBUG} - -{ - TODO: - * Refactor the HotKey painting code into Canvas.DrawString so that other - widgets like TfpgButton could also use it. - * Global keyboard activation of menu items are still missing. -} - -interface - -uses - Classes, - SysUtils, - fpg_base, - fpg_main, - fpg_widget, - fpg_popupwindow, - fpg_stringutils, - fpg_command_intf; - -type - TfpgHotKeyDef = string; - - TfpgMenuOption = (mnuo_autoopen, // auto open menus when mouse over menubar - mnuo_nofollowingmouse // don't auto open new menus as mouse moves over menubar - ); - - TfpgMenuOptions = set of TfpgMenuOption; - - // forward declarations - TfpgPopupMenu = class; - TfpgMenuBar = class; - - - TfpgMenuItem = class(TComponent, ICommandHolder) - private - FCommand: ICommand; - FEnabled: boolean; - FHotKeyDef: TfpgHotKeyDef; - FOnClick: TNotifyEvent; - FSeparator: boolean; - FSubMenu: TfpgPopupMenu; - FText: TfpgString; - FVisible: boolean; - procedure SetEnabled(const AValue: boolean); - procedure SetHotKeyDef(const AValue: TfpgHotKeyDef); - procedure SetSeparator(const AValue: boolean); - procedure SetText(const AValue: TfpgString); - procedure SetVisible(const AValue: boolean); - public - constructor Create(AOwner: TComponent); override; - procedure Click; - function Selectable: boolean; - function GetAccelChar: string; - procedure DrawText(ACanvas: TfpgCanvas; x, y: TfpgCoord); - function GetCommand: ICommand; - procedure SetCommand(ACommand: ICommand); - property Text: TfpgString read FText write SetText; - property HotKeyDef: TfpgHotKeyDef read FHotKeyDef write SetHotKeyDef; - property Separator: boolean read FSeparator write SetSeparator; - property Visible: boolean read FVisible write SetVisible; - property Enabled: boolean read FEnabled write SetEnabled; - property SubMenu: TfpgPopupMenu read FSubMenu write FSubMenu; - property OnClick: TNotifyEvent read FOnClick write FOnClick; - end; - - - // Actual Menu Items are stored in TComponent's Components property - // Visible only items are stored in FItems just before a paint - TfpgPopupMenu = class(TfpgPopupWindow) - private - FBeforeShow: TNotifyEvent; - FMargin: TfpgCoord; - FTextMargin: TfpgCoord; - procedure DoSelect; - procedure CloseSubmenus; - function GetItemPosY(index: integer): integer; - function CalcMouseRow(y: integer): integer; - function VisibleCount: integer; - function VisibleItem(ind: integer): TfpgMenuItem; - function MenuFocused: boolean; - function SearchItemByAccel(s: string): integer; - protected - FMenuFont: TfpgFont; - FMenuAccelFont: TfpgFont; - FMenuDisabledFont: TfpgFont; - FSymbolWidth: integer; - FItems: TList; - FFocusItem: integer; - procedure HandleMouseEnter; override; - procedure HandleMouseExit; override; - procedure HandleMouseMove(x, y: integer; btnstate: word; shiftstate: TShiftState); override; - procedure HandleLMouseDown(x, y: integer; shiftstate: TShiftState); override; - procedure HandleLMouseUp(x, y: integer; shiftstate: TShiftState); override; - procedure HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override; - procedure HandlePaint; override; - procedure HandleShow; override; - procedure HandleClose; override; - procedure DrawItem(mi: TfpgMenuItem; rect: TfpgRect); virtual; - procedure DrawRow(line: integer; focus: boolean); virtual; - function ItemHeight(mi: TfpgMenuItem): integer; virtual; - procedure PrepareToShow; - public - OpenerPopup: TfpgPopupMenu; - OpenerMenuBar: TfpgMenuBar; - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - procedure Close; override; - function AddMenuItem(const AMenuName: TfpgString; const hotkeydef: string; HandlerProc: TNotifyEvent): TfpgMenuItem; - function MenuItemByName(const AMenuName: TfpgString): TfpgMenuItem; - function MenuItem(const AMenuPos: integer): TfpgMenuItem; // added to allow for localization - property BeforeShow: TNotifyEvent read FBeforeShow write FBeforeShow; - end; - - - // Actual Menu Items are stored in TComponents Components property - // Visible only items are stored in FItems just before a paint - TfpgMenuBar = class(TfpgWidget) - private - FBeforeShow: TNotifyEvent; - FLightColor: TfpgColor; - FDarkColor: TfpgColor; - FMenuOptions: TfpgMenuOptions; - FPrevFocusItem: integer; - FFocusItem: integer; - procedure SetFocusItem(const AValue: integer); - procedure DoSelect; - procedure CloseSubmenus; - function ItemWidth(mi: TfpgMenuItem): integer; - protected - FItems: TList; // stores visible items only - property FocusItem: integer read FFocusItem write SetFocusItem; - procedure PrepareToShow; - function VisibleCount: integer; - function VisibleItem(ind: integer): TfpgMenuItem; - procedure HandleShow; override; - procedure HandleMouseMove(x, y: integer; btnstate: word; shiftstate: TShiftState); override; - procedure HandleLMouseDown(x, y: integer; shiftstate: TShiftState); override; - procedure HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override; - procedure HandlePaint; override; - function CalcMouseCol(x: integer): integer; - function GetItemPosX(index: integer): integer; - function MenuFocused: boolean; - function SearchItemByAccel(s: string): integer; - procedure ActivateMenu; - procedure DeActivateMenu; - procedure DrawColumn(col: integer; focus: boolean); virtual; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - function AddMenuItem(const AMenuTitle: string; OnClickProc: TNotifyEvent): TfpgMenuItem; - function MenuItem(const AMenuPos: integer): TfpgMenuItem; // added to allow for localization - property MenuOptions: TfpgMenuOptions read FMenuOptions write FMenuOptions; - property BeforeShow: TNotifyEvent read FBeforeShow write FBeforeShow; - end; - - -function CreateMenuBar(AOwner: TfpgWidget; x, y, w, h: TfpgCoord): TfpgMenuBar; overload; -function CreateMenuBar(AOwner: TfpgWidget): TfpgMenuBar; overload; - - -implementation - -var - uFocusedPopupMenu: TfpgPopupMenu; - -function CreateMenuBar(AOwner: TfpgWidget; x, y, w, h: TfpgCoord): TfpgMenuBar; -begin - if AOwner = nil then - raise Exception.Create('MenuBar component must have an Owner assigned'); - Result := TfpgMenuBar.Create(AOwner); - Result.Left := x; - Result.Top := y; - if w = 0 then - Result.Width := AOwner.Width - else - Result.Width := w; - if h > 0 then - Result.Height := h; -end; - -function CreateMenuBar(AOwner: TfpgWidget): TfpgMenuBar; -begin - Result := CreateMenuBar(AOwner, 0, 0, 0, 0); -end; - - -{ TfpgMenuItem } - -procedure TfpgMenuItem.SetText(const AValue: TfpgString); -begin - if FText = AValue then - Exit; //==> - FText := AValue; -end; - -procedure TfpgMenuItem.SetVisible(const AValue: boolean); -begin - if FVisible=AValue then exit; - FVisible:=AValue; -end; - -procedure TfpgMenuItem.SetHotKeyDef(const AValue: TfpgHotKeyDef); -begin - if FHotKeyDef=AValue then exit; - FHotKeyDef:=AValue; -end; - -procedure TfpgMenuItem.SetEnabled(const AValue: boolean); -begin - if FEnabled=AValue then exit; - FEnabled:=AValue; -end; - -procedure TfpgMenuItem.SetSeparator(const AValue: boolean); -begin - if FSeparator=AValue then exit; - FSeparator:=AValue; -end; - -constructor TfpgMenuItem.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - Text := ''; - HotKeyDef := ''; - FSeparator := False; - FVisible := True; - FEnabled := True; - FSubMenu := nil; - FOnClick := nil; -end; - -procedure TfpgMenuItem.Click; -begin - if Assigned(FOnClick) then - FOnClick(self); -end; - -function TfpgMenuItem.Selectable: boolean; -begin - Result := Enabled and Visible and (not Separator); -end; - -function TfpgMenuItem.GetAccelChar: string; -var - p: integer; -begin - p := UTF8Pos('&', Text); - if p > 0 then - begin - Result := UTF8Copy(Text, p+1, 1); - end - else - Result := ''; -end; - -procedure TfpgMenuItem.DrawText(ACanvas: TfpgCanvas; x, y: TfpgCoord); -var - s: string; - p: integer; - achar: string; -begin -// writeln('DrawText x:', x, ' y:', y); - if not Enabled then - ACanvas.SetFont(fpgStyle.MenuDisabledFont) - else - ACanvas.SetFont(fpgStyle.MenuFont); - - achar := '&'; - s := Text; - - repeat - p := UTF8Pos(achar, s); - if p > 0 then - begin - // first part of text before the & sign - ACanvas.DrawString(x, y, UTF8Copy(s, 1, p-1)); - inc(x, fpgStyle.MenuFont.TextWidth(UTF8Copy(s, 1, p-1))); - if UTF8Copy(s, p+1, 1) = achar then - begin - // Do we need to paint a actual & sign (create via && in item text) - ACanvas.DrawString(x, y, achar); - inc(x, fpgStyle.MenuFont.TextWidth(achar)); - end - else - begin - // Draw the HotKey text - if Enabled then - ACanvas.SetFont(fpgStyle.MenuAccelFont); - ACanvas.DrawString(x, y, UTF8Copy(s, p+1, 1)); - inc(x, ACanvas.Font.TextWidth(UTF8Copy(s, p+1, 1))); - if Enabled then - ACanvas.SetFont(fpgStyle.MenuFont); - end; - s := UTF8Copy(s, p+2, UTF8Length(s)); - end; { if } - until p < 1; - - // Draw the remaining text after the & sign - if UTF8Length(s) > 0 then - ACanvas.DrawString(x, y, s); -end; - -function TfpgMenuItem.GetCommand: ICommand; -begin - Result := FCommand; -end; - -procedure TfpgMenuItem.SetCommand(ACommand: ICommand); -begin - FCommand := ACommand; -end; - -{ TfpgMenuBar } - -procedure TfpgMenuBar.SetFocusItem(const AValue: integer); -begin - if FFocusItem = AValue then - Exit; - FPrevFocusItem := FFocusItem; - FFocusItem := AValue; -end; - -procedure TfpgMenuBar.PrepareToShow; -var - n: integer; - mi: TfpgMenuItem; -begin - if Assigned(FBeforeShow) then - FBeforeShow(self); - - FItems.Count := 0; - // Collecting visible items - for n := 0 to ComponentCount-1 do - begin - if Components[n] is TfpgMenuItem then - begin - mi := TfpgMenuItem(Components[n]); - if mi.Visible then - FItems.Add(mi); - end; - end; -end; - -function TfpgMenuBar.VisibleCount: integer; -begin - Result := FItems.Count; -end; - -function TfpgMenuBar.VisibleItem(ind: integer): TfpgMenuItem; -begin - if (ind < 0) or (ind > FItems.Count-1) then - Result := nil - else - Result := TfpgMenuItem(FItems.Items[ind]); -end; - -procedure TfpgMenuBar.HandleShow; -begin - PrepareToShow; - inherited HandleShow; -end; - -procedure TfpgMenuBar.HandleMouseMove(x, y: integer; btnstate: word; shiftstate: TShiftState); -var - newf: integer; -begin - inherited HandleMouseMove(x, y, btnstate, shiftstate); - - // process menu options - if mnuo_nofollowingmouse in FMenuOptions then - begin - if not MenuFocused then - Exit; //==> - end - else if mnuo_autoopen in FMenuOptions then - begin - if not Focused then - ActivateMenu; - end - else - begin - if not Focused then - Exit; - end; - - - newf := CalcMouseCol(x); - if not VisibleItem(newf).Selectable then - Exit; //==> - - if newf = FFocusItem then - Exit; //==> - - FocusItem := newf; - // continue processing menu options - if mnuo_autoopen in FMenuOptions then - DoSelect - else - begin - Repaint; - if not MenuFocused then - DoSelect; - end -end; - -procedure TfpgMenuBar.HandleLMouseDown(x, y: integer; shiftstate: TShiftState); -var - newf: integer; -begin - inherited HandleLMouseDown(x, y, shiftstate); - - if ComponentCount = 0 then - Exit; // We have no menu items in MainMenu. - - if not Focused then - ActivateMenu; - //else - //begin - //CloseSubmenus; - //DeActivateMenu; - //Exit; //==> - //end; - - newf := CalcMouseCol(x); - - if not VisibleItem(newf).Selectable then - Exit; //==> - - if newf <> FFocusItem then - begin -// DrawColumn(FFocusItem, False); - FocusItem := newf; -// DrawColumn(FFocusItem, True); - end; - - DoSelect; -end; - -procedure TfpgMenuBar.HandleKeyPress(var keycode: word; - var shiftstate: TShiftState; var consumed: boolean); -var - s: string; - i: integer; -begin -// writeln(Classname, '.Keypress'); - s := KeycodeToText(keycode, shiftstate); -// writeln('s: ', s); - // handle MenuBar (Alt+?) shortcuts only - for now! - if (length(s) = 5) and (copy(s, 1, 4) = 'Alt+') then - begin - s := KeycodeToText(keycode, []); - i := SearchItemByAccel(s); - if i <> -1 then - begin - consumed := True; -// writeln('Selected ', VisibleItem(i).Text); - FFocusItem := i; - DoSelect; - end; - end; - inherited HandleKeyPress(keycode, shiftstate, consumed); -end; - -procedure TfpgMenuBar.HandlePaint; -var - n: integer; - r: TfpgRect; -begin - Canvas.BeginDraw; - inherited HandlePaint; - r.SetRect(0, 0, Width, Height); - Canvas.Clear(FBackgroundColor); -// Canvas.DrawButtonFace(r, []); - // inner bottom line - Canvas.SetColor(clShadow1); - Canvas.DrawLine(r.Left, r.Bottom-1, r.Right+1, r.Bottom-1); // bottom - // outer bottom line - Canvas.SetColor(clHilite1); - Canvas.DrawLine(r.Left, r.Bottom, r.Right+1, r.Bottom); // bottom - - for n := 0 to VisibleCount-1 do - DrawColumn(n, n = FocusItem); - Canvas.EndDraw; -end; - -constructor TfpgMenuBar.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - FItems := TList.Create; - FBeforeShow := nil; - FFocusItem := -1; - FPrevFocusItem := -1; - FFocusable := False; - FBackgroundColor := Parent.BackgroundColor; - FTextColor := Parent.TextColor; - // calculate the best height based on font - FHeight := fpgStyle.MenuFont.Height + 6; // 3px margin top and bottom - - FLightColor := TfpgColor($f0ece3); // color at top of menu bar - FDarkColor := TfpgColor($beb8a4); // color at bottom of menu bar - - FMenuOptions := []; -end; - -destructor TfpgMenuBar.Destroy; -begin - FItems.Free; - inherited Destroy; -end; - -function TfpgMenuBar.ItemWidth(mi: TfpgMenuItem): integer; -begin - Result := fpgStyle.MenuFont.TextWidth(mi.Text) + (2*6); -end; - -procedure TfpgMenuBar.DrawColumn(col: integer; focus: boolean); -var - n: integer; - r: TfpgRect; - mi: TfpgMenuItem; -begin - Canvas.BeginDraw; - r.SetRect(2, 1, 1, fpgStyle.MenuFont.Height+1); - - for n := 0 to VisibleCount-1 do - begin - mi := VisibleItem(n); - r.width := ItemWidth(mi); - if col = n then - begin - if focus and Focused then - begin - if MenuFocused then - begin - Canvas.SetColor(clSelection); - Canvas.SetTextColor(clSelectionText); - end - else - begin -// Canvas.SetColor(clInactiveSel); - Canvas.SetColor(clShadow1); - Canvas.SetTextColor(clInactiveSelText); - end; - end - else - begin - if mi.Enabled then - begin - Canvas.SetColor(BackgroundColor); - Canvas.SetTextColor(clMenuText); - end - else - begin - Canvas.SetColor(BackgroundColor); - Canvas.SetTextColor(clMenuDisabled); - end; - end; { if/else } - Canvas.FillRectangle(r); - // a possible future theme option -// Canvas.GradientFill(r, FLightColor, FDarkColor, gdVertical); - mi.DrawText(Canvas, r.left+4, r.top+1); - Canvas.EndDraw(r.Left, r.Top, r.Width, r.Height); - Exit; //==> - end; { if col=n } - inc(r.Left, ItemWidth(mi)); - end; { for } -end; - -function TfpgMenuBar.CalcMouseCol(x: integer): integer; -var - w: integer; - n: integer; -begin - Result := 0; - w := 0; - n := 0; - while (w <= x) and (n < VisibleCount) do - begin - Result := n; - inc(w, ItemWidth(VisibleItem(n))); - inc(n); - end; -end; - -function TfpgMenuBar.GetItemPosX(index: integer): integer; -var - n: integer; -begin - Result := 0; - if index < 0 then - Exit; //==> - n := 0; - while (n < VisibleCount) and (n < index) do - begin - Inc(result, ItemWidth(VisibleItem(n))); - inc(n); - end; -end; - -procedure TfpgMenuBar.DoSelect; -var - mi: TfpgMenuItem; -begin - mi := VisibleItem(FocusItem); - CloseSubMenus; // deactivates menubar! - - if mi.SubMenu <> nil then - begin - ActivateMenu; - // showing the submenu - mi.SubMenu.ShowAt(self, GetItemPosX(FocusItem)+2, fpgStyle.MenuFont.Height+4); - mi.SubMenu.OpenerPopup := nil; - mi.SubMenu.OpenerMenuBar := self; - mi.SubMenu.DontCloseWidget := self; - uFocusedPopupMenu := mi.SubMenu; - RePaint; - end - else - begin - VisibleItem(FocusItem).Click; - DeActivateMenu; - end; -end; - -procedure TfpgMenuBar.CloseSubmenus; -var - n: integer; -begin - // Close all previous popups - for n := 0 to VisibleCount-1 do - with VisibleItem(n) do - begin - if (SubMenu <> nil) and (SubMenu.HasHandle) then - SubMenu.Close; - end; -end; - -function TfpgMenuBar.MenuFocused: boolean; -var - n: integer; - mi: TfpgMenuItem; -begin - Result := True; - for n := 0 to VisibleCount-1 do - begin - mi := VisibleItem(n); - if (mi.SubMenu <> nil) and (mi.SubMenu.HasHandle) then - begin - Result := False; - Break; - end; - end; -end; - -function TfpgMenuBar.SearchItemByAccel(s: string): integer; -var - n: integer; -begin - Result := -1; - for n := 0 to VisibleCount-1 do - begin - with VisibleItem(n) do - begin - {$Note Should UpperCase take note of UTF-8? } - if Enabled and (UpperCase(s) = UpperCase(GetAccelChar)) then - begin - Result := n; - Exit; //==> - end; - end; - end; -end; - -procedure TfpgMenuBar.DeActivateMenu; -begin - Parent.ActiveWidget := nil; -end; - -procedure TfpgMenuBar.ActivateMenu; -begin - Parent.ActiveWidget := self; -end; - -function TfpgMenuBar.AddMenuItem(const AMenuTitle: string; OnClickProc: TNotifyEvent): TfpgMenuItem; -begin - Result := TfpgMenuItem.Create(self); - Result.Text := AMenuTitle; - Result.HotKeyDef := ''; - Result.OnClick := OnClickProc; - Result.Separator := False; -end; - -function TfpgMenuBar.MenuItem(const AMenuPos: integer): TfpgMenuItem; -begin - Result:= TfpgMenuItem(Components[AMenuPos]); -end; - -{ TfpgPopupMenu } - -procedure TfpgPopupMenu.DoSelect; -var - mi: TfpgMenuItem; - op: TfpgPopupMenu; -begin - mi := VisibleItem(FFocusItem); - if mi.SubMenu <> nil then - begin - CloseSubMenus; - // showing the submenu - mi.SubMenu.ShowAt(self, Width, GetItemPosY(FFocusItem)); - mi.SubMenu.OpenerPopup := self; - mi.SubMenu.OpenerMenuBar := OpenerMenuBar; - uFocusedPopupMenu := mi.SubMenu; - RePaint; - end - else - begin - // Close this popup - Close; - op := OpenerPopup; - while op <> nil do - begin - if op.HasHandle then - op.Close; - op := op.OpenerPopup; - end; - VisibleItem(FFocusItem).Click; - end; { if/else } - -// if OpenerMenuBar <> nil then -// OpenerMenuBar.DeActivateMenu; -end; - -procedure TfpgPopupMenu.CloseSubmenus; -var - n: integer; -begin - // Close all previous popups - for n := 0 to VisibleCount-1 do - with VisibleItem(n) do - begin - if (SubMenu <> nil) and (SubMenu.HasHandle) then - SubMenu.Close; - end; -end; - -function TfpgPopupMenu.GetItemPosY(index: integer): integer; -var - n: integer; -begin - Result := 2; - if index < 0 then - Exit; //==> - n := 0; - while (n < VisibleCount) and (n < index) do - begin - Inc(Result, ItemHeight(VisibleItem(n))); - inc(n); - end; -end; - -procedure TfpgPopupMenu.HandleMouseMove(x, y: integer; btnstate: word; shiftstate: TShiftState); -var - newf: integer; -begin - inherited HandleMouseMove(x, y, btnstate, shiftstate); - - if not MenuFocused then - Exit; //==> - - newf := CalcMouseRow(y); - if newf < 0 then - Exit; //==> - - if newf = FFocusItem then - Exit; //==> - - FFocusItem := newf; - Repaint; -end; - -procedure TfpgPopupMenu.HandleLMouseDown(x, y: integer; shiftstate: TShiftState); -var - r: TfpgRect; -begin - inherited HandleLMouseDown(x, y, shiftstate); - - r.SetRect(0, 0, Width, Height); - if not PtInRect(r, Point(x, y)) then - begin - ClosePopups; - Exit; //==> - end; -end; - -procedure TfpgPopupMenu.HandleLMouseUp(x, y: integer; shiftstate: TShiftState); -var - newf: integer; - mi: TfpgMenuItem; - r: TfpgRect; -begin - inherited HandleLMouseUp(x, y, shiftstate); - - newf := CalcMouseRow(y); - if newf < 0 then - Exit; - - if not VisibleItem(newf).Selectable then - Exit; //==> - - if newf <> FFocusItem then - FFocusItem := newf; - - mi := VisibleItem(FFocusItem); - if (mi <> nil) and (not MenuFocused) and (mi.SubMenu <> nil) - and mi.SubMenu.HasHandle then - mi.SubMenu.Close - else - DoSelect; -end; - -procedure TfpgPopupMenu.HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); -var - oldf: integer; - i: integer; - s: string; - op: TfpgPopupMenu; - trycnt: integer; - - procedure FollowFocus; - begin - if oldf <> FFocusItem then - begin - Repaint; - end; - end; - -begin - inherited HandleKeyPress(keycode, shiftstate, consumed); - - oldf := FFocusItem; - - consumed := true; - case keycode of - keyUp: - begin // up - trycnt := 2; - i := FFocusItem-1; - repeat - while (i >= 0) and not VisibleItem(i).Selectable do - dec(i); - - if i >= 0 then - break; //==> - - i := VisibleCount-1; - dec(trycnt); - until trycnt > 0; - - if i >= 0 then - FFocusItem := i; - end; - - keyDown: - begin // down - trycnt := 2; - i := FFocusItem+1; - repeat - while (i < VisibleCount) and not VisibleItem(i).Selectable do - inc(i); - if i < VisibleCount then - Break; //==> - i := 0; - dec(trycnt); - until trycnt > 0; - - if i < VisibleCount then - FFocusItem := i; - end; - - keyReturn: - begin - DoSelect; - end; - - keyLeft: - begin - if OpenerMenubar <> nil then - OpenerMenubar.HandleKeyPress(keycode, shiftstate, consumed); - end; - - keyRight: - begin - if OpenerMenubar <> nil then - OpenerMenubar.HandleKeyPress(keycode, shiftstate, consumed); - // VisibleItem(FFocusItem).SubMenu <> nil then DoSelect; - end; - - keyBackSpace: - begin - //if self.OpenerPopup <> nil then - Close; - end; - - keyEscape: - begin - Close; - op := OpenerPopup; - while op <> nil do - begin - op.Close; - op := op.OpenerPopup; - end; - end; - else - consumed := false; - end; - - FollowFocus; - - if (not consumed) and ((keycode and $8000) <> $8000) then - begin - // normal char - s := chr(keycode and $00FF) + chr((keycode and $FF00) shr 8); - i := SearchItemByAccel(s); - if i >= 0 then - begin - FFocusItem := i; - FollowFocus; - Consumed := true; - DoSelect; - end; - end; -end; - -procedure TfpgPopupMenu.HandlePaint; -var - n: integer; -begin - Canvas.BeginDraw; -// inherited HandlePaint; - Canvas.Clear(BackgroundColor); - Canvas.SetColor(clWidgetFrame); - Canvas.DrawRectangle(0, 0, Width, Height); // black rectangle border - Canvas.DrawButtonFace(1, 1, Width-1, Height-1, []); // 3d rectangle inside black border - - for n := 0 to VisibleCount-1 do - DrawRow(n, n = FFocusItem); - - Canvas.EndDraw; -end; - -procedure TfpgPopupMenu.HandleShow; -begin - PrepareToShow; - inherited HandleShow; -end; - -procedure TfpgPopupMenu.HandleClose; -begin - {$IFDEF DEBUG} - writeln(Classname, '.HandleClose'); - {$ENDIF} - inherited HandleClose; -end; - -function TfpgPopupMenu.VisibleCount: integer; -begin - Result := FItems.Count; -end; - -function TfpgPopupMenu.VisibleItem(ind: integer): TfpgMenuItem; -begin - if (ind < 0) or (ind > FItems.Count-1) then - Result := nil - else - Result := TfpgMenuItem(FItems.Items[ind]); -end; - -procedure TfpgPopupMenu.DrawItem(mi: TfpgMenuItem; rect: TfpgRect); -var - s: string; - x: integer; - img: TfpgImage; -begin - if mi.Separator then - begin - Canvas.SetColor(clMenuText); - Canvas.DrawLine(rect.Left, rect.Top+2, rect.Right+1, rect.Top+2); - end - else - begin - x := rect.Left + FSymbolWidth + FTextMargin; - - mi.DrawText(Canvas, x, rect.top); - - if mi.HotKeyDef <> '' then - begin - s := mi.HotKeyDef; - Canvas.DrawString(rect.Right-FMenuFont.TextWidth(s)-FTextMargin, rect.Top, s); - end; - - if mi.SubMenu <> nil then - begin - canvas.SetColor(Canvas.TextColor); - x := (rect.height div 2) - 3; - img := fpgImages.GetImage('sys.sb.right'); - Canvas.DrawImage(rect.right-x-2, rect.Top + ((rect.Height-img.Height) div 2), img); -// canvas.FillTriangle(rect.right-x-2, rect.top+2, -// rect.right-2, rect.top+2+x, -// rect.right-x-2, rect.top+2+2*x); - end; - end; -end; - -procedure TfpgPopupMenu.DrawRow(line: integer; focus: boolean); -var - n: integer; - r: TfpgRect; - mi: TfpgMenuItem; -begin - Canvas.BeginDraw; - r.SetRect(FMargin, FMargin, FWidth-(2*FMargin), FHeight-(2*FMargin)); - - for n := 0 to VisibleCount-1 do - begin - mi := VisibleItem(n); - - r.height := ItemHeight(mi); - - if line = n then - begin - if focus and (not mi.Separator) then - begin - if MenuFocused then - begin - Canvas.SetColor(clSelection); - if mi.Selectable then - Canvas.SetTextColor(clSelectionText) - else - Canvas.SetTextColor(clMenuDisabled); - end - else - begin - Canvas.SetColor(clShadow1); - Canvas.SetTextColor(clInactiveSelText); - end; - end - else - begin - if mi.Enabled then - begin - Canvas.SetColor(BackgroundColor); - Canvas.SetTextColor(clMenuText); - end - else - begin - Canvas.SetColor(BackgroundColor); - Canvas.SetTextColor(clMenuDisabled); - end; - end; - Canvas.FillRectangle(r); - DrawItem(mi, r); - Canvas.EndDraw(r.Left, r.Top, r.Width, r.Height); - Exit; //==> - end; - inc(r.Top, ItemHeight(mi) ); - end; { for } -end; - -function TfpgPopupMenu.ItemHeight(mi: TfpgMenuItem): integer; -begin - if mi.Separator then - Result := 5 - else - Result := FMenuFont.Height + 2; -end; - -function TfpgPopupMenu.MenuFocused: boolean; -begin - Result := (uFocusedPopupMenu = self); -end; - -function TfpgPopupMenu.SearchItemByAccel(s: string): integer; -var - n: integer; -begin - result := -1; - for n := 0 to VisibleCount-1 do - begin - with VisibleItem(n) do - begin - {$Note Do we need to use UTF-8 upper case? } - if Enabled and (UpperCase(s) = UpperCase(GetAccelChar)) then - begin - result := n; - Exit; //==> - end; - end; - end; -end; - -procedure TfpgPopupMenu.HandleMouseEnter; -begin - {$IFDEF DEBUG} - writeln(Classname, '.HandleMouseEnter'); - {$ENDIF} - inherited HandleMouseEnter; -end; - -procedure TfpgPopupMenu.HandleMouseExit; -begin - {$IFDEF DEBUG} - writeln(Classname, '.HandleMouseExit'); - {$ENDIF} - inherited HandleMouseExit; - FFocusItem := -1; - Repaint; -end; - -// Collecting visible items and measuring sizes -procedure TfpgPopupMenu.PrepareToShow; -var - n: integer; - h: integer; - tw: integer; - hkw: integer; - x: integer; - mi: TfpgMenuItem; -begin - if Assigned(FBeforeShow) then - BeforeShow(self); - - // Collecting visible items - FItems.Count := 0; - - for n := 0 to ComponentCount-1 do - begin - if Components[n] is TfpgMenuItem then - begin - mi := TfpgMenuItem(Components[n]); - if mi.Visible then - FItems.Add(mi); - end; - end; - - // Measuring sizes - h := 0; // height - tw := 0; // text width - hkw := 0; // hotkey width - FSymbolWidth := 0; - for n := 0 to VisibleCount-1 do - begin - mi := VisibleItem(n); - x := ItemHeight(mi); - inc(h, x); - x := FMenuFont.TextWidth(mi.Text); - if tw < x then - tw := x; - - if mi.SubMenu <> nil then - x := FMenuFont.Height - else - x := FMenuFont.TextWidth(mi.HotKeyDef); - if hkw < x then - hkw := x; - end; - - if hkw > 0 then - hkw := hkw + 10; // spacing between text and hotkey text - - FHeight := FMargin*2 + h; - FWidth := (FMargin+FTextMargin)*2 + FSymbolWidth + tw + hkw; - - uFocusedPopupMenu := self; -end; - -function TfpgPopupMenu.CalcMouseRow(y: integer): integer; -var - h: integer; - n: integer; -begin - h := 2; - n := 0; - Result := n; - - // sanity check - if y < 0 then - Exit - else - n := 0; - - while (h <= y) and (n < VisibleCount) do - begin - Result := n; - inc(h, ItemHeight(VisibleItem(n))); - inc(n); - end; -end; - -constructor TfpgPopupMenu.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - FMargin := 3; - FTextMargin := 3; - FItems := TList.Create; - - // fonts - FMenuFont := fpgStyle.MenuFont; - FMenuAccelFont := fpgStyle.MenuAccelFont; - FMenuDisabledFont := fpgStyle.MenuDisabledFont; - FSymbolWidth := FMenuFont.Height+2; - - FBeforeShow := nil; - FFocusItem := -1; - OpenerPopup := nil; - OpenerMenubar := nil; -end; - -destructor TfpgPopupMenu.Destroy; -begin - {$IFDEF DEBUG} - writeln(Classname, '.Destroy'); - {$ENDIF} - FItems.Free; - inherited Destroy; -end; - -{$Note See if we can move this to HandleHide + not make Close virtual! } -procedure TfpgPopupMenu.Close; -var - n: integer; - mi: TfpgMenuItem; -begin - for n := 0 to FItems.Count-1 do - begin - mi := TfpgMenuItem(FItems[n]); - if mi.SubMenu <> nil then - begin - if mi.SubMenu.HasHandle then - mi.SubMenu.Close; - end; - end; - inherited Close; - uFocusedPopupMenu := OpenerPopup; - if (uFocusedPopupMenu <> nil) and uFocusedPopupMenu.HasHandle then - uFocusedPopupMenu.RePaint; - - if (OpenerMenuBar <> nil) and OpenerMenuBar.HasHandle then - begin - if (OpenerPopup = nil) or not OpenerPopup.HasHandle then - begin - OpenerMenuBar.DeActivateMenu; - //OpenerMenuBar.Repaint; - end; - //else - //OpenerMenuBar.RePaint; - end; -end; - -function TfpgPopupMenu.AddMenuItem(const AMenuName: TfpgString; - const hotkeydef: string; HandlerProc: TNotifyEvent): TfpgMenuItem; -begin - result := TfpgMenuItem.Create(self); - if AMenuName <> '-' then - begin - result.Text := AMenuName; - result.hotkeydef := hotkeydef; - result.OnClick := HandlerProc; - end - else - begin - result.Separator := true; - end; -end; - -function TfpgPopupMenu.MenuItemByName(const AMenuName: TfpgString): TfpgMenuItem; -var - i: integer; -begin - Result := nil; - for i := 0 to ComponentCount-1 do - begin - if Components[i] is TfpgMenuItem then - if SameText(TfpgMenuItem(Components[i]).Text, AMenuName) then - begin - Result := TfpgMenuItem(Components[i]); - Exit; //==> - end; - end; -end; - -function TfpgPopupMenu.MenuItem(const AMenuPos: integer): TfpgMenuItem; -begin - Result:= TfpgMenuItem(Components[AMenuPos]); -end; - -initialization - uFocusedPopupMenu := nil; - -end. - diff --git a/src/gui/gui_mru.pas b/src/gui/gui_mru.pas deleted file mode 100644 index 4e4d9e9e..00000000 --- a/src/gui/gui_mru.pas +++ /dev/null @@ -1,276 +0,0 @@ -{ - fpGUI - Free Pascal GUI Toolkit - - Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this - distribution, for details of the copyright. - - See the file COPYING.modifiedLGPL, included in this distribution, - for details about redistributing fpGUI. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - - Description: - A component implementing a 'Most Recently Used' feature normally - inserted in the File menu. -} - -unit gui_mru; - -{$mode objfpc}{$H+} - -interface - -uses - Classes, SysUtils, gui_menu; - -type - - TMRUClickEvent = procedure(Sender: TObject; const FileName: String) of object; - - TfpgMRU = class(TComponent) - private - FItems: TStringList; - FMaxItems: Integer; - FShowFullPath: boolean; - FParentMenuItem: TfpgPopupMenu; -// FIniFilePath: string; - FOnClick: TMRUClickEvent; - procedure SetMaxItems(const AValue: Integer); -// procedure SetIniFilePath(const AValue: string); - procedure SetParentMenuItem(const AValue: TfpgPopupMenu); - procedure SetShowFullPath(const AValue: boolean); - procedure SaveMRU; - procedure ItemsChange(Sender: TObject); - procedure ClearParentMenu; - protected - // this never gets called without a Form Streaming class, which fpGUI doesn't use - procedure Loaded; override; - procedure Notification(AComponent: TComponent; Operation: TOperation); override; - procedure DoClick(Sender: TObject); - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - procedure AddItem(const FileName: string); - function RemoveItem(const FileName : string) : boolean; - procedure LoadMRU; - published - property MaxItems: Integer read FMaxItems write SetMaxItems default 4; -// property IniFilePath: string read FIniFilePath write SetIniFilePath; - property ShowFullPath: boolean read FShowFullPath write SetShowFullPath default True; - property ParentMenuItem: TfpgPopupMenu read FParentMenuItem write SetParentMenuItem; - property OnClick: TMRUClickEvent read FOnClick write FOnClick; - end; - - -implementation - -uses - gui_iniutils; - -type - //to be able to recognize MRU menu item when deleting - TMRUMenuItem = class(TfpgMenuItem); - - -{ TfpgMRU } - -procedure TfpgMRU.SetMaxItems(const AValue: Integer); -begin - if AValue <> FMaxItems then - begin - if AValue < 1 then - FMaxItems := 1 - else - begin - if AValue > High(Word) then // 65535 should be enough - FMaxItems := High(Word) - else - begin - FMaxItems := AValue; - FItems.BeginUpdate; - try - while FItems.Count > MaxItems do - FItems.Delete(FItems.Count - 1); - finally - FItems.EndUpdate; - end; - end; - end; { if/else } - end; -end; - -{ -procedure TfpgMRU.SetIniFilePath(const AValue: string); -begin - if FIniFilePath=AValue then exit; - FIniFilePath:=AValue; -end; -} - -procedure TfpgMRU.SetParentMenuItem(const AValue: TfpgPopupMenu); -begin - if AValue = FParentMenuItem then - Exit; - FParentMenuItem := AValue; -end; - -procedure TfpgMRU.SetShowFullPath(const AValue: boolean); -begin - if FShowFullPath <> AValue then - begin - FShowFullPath := AValue; - ItemsChange(Self); - end; -end; - -procedure TfpgMRU.LoadMRU; -var - i: cardinal; -begin - FItems.BeginUpdate; - FItems.Clear; - try - for i := 1 to FMaxItems do - if gINI.ValueExists('MRU', 'MRU'+IntToStr(i)) then - FItems.Add(gINI.ReadString('MRU', 'MRU'+IntToStr(i), '')); - finally - FItems.EndUpdate; - end; -end; - -procedure TfpgMRU.SaveMRU; -var - i: integer; -begin - if FItems.Count = 0 then - Exit; - - //delete old mru - i := 1; - while gINI.ValueExists('MRU', 'MRU'+IntToStr(i)) do - begin - gINI.DeleteKey('MRU', 'MRU'+IntToStr(i)); - Inc(i); - end; - - //write new mru - for i := 0 to FItems.Count-1 do - gINI.WriteString('MRU', 'MRU'+IntToStr(i+1), FItems[i]); -end; - -procedure TfpgMRU.ItemsChange(Sender: TObject); -var - i: Integer; - NewMenuItem: TfpgMenuItem; - FileName: String; -begin -// writeln('TfpgMRU.ItemsChange'); - if ParentMenuItem <> nil then - begin - ClearParentMenu; - if FItems.Count = 0 then - ParentMenuItem.AddMenuItem('-', '', nil); // add something if we have no previous MRU's - for i := 0 to -1 + FItems.Count do - begin - if ShowFullPath then - FileName := StringReplace(FItems[I], '&', '&&', [rfReplaceAll, rfIgnoreCase]) - else - FileName := StringReplace(ExtractFileName(FItems[i]), '&', '&&', [rfReplaceAll, rfIgnoreCase]); - -// NewMenuItem := ParentMenuItem.AddMenuItem(Format('%s', [FileName]), '', @DoClick); -// NewMenuItem.Tag := i; - NewMenuItem := TMRUMenuItem.Create(ParentMenuItem); - NewMenuItem.Text := Format('%s', [FileName]); - NewMenuItem.Tag := i; - NewMenuItem.OnClick := @DoClick; - end; - end; -end; - -procedure TfpgMRU.ClearParentMenu; -//var -// i:integer; -begin - if Assigned(ParentMenuItem) then - ParentMenuItem.DestroyComponents; -{ - for i := ParentMenuItem.ComponentCount-1 downto 0 do - if ParentMenuItem.Components[i] is TMRUMenuItem then - ParentMenuItem.Delete(i); -} -end; - -procedure TfpgMRU.Loaded; -begin - inherited Loaded; - if not (csDesigning in ComponentState) then -// if FIniFilePath <> '' then - LoadMRU; -end; - -procedure TfpgMRU.Notification(AComponent: TComponent; Operation: TOperation); -begin - inherited Notification(AComponent, Operation); - if (Operation = opRemove) and (AComponent = FParentMenuItem) then - FParentMenuItem := nil; -end; - -procedure TfpgMRU.DoClick(Sender: TObject); -begin - if Assigned(FOnClick) and (Sender is TMRUMenuItem) then - FOnClick(Self, FItems[TMRUMenuItem(Sender).Tag]); -end; - -constructor TfpgMRU.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - FParentMenuItem := nil; - FItems := TStringList.Create; - FItems.OnChange := @ItemsChange; - FMaxItems := 4; - FShowFullPath := True; -// Loaded; -end; - -destructor TfpgMRU.Destroy; -begin - if not (csDesigning in ComponentState) then - SaveMRU; - FItems.OnChange := nil; - FItems.Free; - inherited Destroy; -end; - -procedure TfpgMRU.AddItem(const FileName: string); -begin - if FileName <> '' then - begin - FItems.BeginUpdate; - try - if FItems.IndexOf(FileName) > -1 then - FItems.Delete(FItems.IndexOf(FileName)); - FItems.Insert(0, FileName); - - while FItems.Count > MaxItems do - FItems.Delete(MaxItems); - finally - FItems.EndUpdate; - end; - end; -end; - -function TfpgMRU.RemoveItem(const FileName: string): boolean; -begin - if FItems.IndexOf(FileName) > -1 then - begin - FItems.Delete(FItems.IndexOf(FileName)); - Result := True; - end - else - Result := False; -end; - -end. - diff --git a/src/gui/gui_panel.pas b/src/gui/gui_panel.pas deleted file mode 100644 index 7b988a96..00000000 --- a/src/gui/gui_panel.pas +++ /dev/null @@ -1,754 +0,0 @@ -{ - fpGUI - Free Pascal GUI Toolkit - - Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this - distribution, for details of the copyright. - - See the file COPYING.modifiedLGPL, included in this distribution, - for details about redistributing fpGUI. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - - Description: - Defines a Panel control. Also known as a Bevel or Frame control. - This control can also draw itself like a GroupBox component. -} - -unit gui_panel; - -{$mode objfpc}{$H+} - -interface - -uses - Classes, - SysUtils, - fpg_base, - fpg_main, - fpg_widget; - -type - - TPanelShape = (bsBox, bsFrame, bsTopLine, bsBottomLine, bsLeftLine, - bsRightLine, bsSpacer); - - TPanelStyle = (bsLowered, bsRaised); - - TPanelBorder = (bsSingle, bsDouble); - - - TfpgAbstractPanel = class(TfpgWidget) - private - FPanelShape: TPanelShape; - FPanelStyle: TPanelStyle; - FPanelBorder: TPanelBorder; - function GetClientRect: TfpgRect; override; - procedure SetPanelStyle(const AValue: TPanelStyle); - procedure SetPanelBorder(const AValue: TPanelBorder); - protected - property Style: TPanelStyle read FPanelStyle write SetPanelStyle default bsRaised; - property BorderStyle: TPanelBorder read FPanelBorder write SetPanelBorder default bsSingle; - public - constructor Create(AOwner: TComponent); override; - end; - - - TfpgBevel = class(TfpgAbstractPanel) - private - procedure SetPanelShape(const AValue: TPanelShape); - protected - procedure HandlePaint; override; - published - property BackgroundColor; - property BorderStyle; - property ParentShowHint; - property Shape: TPanelShape read FPanelShape write SetPanelShape default bsBox; - property ShowHint; - property Style; - property OnClick; - property OnDoubleClick; - property OnMouseDown; - property OnMouseUp; - property OnPaint; - end; - - - TfpgPanel = class(TfpgAbstractPanel) - private - FAlignment: TAlignment; - FLayout: TLayout; - FWrapText: boolean; - FLineSpace: integer; - FMargin: integer; - FText: string; - function GetAlignment: TAlignment; - procedure SetAlignment(const AValue: TAlignment); - function GetLayout: TLayout; - procedure SetLayout(const AValue: TLayout); - function GetText: string; - procedure SetText(const AValue: string); - function GetFontDesc: string; - procedure SetFontDesc(const AValue: string); - function GetLineSpace: integer; - procedure SetLineSpace(const AValue: integer); - function GetMargin: integer; - procedure SetMargin(const AValue: integer); - function GetWrapText: boolean; - procedure SetWrapText(const AValue: boolean); - protected - FFont: TfpgFont; - procedure HandlePaint; override; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - property Font: TfpgFont read FFont; - published - property Alignment: TAlignment read GetAlignment write SetAlignment default taCenter; - property BackgroundColor; - property BorderStyle; - property FontDesc: string read GetFontDesc write SetFontDesc; - property Layout: TLayout read GetLayout write SetLayout default tlCenter; - property ParentShowHint; - property ShowHint; - property Style; - property Text: string read GetText write SetText; - property TextColor; - property LineSpace: integer read GetLineSpace write SetLineSpace default 2; - property Margin: integer read GetMargin write SetMargin default 2; - property WrapText: boolean read GetWrapText write SetWrapText default False; - property OnClick; - property OnDoubleClick; - end; - - - TfpgGroupBox = class(TfpgAbstractPanel) - private - FAlignment: TAlignment; - FMargin: integer; - FText: string; - function GetAlignment: TAlignment; - procedure SetAlignment(const AValue: TAlignment); - function GetText: string; - procedure SetText(const AValue: string); - function GetFontDesc: string; - procedure SetFontDesc(const AValue: string); - function GetMargin: integer; - procedure SetMargin(const AValue: integer); - protected - FFont: TfpgFont; - function GetClientRect: TfpgRect; override; - procedure HandlePaint; override; - public - constructor Create(AOwner: TComponent); override; - property Font: TfpgFont read FFont; - published - property Alignment: TAlignment read GetAlignment write SetAlignment default taCenter; - property BackgroundColor; - property BorderStyle; - property FontDesc: string read GetFontDesc write SetFontDesc; - property Style; - property Text: string read GetText write SetText; - property TextColor; - property Margin: integer read GetMargin write SetMargin default 2; - property OnClick; - property OnDoubleClick; - end; - - -function CreateBevel(AOwner: TComponent; ALeft, ATop, AWidth, AHeight: TfpgCoord; AShape: TPanelShape; - AStyle: TPanelStyle): TfpgBevel; - -function CreatePanel(AOwner: TComponent; ALeft, ATop, AWidth, AHeight: TfpgCoord; AText: string; - AStyle: TPanelStyle; AALignment: TAlignment= taCenter; ALayout: TLayout= tlCenter; - AMargin: integer= 2; ALineSpace: integer= 2): TfpgPanel; - -function CreateGroupBox(AOwner: TComponent; ALeft, ATop, AWidth, AHeight: TfpgCoord; AText: string; - AStyle: TPanelStyle; AALignment: TAlignment= taCenter; AMargin: integer= 2): TfpgGroupBox; - - -implementation - -function CreateBevel(AOwner: TComponent; ALeft, ATop, AWidth, AHeight: TfpgCoord; AShape: TPanelShape; - AStyle: TPanelStyle): TfpgBevel; -begin - Result := TfpgBevel.Create(AOwner); - Result.Left := ALeft; - Result.Top := ATop; - Result.Width := AWidth; - Result.Height := AHeight; - Result.Shape := AShape; - Result.Style := AStyle; -end; - -function CreatePanel(AOwner: TComponent; ALeft, ATop, AWidth, AHeight: TfpgCoord; AText: string; - AStyle: TPanelStyle; AALignment: TAlignment= taCenter; ALayout: TLayout= tlCenter; - AMargin: integer= 2; ALineSpace: integer= 2): TfpgPanel; -begin - Result := TfpgPanel.Create(AOwner); - Result.Left := ALeft; - Result.Top := ATop; - Result.Width := AWidth; - Result.Height := AHeight; - Result.FText := AText; - Result.Style := AStyle; - Result.FAlignment:= AAlignment; - Result.FLayout := ALayout; - Result.FMargin := AMargin; - Result.FLineSpace:= ALineSpace; -end; - -function CreateGroupBox(AOwner: TComponent; ALeft, ATop, AWidth, AHeight: TfpgCoord; AText: string; - AStyle: TPanelStyle; AALignment: TAlignment= taCenter; AMargin: integer= 2): TfpgGroupBox; -begin - Result := TfpgGroupBox.Create(AOwner); - Result.Left := ALeft; - Result.Top := ATop; - Result.Width := AWidth; - Result.Height := AHeight; - Result.FText := AText; - Result.Style := AStyle; - Result.FAlignment := AAlignment; - Result.FMargin := AMargin; -end; - - -{TfpgAbstractPanel} - -function TfpgAbstractPanel.GetClientRect: TfpgRect; -begin - Result.SetRect(2, 2, Width - 4, Height - 4); -end; - -procedure TfpgAbstractPanel.SetPanelStyle(const AValue: TPanelStyle); -begin - if FPanelStyle <> AValue then - begin - FPanelStyle := AValue; - Repaint; - end; -end; - -procedure TfpgAbstractPanel.SetPanelBorder(const AValue: TPanelBorder); -begin - if FPanelBorder <> AValue then - begin - FPanelBorder := AValue; - Repaint; - end; -end; - -constructor TfpgAbstractPanel.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - FPanelShape := bsBox; - FPanelStyle := bsRaised; - FPanelBorder := bsSingle; - FWidth := 80; - FHeight := 80; - FFocusable := True; // otherwise children can't get focus - FBackgroundColor := Parent.BackgroundColor; - FIsContainer := True; -end; - -{TfpgBevel} - -procedure TfpgBevel.SetPanelShape(const AValue: TPanelShape); -begin - if FPanelShape <> AValue then - begin - FPanelShape := AValue; - Repaint; - end; -end; - -procedure TfpgBevel.HandlePaint; -begin - inherited HandlePaint; - - Canvas.Clear(BackgroundColor); - - // Canvas.SetLineStyle(2, lsSolid); - // Canvas.SetColor(clWindowBackground); - // Canvas.DrawRectangle(1, 1, Width - 1, Height - 1); - if FPanelBorder = bsSingle then - Canvas.SetLineStyle(1, lsSolid) - else - Canvas.SetLineStyle(2, lsSolid); - - if Style = bsRaised then - Canvas.SetColor(clHilite2) - else - Canvas.SetColor(clShadow2); - - if Shape in [bsBox] then - if FPanelBorder = bsSingle then - Canvas.DrawLine(0, 0, Width - 1, 0) - else - Canvas.DrawLine(0, 1, Width - 1, 1); - if Shape in [bsFrame, bsTopLine] then - Canvas.DrawLine(0, 0, Width - 1, 0); - if Shape in [bsBox] then - if FPanelBorder = bsSingle then - Canvas.DrawLine(0, 1, 0, Height - 1) - else - Canvas.DrawLine(1, 1, 1, Height - 1); - if Shape in [bsFrame, bsLeftLine] then - Canvas.DrawLine(0, 1, 0, Height - 1); - if Shape in [bsFrame, bsRightLine] then - Canvas.DrawLine(Width - 2, 1, Width - 2, Height - 1); - if Shape in [bsFrame, bsBottomLine] then - Canvas.DrawLine(1, Height - 2, Width - 1, Height - 2); - - if Style = bsRaised then - Canvas.SetColor(clShadow2) - else - Canvas.SetColor(clHilite2); - - if Shape in [bsFrame, bsTopLine] then - Canvas.DrawLine(1, 1, Width - 2, 1); - if Shape in [bsFrame, bsLeftLine] then - Canvas.DrawLine(1, 2, 1, Height - 2); - if Shape in [bsBox, bsFrame, bsRightLine] then - Canvas.DrawLine(Width - 1, 0, Width - 1, Height - 1); - if Shape in [bsBox, bsFrame, bsBottomLine] then - Canvas.DrawLine(0, Height - 1, Width, Height - 1); - - // To make it more visible in the UI Designer - if csDesigning in ComponentState then - begin - if Shape in [bsSpacer] then - begin - Canvas.SetColor(clInactiveWgFrame); - Canvas.SetLineStyle(1, lsDash); - Canvas.DrawRectangle(0, 0, Width, Height); -// Canvas.SetTextColor(clText1); -// Canvas.DrawString(2, 2, Name + ': ' + Classname); - end; - end; -end; - -{TfpgPanel} - -function TfpgPanel.GetAlignment: TAlignment; -begin - Result := FAlignment; -end; - -procedure TfpgPanel.SetAlignment(const AValue: TAlignment); -begin - if FAlignment <> AValue then - begin - FAlignment := AValue; - Repaint; - end; -end; - -function TfpgPanel.GetLayout: TLayout; -begin - Result := FLayout; -end; - -procedure TfpgPanel.SetLayout(const AValue: TLayout); -begin - if FLayout <> AValue then - begin - FLayout := AValue; - Repaint; - end; -end; - -function TfpgPanel.GetText: string; -begin - Result := FText; -end; - -procedure TfpgPanel.SetText(const AValue: string); -begin - if FText <> AValue then - begin - FText := AValue; - Repaint; - end; -end; - -function TfpgPanel.GetFontDesc: string; -begin - Result := FFont.FontDesc; -end; - -procedure TfpgPanel.SetFontDesc(const AValue: string); -begin - FFont.Free; - FFont := fpgGetFont(AValue); - Repaint; -end; - -function TfpgPanel.GetLineSpace: integer; -begin - Result := FLineSpace; -end; - -procedure TfpgPanel.SetLineSpace(const AValue: integer); -begin - if FLineSpace <> AValue then - begin - FLineSpace := AValue; - Repaint; - end; -end; - -function TfpgPanel.GetMargin: integer; -begin - Result := FMargin; -end; - -procedure TfpgPanel.SetMargin(const AValue: integer); -begin - if FMargin <> AValue then - begin - FMargin := AValue; - Repaint; - end; -end; - -function Tfpgpanel.GetWrapText: boolean; -begin - Result := FWrapText; -end; - -procedure Tfpgpanel.SetWrapText(const AValue: boolean); -begin - if FWrapText <> AValue then - begin - FWrapText := AValue; - Repaint; - end; -end; -procedure TfpgPanel.HandlePaint; -var - lTxtFlags: TFTextFlags; -begin - inherited HandlePaint; - - Canvas.Clear(BackgroundColor); - - // Canvas.SetLineStyle(2, lsSolid); - // Canvas.SetColor(clWindowBackground); - // Canvas.DrawRectangle(1, 1, Width - 1, Height - 1); - if FPanelBorder = bsSingle then - Canvas.SetLineStyle(1, lsSolid) - else - Canvas.SetLineStyle(2, lsSolid); - - if Style = bsRaised then - Canvas.SetColor(clHilite2) - else - Canvas.SetColor(clShadow2); - - if FPanelBorder = bsSingle then - begin - Canvas.DrawLine(0, 0, Width - 1, 0); - Canvas.DrawLine(0, 1, 0, Height - 1); - end - else - begin - Canvas.DrawLine(0, 1, Width - 1, 1); - Canvas.DrawLine(1, 1, 1, Height - 1); - end; - - if Style = bsRaised then - Canvas.SetColor(clShadow2) - else - Canvas.SetColor(clHilite2); - - Canvas.DrawLine(Width - 1, 0, Width - 1, Height - 1); - Canvas.DrawLine(0, Height - 1, Width, Height - 1); - - Canvas.SetTextColor(FTextColor); - Canvas.SetFont(Font); - - lTxtFlags:= []; - if not Enabled then - Include(lTxtFlags, txtDisabled); - - if FWrapText then - Include(lTxtFlags, txtWrap); - case FAlignment of - taLeftJustify: - Include(lTxtFlags, txtLeft); - taRightJustify: - Include(lTxtFlags, txtRight); - taCenter: - Include(lTxtFlags, txtHCenter); - end; - case FLayout of - tlTop: - Include(lTxtFlags, txtTop); - tlBottom: - Include(lTxtFlags, txtBottom); - tlCenter: - Include(lTxtFlags, txtVCenter); - end; - Canvas.DrawText(FMargin, FMargin, Width - FMargin * 2, Height - FMargin * 2, FText, lTxtFlags, FLineSpace); -end; - -constructor TfpgPanel.Create(Aowner: TComponent); -begin - inherited Create(AOwner); - FText := 'Panel'; - FFont := fpgGetFont('#Label1'); - FPanelShape := bsBox; - FPanelStyle := bsRaised; - FWidth := 80; - FHeight := 80; - FFocusable := True; // otherwise children can't get focus - FBackgroundColor := Parent.BackgroundColor; - FAlignment := taCenter; - FLayout := tlCenter; - FWrapText := False; - FLineSpace := 2; - FMargin := 2; -end; - -destructor TfpgPanel.Destroy; -begin - FText := ''; - FFont.Free; - inherited Destroy; -end; - -{TfpgGroupBox} - -function TfpgGroupBox.GetAlignment: TAlignment; -begin - Result := FAlignment; -end; - -procedure TfpgGroupBox.SetAlignment(const AValue: TAlignment); -begin - if FAlignment <> AValue then - begin - FAlignment := AValue; - Repaint; - end; -end; - -function TfpgGroupBox.GetText: string; -begin - Result := FText; -end; - -procedure TfpgGroupBox.SetText(const AValue: string); -begin - if FText <> AValue then - begin - FText := AValue; - Repaint; - end; -end; - -function TfpgGroupBox.GetFontDesc: string; -begin - Result := FFont.FontDesc; -end; - -procedure TfpgGroupBox.SetFontDesc(const AValue: string); -begin - FFont.Free; - FFont := fpgGetFont(AValue); - Repaint; -end; - -function TfpgGroupBox.GetMargin: integer; -begin - Result := FMargin; -end; - -procedure TfpgGroupBox.SetMargin(const AValue: integer); -begin - if FMargin <> AValue then - begin - FMargin := AValue; - Repaint; - end; -end; - -function TfpgGroupBox.GetClientRect: TfpgRect; -var - h: integer; -begin - h := FFont.Height + 4; - Result.SetRect(2, h, Width - 4, Height - (h + 2)); -end; - -procedure TfpgGroupBox.HandlePaint; -var - r: TfpgRect; - w: integer; - lTxtFlags: TFTextFlags; -begin - inherited HandlePaint; - - Canvas.Clear(Parent.BackgroundColor); - Canvas.ClearClipRect; - r.SetRect(0, 5, Width, Height); - Canvas.SetClipRect(r); - Canvas.Clear(FBackgroundColor); - - lTxtFlags := TextFlagsDflt; - if not Enabled then - Include(lTxtFlags, txtDisabled); - -// Canvas.ClearClipRect; - - // Canvas.SetLineStyle(2, lsSolid); - // Canvas.SetColor(clWindowBackground); - // Canvas.DrawRectangle(1, 1, Width - 1, Height - 1); - if FPanelBorder = bsSingle then - Canvas.SetLineStyle(1, lsSolid) - else - Canvas.SetLineStyle(2, lsSolid); - - if Style = bsRaised then - Canvas.SetColor(clHilite2) - else - Canvas.SetColor(clShadow2); - - if FPanelBorder = bsSingle then - begin - Canvas.DrawLine(0, 5, Width - 1, 5); - Canvas.DrawLine(0, 6, 0, Height - 1); - end - else - begin - Canvas.DrawLine(0, 6, Width - 1, 6); - Canvas.DrawLine(1, 6, 1, Height - 1); - end; - - if Style = bsRaised then - Canvas.SetColor(clShadow2) - else - Canvas.SetColor(clHilite2); - - Canvas.DrawLine(Width - 1, 5, Width - 1, Height - 1); - Canvas.DrawLine(0, Height - 1, Width, Height - 1); - - Canvas.SetTextColor(FTextColor); - Canvas.SetFont(Font); - - case FAlignment of - taLeftJustify: - begin - w := FFont.TextWidth(FText) + FMargin * 2; - r.SetRect(5, 0, w, FFont.Height + FMargin); - Canvas.SetClipRect(r); - Canvas.Clear(FBackgroundColor); - - if Style = bsRaised then - Canvas.SetColor(clHilite2) - else - Canvas.SetColor(clShadow2); - - if FPanelBorder = bsSingle then - begin - Canvas.DrawLine(5, 0, w + 5, 0); - Canvas.DrawLine(5, 0, 5, 6); - end - else - begin - Canvas.DrawLine(5, 1, w + 5, 1); - Canvas.DrawLine(6, 0, 6, 7); - end; - - if Style = bsRaised then - Canvas.SetColor(clShadow2) - else - Canvas.SetColor(clHilite2); - - Canvas.DrawLine(w + 5, 0, w + 5, 6); - Canvas.DrawText(FMargin + 5, 0, FText, lTxtFlags); - end; - taRightJustify: - begin - w := Width - FFont.TextWidth(FText) - (FMargin * 2) - 5; - r.SetRect(w, 0, FFont.TextWidth(FText) + FMargin * 2, FFont.Height + FMargin); - Canvas.SetClipRect(r); - Canvas.Clear(FBackgroundColor); - - if Style = bsRaised then - Canvas.SetColor(clHilite2) - else - Canvas.SetColor(clShadow2); - - if FPanelBorder = bsSingle then - begin - Canvas.DrawLine(w, 0, Width - 5, 0); - Canvas.DrawLine(w, 0, w, 6); - end - else - begin - Canvas.DrawLine(w, 1, Width - 5, 1); - Canvas.DrawLine(w + 1, 0, w + 1, 7); - end; - - if Style = bsRaised then - Canvas.SetColor(clShadow2) - else - Canvas.SetColor(clHilite2); - - Canvas.DrawLine(Width - 6, 0, Width - 6, 6); - Canvas.DrawText(Width - FFont.TextWidth(FText) - FMargin - 5, 0, FText, lTxtFlags); - end; - taCenter: - begin - w := (Width - FFont.TextWidth(FText) - FMargin * 2) div 2; - r.SetRect(w, 0, FFont.TextWidth(FText) + FMargin * 2, FFont.Height + FMargin); - Canvas.SetClipRect(r); - Canvas.Clear(FBackgroundColor); - - if Style = bsRaised then - Canvas.SetColor(clHilite2) - else - Canvas.SetColor(clShadow2); - - if FPanelBorder = bsSingle then - begin - Canvas.DrawLine(w, 0, w + FFont.TextWidth(FText) + FMargin * 2, 0); - Canvas.DrawLine(w, 0, w, 6); - end - else - begin - Canvas.DrawLine(w, 1, w + FFont.TextWidth(FText) + FMargin * 2, 1); - Canvas.DrawLine(w + 1, 0, w + 1, 7); - end; - - if Style = bsRaised then - Canvas.SetColor(clShadow2) - else - Canvas.SetColor(clHilite2); - - Canvas.DrawLine(w + FFont.TextWidth(FText) + FMargin * 2 - 1, 0, w + FFont.TextWidth(FText) + FMargin * 2 - 1, 6); - Canvas.DrawText(w + FMargin, 0, FText, lTxtFlags); - end; - end; -end; - -constructor TfpgGroupBox.Create(Aowner: TComponent); -begin - inherited Create(AOwner); - FText := 'Group box'; - FFont := fpgGetFont('#Label1'); - FPanelShape := bsBox; - FPanelStyle := bsRaised; - FWidth := 80; - FHeight := 80; - FFocusable := True; // otherwise children can't get focus - FBackgroundColor := Parent.BackgroundColor; - FAlignment := taLeftJustify; - FMargin := 2; -end; - -end. - diff --git a/src/gui/gui_popupcalendar.pas b/src/gui/gui_popupcalendar.pas deleted file mode 100644 index a31d2cf1..00000000 --- a/src/gui/gui_popupcalendar.pas +++ /dev/null @@ -1,807 +0,0 @@ -{ - fpGUI - Free Pascal GUI Toolkit - - Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this - distribution, for details of the copyright. - - See the file COPYING.modifiedLGPL, included in this distribution, - for details about redistributing fpGUI. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - - Description: - A calendar component. Soon it would be possible to use it in a - popup windows like Calender Combobox, or directly in a Form. -} - -unit gui_popupcalendar; - -{$mode objfpc}{$H+} - -{.$Define DEBUG} // while developing the component - -{ - *********************************************************** - ********** This is still under development! *********** - *********************************************************** - - It needs lots of testing and debugging. -} - - -{ todo: Support highlighting special days. } -{ todo: Support custom colors. } -{ todo: Must be able to switch the first day of the week. } -{ todo: Create a TfpgDateTimeEdit component with options for Date, Time or Date & Time. } -{ todo: Changing months and checking min/max limits takes into account the - original date, not the selected day in the grid. It should use the - selected day in grid. } -{ todo: Paint previous and next months days in grey. Visiblity of these must - be user selectable. } -{ todo: Paint days out of min/max range in grey. } - -interface - -uses - SysUtils, - Classes, - fpg_base, - fpg_main, - fpg_widget, - fpg_popupwindow, - gui_edit, - gui_button, - gui_combobox, - gui_grid, - gui_dialogs; - -type - - TfpgOnDateSetEvent = procedure(Sender: TObject; const ADate: TDateTime) of object; - - - TfpgPopupCalendar = class(TfpgPopupWindow) - private - {@VFD_HEAD_BEGIN: fpgPopupCalendar} - edtYear: TfpgEdit; - btnYearUp: TfpgButton; - btnYearDown: TfpgButton; - edtMonth: TfpgEdit; - btnMonthUp: TfpgButton; - btnMonthDown: TfpgButton; - btnToday: TfpgButton; - grdName1: TfpgStringGrid; - {@VFD_HEAD_END: fpgPopupCalendar} - FMonthOffset: integer; - FDate: TDateTime; - FMaxDate: TDateTime; - FMinDate: TDateTime; - FCallerWidget: TfpgWidget; - FOnValueSet: TfpgOnDateSetEvent; - FCloseOnSelect: boolean; - function GetDateElement(Index: integer): Word; - procedure PopulateDays; - procedure CalculateMonthOffset; - function CalculateCellDay(const ACol, ARow: Integer): Integer; - procedure SetDateElement(Index: integer; const AValue: Word); - procedure SetDateValue(const AValue: TDateTime); - procedure SetMaxDate(const AValue: TDateTime); - procedure SetMinDate(const AValue: TDateTime); - procedure SetCloseOnSelect(const AValue: boolean); - procedure UpdateCalendar; - procedure btnYearUpClicked(Sender: TObject); - procedure btnYearDownClicked(Sender: TObject); - procedure btnMonthUpClicked(Sender: TObject); - procedure btnMonthDownClicked(Sender: TObject); - procedure btnTodayClicked(Sender: TObject); - procedure grdName1DoubleClick(Sender: TObject; AButton: TMouseButton; AShift: TShiftState; const AMousePos: TPoint); - procedure grdName1KeyPress(Sender: TObject; var KeyCode: word; var ShiftState: TShiftState; var Consumed: boolean); - procedure TearDown; - protected - FOrigFocusWin: TfpgWidget; - procedure HandlePaint; override; - procedure HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override; - procedure HandleShow; override; - procedure HandleHide; override; - property CallerWidget: TfpgWidget read FCallerWidget write FCallerWidget; - public - constructor Create(AOwner: TComponent; AOrigFocusWin: TfpgWidget); reintroduce; - procedure AfterCreate; - property CloseOnSelect: boolean read FCloseOnSelect write SetCloseOnSelect default True; - property Day: Word index 1 read GetDateElement write SetDateElement; - property Month: Word index 2 read GetDateElement write SetDateElement; - property Year: Word index 3 read GetDateElement write SetDateElement; - property OnValueSet: TfpgOnDateSetEvent read FOnValueSet write FOnValueSet; - published - property DateValue: TDateTime read FDate write SetDateValue; - property MinDate: TDateTime read FMinDate write SetMinDate; - property MaxDate: TDateTime read FMaxDate write SetMaxDate; - end; - - - TfpgCalendarCombo = class(TfpgBaseStaticCombo) - private - FDate: TDateTime; - FDateFormat: string; - FMaxDate: TDateTime; - FMinDate: TDateTime; - FCloseOnSelect: boolean; - procedure InternalOnValueSet(Sender: TObject; const ADate: TDateTime); - procedure SetDateFormat(const AValue: string); - procedure SetDateValue(const AValue: TDateTime); - procedure SetMaxDate(const AValue: TDateTime); - procedure SetMinDate(const AValue: TDateTime); - procedure SetText(const AValue: string); override; - function GetText: string; override; - procedure SetCloseOnSelect(const AValue: boolean); - protected - function HasText: boolean; override; - procedure DoDropDown; override; - public - constructor Create(AOwner: TComponent); override; - published - property BackgroundColor; - property DateFormat: string read FDateFormat write SetDateFormat; - property DateValue: TDateTime read FDate write SetDateValue; - property FontDesc; - property MinDate: TDateTime read FMinDate write SetMinDate; - property MaxDate: TDateTime read FMaxDate write SetMaxDate; - property ParentShowHint; - property ShowHint; - { Clicking on calendar Today button will close the popup calendar by default } - property CloseOnSelect: boolean read FCloseOnSelect write SetCloseOnSelect default True; - property TabOrder; - property OnChange; - property OnCloseUp; - property OnDropDown; - end; - -{@VFD_NEWFORM_DECL} - -implementation - -uses - gui_scrollbar, - fpg_constants; - - -{@VFD_NEWFORM_IMPL} - -procedure TfpgPopupCalendar.PopulateDays; -var - r, c: integer; - lCellDay: Integer; -begin - grdName1.BeginUpdate; - for r := -1 to 5 do - for c := 0 to 6 do - begin - if r = -1 then - grdName1.ColumnTitle[c] := ShortDayNames[c+1] // ShortDayNames is 1-based indexing - else - begin - lCellDay := CalculateCellDay(c, r); - if lCellDay = -1 then - grdName1.Cells[c, r] := '' - else - grdName1.Cells[c, r] := IntToStr(lCellDay); - end; - end; - grdName1.EndUpdate; -end; - -procedure TfpgPopupCalendar.grdName1DoubleClick(Sender: TObject; - AButton: TMouseButton; AShift: TShiftState; const AMousePos: TPoint); -begin - TearDown; -end; - -procedure TfpgPopupCalendar.grdName1KeyPress(Sender: TObject; - var KeyCode: word; var ShiftState: TShiftState; var Consumed: boolean); -begin - // Pass the grid event on to the TfpgPopupCalender instance. - HandleKeyPress(KeyCode, ShiftState, consumed); - Consumed := True; -end; - -procedure TfpgPopupCalendar.TearDown; -var - lD: Word; - s: string; - d: TDateTime; -begin - s := grdName1.Cells[grdName1.FocusCol, grdName1.FocusRow]; - if s = '' then - Exit; //==> - lD := StrToInt(s); - d := EncodeDate(Year, Month, lD); - if (d >= FMinDate) and (d <= FMaxDate) then - begin - DateValue := d; - if Assigned(OnValueSet) then - OnValueSet(self, DateValue); - {$IFDEF DEBUG} - writeln('Selected date: ', FormatDateTime('yyyy-mm-dd', DateValue)); - {$ENDIF} - if CloseOnSelect then - Close; - end; -end; - -function TfpgPopupCalendar.GetDateElement(Index: integer): Word; -var - lD, lM, lY: Word; -begin - DecodeDate(FDate, lY, lM, lD); - case Index of - 1: Result := lD; - 2: Result := lM; - 3: Result := lY; - end; -end; - -procedure TfpgPopupCalendar.CalculateMonthOffset; -var - lD, lM, lY: Word; - lTheFirst: TDateTime; -begin - DecodeDate(FDate, lY, lM, lD); - lTheFirst := EncodeDate(lY, lM, 1); - FMonthOffset := 2 - DayOfWeek(lTheFirst); -end; - -function TfpgPopupCalendar.CalculateCellDay(const ACol, ARow: Integer): Integer; -begin - Result := FMonthOffset + ACol + ARow * 7; - if (Result < 1) or (Result > MonthDays[IsLeapYear(Year), Month]) then - Result := -1; -end; - -procedure TfpgPopupCalendar.SetDateElement(Index: integer; const AValue: Word); -var - lD, lM, lY: Word; - lDate: TDateTime; -begin - if AValue > 0 then - begin - DecodeDate(FDate, lY, lM, lD); - case Index of - 1: lD := AValue; - 2: lM := AValue; - 3: lY := AValue; - end; - try - lDate := EncodeDate(lY, lM, lD); - SetDateValue(lDate); - except - // do nothing! Not nice? - end; - end; -end; - -procedure TfpgPopupCalendar.SetDateValue(const AValue: TDateTime); -begin - if FDate = AValue then - Exit; //==> - - if (trunc(FDate) >= trunc(FMinDate)) then - {$IFDEF DEBUG} - writeln('Passed min test') - {$ENDIF} - else - exit; - - if (FDate <= FMaxDate) then - {$IFDEF DEBUG} - writeln('Passed max test') - {$ENDIF} - else - exit; - - {$IFDEF DEBUG} writeln('SetDateValue: ', FormatDateTime('yyyy-mm-dd', AValue)); {$ENDIF} - FDate := AValue; - UpdateCalendar; -end; - -procedure TfpgPopupCalendar.SetMaxDate(const AValue: TDateTime); -begin - if FMaxDate = AValue then - Exit; //==> - FMaxDate := AValue; - - // correct min/max values - if FMinDate > AValue then - FMinDate := IncMonth(AValue, -12); // one year less - - if FDate > FMaxDate then - begin - FDate := FMaxDate; - UpdateCalendar; - end; -end; - -procedure TfpgPopupCalendar.SetMinDate(const AValue: TDateTime); -begin - if FMinDate = AValue then - Exit; //==> - FMinDate := AValue; - - // correct min/max values - if AValue > FMaxDate then - FMaxDate := IncMonth(AValue, 12); // one year more - - if FDate < FMinDate then - begin - FDate := FMinDate; - UpdateCalendar; - end; -end; - -procedure TfpgPopupCalendar.SetCloseOnSelect(const AValue: boolean); -begin - if FCloseOnSelect = AValue then - Exit; - FCloseOnSelect := AValue; -end; - -procedure TfpgPopupCalendar.UpdateCalendar; -var - lD, lM, lY: Word; -begin - if (FDate >= FMinDate) and (FDate <= FMaxDate) then - begin - CalculateMonthOffset; - PopulateDays; - edtYear.Text := IntToStr(Year); - edtMonth.Text := LongMonthNames[Month]; - DecodeDate(FDate, lY, lM, lD); - - grdName1.FocusCol := (lD - FMonthOffset) mod 7{ + 1}; - grdName1.FocusRow := (lD - FMonthOffset) div 7{ + 1}; - end; -end; - -procedure TfpgPopupCalendar.btnYearUpClicked(Sender: TObject); -var - d: TDateTime; -begin - d := IncMonth(FDate, 12); - if d <= FMaxDate then - DateValue := d; -end; - -procedure TfpgPopupCalendar.btnYearDownClicked(Sender: TObject); -var - d: TDateTime; -begin - d := IncMonth(FDate, -12); - if d >= FMinDate then - DateValue := d; -end; - -procedure TfpgPopupCalendar.btnMonthUpClicked(Sender: TObject); -var - d: TDateTime; -begin - d := IncMonth(FDate); - if d <= FMaxDate then - DateValue := d; -end; - -procedure TfpgPopupCalendar.btnMonthDownClicked(Sender: TObject); -var - d: TDateTime; -begin - d := IncMonth(FDate, -1); - if d >= FMinDate then - DateValue := d; -end; - -procedure TfpgPopupCalendar.btnTodayClicked(Sender: TObject); -begin - if Now >= FMinDate then - begin - DateValue := Now; - TearDown; - end; -end; - -procedure TfpgPopupCalendar.HandlePaint; -begin - Canvas.BeginDraw; - inherited HandlePaint; - if PopupFrame then - Canvas.SetClipRect(fpgRect(1, 1, Width-2, Height-2)); - Canvas.Clear(clWindowBackground); - Canvas.ClearClipRect; - Canvas.EndDraw; -end; - -procedure TfpgPopupCalendar.HandleKeyPress(var keycode: word; - var shiftstate: TShiftState; var consumed: boolean); -begin - case keycode of - keyUp: - begin - if (ssCtrl in shiftstate) then - begin - btnYearUpClicked(nil); // Ctrl+Up Arrow - consumed := True; - end; - end; - keyDown: - begin - if (ssCtrl in shiftstate) then - begin - btnYearDownClicked(nil); // Ctrl+Down Arrow - consumed := True; - end; - end; - keyLeft: - begin - if (ssCtrl in shiftstate) then - begin - btnMonthDownClicked(nil); // Ctrl+Left Arrow - consumed := True; - end; - end; - keyRight: - begin - if (ssCtrl in shiftstate) then - begin - btnMonthUpClicked(nil); // Ctrl+Right Arrow - consumed := True; - end; - end; - keyPageUp: - begin - if (ssCtrl in shiftstate) then - btnYearUpClicked(nil) // Ctrl+PageUp - else - btnMonthUpClicked(nil); // PageUp - consumed := True; - end; - keyPageDown: - begin - if (ssCtrl in shiftstate) then - btnYearDownClicked(nil) // Ctrl+PageDown - else - btnMonthDownClicked(nil); // PageDown - consumed := True; - end; - end; - - if not consumed then - begin - if keycode = keyEnter then - begin - consumed := True; - TearDown; - end - else if keycode = keyEscape then - begin - consumed := True; - Close; - end; - end; - - if not consumed then - inherited HandleKeyPress(keycode, shiftstate, consumed); -end; - -procedure TfpgPopupCalendar.HandleShow; -begin - inherited HandleShow; - grdName1.SetFocus; - {$IFDEF DEBUG} - writeln('Min: ', FormatDateTime('yyyy-mm-dd', MinDate), - ' Max: ', FormatDateTime('yyyy-mm-dd', MaxDate)); - {$ENDIF} -end; - -procedure TfpgPopupCalendar.HandleHide; -begin - FocusRootWidget := FOrigFocusWin; - FOrigFocusWin := nil; - inherited HandleHide; - if Assigned(FocusRootWidget) then - FocusRootWidget.SetFocus; -end; - -constructor TfpgPopupCalendar.Create(AOwner: TComponent; AOrigFocusWin: TfpgWidget); -begin - inherited Create(AOwner); - FOrigFocusWin := AOrigFocusWin; - AfterCreate; - FDate := Date; - FMonthOffset := 0; - FCloseOnSelect := True; - UpdateCalendar; -end; - -procedure TfpgPopupCalendar.AfterCreate; -begin - {@VFD_BODY_BEGIN: fpgPopupCalendar} - Name := 'fpgPopupCalendar'; - SetPosition(285, 249, 233, 142); -// WindowTitle := 'fpgPopupCalendar'; -// Sizeable := False; -// WindowPosition := wpUser; - - edtYear := TfpgEdit.Create(self); - with edtYear do - begin - Name := 'edtYear'; - SetPosition(0, 0, 52, 22); - Text := ''; - FontDesc := '#Edit1'; - Focusable := False; - BorderStyle := ebsSingle; - end; - - btnYearUp := TfpgButton.Create(self); - with btnYearUp do - begin - Name := 'btnYearUp'; - SetPosition(52, 0, 13, 11); - Text := ''; - Embedded := True; - FontDesc := '#Label1'; - ImageMargin := 0; - ImageName := 'sys.sb.up'; - Focusable := False; - OnClick := @btnYearUpClicked; - end; - - btnYearDown := TfpgButton.Create(self); - with btnYearDown do - begin - Name := 'btnYearDown'; - SetPosition(52, 11, 13, 11); - Text := ''; - Embedded := True; - FontDesc := '#Label1'; - ImageMargin := 0; - ImageName := 'sys.sb.down'; - Focusable := False; - OnClick := @btnYearDownClicked; - end; - - edtMonth := TfpgEdit.Create(self); - with edtMonth do - begin - Name := 'edtMonth'; - SetPosition(65, 0, 115, 22); - Text := ''; - FontDesc := '#Edit1'; - Focusable := False; - BorderStyle := ebsSingle; - end; - - btnMonthUp := TfpgButton.Create(self); - with btnMonthUp do - begin - Name := 'btnMonthUp'; - SetPosition(180, 0, 13, 11); - Text := ''; - Embedded := True; - FontDesc := '#Label1'; - ImageMargin := 0; - ImageName := 'sys.sb.up'; - Focusable := False; - OnClick := @btnMonthUpClicked; - end; - - btnMonthDown := TfpgButton.Create(self); - with btnMonthDown do - begin - Name := 'btnMonthDown'; - SetPosition(180, 11, 13, 11); - Text := ''; - Embedded := True; - FontDesc := '#Label1'; - ImageMargin := 0; - ImageName := 'sys.sb.down'; - Focusable := False; - OnClick := @btnMonthDownClicked; - end; - - btnToday := TfpgButton.Create(self); - with btnToday do - begin - Name := 'btnToday'; - SetPosition(194, 0, 40, 22); - Text := 'Today'; - FontDesc := '#Label1'; - Focusable := True; - OnClick := @btnTodayClicked; - end; - - grdName1 := TfpgStringGrid.Create(self); - with grdName1 do - begin - Name := 'grdName1'; - SetPosition(0, 23, 233, 119); - AddColumn('Sun', 33, taCenter); - AddColumn('Mon', 32, taCenter); - AddColumn('Tue', 33, taCenter); - AddColumn('Wed', 32, taCenter); - AddColumn('Thu', 33, taCenter); - AddColumn('Fri', 32, taCenter); - AddColumn('Sat', 33, taCenter); - FontDesc := '#Grid'; - HeaderFontDesc := '#GridHeader'; - RowCount := 6; - ScrollBarStyle := ssNone; - OnDoubleClick := @grdName1DoubleClick; - OnKeyPress := @grdName1KeyPress; - end; - - {@VFD_BODY_END: fpgPopupCalendar} -{ - // Setup localization - // UI Designer doesn't support resource strings yet! - grdName1.ColumnTitle[0] := rsShortSun; - grdName1.ColumnTitle[1] := rsShortMon; - grdName1.ColumnTitle[2] := rsShortTue; - grdName1.ColumnTitle[3] := rsShortWed; - grdName1.ColumnTitle[4] := rsShortThu; - grdName1.ColumnTitle[5] := rsShortFri; - grdName1.ColumnTitle[6] := rsShortSat; -} - btnToday.Text := rsToday; -end; - - -{ TfpgCalendarCombo } - -procedure TfpgCalendarCombo.SetDateValue(const AValue: TDateTime); -begin - if FDate = AValue then - Exit; //==> - FDate := AValue; - RePaint; -end; - -procedure TfpgCalendarCombo.SetMaxDate(const AValue: TDateTime); -begin - if FMaxDate = AValue then - Exit; //==> - FMaxDate := AValue; - - // correct min/max values - if FMinDate > AValue then - FMinDate := IncMonth(AValue, -12); // one year less - - if FDate > FMaxDate then - begin - FDate := FMaxDate; - Repaint; - end; -end; - -procedure TfpgCalendarCombo.SetMinDate(const AValue: TDateTime); -begin - if FMinDate = AValue then - Exit; //==> - FMinDate := AValue; - - // correct min/max values - if AValue > FMaxDate then - FMaxDate := IncMonth(AValue, 12); // one year more - - if FDate < FMinDate then - begin - FDate := FMinDate; - Repaint; - end; -end; - -procedure TfpgCalendarCombo.SetText(const AValue: string); -begin - try - FDate := StrToDateTime(AValue); - except - on E: Exception do - begin - ShowMessage(E.Message); - end; - end; -end; - -function TfpgCalendarCombo.GetText: string; -begin - Result := FormatDateTime(FDateFormat, FDate); -end; - -procedure TfpgCalendarCombo.SetCloseOnSelect(const AValue: boolean); -begin - if FCloseOnSelect = AValue then - Exit; //==> - FCloseOnSelect := AValue; -end; - -function TfpgCalendarCombo.HasText: boolean; -begin - Result := FDate >= FMinDate; -end; - -constructor TfpgCalendarCombo.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - FMinDate := EncodeDate(1900, 01, 01); - FMaxDate := EncodeDate(2100, 01, 31); - FDate := Now; - FCloseOnSelect := True; - DateFormat := ShortDateFormat; -end; - -procedure TfpgCalendarCombo.InternalOnValueSet(Sender: TObject; - const ADate: TDateTime); -begin - DateValue := ADate; - if Assigned(OnChange) then - OnChange(self); - {$IFDEF DEBUG} - writeln('New value: ', FormatDateTime(FDateFormat, ADate)); - {$ENDIF} -end; - -procedure TfpgCalendarCombo.SetDateFormat(const AValue: string); -var - OldFormat: string; -begin - if FDateFormat = AValue then - Exit; //==> - OldFormat := FDateFormat; - FDateFormat := AValue; - try - FormatDateTime(FDateFormat, FDate); - RePaint; - except - on E: Exception do - begin - FDateFormat := OldFormat; - fpgApplication.HandleException(self); - end; - end; -end; - -procedure TfpgCalendarCombo.DoDropDown; -var - ddw: TfpgPopupCalendar; -begin - if (not Assigned(FDropDown)) or (not FDropDown.HasHandle) then - begin - FDropDown := TfpgPopupCalendar.Create(nil, FocusRootWidget); - ddw := TfpgPopupCalendar(FDropDown); - ddw.DontCloseWidget := self; - { Set to false CloseOnSelect to leave opened popup calendar menu } - ddw.CloseOnSelect := CloseOnSelect; - ddw.CallerWidget := self; - - if Assigned(OnDropDown) then - OnDropDown(self); - - ddw.MinDate := FMinDate; - ddw.MaxDate := FMaxDate; - ddw.DateValue := FDate; - ddw.ShowAt(Parent, Left, Top+Height); - { I added this call to UpdateCalendar because sometimes after - btnTodayClicked event, reopeing the dropdown menu gave an empty calendar } - ddw.UpdateCalendar; //slapshot - ddw.PopupFrame := True; - ddw.OnValueSet := @InternalOnValueSet; - ddw.OnClose := @InternalOnClose; - end - else - begin - FBtnPressed := False; - FDropDown.Close; - FreeAndNil(FDropDown); - end; -end; - -end. diff --git a/src/gui/gui_progressbar.pas b/src/gui/gui_progressbar.pas deleted file mode 100644 index 14619bee..00000000 --- a/src/gui/gui_progressbar.pas +++ /dev/null @@ -1,227 +0,0 @@ -{ - fpGUI - Free Pascal GUI Toolkit - - Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this - distribution, for details of the copyright. - - See the file COPYING.modifiedLGPL, included in this distribution, - for details about redistributing fpGUI. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - - Description: - Defines a component for a progress bar. -} - -unit gui_progressbar; - -{$mode objfpc}{$H+} - -interface - -uses - Classes, - SysUtils, - fpg_base, - fpg_main, - fpg_widget; - -type - TfpgCustomProgressBar = class(TfpgWidget) - private - FMax: longint; - FMin: longint; - FPosition: longint; - FShowCaption: boolean; - FStep: longint; - FFont: TfpgFont; - procedure SetMax(const AValue: longint); - procedure SetMin(const AValue: longint); - procedure SetPBPosition(const AValue: longint); - procedure SetShowCaption(const AValue: boolean); - procedure SetStep(const AValue: longint); - protected - procedure HandlePaint; override; - property Max: longint read FMax write SetMax default 100; - property Min: longint read FMin write SetMin default 0; - property Position: longint read FPosition write SetPBPosition default 0; - property Step: longint read FStep write SetStep; -// property FontName: string read GetFontName write SetFontName; - property ShowCaption: boolean read FShowCaption write SetShowCaption default False; - public - constructor Create(AOwner: TComponent); override; - procedure StepIt; - procedure StepBy(AStep: integer); - property Font: TfpgFont read FFont; - end; - - - TfpgProgressBar = class(TfpgCustomProgressBar) - published - property BackgroundColor default $c4c4c4; - property ShowCaption; - property Max; - property Min; - property ParentShowHint; - property Position; - property ShowHint; - property Step; - property TextColor; - end; - - -implementation - - -{ TfpgCustomProgressBar } - -procedure TfpgCustomProgressBar.SetMax(const AValue: longint); -begin - if FMax = AValue then - Exit; //==> - - // correct wrong inputs - if FMin > AValue then - FMin := AValue - 1; - if FPosition > AValue then - FPosition := AValue; - - FMax := AValue; - RePaint; -end; - -procedure TfpgCustomProgressBar.SetMin(const AValue: longint); -begin - if FMin = AValue then - Exit; //==> - - // correct wrong inputs - if AValue > FPosition then - FPosition := AValue; - if AValue > FMax then - FMax := AValue+1; - - FMin := AValue; - RePaint; -end; - -procedure TfpgCustomProgressBar.SetPBPosition(const AValue: longint); -begin - if FPosition = AValue then - Exit; //==> - - // correct limits - if AValue < Min then - FPosition := Min - else if AValue > Max then - FPosition := Max - else - FPosition := AValue; - - RePaint; -end; - -procedure TfpgCustomProgressBar.SetShowCaption(const AValue: boolean); -begin - if FShowCaption = AValue then - Exit; //==> - FShowCaption := AValue; - RePaint; -end; - -procedure TfpgCustomProgressBar.SetStep(const AValue: longint); -begin - if AValue < 1 then - Exit; //==> - if FStep = AValue then - Exit; //==> - FStep := AValue; -end; - -procedure TfpgCustomProgressBar.HandlePaint; -var - r: TfpgRect; - diff: integer; - aPos: integer; // absolute position - pos: integer; - percent: integer; - txt: string; - x: TfpgCoord; - y: TfpgCoord; -begin - inherited HandlePaint; - Canvas.ClearClipRect; - r.SetRect(0, 0, Width, Height); - - Canvas.Clear(BackgroundColor); -// Canvas.SetColor(clInactiveWgFrame); - - // calculate position - diff := Max - Min; // diff.. - aPos := Position - Min; // absolute position - percent := round(((100 / diff) * aPos)); - txt := IntToStr(percent) + '%'; - pos := round(percent * (Width-2) / 100); - - // Bluecurve theme :) - // outer dark border - Canvas.SetColor(TfpgColor($999999)); - Canvas.SetLineStyle(1, lsSolid); - Canvas.DrawRectangle(r); - InflateRect(r, -1, -1); - r.Width := pos; - if FPosition > 0 then - begin - // left top - Canvas.SetColor(TfpgColor($98b2ed)); - Canvas.DrawLine(r.Left, r.Bottom, r.Left, r.Top); // left - Canvas.DrawLine(r.Left, r.Top, r.Right, r.Top); // top - // right bottom - Canvas.SetColor(TfpgColor($3b4c71)); - Canvas.DrawLine(r.Right, r.Top, r.Right, r.Bottom); // right - Canvas.DrawLine(r.Right, r.Bottom, r.Left, r.Bottom); // bottom - // inside gradient fill - InflateRect(r, -1, -1); - Canvas.GradientFill(r, TfpgColor($425d9b), TfpgColor($97b0e8), gdVertical); - end; - // paint percentage if required - if FShowCaption then - begin - x := (Width - FFont.TextWidth(txt)) div 2; - y := (Height - FFont.Height) div 2; - Canvas.SetTextColor(TextColor); - Canvas.Font := FFont; - Canvas.DrawString(x, y, txt); - end; -end; - -constructor TfpgCustomProgressBar.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - Focusable := False; - Width := 150; - Height := 22; - FMin := 0; - FMax := 100; - FStep := 1; - FPosition := 0; - FBackgroundColor := TfpgColor($c4c4c4); // clListBox; - FTextColor := Parent.TextColor; - FShowCaption := False; - FFont := fpgStyle.DefaultFont; -end; - -procedure TfpgCustomProgressBar.StepIt; -begin - Position := Position + Step; -end; - -procedure TfpgCustomProgressBar.StepBy(AStep: integer); -begin - Position := Position + AStep; -end; - -end. - diff --git a/src/gui/gui_radiobutton.pas b/src/gui/gui_radiobutton.pas deleted file mode 100644 index 33322a26..00000000 --- a/src/gui/gui_radiobutton.pas +++ /dev/null @@ -1,377 +0,0 @@ -{ - fpGUI - Free Pascal GUI Toolkit - - Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this - distribution, for details of the copyright. - - See the file COPYING.modifiedLGPL, included in this distribution, - for details about redistributing fpGUI. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - - Description: - Defines a Radio Button control. -} - -unit gui_radiobutton; - -{$mode objfpc}{$H+} - -interface - -uses - Classes, - SysUtils, - fpg_base, - fpg_main, - fpg_widget; - -type - - { TfpgRadioButton } - - TfpgRadioButton = class(TfpgWidget) - private - FAutoSize: boolean; - FChecked: boolean; - FFont: TfpgFont; - FGroupIndex: integer; - FOnChange: TNotifyEvent; - FText: string; - FBoxSize: integer; - FIsPressed: boolean; - function GetFontDesc: string; - procedure SetAutoSize(const AValue: boolean); - procedure SetChecked(const AValue: boolean); - procedure SetFontDesc(const AValue: string); - procedure SetText(const AValue: string); - procedure DoAdjustWidth; - protected - procedure HandlePaint; override; - procedure HandleLMouseDown(x, y: integer; shiftstate: TShiftState); override; - procedure HandleLMouseUp(x, y: integer; shiftstate: TShiftState); override; - procedure HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override; - procedure HandleKeyRelease(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override; - function FindNeighbour(direction: TFocusSearchDirection): TfpgRadioButton; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - property Font: TfpgFont read FFont; - published - property AutoSize: boolean read FAutoSize write SetAutoSize default False; - property BackgroundColor; - property Checked: boolean read FChecked write SetChecked default False; - property FontDesc: string read GetFontDesc write SetFontDesc; - property GroupIndex: integer read FGroupIndex write FGroupIndex; - property ParentShowHint; - property ShowHint; - property TabOrder; - property Text: string read FText write SetText; - property TextColor; - property OnChange: TNotifyEvent read FOnChange write FOnChange; - end; - - -function CreateRadioButton(AOwner: TComponent; x, y: TfpgCoord; AText: string): TfpgRadioButton; - - -implementation - - -function CreateRadioButton(AOwner: TComponent; x, y: TfpgCoord; AText: string): TfpgRadioButton; -begin - Result := TfpgRadioButton.Create(AOwner); - Result.Top := y; - Result.Left := x; - Result.Text := AText; - Result.Width := Result.Font.TextWidth(Result.Text) + 24; -end; - -{ TfpgRadioButton } - -function TfpgRadioButton.GetFontDesc: string; -begin - Result := FFont.FontDesc; -end; - -procedure TfpgRadioButton.SetAutoSize(const AValue: boolean); -begin - if FAutoSize = AValue then - Exit; //==> - FAutoSize := AValue; - if FAutoSize then - DoAdjustWidth; - Repaint; -end; - -procedure TfpgRadioButton.SetChecked(const AValue: boolean); -var - i: integer; - wg: TfpgWidget; -begin - if FChecked = AValue then - Exit; //==> - FChecked := AValue; - - // Clear other radio buttons in the same group - if FChecked and (Parent <> nil) then - begin - for i := 0 to Parent.ComponentCount-1 do - if (Parent.Components[i] is TfpgWidget) then - begin - wg := TfpgWidget(Parent.Components[i]); - if (wg <> nil) and (wg <> self) and (wg is TfpgRadioButton) and - (TfpgRadioButton(wg).GroupIndex = GroupIndex) then - begin - TfpgRadioButton(wg).Checked := False; - end; - end; { if } - end; { if } - - RePaint; - - if Assigned(FOnChange) then - FOnChange(self); -end; - -procedure TfpgRadioButton.SetFontDesc(const AValue: string); -begin - FFont.Free; - FFont := fpgGetFont(AValue); - RePaint; -end; - -procedure TfpgRadioButton.SetText(const AValue: string); -begin - if FText = AValue then - Exit; //==> - FText := AValue; - if AutoSize then - DoAdjustWidth; - RePaint; -end; - -procedure TfpgRadioButton.DoAdjustWidth; -begin - if AutoSize then - begin - Width := Font.TextWidth(FText) + 24; // 24 is extra padding for image - UpdateWindowPosition; - end; -end; - -procedure TfpgRadioButton.HandlePaint; -var - r: TfpgRect; - ty: integer; - tx: integer; - img: TfpgImage; - ix: integer; -begin - inherited HandlePaint; - - Canvas.SetColor(FBackgroundColor); - Canvas.FillRectangle(0, 0, Width, Height); - Canvas.SetFont(Font); - - if FFocused then - begin - Canvas.SetColor(clText1); - Canvas.SetLineStyle(1, lsDot); - Canvas.DrawRectangle(1, 1, Width-2, Height-2); - end; - Canvas.SetLineStyle(1, lsSolid); - - r.SetRect(2, (Height div 2) - (FBoxSize div 2), FBoxSize, FBoxSize); - if r.top < 0 then - r.top := 0; - - // calculate which image to paint. - if Enabled then - begin - ix := Ord(FChecked); - if FIsPressed then - Inc(ix, 2); - end - else - ix := (2 + (Ord(FChecked) * 2)) - Ord(FChecked); - - // paint the radio button - tx := r.right + 8; - inc(r.left, 2); - inc(r.top, 1); - img := fpgImages.GetImage('sys.radiobuttons'); // Do NOT localize - Canvas.DrawImagePart(r.Left, r.Top, img, ix*12, 0, 12, 12); - - ty := (Height div 2) - (Font.Height div 2); - if ty < 0 then - ty := 0; - Canvas.SetTextColor(FTextColor); - fpgStyle.DrawString(Canvas, tx, ty, FText, Enabled); -end; - -procedure TfpgRadioButton.HandleLMouseDown(x, y: integer; - shiftstate: TShiftState); -begin - inherited HandleLMouseDown(x, y, shiftstate); - FIsPressed := True; - Repaint; -end; - -procedure TfpgRadioButton.HandleLMouseUp(x, y: integer; shiftstate: TShiftState); -begin - inherited HandleLMouseUp(x, y, shiftstate); - FIsPressed := False; - if not FChecked then - Checked := true - else - RePaint; -end; - -procedure TfpgRadioButton.HandleKeyPress(var keycode: word; - var shiftstate: TShiftState; var consumed: boolean); -var - nbr: TfpgRadioButton; -begin - case keycode of - keyUp, keyLeft: - begin - consumed := True; - nbr := FindNeighbour(fsdPrev); - if nbr = Self then - nbr := FindNeighbour(fsdLast); - nbr.SetFocus; - nbr.Checked := True; - end; - keyDown, keyRight: - begin - consumed := True; - nbr := FindNeighbour(fsdNext); - if nbr = Self then - nbr := FindNeighbour(fsdFirst); - nbr.SetFocus; - nbr.Checked := True; - end; - end; - - if consumed then - Exit; //==> - - inherited HandleKeyPress(keycode, shiftstate, consumed); -end; - -procedure TfpgRadioButton.HandleKeyRelease(var keycode: word; - var shiftstate: TShiftState; var consumed: boolean); -begin - if (keycode = keySpace) then - begin - consumed := True; - Checked := true; - end; - - if consumed then - Exit; //==> - - inherited HandleKeyRelease(keycode, shiftstate, consumed); -end; - -function TfpgRadioButton.FindNeighbour(direction: TFocusSearchDirection): TfpgRadioButton; -var - i: integer; - wg: TfpgWidget; - bestdtab: integer; - FoundIt: boolean; -begin - Result := Self; - if (Parent <> nil) then - begin - FoundIt := False; - if direction in [fsdLast, fsdPrev] then - bestdtab := Low(integer) - else - bestdtab := High(integer); - - for i := 0 to Parent.ComponentCount-1 do - begin - if (Parent.Components[i] is TfpgWidget) then - begin - wg := TfpgWidget(Parent.Components[i]); - if (wg <> nil) and (wg is TfpgRadioButton) and - wg.Visible and wg.Enabled and wg.Focusable and - (TfpgRadioButton(wg).GroupIndex = GroupIndex) then - begin - case direction of - fsdFirst: - if (wg.TabOrder < bestdtab) then - begin - Result := TfpgRadioButton(wg); - bestdtab := wg.TabOrder; - end; - - fsdLast: - if (wg.TabOrder >= bestdtab) then - begin - Result := TfpgRadioButton(wg); - bestdtab := wg.TabOrder; - end; - - fsdNext: - if wg = Self then - FoundIt := True - else - begin - if ((wg.TabOrder > Self.TabOrder) and (wg.TabOrder < bestdtab)) or - ((wg.TabOrder = Self.TabOrder) and FoundIt) then - begin - Result := TfpgRadioButton(wg); - bestdtab := wg.TabOrder; - end; - end; - - fsdPrev: - if wg = Self then - FoundIt := True - else - begin - if ((wg.TabOrder < Self.TabOrder) and (wg.TabOrder >= bestdtab)) or - ((wg.TabOrder = Self.TabOrder) and not FoundIt) then - begin - Result := TfpgRadioButton(wg); - bestdtab := wg.TabOrder; - end; - end; - end; { case } - end; { if } - end; { if is TfpgWidget } - end; { for ComponentCount } - end; { if } -end; - -constructor TfpgRadioButton.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - FText := 'RadioButton'; - FFont := fpgGetFont('#Label1'); - FHeight := FFont.Height + 4; - FWidth := 120; - FTextColor := Parent.TextColor; - FBackgroundColor := Parent.BackgroundColor; - FFocusable := True; - FBoxSize := 12; - FChecked := False; - FGroupIndex := 0; - FIsPressed := False; - FAutoSize := False; - FOnChange := nil; -end; - -destructor TfpgRadioButton.Destroy; -begin - FFont.Free; - inherited Destroy; -end; - -end. - diff --git a/src/gui/gui_scrollbar.pas b/src/gui/gui_scrollbar.pas deleted file mode 100644 index 9e207303..00000000 --- a/src/gui/gui_scrollbar.pas +++ /dev/null @@ -1,581 +0,0 @@ -{ - fpGUI - Free Pascal GUI Toolkit - - Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this - distribution, for details of the copyright. - - See the file COPYING.modifiedLGPL, included in this distribution, - for details about redistributing fpGUI. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - - Description: - Defines Scrollbar controls. -} - -unit gui_scrollbar; - -{$mode objfpc}{$H+} - -{ - TODO: - * Set slider button to minimum length (default setting) - * Create property to enable dynamic sizing of slider button length. - * Paint scroll area between arrow buttons and slider button a different - color on click. -} - -interface - -uses - Classes, - SysUtils, - fpg_base, - fpg_main, - fpg_widget; - -type - TScrollNotifyEvent = procedure(Sender: TObject; position: integer) of object; - - TfpgScrollStyle = (ssNone, ssHorizontal, ssVertical, ssAutoBoth); - - TfpgScrollBarPart = (sbpNone, sbpUpBack, sbpPageUpBack, sbpSlider, sbpDownForward, sbpPageDownForward); - - { TfpgScrollBar } - - TfpgScrollBar = class(TfpgWidget) - private - FLargeChange: Integer; - FScrollbarDownPart: TfpgScrollBarPart; - procedure SetMax(const AValue: integer); - procedure SetMin(const AValue: integer); - procedure SetSBPosition(const AValue: integer); - procedure Step(ASteps: Integer); - procedure StepPage(ASteps: Integer); - procedure StepStart; - procedure StepEnd; - protected - FMax: integer; - FMin: integer; - FPageSize: integer; - FPosition: integer; - FScrollStep: integer; - FSliderPos: TfpgCoord; - FSliderLength: TfpgCoord; - FSliderDragPos: TfpgCoord; - FSliderDragStart: TfpgCoord; - FScrollTimer: TfpgTimer; - FActiveButtonRect: TfpgRect; - FMousePosition: TPoint; - FOnScroll: TScrollNotifyEvent; - procedure ScrollTimer(Sender: TObject); - procedure DrawButton(x, y, w, h: TfpgCoord; const imgname: string; Pressed: Boolean = False); virtual; - procedure DrawSlider(recalc: boolean); virtual; - procedure HandleLMouseDown(x, y: integer; shiftstate: TShiftState); override; - procedure HandleLMouseUp(x, y: integer; shiftstate: TShiftState); override; - procedure HandleMouseMove(x, y: integer; btnstate: word; shiftstate: TShiftState); override; - procedure HandleMouseScroll(x, y: integer; shiftstate: TShiftState; delta: smallint); override; - procedure HandlePaint; override; - procedure PositionChange(d: integer); - public - Orientation: TOrientation; - SliderSize: double; // 0-1 - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - procedure RepaintSlider; - property PageSize: integer read FPageSize write FPageSize default 5; - property Position: integer read FPosition write SetSBPosition default 10; - property ScrollStep: integer read FScrollStep write FScrollStep default 1; -// property LargeChange: Integer read FLargeChange write FLargeChange default 0; - property Min: integer read FMin write SetMin default 0; - property Max: integer read FMax write SetMax default 100; - property OnScroll: TScrollNotifyEvent read FOnScroll write FOnScroll; - end; - - -implementation - -{ TfpgScrollBar } - -constructor TfpgScrollBar.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - FScrollTimer := TfpgTimer.Create(500); - FScrollTimer.Enabled := False; - FScrollTimer.OnTimer := @ScrollTimer; - Orientation := orVertical; - FMin := 0; - FMax := 100; - FPosition := 10; - SliderSize := 0.5; - FOnScroll := nil; - FSliderPos := 0; - FSliderLength := 10; - FScrollStep := 1; - FPageSize := 5; - FLargeChange := 0; -end; - -destructor TfpgScrollBar.Destroy; -begin - FScrollTimer.Free; - inherited Destroy; -end; - -procedure TfpgScrollBar.HandlePaint; -begin - // Do NOT localize - Canvas.BeginDraw; - - if Orientation = orVertical then - begin - DrawButton(0, 0, Width, Width, 'sys.sb.up', FScrollbarDownPart = sbpUpBack); - DrawButton(0, Height-Width, Width, Width, 'sys.sb.down', FScrollbarDownPart = sbpDownForward); - end - else - begin - DrawButton(0, 0, Height, Height, 'sys.sb.left', FScrollbarDownPart = sbpUpBack); - DrawButton(Width-Height, 0, Height, Height, 'sys.sb.right', FScrollbarDownPart = sbpDownForward); - end; - - DrawSlider(True); - Canvas.EndDraw; -end; - -procedure TfpgScrollBar.RepaintSlider; -begin - if not HasHandle then - Exit; //==> - DrawSlider(True); -end; - -procedure TfpgScrollBar.SetMax(const AValue: integer); -begin - if AValue = FMax then - Exit; - if AValue < FMin then - FMax := FMin - else - FMax := AValue; - if FPosition > FMax then - StepEnd; -end; - -procedure TfpgScrollBar.SetMin(const AValue: integer); -begin - if AValue = FMin then - Exit; - if AValue > FMax then - FMin := FMax - else - FMin := AValue; - if FPosition < FMin then - StepStart; -end; - -procedure TfpgScrollBar.SetSBPosition(const AValue: integer); -begin - if AValue < FMin then - FPosition := FMin - else if AValue > FMax then - FPosition := FMax - else - FPosition := AValue; - - if HasHandle then - DrawSlider(False); -end; - -procedure TfpgScrollBar.Step(ASteps: Integer); -begin - PositionChange(FScrollStep*ASteps); -end; - -procedure TfpgScrollBar.StepPage(ASteps: Integer); -begin - PositionChange(ASteps*FPageSize); -end; - -procedure TfpgScrollBar.StepStart; -begin - SetSBPosition(FMin) -end; - -procedure TfpgScrollBar.StepEnd; -begin - SetSBPosition(FMax); -end; - -procedure TfpgScrollBar.ScrollTimer(Sender: TObject); - function WithinActiveButton: Boolean; - begin - Result := (FMousePosition.X < FActiveButtonRect.Right) - and (FMousePosition.X > FActiveButtonRect.Left) - and (FMousePosition.Y < FActiveButtonRect.Bottom) - and (FMousePosition.Y > FActiveButtonRect.Top); - end; - function WithinPageArea(IsBefore: Boolean): Boolean; - begin - case Orientation of - orVertical: - if IsBefore then - Result := (FMousePosition.X > -1) - and (FMousePosition.X < Width) - and (FMousePosition.Y < FSliderPos + Width) - and (FMousePosition.Y > Width) - else - Result := (FMousePosition.X > -1) - and (FMousePosition.X < Width) - and (FMousePosition.Y < Height - Width) - and (FMousePosition.Y > Width + FSliderPos + FSliderLength); - orHorizontal: - if IsBefore then - Result := (FMousePosition.X > Height) - and (FMousePosition.X < FSliderPos + Height) - and (FMousePosition.Y < Height) - and (FMousePosition.Y > -1) - else - Result := (FMousePosition.X > Height + FSliderPos + FSliderLength) - and (FMousePosition.X < Width - Height) - and (FMousePosition.Y < Height) - and (FMousePosition.Y > -1); - end; - end; -begin - - case FScrollbarDownPart of - sbpDownForward, - sbpUpBack : FScrollTimer.Interval := 25; - sbpPageDownForward, - sbpPageUpBack : FScrollTimer.Interval := 50; - end; - - case FScrollbarDownPart of - sbpUpBack: - begin - if WithinActiveButton then - Step(-1); - if Position = FMin then - FScrollTimer.Enabled := False; - end; - sbpDownForward: - begin - if WithinActiveButton then - Step(1); - if Position = FMax then - FScrollTimer.Enabled := False; - end; - sbpPageUpBack: - begin - if (Position = FMin) or not WithinPageArea(True) then - FScrollTimer.Enabled := False - else - StepPage(-1); - end; - sbpPageDownForward: - begin - if (Position = FMax) or not WithinPageArea(False) then - FScrollTimer.Enabled := False - else - StepPage(1); - end; - else - FScrollTimer.Enabled := False; - end; -end; - -procedure TfpgScrollBar.DrawButton(x, y, w, h: TfpgCoord; const imgname: string; Pressed: Boolean = False); -var - img: TfpgImage; - dx: integer; - dy: integer; -begin - if Pressed then - begin - Canvas.DrawButtonFace(x, y, w, h, [btfIsEmbedded, btfIsPressed]); - dx := 1; - dy := 1; - end - else - begin - Canvas.DrawButtonFace(x, y, w, h, [btfIsEmbedded]); - dx := 0; - dy := 0; - end; - Canvas.SetColor(clText1); - img := fpgImages.GetImage(imgname); - if img <> nil then - Canvas.DrawImage(x + w div 2 - (img.Width div 2) + dx, y + h div 2 - (img.Height div 2) + dy, img); -end; - -procedure TfpgScrollBar.DrawSlider(recalc: boolean); -var - area: TfpgCoord; - mm: TfpgCoord; -begin - Canvas.BeginDraw; - - if SliderSize > 1 then - SliderSize := 1; - - Canvas.SetColor(clScrollBar); - - if Orientation = orVertical then - begin - Canvas.FillRectangle(0, Width, Width, Height-Width-Width); - area := Height - (Width shl 1); - end - else - begin - Canvas.FillRectangle(Height, 0, Width-Height-Height, Height); - area := Width - (Height shl 1); - end; - - if recalc then - begin - if FPosition > FMax then - FPosition := FMax; - if FPosition < FMin then - FPosition := FMin; - - FSliderLength := Trunc(area * SliderSize); - //FSliderLength := Trunc((width/area) * (fmax /area )); - if FSliderLength < 20 then - FSliderLength := 20; - if FSliderLength > area then - FSliderLength := area; - area := area - FSliderLength; - mm := FMax - FMin; - if mm = 0 then - FSliderPos := 0 - else - FSliderPos := Trunc(area * ((FPosition - FMin) / mm)); - end; - - // Paint the area between the buttons and the Slider - if Orientation = orVertical then - begin - if FScrollbarDownPart in [{sbpUpBack,} sbpPageUpBack] then - begin - Canvas.SetColor(clShadow1); - Canvas.FillRectangle(0, Width, Width, FSliderPos); - Canvas.SetColor(clScrollBar); - end - else if FScrollbarDownPart in [{sbpDownForward,} sbpPageDownForward] then - begin - Canvas.SetColor(clShadow1); - Canvas.FillRectangle(0, FSliderPos + FSliderLength, Width, Height - Width - (FSliderPos + FSliderLength)); - Canvas.SetColor(clScrollBar); - end; - end - else - begin - if FScrollbarDownPart in [{sbpUpBack,} sbpPageUpBack] then - begin - Canvas.SetColor(clShadow1); - Canvas.FillRectangle(Height, 0, FSliderPos, Height); - Canvas.SetColor(clScrollBar); - end - else if FScrollbarDownPart in [{sbpDownForward,} sbpPageDownForward] then - begin - Canvas.SetColor(clShadow1); - Canvas.FillRectangle(FSliderPos + FSliderLength, 0, Width - Height - (FSliderPos + FSliderLength), Height); - Canvas.SetColor(clScrollBar); - end; - end; - - // Paint the slider button - if Orientation = orVertical then - begin - Canvas.DrawButtonFace(0, Width + FSliderPos, Width, FSliderLength, [btfIsEmbedded]); - Canvas.EndDraw(0, Width, Width, Height - Width - Width); - end - else - begin - Canvas.DrawButtonFace(Height + FSliderPos, 0, FSliderLength, Height, [btfIsEmbedded]); - Canvas.EndDraw(Height, 0, Width - Height - Height, Height); - end; -end; - -procedure TfpgScrollBar.HandleLMouseDown(x, y: integer; shiftstate: TShiftState); -var - lPos: TfpgCoord; -begin - inherited; - CaptureMouse; - - if Orientation = orVertical then - begin - if y <= Width then - begin - // Up button has been pressed - Step(-1); - FScrollbarDownPart := sbpUpBack; - FActiveButtonRect.SetRect(0, 0, Width, Width); - end - else if y >= Height - Width then - begin - // Down button has been pressed - Step(1); - FScrollbarDownPart := sbpDownForward; - FActiveButtonRect.SetRect(0,Height-Width, Width, Height); - end - else if (y >= (Width + FSliderPos)) and (y <= Width + FSliderPos + FSliderLength) then - begin - FScrollbarDownPart := sbpSlider; - FSliderDragPos := y; - end - else if (y > Width) and (y < (Width + FSliderPos)) then - begin - // Clicked between Up button and Slider - FScrollbarDownPart := sbpPageUpBack; - StepPage(-1); - end - else if (y < (Height - Width)) and (y > (Width + FSliderPos + FSliderLength)) then - begin - // Clicked between Down button and Slider - FScrollbarDownPart := sbpPageDownForward; - StepPage(1); - end; - end - else - begin - if x <= Height then - begin - // Left button has been pressed - StepPage(-1); - FScrollbarDownPart := sbpUpBack; - FActiveButtonRect.SetRect(0, 0, Height, Height); - end - else if x >= Width - Height then - begin - // Right button has been pressed - StepPage(1); - FScrollbarDownPart := sbpDownForward; - FActiveButtonRect.SetRect(Width-Height, 0, Width, Height); - end - else if (x >= (Height + FSliderPos)) and (x <= Height + FSliderPos + FSliderLength) then - begin - FScrollbarDownPart := sbpSlider; - FSliderDragPos := x; - end - else if (x > Height) and (x < (Height + FSliderPos)) then - begin - // Clicked between Left button and Slider - FScrollbarDownPart := sbpPageUpBack; - StepPage(-1); - end - else if (x < (Width - Height)) and (x > (Height + FSliderPos + FSliderLength)) then - begin - // Clicked between the Right button and Slider - FScrollbarDownPart := sbpPageDownForward; - StepPage(1); - end; - end; - - if FScrollbarDownPart = sbpSlider then - begin - FSliderDragStart := FSliderPos; - DrawSlider(False); - end - else if not (FScrollbarDownPart in [sbpNone, sbpSlider]) then - begin - FScrollTimer.Interval := 300; - FScrollTimer.Enabled := True; - - HandlePaint; - end; -end; - -procedure TfpgScrollBar.HandleLMouseUp(x, y: integer; shiftstate: TShiftState); -var - WasPressed: Boolean; -begin - inherited; - ReleaseMouse; - - WasPressed := FScrollbarDownPart <> sbpNone; - FScrollTimer.Enabled := False; - - FScrollbarDownPart := sbpNone; - - if WasPressed then - HandlePaint; -end; - -procedure TfpgScrollBar.HandleMouseMove(x, y: integer; btnstate: word; shiftstate: TShiftState); -var - d: integer; - area: integer; - newp: integer; - ppos: integer; -begin - inherited HandleMouseMove(x, y, btnstate, shiftstate); - - FMousePosition.X := x; - FMousePosition.Y := y; - - if (FScrollbarDownPart <> sbpSlider) or ((btnstate and MOUSE_LEFT) = 0) then - Exit; - - if Orientation = orVertical then - begin - d := y - FSliderDragPos; - area := Height - (Width shl 1) - FSliderLength; - end - else - begin - d := x - FSliderDragPos; - area := Width - (Height shl 1) - FSliderLength; - end; - - ppos := FSliderPos; - FSliderPos := FSliderDragStart + d; - - if FSliderPos < 0 then - FSliderPos := 0; - if FSliderPos > area then - FSliderPos := area; - - if ppos <> FSliderPos then - DrawSlider(False); - - if area <> 0 then - newp := FMin + Trunc((FMax - FMin) * (FSliderPos / area)) - else - newp := FMin; - - if newp <> FPosition then - begin - Position := newp; - if Assigned(FOnScroll) then - FOnScroll(self, FPosition); - end; -end; - -procedure TfpgScrollBar.HandleMouseScroll(x, y: integer; shiftstate: TShiftState; - delta: smallint); -begin - inherited HandleMouseScroll(x, y, shiftstate, delta); - Step(delta); -end; - -procedure TfpgScrollBar.PositionChange(d: integer); -begin - FPosition := FPosition + d; - if FPosition < FMin then - FPosition := FMin; - if FPosition > FMax then - FPosition := FMax; - - if Visible then - DrawSlider(True); - - if Assigned(FOnScroll) then - FOnScroll(self, FPosition); -end; - -end. - diff --git a/src/gui/gui_splitter.pas b/src/gui/gui_splitter.pas deleted file mode 100644 index ac556d03..00000000 --- a/src/gui/gui_splitter.pas +++ /dev/null @@ -1,470 +0,0 @@ -{ - fpGUI - Free Pascal GUI Toolkit - - Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this - distribution, for details of the copyright. - - See the file COPYING.modifiedLGPL, included in this distribution, - for details about redistributing fpGUI. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - - Description: - Defines a Splitter control. -} - -unit gui_splitter; - -{$mode objfpc}{$H+} - -interface - -uses - Classes, - SysUtils, - fpg_base, - fpg_main, - fpg_widget; - -const - clColorGrabBar = $839EFE; // Pale navy blue - cSplitterWidth = 8; - -type - - NaturalNumber = 1..High(Integer); - - - TfpgSplitter = class(TfpgWidget) - private - FAutoSnap: Boolean; - FColorGrabBar: TfpgColor; - FControl: TfpgWidget; - FDownPos: TPoint; - FMinSize: NaturalNumber; - FMaxSize: Integer; - FNewSize: Integer; - FOldSize: Integer; - FSplit: Integer; - FMouseOver: Boolean; - procedure CalcSplitSize(X, Y: Integer; out NewSize, Split: Integer); - function FindControl: TfpgWidget; - procedure SetColorGrabBar(const AValue: TfpgColor); - procedure UpdateControlSize; - procedure UpdateSize(const X, Y: Integer); - protected - function DoCanResize(var NewSize: Integer): Boolean; virtual; - procedure HandleLMouseDown(x, y: integer; shiftstate: TShiftState); override; - procedure HandleLMouseUp(x, y: integer; shiftstate: TShiftState); override; - procedure HandleMouseMove(x, y: integer; btnstate: word; shiftstate: TShiftState); override; - procedure HandleMouseEnter; override; - procedure HandleMouseExit; override; - procedure HandlePaint; override; - procedure StopSizing; dynamic; - Procedure DrawGrabBar(ARect: TfpgRect); virtual; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - published - property ColorGrabBar: TfpgColor read FColorGrabBar write SetColorGrabBar default clColorGrabBar; - end; - -function CreateSplitter(AOwner: TComponent; ALeft, ATop, AWidth, AHeight: TfpgCoord; - AnAlign: TAlign): TfpgSplitter; - -implementation - -function CreateSplitter(AOwner: TComponent; ALeft, ATop, AWidth, AHeight: TfpgCoord; - AnAlign: TAlign): TfpgSplitter; -begin - Result := TfpgSplitter.Create(AOwner); - Result.Left := ALeft; - Result.Top := ATop; - Result.Width := AWidth; - Result.Height := AHeight; - Result.Align := AnAlign; -end; - -{ TfpgSplitter } - -procedure TfpgSplitter.CalcSplitSize(X, Y: Integer; out NewSize, Split: Integer); -var - S: Integer; -begin - if Align in [alLeft, alRight] then - Split := X - FDownPos.X - else - Split := Y - FDownPos.Y; - S := 0; - case Align of - alLeft: S := FControl.Width + Split; - alRight: S := FControl.Width - Split; - alTop: S := FControl.Height + Split; - alBottom: S := FControl.Height - Split; - end; - NewSize := S; - if S < FMinSize then - NewSize := FMinSize - else if S > FMaxSize then - NewSize := FMaxSize; - if S <> NewSize then - begin - if Align in [alRight, alBottom] then - S := S - NewSize - else - S := NewSize - S; - Inc(Split, S); - end; -end; - -function TfpgSplitter.FindControl: TfpgWidget; -var - i: Integer; - wg: TfpgWidget; - p: TPoint; - r: TfpgRect; -begin - Result := nil; - p := Point(Left, Top); - case Align of - alLeft: Dec(p.X); - alRight: Inc(p.X, Width); - alTop: Dec(p.Y); - alBottom: Inc(p.Y, Height); - else - Exit; - end; - - for i := 0 to Parent.ComponentCount-1 do - begin - wg := TfpgWidget(Parent.Components[i]); - if (wg <> nil) and wg.Visible and wg.Enabled then - begin - Result := wg; - r := Result.GetBoundsRect; - if (r.Width = 0) then - if Align in [alTop, alLeft] then - Dec(r.Left) - else - Inc(r.Width); - if (r.Height = 0) then - if Align in [alTop, alLeft] then - Dec(r.Top) - else - Inc(r.Height); - if PtInRect(r, p) then Exit; - end; - end; - Result := nil; -end; - -procedure TfpgSplitter.SetColorGrabBar(const AValue: TfpgColor); -begin - if FColorGrabBar = AValue then - Exit; //==> - FColorGrabBar := AValue; - Repaint; -end; - -procedure TfpgSplitter.UpdateControlSize; -begin - if FNewSize <> FOldSize then - begin - case Align of - alLeft, alRight: -// FControl.Width := FNewSize; // (1) - FControl.SetPosition(FControl.Left, FControl.Top, FNewSize, FControl.Height); // (2) - alTop, alBottom: -// FControl.Height := FNewSize; // (1) - FControl.SetPosition(FControl.Left, FControl.Top, FControl.Width, FNewSize); // (2) - end; -// FControl.UpdateWindowPosition; // (1) - // vvzh: - // Lines marked with (1) work wrong under Linux (e.g. folding/unfolding Memo1) - // Lines marked with (2) work OK under both platforms. Why? - Parent.Realign; - // if Assigned(FOnMoved) then FOnMoved(Self); - FOldSize := FNewSize; - end; -end; - -procedure TfpgSplitter.UpdateSize(const X, Y: Integer); -begin - CalcSplitSize(X, Y, FNewSize, FSplit); -end; - -function TfpgSplitter.DoCanResize(var NewSize: Integer): Boolean; -begin - // Result := CanResize(NewSize); // omit onCanResize call - Result := True; - if Result and (NewSize <= FMinSize) and FAutoSnap then - NewSize := 0; -end; - -procedure TfpgSplitter.HandleLMouseDown(x, y: integer; shiftstate: TShiftState); -var - i: integer; - wg: TfpgWidget; -begin - inherited HandleLMouseDown(x, y, shiftstate); - - FControl := FindControl; - FDownPos := Point(X, Y); - - if Assigned(FControl) then - begin - if Align in [alLeft, alRight] then - begin - FMaxSize := Parent.Width - FMinSize; - for i := 0 to Parent.ComponentCount-1 do - begin - wg := TfpgWidget(Parent.Components[i]); - if wg.Visible and (wg.Align in [alLeft, alRight]) then - Dec(FMaxSize, Width); - end; - Inc(FMaxSize, FControl.Width); - end - else - begin - FMaxSize := Parent.Height - FMinSize; - for i := 0 to Parent.ComponentCount-1 do - begin - wg := TfpgWidget(Parent.Components[i]); - if (wg.Align in [alTop, alBottom]) then - Dec(FMaxSize, Height); - end; - Inc(FMaxSize, FControl.Height); - end; - UpdateSize(X, Y); - CaptureMouse; - {AllocateLineDC; - with ValidParentForm(Self) do - if ActiveControl <> nil then - begin - FActiveControl := ActiveControl; - FOldKeyDown := TWinControlAccess(FActiveControl).OnKeyDown; - TWinControlAccess(FActiveControl).OnKeyDown := FocusKeyDown; - end; - if ResizeStyle in [rsLine, rsPattern] then DrawLine;} - end; -end; - -procedure TfpgSplitter.HandleLMouseUp(x, y: integer; shiftstate: TShiftState); -begin - inherited HandleLMouseUp(x, y, shiftstate); - if Assigned(FControl) then - begin - ReleaseMouse; - // if ResizeStyle in [rsLine, rsPattern] then DrawLine; - UpdateControlSize; - {writeln('LT: ', FControl.Left, ':', FControl.Width, ' ', Self.Left, ':', Self.Width); - writeln('RB: ', FControl.Top, ':', FControl.Height, ' ', Self.Top, ':', Self.Height);} - StopSizing; - end; -end; - -procedure TfpgSplitter.HandleMouseMove(x, y: integer; btnstate: word; - shiftstate: TShiftState); -var - NewSize, Split: Integer; -begin - inherited HandleMouseMove(x, y, btnstate, shiftstate); - if (ssLeft in shiftstate) and Assigned(FControl) then - begin - CalcSplitSize(X, Y, NewSize, Split); - if DoCanResize(NewSize) then - begin - // if ResizeStyle in [rsLine, rsPattern] then DrawLine; - FNewSize := NewSize; - FSplit := Split; - // if ResizeStyle = rsUpdate then - UpdateControlSize; - // if ResizeStyle in [rsLine, rsPattern] then DrawLine; - end; - end; -end; - -procedure TfpgSplitter.HandleMouseEnter; -begin - FMouseOver := True; - if Align in [alBottom, alTop] then - MouseCursor := mcSizeNS - else - MouseCursor := mcSizeEW; - Repaint; -end; - -procedure TfpgSplitter.HandleMouseExit; -begin - FMouseOver := False; - if FControl = nil then - MouseCursor := mcDefault; - Repaint; -end; - -procedure TfpgSplitter.HandlePaint; -var - lRect: TfpgRect; -begin - Canvas.SetColor(clWindowBackground); - Canvas.FillRectangle(GetClientRect); - - case Align of - alRight, - alLeft: - begin - lRect.Top := Height div 4; - lRect.SetBottom(Height div 4 * 3); - lRect.Left := 1; - lRect.SetRight(6); - end; - - alTop, - alBottom: - begin - lRect.Left := Width div 4; - lRect.SetRight(Width div 4 * 3); - lRect.Top := 1; - lRect.SetBottom(6); - end; - end; - DrawGrabBar(lRect); -end; - -procedure TfpgSplitter.StopSizing; -begin - if Assigned(FControl) then - begin - // if FLineVisible then DrawLine; - FControl := nil; - {ReleaseLineDC; - if Assigned(FActiveControl) then - begin - TWinControlAccess(FActiveControl).OnKeyDown := FOldKeyDown; - FActiveControl := nil; - end;} - end; - {if Assigned(FOnMoved) then - FOnMoved(Self);} -end; - -procedure TfpgSplitter.DrawGrabBar(ARect: TfpgRect); -var - lFillRect: TfpgRect; - lSaveColor: TfpgColor; -begin - lSaveColor := Canvas.Color; - - // Draw the outline of the rectangle - Canvas.Color := clGray; - Canvas.DrawRectangle(ARect); - - // If the mouse is over the splitter bar, then fill the grab bar part - // with colour. - if FMouseOver then - begin - lFillRect := ARect; - InflateRect(lFillRect, -1, -1); - Canvas.Color := FColorGrabBar; - Canvas.FillRectangle(lFillRect); - end; - - // Draw a shadow around the inside of the grab bar - Canvas.Color := clWhite; - Canvas.DrawLine(ARect.Left+1, ARect.Top+1, ARect.Right, ARect.Top+1); - Canvas.DrawLine(ARect.Left+1, ARect.Top+1, ARect.Left+1, ARect.Bottom); - - // Draw some texture inside the grab bar - Canvas.SetLineStyle(1, lsDot); - if Align in [alLeft, alRight] then - begin - Canvas.DrawLine(ARect.Left+3, ARect.Top+15, ARect.Left+3, ARect.Bottom-15); - Canvas.Color := clGray; - Canvas.DrawLine(ARect.Left+4, ARect.Top+16, ARect.Left+4, ARect.Bottom-16); - end - else - begin - Canvas.DrawLine(ARect.Left+15, ARect.Top+3, ARect.Right-15, ARect.Top+3); - Canvas.Color := clGray; - Canvas.DrawLine(ARect.Left+16, ARect.Top+4, ARect.Right-16, ARect.Top+4); - end; - - Canvas.SetLineStyle(1, lsSolid); - Canvas.Color := clBlack; - - { TODO : Improve the look of the triangles } - case Align of - alRight: - begin - // Draw the top triangle - Canvas.FillTriangle(ARect.Left+2, ARect.Top+5, - ARect.Left+2, ARect.Top+10, - ARect.Left+4, ARect.Top+7); - // Draw the bottom triangle - Canvas.FillTriangle(ARect.Left+2, ARect.Bottom-5, - ARect.Left+2, ARect.Bottom-10, - ARect.Left+4, ARect.Bottom-7); - end; - - alLeft: - begin - // Draw the top triangle - Canvas.FillTriangle(ARect.Right-2, ARect.Top+5, - ARect.Right-2, ARect.Top+10, - ARect.Right-4, ARect.Top+7); - // Draw the bottom triangle - Canvas.FillTriangle(ARect.Right-2, ARect.Bottom-5, - ARect.Right-2, ARect.Bottom-10, - ARect.Right-4, ARect.Bottom-7); - end; - - alBottom: - begin - // Draw the left triangle - Canvas.FillTriangle(ARect.Left+5, ARect.Top+2, - ARect.Left+10, ARect.Top+2, - ARect.Left+7, ARect.Top+4); - // Draw the right triangle - Canvas.FillTriangle(ARect.Right-5, ARect.Top+2, - ARect.Right-10, ARect.Top+2, - ARect.Right-7, ARect.Top+4); - end; - - alTop: - begin - // Draw the left triangle - Canvas.FillTriangle(ARect.Left+5, ARect.Bottom-1, - ARect.Left+10, ARect.Bottom-1, - ARect.Left+7, ARect.Bottom-4); - // Draw the right triangle - Canvas.FillTriangle(ARect.Right-5, ARect.Bottom-1, - ARect.Right-10, ARect.Bottom-1, - ARect.Right-7, ARect.Bottom-4); - end; - end; - - Canvas.Color := lSaveColor; -end; - -constructor TfpgSplitter.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - FAutoSnap := True; - Height := 100; - Align := alLeft; - Width := cSplitterWidth; - FMinSize := 30; - // FResizeStyle := rsPattern; - FOldSize := -1; - FMouseOver := False; - FColorGrabBar := clColorGrabBar; -end; - -destructor TfpgSplitter.Destroy; -begin - inherited Destroy; -end; - -end. diff --git a/src/gui/gui_style.pas b/src/gui/gui_style.pas deleted file mode 100644 index 7a5b1e91..00000000 --- a/src/gui/gui_style.pas +++ /dev/null @@ -1,315 +0,0 @@ -{ - fpGUI - Free Pascal GUI Toolkit - - Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this - distribution, for details of the copyright. - - See the file COPYING.modifiedLGPL, included in this distribution, - for details about redistributing fpGUI. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - - Description: - This is where all style related types should be defined. The base - Style class should also be defined here. - This is still work in progress! -} - -unit gui_style; - -{$mode objfpc}{$H+} - -{.$Define DEBUG} - -interface - -uses - Classes, - SysUtils, - fpg_base, - fpg_main, - fpg_widget; - - -type - TfpgPrimitiveElement = ( - peFocusRectangle, // The focus rectangle - pePanel, // Generic bevel of a panel - pePanelButton, // Panel are of standard button - pePanelButtonBevel, // The bevel of a button - pePanelEditBox, // Frame around a text edit box - pePanelToolbarButton, // Panel area of a toolbar button - pePanelMenuBar, // The menu bar panel - pePanelScrollAreaCorner, // Panel at the bottom right corner of the scroll area - peFrameMenu, // Frame for popup windows and menus - peFrameDefaultButton, // Frame around a default button like in a dialog - peFrameToolbarButton, // Frame around a toolbar button - peFramePageControl, // Frame for a Page Control - peIndicatorArrowUp, // Generic up arrow - peIndicatorArrowDown, // Generic down arrow - peIndicatorArrowRight, // Generic right arrow - peIndicatorArrowLeft, // Generic left arrow - peIndicatorCheckBox, // On/off indicator used in a CheckBox - peIndicatorRadioButton, // Exclusive on indicator used in a Radio Button - peIndicatorHeaderArrow, // Indicator used in List or Tabel header to show sorting - peIndicatorMenuCheckMark, // Check mark used in menus - peIndicatorProgressBar // Body section of a Progress Bar - ); - - - TfpgControlElement = ( - cePushButton, // The Bevel, Label and FocusRect - cePushButtonBevel, - cePushButtonLabel, - ceRadioButton, // Indicator, FocusRect and Label - ceRadioButtonLabel, - ceCheckBox, // Indicator, FocusRect and Label - ceCheckBoxLabel, - ceMenuItem, - ceMenuBarItem, - ceMenuBarEmptyArea, - ceMenuTearOff, - ceMenuHMargin, - ceMenuVMargin, - ceProgressBar, - cePageControlTab, // Both the Shape and Label - cePageControlShape, - cePageControlLabel - ); - - - TfpgStyleOptionEnum = ( - soDefault, - soFocusRect, - soButton, - soComboBox, - soCheckBox, - soMenuItem, - soTrackBar, - soPanel, - soComplex - ); - - - TfpgStateItem = ( - stNone, - stActive, - stReadOnly, - stSelected, - stRaised, - stLowered, - stHasFocus, - stEnabled - ); - TfpgState = set of TfpgStateItem; - - - TfpgStandardPixmap = ( - spMessageBoxInformation, - spMessageBoxCritical, - spMessageBoxError, - spMessageBoxWarning, - spMessageBoxQuestion, - spDirOpenIcon, - spDirCloseIcon, - spDirIcon, - spDirLinkIcon, - spFileIcon, - spFileLinkIcon, - spFileDialogToParent, // Icon of back to parent dir - spFileDialogNewFolder, - spDialogOkButton, - spDialogCancelButton, - spDialogHelpButton, - spDialogSaveButton, - spDialogOpenButton, - spDialogCloseButton, - spDialogApplyButton, - spDialogResetButton, - spDialogDiscardButton, - spDialogYesButton, - spDialogNoButton - ); - - - // Just a data class - TfpgStyleOption = class(TObject) - private - FRect: TfpgRect; - FState: TfpgState; - FStyleOption: TfpgStyleOptionEnum; - public - property StyleOption: TfpgStyleOptionEnum read FStyleOption write FStyleOption; - property Rect: TfpgRect read FRect write FRect; - property State: TfpgState read FState write FState; - end; - - - TfpgButtonFeatures = set of (bfNone, bfFlat, bfDefault, bfEmbedded); - - // Button specific options - TfpgButtonStyleOption = class(TfpgStyleOption) - private - FButtonFeatures: TfpgButtonFeatures; - public - property ButtonFeatures: TfpgButtonFeatures read FButtonFeatures write FButtonFeatures; - end; - - - TfpgBaseStyle = class(TObject) - public - procedure DrawControl(element: TfpgControlElement; const option: TfpgStyleOption; canvas: TfpgCanvas; widget: TfpgWidget = nil); virtual; abstract; - procedure DrawPrimitive(element: TfpgPrimitiveElement; const option: TfpgStyleOption; canvas: TfpgCanvas; widget: TfpgWidget = nil); virtual; abstract; - end; - - - - //----------------------------------------- - // The classes below will be better placed in their own units! - - - // This class encapsulates the common look and feel of the GUI - TfpgCommonStyle = class(TfpgBaseStyle) - public - procedure DrawControl(element: TfpgControlElement; const option: TfpgStyleOption; canvas: TfpgCanvas; widget: TfpgWidget=nil); override; - procedure DrawPrimitive(element: TfpgPrimitiveElement; const option: TfpgStyleOption; canvas: TfpgCanvas; widget: TfpgWidget=nil); override; - end; - - - // The Windows 2000 look - TfpgWin2000Style = class(TfpgCommonStyle) - end; - - - TfpgWinXPStyle = class(TfpgCommonStyle) - end; - - - // This class provides a widgte style similar to the classic BlueCurve theme - // originally created by Red Hat. - TfpgBlueCurveStyle = class(TfpgCommonStyle) - end; - - - // This class provides a widget style similar to GNOME - TfpgClearLookStyle = class(TfpgCommonStyle) - end; - - - // For the die-hard unix fans! - TfpgMotifStyle = class(TfpgCommonStyle) - end; - - -implementation - - -{ TfpgCommonStyle } - -procedure TfpgCommonStyle.DrawControl(element: TfpgControlElement; - const option: TfpgStyleOption; canvas: TfpgCanvas; widget: TfpgWidget); -var - r: TfpgRect; -begin - // Do common things here - case element of - cePushButtonBevel: - begin - {$IFDEF DEBUG} - writeln('TfpgCommonStyle.DrawControl: cePushButtonBevel'); - {$ENDIF} - r.SetRect(option.Rect.Left, option.Rect.Top, option.Rect.Width, option.Rect.Height); - - if bfDefault in TfpgButtonStyleOption(option).ButtonFeatures then - begin - Canvas.SetColor(clBlack); - Canvas.SetLineStyle(1, lsSolid); - Canvas.DrawRectangle(r); - InflateRect(r, -1, -1); - end; - -// Canvas.SetColor(clButtonFace); -// Canvas.SetLineStyle(1, lsSolid); - // Canvas.FillRectangle(r.Left, r.Top, r.Width, r.Height); - - // Left and Top (outer) - if stLowered in option.State then - begin - if bfEmbedded in TfpgButtonStyleOption(option).ButtonFeatures then - Canvas.SetColor(clHilite1) - else - Canvas.SetColor(clShadow2); - end - else - Canvas.SetColor(clHilite1); - Canvas.DrawLine(r.Left, r.Bottom, r.Left, r.Top); // left - Canvas.DrawLine(r.Left, r.Top, r.Right, r.Top); // top - - // Right and Bottom (outer) - if stLowered in option.State then - begin - if bfEmbedded in TfpgButtonStyleOption(option).ButtonFeatures then - Canvas.SetColor(clHilite1) - else - Canvas.SetColor(clShadow2); - end - else - Canvas.SetColor(clShadow2); - Canvas.DrawLine(r.Right, r.Top, r.Right, r.Bottom); // right - Canvas.DrawLine(r.Right, r.Bottom, r.Left-1, r.Bottom); // bottom - - // Right and Bottom (inner) - if stLowered in option.State then - begin - if bfEmbedded in TfpgButtonStyleOption(option).ButtonFeatures then - Canvas.SetColor(clButtonFace) - else - Canvas.SetColor(clHilite1); - end - else - Canvas.SetColor(clShadow1); - Canvas.DrawLine(r.Right-1, r.Top+1, r.Right-1, r.Bottom-1); // right - Canvas.DrawLine(r.Right-1, r.Bottom-1, r.Left, r.Bottom-1); // bottom - end { cePushButtonBevel } - end; -end; - -procedure TfpgCommonStyle.DrawPrimitive(element: TfpgPrimitiveElement; - const option: TfpgStyleOption; canvas: TfpgCanvas; widget: TfpgWidget); -var - r: TfpgRect; -begin - // Do common things here. It's going to be a huge case statement. This design - // allows us to add new controls or elements without having to instantly - // implement them in all descendant classes! - case element of - peFocusRectangle: - begin - {$IFDEF DEBUG} - writeln('TfpgCommonStyle.DrawPrimitive: peFocusRectangle'); - {$ENDIF} - if stHasFocus in option.State then - begin - r.SetRect(option.Rect.Left, option.Rect.Top, option.Rect.Width, option.Rect.Height); - InflateRect(r, -3, -3); - Canvas.DrawFocusRect(r); - end; - end; { peFocusRectangle } - - peIndicatorRadioButton: - begin // just an example!!!!!!!! - {$IFDEF DEBUG} - writeln('TfpgCommonStyle.DrawPrimitive: peIndicatorRadioButton'); - {$ENDIF} - Canvas.SetColor(clShadow1); - Canvas.DrawArc(option.Rect.Left, option.Rect.Top, option.Rect.Width, option.Rect.Height, 0, 180); - Canvas.SetColor(clHilite1); - Canvas.DrawArc(option.Rect.Left, option.Rect.Top, option.Rect.Width, option.Rect.Height, 180, 0); - end; { peIndicatorRadioButton } - end; -end; - -end. - diff --git a/src/gui/gui_tab.pas b/src/gui/gui_tab.pas deleted file mode 100644 index 69a93244..00000000 --- a/src/gui/gui_tab.pas +++ /dev/null @@ -1,843 +0,0 @@ -{ - fpGUI - Free Pascal GUI Toolkit - - Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this - distribution, for details of the copyright. - - See the file COPYING.modifiedLGPL, included in this distribution, - for details about redistributing fpGUI. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - - Description: - Defines a Page Control and Tab Sheets. -} - -unit gui_tab; - -{$mode objfpc}{$H+} - -{ - TODO: - * Tab Styles (tab, button, flat button, angled) - * Tab Position (top, bottom, left, right) - * Better keyboard support - * Focus rectangle drawn on tabs itself - * FindNextPage() must be implemented -} - -interface - -uses - Classes, - SysUtils, - fpg_base, - fpg_main, - fpg_widget, - gui_button; - -type - // forward declaration - TfpgPageControl = class; - - TfpgTabStyle = (tsTabs, tsButtons, tsFlatButtons); - TfpgTabPosition = (tpTop, tpBottom{, tpLeft, tpRight}); - - - TfpgTabSheet = class(TfpgWidget) - private - FText: string; - function GetPageControl: TfpgPageControl; - function GetPageIndex: Integer; - function GetText: string; - procedure SetPageIndex(const AValue: Integer); - procedure SetText(const AValue: string); - protected - procedure HandlePaint; override; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - procedure AfterConstruction; override; - property Text: string read GetText write SetText; - property PageIndex: Integer read GetPageIndex write SetPageIndex; - property PageControl: TfpgPageControl read GetPageControl; - end; - - - TTabSheetChange = procedure(Sender: TObject; NewActiveSheet: TfpgTabSheet) of object; - - - TfpgPageControl = class(TfpgWidget) - private - FFont: TfpgFont; - FActivePage: TfpgTabSheet; - FMargin: integer; - FFixedTabWidth: integer; - FPages: TList; - FActivePageIndex: integer; - FOnChange: TTabSheetChange; - FRightButton: TfpgButton; - FLeftButton: TfpgButton; - FFirstTabButton: TfpgTabSheet; - FSortPages: boolean; - FStyle: TfpgTabStyle; - FTabPosition: TfpgTabPosition; - function GetActivePageIndex: integer; - function GetPage(AIndex: integer): TfpgTabSheet; - function GetPageCount: Integer; - procedure InsertPage(const APage: TfpgTabSheet); - procedure RemovePage(const APage: TfpgTabSheet); - procedure SetActivePageIndex(const AValue: integer); - procedure SetActivePage(const AValue: TfpgTabSheet); - function MaxButtonWidthSum: integer; - function MaxButtonHeight: integer; - function MaxButtonWidth: integer; - function ButtonHeight: integer; - function ButtonWidth(AText: string): integer; - procedure SetFixedTabWidth(const AValue: integer); - function GetTabText(AText: string): string; - procedure LeftButtonClick(Sender: TObject); - procedure RightButtonClick(Sender: TObject); - function FindNextPage(ACurrent: TfpgTabSheet; AForward: boolean): TfpgTabSheet; - procedure SetSortPages(const AValue: boolean); - procedure SetStyle(const AValue: TfpgTabStyle); - procedure SetTabPosition(const AValue: TfpgTabPosition); - procedure DoChange(ATabSheet: TfpgTabSheet); - function DrawTab(const rect: TfpgRect; const Selected: Boolean = False; const Mode: Integer = 1): TfpgRect; - protected - procedure OrderSheets; // currently using bubblesort - procedure RePaintTitles; virtual; - procedure HandlePaint; override; - procedure HandleShow; override; - procedure HandleLMouseUp(x, y: integer; shiftstate: TShiftState); override; - procedure HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - function AppendTabSheet(ATitle: string): TfpgTabSheet; - property PageCount: Integer read GetPageCount; - property ActivePage: TfpgTabSheet read FActivePage write SetActivePage; - property Pages[AIndex: integer]: TfpgTabSheet read GetPage; - property OnChange: TTabSheetChange read FOnChange write FOnChange; - published - property ActivePageIndex: integer read GetActivePageIndex write SetActivePageIndex; - property BackgroundColor; - property FixedTabWidth: integer read FFixedTabWidth write SetFixedTabWidth default 0; - property ParentShowHint; - property ShowHint; - property SortPages: boolean read FSortPages write SetSortPages default False; - property Style: TfpgTabStyle read FStyle write SetStyle default tsTabs; - property TabOrder; - property TabPosition: TfpgTabPosition read FTabPosition write SetTabPosition default tpTop; - property TextColor; - end; - - -implementation - -uses - fpg_stringutils; - - -// compare function used by FPages.Sort - -function SortCompare(Item1, Item2: Pointer): integer; -begin - Result := CompareText(TfpgTabSheet(Item1).Text, TfpgTabSheet(Item2).Text); -end; - -{ TfpgTabSheet } - -function TfpgTabSheet.GetPageControl: TfpgPageControl; -begin - if Owner is TfpgPageControl then - Result := TfpgPageControl(Owner) - else - Result := nil; -end; - -function TfpgTabSheet.GetPageIndex: Integer; -begin - if PageControl <> nil then - Result := PageControl.FPages.IndexOf(Self) - else - Result := -1; -end; - -function TfpgTabSheet.GetText: string; -begin - Result := FText; -end; - -procedure TfpgTabSheet.SetPageIndex(const AValue: Integer); -begin - if PageControl <> nil then - begin - PageControl.FPages.Move(PageIndex, AValue); - PageControl.RePaint;//Titles; - end; -end; - -procedure TfpgTabSheet.SetText(const AValue: string); -begin - if FText = AValue then - Exit; //==> - FText := AValue; - if PageControl <> nil then - PageControl.RePaintTitles; -end; - -procedure TfpgTabSheet.HandlePaint; -begin - inherited HandlePaint; - Canvas.Clear(FBackgroundColor); -end; - -constructor TfpgTabSheet.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - FText := ''; - FFocusable := True; - FBackgroundColor := Parent.BackgroundColor; - FTextColor := Parent.TextColor; - FIsContainer := True; -end; - -destructor TfpgTabSheet.Destroy; -begin - if Owner is TfpgPageControl then - TfpgPageControl(Owner).RemovePage(self); - inherited Destroy; -end; - -procedure TfpgTabSheet.AfterConstruction; -begin - inherited AfterConstruction; - if Owner is TfpgPageControl then - TfpgPageControl(Owner).InsertPage(self); -end; - -{ TfpgPageControl } - -function TfpgPageControl.GetActivePageIndex: integer; -begin - Result := FActivePageIndex; -end; - -function TfpgPageControl.GetPage(AIndex: integer): TfpgTabSheet; -begin - Result := nil; - if (AIndex >= 0) and (AIndex < FPages.Count) then - Result := TfpgTabSheet(FPages[AIndex]); -end; - -function TfpgPageControl.GetPageCount: Integer; -begin - Result := FPages.Count; -end; - -procedure TfpgPageControl.InsertPage(const APage: TfpgTabSheet); -begin - if FPages.IndexOf(APage) <> -1 then - Exit; //==> The page has already been added. - FPages.Add(APage); - ActivePage := APage; -end; - -procedure TfpgPageControl.RemovePage(const APage: TfpgTabSheet); -begin - FPages.Remove(APage); - {$Note This still needs to be fixed.} - if APage = FActivePage then - begin -// FActivePage := FindNextPage(APage, True); -// if FPages.Count > 0 then - ActivePage := TfpgTabSheet(FPages.First); -// else -// ActivePage := nil; - end; -end; - -procedure TfpgPageControl.SetActivePageIndex(const AValue: integer); -begin - if (AValue >= 0) or (AValue < FPages.Count) then - ActivePage := TfpgTabSheet(FPages[AValue]); -end; - -procedure TfpgPageControl.SetActivePage(const AValue: TfpgTabSheet); -begin - if FActivePage = AValue then - Exit; //==> - FActivePage := AValue; - ActiveWidget := AValue; - FActivePageIndex := FPages.IndexOf(AValue); - RePaint; -end; - -function TfpgPageControl.MaxButtonWidthSum: integer; -var - i: integer; - t: TfpgTabSheet; -begin - {$IFDEF DEBUG}writeln(Classname + '.MaxButtonWidthSum');{$ENDIF} - Result := 0; - - for i := 0 to FPages.Count-1 do - begin - t := TfpgTabSheet(FPages[i]); - Result := Result + ButtonWidth(t.Text); - end; -end; - -function TfpgPageControl.MaxButtonHeight: integer; -begin - result := PageCount * ButtonHeight; -end; - -function TfpgPageControl.MaxButtonWidth: integer; -var - t: TfpgTabSheet; - i: integer; -begin - Result := 0; - for i := 0 to FPages.Count-1 do - begin - t := TfpgTabSheet(FPages[i]); - if ButtonWidth(t.Text) > Result then - Result := ButtonWidth(t.Text); - end; -end; - -function TfpgPageControl.ButtonHeight: integer; -begin - Result := FRightButton.Height; -end; - -function TfpgPageControl.ButtonWidth(AText: string): integer; -begin - if FFixedTabWidth > 0 then - result := FFixedTabWidth - else - result := FFont.TextWidth(AText) + 10; -end; - -procedure TfpgPageControl.SetFixedTabWidth(const AValue: integer); -begin - if FFixedTabWidth = AValue then - Exit; //==> - if AValue > 5 then - begin - FFixedTabWidth := AValue; - RePaint; - end; -end; - -function TfpgPageControl.GetTabText(AText: string): string; -var - s, s1: string; - i: integer; -begin - {$IFDEF DEBUG}writeln(Classname + '.GetTabText');{$ENDIF} - Result := AText; - s := AText; - s1 := ''; - i := 1; - if FFixedTabWidth > 0 then - begin - while FFont.TextWidth(s1) < (FFixedTabWidth-10) do - begin - if Length(s1) = Length(s) then - Break; - s1 := UTF8Copy(s, 1, i); - inc(i); - end; - if FFont.TextWidth(s1) > (FFixedTabWidth-10) then - Delete(s1, length(s1), 1); {$Note This must become a UTF8 function} - if Length(s1) > 0 then - s1 := Trim(s1); - Result := s1; - end; -end; - -procedure TfpgPageControl.LeftButtonClick(Sender: TObject); -begin - {$IFDEF DEBUG}writeln(Classname + '.LeftButtonClick');{$ENDIF} - if FFirstTabButton <> nil then - begin - if TfpgTabSheet(FPages.First) <> FFirstTabButton then - begin - FFirstTabButton := TfpgTabSheet(FPages[FPages.IndexOf(FFirstTabButton)-1]); - RePaint; - end; - end; -end; - -procedure TfpgPageControl.RightButtonClick(Sender: TObject); -begin - {$IFDEF DEBUG}writeln(Classname + '.RightButtonClick');{$ENDIF} - if FFirstTabButton <> nil then - begin - if TfpgTabSheet(FPages.Last) <> FFirstTabButton then - begin - FFirstTabButton := TfpgTabSheet(FPages[FPages.IndexOf(FFirstTabButton)+1]); - RePaint; - end; - end; -end; - -function TfpgPageControl.FindNextPage(ACurrent: TfpgTabSheet; AForward: boolean - ): TfpgTabSheet; -begin - // To be completed - result := nil; -end; - -procedure TfpgPageControl.SetSortPages(const AValue: boolean); -begin - if FSortPages = AValue then - Exit; //==> - FSortPages := AValue; - RePaint; -end; - -procedure TfpgPageControl.SetStyle(const AValue: TfpgTabStyle); -begin - if FStyle = AValue then - Exit; //==> - FStyle := AValue; - RePaintTitles; -end; - -procedure TfpgPageControl.SetTabPosition(const AValue: TfpgTabPosition); -begin - if FTabPosition = AValue then - Exit; //==> - FTabPosition := AValue; - RePaint; -end; - -procedure TfpgPageControl.DoChange(ATabSheet: TfpgTabSheet); -begin - if Assigned(FOnChange) then - FOnChange(self, ATabSheet); -end; - -function TfpgPageControl.DrawTab(const rect: TfpgRect; const Selected: Boolean = False; const Mode: Integer = 1): TfpgRect; -var - r: TfpgRect; -begin - r := rect; - if Selected then - begin - Result := rect; - InflateRect(Result, 2, 2); - Exit; //==> - end; - - if Mode = 2 then - r.Height := r.Height - 1; - - Canvas.SetColor(clButtonFace); - Canvas.FillRectangle(r.Left, r.Top, r.Width, r.Height-2); - Canvas.SetColor(clHilite2); - Canvas.DrawLine(r.Left, r.Bottom-2, r.Left, r.Top+2); - Canvas.DrawLine(r.Left, r.Top+2, r.Left+2, r.Top); - Canvas.DrawLine(r.Left+2, r.Top, r.Right-1, r.Top); - Canvas.SetColor(clShadow1); - Canvas.DrawLine(r.Right-1, r.Top+1, r.Right-1, r.Bottom-1); - Canvas.SetColor(clShadow2); - Canvas.DrawLine(r.Right-1, r.Top+1, r.Right, r.Top+2); - Canvas.DrawLine(r.Right, r.Top+2, r.Right, r.Bottom-1); -end; - -procedure TfpgPageControl.OrderSheets; -begin - FPages.Sort(@SortCompare); -end; - -procedure TfpgPageControl.RePaintTitles; -var - r: TfpgRect; - r2: TfpgRect; - r3: TfpgRect; - h: TfpgTabSheet; - lp: integer; - toffset: integer; - dx: integer; - lTxtFlags: TFTextFlags; -begin - if not HasHandle then - Exit; //==> - - if PageCount = 0 then - Exit; //==> - - h := TfpgTabSheet(FPages.First); - if h = nil then - Exit; - Canvas.BeginDraw; - Canvas.SetTextColor(TextColor); - lTxtFlags := TextFlagsDflt; - if not Enabled then - Include(lTxtFlags, txtDisabled); - - case TabPosition of - tpBottom: - begin -(* - if MaxButtonWidthSum > (Width-(FMargin*2)) then - begin - if FFirstTabButton = nil then - FFirstTabButton := h - else - h := FFirstTabButton; - r.SetRect(FMargin, FMargin, Width-(FMargin*2)-(FRightButton.Width*2)-1, FRightButton.Height); - FLeftButton.SetPosition(Width - FMargin * 2 - FRightButton.Width * 2, FMargin, FRightButton.Height, FRightButton.Height); - FRightButton.SetPosition(Width - FMargin * 2 - FrightButton.Width, FMargin, FRightButton.Height, FRightButton.Height); - FLeftButton.Visible := True; - FRightButton.Visible := True; - end - else - begin - r.SetRect(FMargin, FMargin, Width-(FMargin*2), ButtonHeight); - FLeftButton.Visible := False; - FRightButton.Visible := False; - end; - // tabsheet area - left outer line - Canvas.SetColor(clHilite1); - Canvas.DrawLine(FMargin, ButtonHeight, FMargin, Height-(FMargin*2)); - // tabsheet area - left inner line - Canvas.SetColor(clHilite2); - Canvas.DrawLine(FMargin+1, ButtonHeight+1, FMargin+1, Height - (FMargin*2) - 1); - // tabsheet area - outer bottom & right line - Canvas.SetColor(clShadow2); - Canvas.DrawLine(FMargin, Height - (FMargin*2), Width - (FMargin*2), Height - (FMargin*2)); - Canvas.DrawLine(Width - (FMargin*2), Height - (FMargin*2), Width - (FMargin*2), FMargin + ButtonHeight - 3); - // tabsheet area - inner bottom & right line - Canvas.SetColor(clShadow1); - Canvas.DrawLine(FMargin + 1, Height - (FMargin*2) - 1, Width - (FMargin*2) - 1, Height - (FMargin*2) - 1); - Canvas.DrawLine(Width - FMargin - 2, Height - FMargin - 2, Width - FMargin - 2, FMargin + ButtonHeight - 2); - Canvas.SetClipRect(r); - lp := 0; - while h <> nil do - begin - if h <> ActivePage then - begin - toffset := 4; - // tabsheet area - top lines under inactive tabs - Canvas.SetColor(clHilite1); - Canvas.DrawLine(FMargin + lp, FMargin + ButtonHeight - 2, FMargin + lp + ButtonWidth(h.Text), FMargin + ButtonHeight - 2); - Canvas.SetColor(clHilite2); - if TfpgTabSheet(FPages.First) = h then - dx := 1 - else - dx := -1; - Canvas.DrawLine(FMargin + lp+dx, FMargin + ButtonHeight - 1, FMargin + lp + ButtonWidth(h.Text) + 1, FMargin + ButtonHeight - 1); - // vertical divider line between inactive tabs - Canvas.SetColor(clShadow1); - Canvas.DrawLine(lp + FMargin + ButtonWidth(h.Text), FMargin, lp + FMargin + ButtonWidth(h.Text), FMargin + ButtonHeight - 2); - h.Visible := False; - end - else - begin - toffset := 2; - h.Visible := True; - h.SetPosition(FMargin+2, FMargin + ButtonHeight, Width - (FMargin*2) - 4, Height - (FMargin*2) - ButtonHeight - 2); - // tab outer left & top line - Canvas.SetColor(clHilite1); - Canvas.DrawLine(lp + FMargin, FMargin + ButtonHeight - 2, lp + FMargin, FMargin); - Canvas.DrawLine(lp + FMargin, FMargin, lp + FMargin + ButtonWidth(h.Text)-1, FMargin); - // tab inner left & top line - Canvas.SetColor(clHilite2); - Canvas.DrawLine(lp + FMargin + 1, FMargin + ButtonHeight - 1, lp + FMargin + 1, FMargin + 1); - Canvas.DrawLine(lp + FMargin + 1, FMargin + 1, lp + FMargin + ButtonWidth(h.Text) - 2, FMargin + 1); - // tab inner right line - Canvas.SetColor(clShadow1); - Canvas.DrawLine(lp + FMargin + ButtonWidth(h.Text) - 2, FMargin + 1, lp + FMargin + ButtonWidth(h.Text) - 2, FMargin + ButtonHeight); - // tab outer right line - Canvas.SetColor(clShadow2); - Canvas.DrawLine(lp + FMargin + ButtonWidth(h.Text) - 1, FMargin, lp + FMargin + ButtonWidth(h.Text) - 1, FMargin + ButtonHeight-1); - end; - // paint text - Canvas.DrawString(lp + (ButtonWidth(h.Text) div 2) - FFont.TextWidth(GetTabText(h.Text)) div 2, FMargin+toffset, GetTabText(h.Text)); - - lp := lp + ButtonWidth(h.Text); - if h <> TfpgTabSheet(FPages.Last) then - h := TfpgTabSheet(FPages[FPages.IndexOf(h)+1]) - else - h := nil; - end; { while } - // tabsheet area - top lines on right of tabs - Canvas.SetColor(clHilite1); - Canvas.Drawline(lp + 1, FMargin + ButtonHeight - 2, Width - (FMargin*2), FMargin + ButtonHeight - 2); - Canvas.SetColor(clHilite2); - Canvas.Drawline(lp , FMargin + ButtonHeight - 1, Width - (FMargin*2)-1, FMargin + ButtonHeight - 1); -*) - end; - - tpTop: - begin - if MaxButtonWidthSum > (Width-(FMargin*2)) then - begin - if FFirstTabButton = nil then - FFirstTabButton := h - else - h := FFirstTabButton; - r.SetRect(FMargin, FMargin, Width-(FMargin*2)-(FRightButton.Width*2)-1, FRightButton.Height); - FLeftButton.SetPosition(Width - FRightButton.Width * 2, FMargin, FRightButton.Height, FRightButton.Height); - FRightButton.SetPosition(Width - FrightButton.Width, FMargin, FRightButton.Height, FRightButton.Height); - FLeftButton.Visible := True; - FRightButton.Visible := True; - end - else - begin - r.SetRect(FMargin, FMargin, Width-(FMargin*2), ButtonHeight); - FLeftButton.Visible := False; - FRightButton.Visible := False; - end; - - lp := 0; - r2.SetRect(2, 2, 50, 21); - while h <> nil do - begin - if h <> ActivePage then - begin - toffset := 4; - h.Visible := False; - end - else - begin - toffset := 2; - h.Visible := True; - h.SetPosition(FMargin+2, FMargin+2 + r2.Height, Width - (FMargin*2) - 4, Height - r2.Height - ((FMargin+2)*2)); - end; - // paint tab button - r2.Width := ButtonWidth(h.Text); - r3 := DrawTab(r2, h = ActivePage); - - // paint text on non-active tabs - if h <> ActivePage then - Canvas.DrawText(lp + (ButtonWidth(h.Text) div 2) - FFont.TextWidth(GetTabText(h.Text)) div 2, FMargin+toffset, GetTabText(h.Text), lTxtFlags); - - r2.Left := r2.Left + r2.Width; - lp := lp + ButtonWidth(h.Text); - if h <> TfpgTabSheet(FPages.Last) then - h := TfpgTabSheet(FPages[FPages.IndexOf(h)+1]) - else - h := nil; - end; - // Draw Page Control body rectangle (client area) - r2.Left := 0; - r2.Top := r2.Top + r2.Height-2; - r2.Width := Width; - r2.Height := Height - r2.Height; - Canvas.DrawButtonFace(r2, []); - - // Draw text of ActivePage, because we didn't before. - DrawTab(r3, false, 2); - Canvas.DrawText(r3.Left+4, r3.Top+3, r3.Width, r3.Height, ActivePage.Text, lTxtFlags); - end; - end; - - Canvas.EndDraw; -end; - -procedure TfpgPageControl.HandlePaint; -begin - inherited HandlePaint; - if SortPages then - OrderSheets; - Canvas.ClearClipRect; - Canvas.Clear(FBackgroundColor); - - // To make it more visible in the UI Designer - if csDesigning in ComponentState then - begin - Canvas.SetColor(clInactiveWgFrame); - Canvas.DrawRectangle(0, 0, Width, Height); - Canvas.SetTextColor(clText1); - Canvas.DrawString(2, 2, Name + ': ' + Classname); - end; - - if TabPosition = tpBottom then - begin - if Focused then - Canvas.SetColor(clWidgetFrame) - else - Canvas.SetColor(clInactiveWgFrame); - Canvas.DrawRectangle(0, 0, Width, Height); - end; - RePaintTitles; -end; - -procedure TfpgPageControl.HandleShow; -begin - inherited HandleShow; - FLeftButton.Visible := False; - FRightButton.Visible := False; -end; - -procedure TfpgPageControl.HandleLMouseUp(x, y: integer; shiftstate: TShiftState); -var - h: TfpgTabSheet; - lp: integer; // left position - bw: integer; // button width -begin - h := TfpgTabSheet(FPages.First); - if h = nil then - Exit; //==> - - lp := FMargin; - if MaxButtonWidthSum > (Width-(FMargin*2)) then - h := FFirstTabButton; - - case TabPosition of - tpTop: - begin - if (y > FMargin) and (y < ButtonHeight) then - begin - while h <> nil do - begin - bw := ButtonWidth(h.Text); // initialize button width - if (x > lp) and (x < lp + bw) then - begin - if h <> ActivePage then - begin - ActivePage := h; - DoChange(ActivePage); - end; - exit; - end; { if } - lp := lp + bw; - if h <> TfpgTabSheet(FPages.Last) then - h := TfpgTabSheet(FPages[FPages.IndexOf(h)+1]) - else - h := nil; - end; { while } - end; { if } - end; - - tpBottom: - begin -(* - if (y > Height - FMargin - buttonheight) and (y < height - FMargin) then - begin - while h <> nil do - begin - bw := ButtonWidth(h^.TabSheet.Text); // initialize button width - if (x > lp) and (x < lp + bw) then - begin - if h^.TabSheet <> ActiveTabSheet then - begin - ActiveTabSheet := h^.TabSheet; - DoChange(ActiveTabSheet); - end; - exit; - end; - lp := lp + bw; - h := h^.next; - end; { while } - end; { if } -*) - end; - end; { case } - inherited HandleLMouseUp(x, y, shiftstate); -end; - -procedure TfpgPageControl.HandleKeyPress(var keycode: word; - var shiftstate: TShiftState; var consumed: boolean); -var - i: integer; -begin -// writeln(Classname, '.Keypress'); - consumed := True; - i := ActivePageIndex; - - case keycode of - keyLeft: - begin - if ActivePage <> TfpgTabSheet(FPages.First) then - begin - ActivePage := TfpgTabSheet(FPages[i-1]); - DoChange(ActivePage); - end; - end; - - keyRight: - begin - if ActivePage <> TfpgTabSheet(FPages.Last) then - begin - ActivePage := TfpgTabSheet(FPages[i+1]); - DoChange(ActivePage); - end; - end; - - else - consumed := False; - end; { case/else } - inherited HandleKeyPress(keycode, shiftstate, consumed); -end; - -constructor TfpgPageControl.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - FFont := fpgStyle.DefaultFont; - FPages := TList.Create; - FWidth := 150; - FHeight := 100; - FIsContainer := True; - - FTextColor := Parent.TextColor; - FBackgroundColor := Parent.BackgroundColor; - FFocusable := True; - FOnChange := nil; - FFixedTabWidth := 0; - FFirstTabButton := nil; - FStyle := tsTabs; - FTabPosition := tpTop; - FMargin := 1; - FSortPages := False; - - FLeftButton := TfpgButton.Create(self); - FLeftButton.Text := '<'; - FLeftButton.Height := 20; - FLeftButton.Width := 20; - FLeftButton.OnClick := @LeftButtonClick; - - FRightButton := TfpgButton.Create(self); - FRightButton.Text := '>'; - FRightButton.Height := 20; - FRightButton.Width := 20; - FRightButton.OnClick := @RightButtonClick; -end; - -destructor TfpgPageControl.Destroy; -var - ts: TfpgTabSheet; -begin - FOnChange := nil; - if FPages.Count > 0 then - FActivePage := TfpgTabSheet(FPages[0]); - ActiveWidget := nil; - while FPages.Count > 0 do - begin - ts := TfpgTabSheet(FPages.Last); - FPages.Remove(ts); - ts.Free; - end; - FPages.Free; - FFirstTabButton := nil; - inherited Destroy; -end; - -function TfpgPageControl.AppendTabSheet(ATitle: string): TfpgTabSheet; -begin - Result := TfpgTabSheet.Create(self); - Result.Text := ATitle; - InsertPage(Result); -end; - -end. - diff --git a/src/gui/gui_trackbar.pas b/src/gui/gui_trackbar.pas deleted file mode 100644 index c8f1ce56..00000000 --- a/src/gui/gui_trackbar.pas +++ /dev/null @@ -1,647 +0,0 @@ -{ - fpGUI - Free Pascal GUI Toolkit - - Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this - distribution, for details of the copyright. - - See the file COPYING.modifiedLGPL, included in this distribution, - for details about redistributing fpGUI. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - - Description: - Defines two types of TrackBar controls. Also known as Slider controls. -} - -unit gui_trackbar; - -{$mode objfpc}{$H+} - -{ - TODO: - - TfpgTrackBarExtra - * Tick line orientation (top, bottom, left or right) - * Slide the slider with the mouse button down (like a scrollbar) - * Slider button style (rectangle, pointer, double pointer) - * Tick captions - - - TfpgTrackBar - * Vertical orientation - * show ticks property -} - -interface - -uses - Classes, - SysUtils, - fpg_base, - fpg_main, - fpg_widget; - -type - TTrackBarChange = procedure(Sender: TObject; APosition: integer) of object; - - - TfpgTrackBarExtra = class(TfpgWidget) - private - FMax: integer; - FMin: integer; - FOnChange: TTrackBarChange; - FOrientation: TOrientation; - FPosition: integer; - FSliderSize: integer; - procedure DoChange; - procedure SetMax(const AValue: integer); - procedure SetMin(const AValue: integer); - procedure SetTBPosition(const AValue: integer); - procedure SetSliderSize(const AValue: integer); - procedure FixMinMaxOrder; - procedure FixPositionLimits; - procedure DrawSlider(p: integer); - protected - procedure HandlePaint; override; - procedure HandleLMouseUp(x, y: integer; shiftstate: TShiftState); override; - procedure HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override; - public - constructor Create(AOwner: TComponent); override; - published - property BackgroundColor; - property Min: integer read FMin write SetMin default 0; - property Max: integer read FMax write SetMax default 10; - property Position: integer read FPosition write SetTBPosition default 0; - property SliderSize: integer read FSliderSize write SetSliderSize default 11; - property Orientation: TOrientation read FOrientation write FOrientation default orHorizontal; - property TabOrder; - property OnChange: TTrackBarChange read FOnChange write FOnChange; - end; - - - TfpgTrackBar = class(TfpgWidget) - private - FMax: integer; - FMin: integer; - FOrientation: TOrientation; - FPosition: integer; - FScrollStep: integer; - FShowPosition: boolean; - FSliderPos: TfpgCoord; - FSliderLength: TfpgCoord; - FSliderDragging: boolean; - FSliderDragPos: TfpgCoord; - FSliderDragStart: TfpgCoord; - FMousePosition: TPoint; - FOnChange: TTrackBarChange; - FFont: TfpgFont; - procedure SetMax(const AValue: integer); - procedure SetMin(const AValue: integer); - procedure SetTBPosition(const AValue: integer); - procedure SetShowPosition(const AValue: boolean); - function GetTextWidth: TfpgCoord; - protected - procedure HandleLMouseDown(x, y: integer; shiftstate: TShiftState); override; - procedure HandleLMouseUp(x, y: integer; shiftstate: TShiftState); override; - procedure HandleMouseMove(x, y: integer; btnstate: word; shiftstate: TShiftState); override; - procedure HandlePaint; override; - procedure DrawSlider(recalc: boolean); virtual; - procedure RepaintSlider; - procedure PositionChange(d: integer); - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - published - property BackgroundColor; - property Position: integer read FPosition write SetTBPosition default 0; - property ScrollStep: integer read FScrollStep write FScrollStep default 1; - property Min: integer read FMin write SetMin default 0; - property Max: integer read FMax write SetMax default 100; - property ParentShowHint; - property ShowHint; - property ShowPosition: boolean read FShowPosition write SetShowPosition default False; - property Orientation: TOrientation read FOrientation write FOrientation default orHorizontal; - property TabOrder; - property TextColor; - property OnChange: TTrackBarChange read FOnChange write FOnChange; - property OnEnter; - property OnExit; - end; - - -implementation - -{ TfpgTrackBarExtra } - -procedure TfpgTrackBarExtra.DoChange; -begin - if Assigned(FOnChange) then - FOnChange(self, FPosition); -end; - -procedure TfpgTrackBarExtra.SetMax(const AValue: integer); -begin - if FMax = AValue then - Exit; //==> - FMax := AValue; - RePaint; -end; - -procedure TfpgTrackBarExtra.SetMin(const AValue: integer); -begin - if FMin = AValue then - Exit; //==> - FMin := AValue; - RePaint; -end; - -procedure TfpgTrackBarExtra.SetTBPosition(const AValue: integer); -begin - if FPosition = AValue then - Exit; //==> - FPosition := AValue; - RePaint; - DoChange; -end; - -procedure TfpgTrackBarExtra.SetSliderSize(const AValue: integer); -begin - if FSliderSize = AValue then - Exit; //==> - if AValue > 11 then - begin - FSliderSize := AValue; - RePaint; - end; -end; - -procedure TfpgTrackBarExtra.FixMinMaxOrder; -var - lmin: integer; - lmax: integer; -begin - if FMax < FMin then - begin - lmin := FMax; // change order - lmax := FMin; - FMax := lmax; // reassign values - FMin := lmin; - end; -end; - -procedure TfpgTrackBarExtra.FixPositionLimits; -begin - if FPosition < FMin then - FPosition := FMin; - if FPosition > FMax then - FPosition := FMax; -end; - -procedure TfpgTrackBarExtra.DrawSlider(p: integer); -var - h: integer; -begin - if Orientation = orHorizontal then - begin - h := Height div 2 - 1; - Canvas.SetColor(clHilite1); - Canvas.DrawLine(p - FSliderSize div 2,5, p + FSliderSize div 2, 5); - Canvas.DrawLine(p - FSliderSize div 2,5, p - FSliderSize div 2, h - FSliderSize div 2); - Canvas.DrawLine(p - FSliderSize div 2, h - FSliderSize div 2, p, h + FSliderSize div 2); - Canvas.SetColor(clHilite2); - Canvas.DrawLine(p - FSliderSize div 2 + 1,6, p + FSliderSize div 2 - 1, 6); - Canvas.DrawLine(p - FSliderSize div 2 + 1,6, p - FSliderSize div 2 + 1, h - FSliderSize div 2); - Canvas.DrawLine(p - FSliderSize div 2 + 1, h - FSliderSize div 2, p, h + FSliderSize div 2 - 1); - Canvas.SetColor(clShadow2); - Canvas.DrawLine(p + FSliderSize div 2, 6, p + FSliderSize div 2, h - FSliderSize div 2); - Canvas.DrawLine(p + FSliderSize div 2, h - FSliderSize div 2, p + 1, h + FSliderSize div 2 - 1); - Canvas.SetColor(clShadow1); - Canvas.DrawLine(p + FSliderSize div 2 - 1, 7, p + FSliderSize div 2 - 1, h - FSliderSize div 2); - Canvas.DrawLine(p + FSliderSize div 2 - 1, h - FSliderSize div 2, p + 1, h + FSliderSize div 2 - 2); - end - else - begin - h := Width div 2 - 1; - Canvas.SetColor(clHilite1); - Canvas.DrawLine(5,p - FSliderSize div 2, 5, p + FSliderSize div 2); - Canvas.DrawLine(5,p - FSliderSize div 2, h - FSliderSize div 2, p - FSliderSize div 2); - Canvas.DrawLine( h - FSliderSize div 2, p - FSliderSize div 2, h + FSliderSize div 2,p); - Canvas.SetColor(clHilite2); - Canvas.DrawLine(6,p - FSliderSize div 2 + 1, 6, p + FSliderSize div 2 - 1); - Canvas.DrawLine(6,p - FSliderSize div 2 + 1, h - FSliderSize div 2, p - FSliderSize div 2 + 1); - Canvas.DrawLine(h - FSliderSize div 2,p - FSliderSize div 2 + 1, h + FSliderSize div 2 - 1,p); - Canvas.SetColor(clShadow2); - Canvas.DrawLine( 6,p + FSliderSize div 2, h - FSliderSize div 2, p + FSliderSize div 2); - Canvas.DrawLine( h - FSliderSize div 2,p + FSliderSize div 2, h + FSliderSize div 2 - 1, p + 1); - Canvas.SetColor(clShadow1); - Canvas.DrawLine( 7, p + FSliderSize div 2 - 1, h - FSliderSize div 2,p + FSliderSize div 2 - 1); - Canvas.DrawLine( h - FSliderSize div 2, p + FSliderSize div 2 - 1, h + FSliderSize div 2 - 2, p + 1); - end; -end; - -procedure TfpgTrackBarExtra.HandlePaint; -var - r: TfpgRect; - linepos: double; - drawwidth: integer; - i: integer; -begin - Canvas.BeginDraw; -// inherited HandlePaint; - r.SetRect(0, 0, Width, Height); - Canvas.Clear(FBackgroundColor); - - if FFocused then - Canvas.SetColor(clWidgetFrame) - else - Canvas.SetColor(clInactiveWgFrame); - Canvas.DrawRectangle(r); - - FixMinMaxOrder; - FixPositionLimits; - - if Orientation = orHorizontal then - begin - drawwidth := Width - 5 - FSliderSize; - linepos := FMax - FMin; - if linepos <> 0 then - begin - linepos := drawwidth / linepos; - Canvas.SetColor(clWidgetFrame); - for i := 0 to (FMax - FMin) do - Canvas.DrawLine(round(2 + (FSliderSize div 2) + (linepos * i)), Height div 2 + FSliderSize * 2, round(2 + FSliderSize div 2 + linepos * i), Height - 5); - DrawSlider(round(2 + FSliderSize div 2 + linepos * position)); - end; - end - else - begin - drawwidth := Height - 5 - FSliderSize; - linepos := FMax - FMin; - if linepos <> 0 then - begin - linepos := drawwidth / linepos; - Canvas.SetColor(clWidgetFrame); - for i := 0 to (FMax - FMin) do - Canvas.DrawLine(Width div 2 + FSliderSize * 2, round(2 + (FSliderSize div 2) + (linepos * i)), Width - 5, round(2 + FSliderSize div 2 + linepos * i)); - DrawSlider(round(2 + FSliderSize div 2 + linepos * position)); - end; - end; { if/else } - - Canvas.EndDraw; -end; - -procedure TfpgTrackBarExtra.HandleLMouseUp(x, y: integer; shiftstate: TShiftState); -var - linepos: double; - drawwidth: integer; - OldPos: integer; -begin - OldPos := Position; - FixMinMaxOrder; - linepos := FMax - FMin; - - if Orientation = orHorizontal then - begin - drawwidth := Width - 5 - FSliderSize; - linepos := drawwidth / linepos; - FPosition := round((x - 2 - FSliderSize div 2) / linepos) + FMin; - end - else - begin - drawwidth := Height - 5 - FSliderSize; - linepos := drawwidth / linepos; - FPosition := round((y - 2 - FSliderSize div 2) / linepos) + FMin; - end; - RePaint; - - if Position <> OldPos then - DoChange; - -// inherited HandleLMouseUp(x, y, shiftstate); -end; - -procedure TfpgTrackBarExtra.HandleKeyPress(var keycode: word; - var shiftstate: TShiftState; var consumed: boolean); -var - OldPos: integer; -begin - consumed := True; - OldPos := FPosition; - - if Orientation = orHorizontal then - begin - case keycode of - keyLeft: Position := Position - 1; - keyRight: Position := Position + 1; - keyPageUp: Position := FMin; - keyPageDown: Position := FMax; - else - consumed := False; - end; - end - else - begin - case keycode of - keyUp: Position := Position - 1; - keyDown: Position := Position + 1; - keyPageUp: Position := FMin; - keyPageDown: Position := FMax; - else - consumed := False; - end; - end; { if/else } - - inherited HandleKeyPress(keycode, shiftstate, consumed); - if OldPos <> Position then - DoChange; -end; - -constructor TfpgTrackBarExtra.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - FFocusable := True; - FMin := 0; - FMax := 10; - FPosition := 0; - FSliderSize := 11; - FOrientation := orHorizontal; - FOnChange := nil; - FTextColor := Parent.TextColor; - FBackgroundColor := Parent.BackgroundColor; -end; - -{ TfpgTrackBar } - -procedure TfpgTrackBar.SetMax(const AValue: integer); -begin - if AValue = FMax then - Exit; - if AValue < FMin then - FMax := FMin - else - FMax := AValue; - if FPosition > FMax then - SetTBPosition(FMax); - Repaint; -end; - -procedure TfpgTrackBar.SetMin(const AValue: integer); -begin - if AValue = FMin then - Exit; - if AValue > FMax then - FMin := FMax - else - FMin := AValue; - if FPosition < FMin then - SetTBPosition(FMin); - Repaint; -end; - -procedure TfpgTrackBar.SetTBPosition(const AValue: integer); -begin - if AValue < FMin then - FPosition := FMin - else if AValue > FMax then - FPosition := FMax - else - FPosition := AValue; - - if HasHandle then - DrawSlider(False); - Repaint; -end; - -procedure TfpgTrackBar.SetShowPosition(const AValue: boolean); -begin - if FShowPosition = AValue then - Exit; //==> - FShowPosition := AValue; - RePaint; -end; - -function TfpgTrackBar.GetTextWidth: TfpgCoord; -begin - if FShowPosition then - Result := FFont.TextWidth(IntToStr(Max)) + 4 - else - Result := 0; -end; - -procedure TfpgTrackBar.HandleLMouseDown(x, y: integer; shiftstate: TShiftState); -var - tw: TfpgCoord; -begin - inherited HandleLMouseDown(x, y, shiftstate); - - if Orientation = orVertical then - begin - if (y >= Width + FSliderPos) and (y <= Width + FSliderPos + FSliderLength) then - begin - FSliderDragging := True; - FSliderDragPos := y; - end; - end - else - begin - tw := GetTextWidth; - if (x >= FSliderPos) and (x <= (FSliderPos + FSliderLength + tw)) then - begin - FSliderDragging := True; - FSliderDragPos := x; - end; - end; - - if FSliderDragging then - begin - FSliderDragStart := FSliderPos; - DrawSlider(False); - end; -end; - -procedure TfpgTrackBar.HandleLMouseUp(x, y: integer; shiftstate: TShiftState); -begin - inherited HandleLMouseUp(x, y, shiftstate); - FSliderDragging := False; - HandlePaint; -end; - -procedure TfpgTrackBar.HandleMouseMove(x, y: integer; btnstate: word; shiftstate: TShiftState); -var - d: integer; - area: integer; - newp: integer; - ppos: integer; - tw: TfpgCoord; -begin - inherited HandleMouseMove(x, y, btnstate, shiftstate); - - FMousePosition.X := x; - FMousePosition.Y := y; - - if (not FSliderDragging) or ((btnstate and MOUSE_LEFT) = 0) then - begin - FSliderDragging := False; - Exit; - end; - - if Orientation = orVertical then - begin - d := y - FSliderDragPos; - area := Height - FSliderLength-4; - end - else - begin - d := x - FSliderDragPos; - tw := GetTextWidth; - area := Width - FSliderLength-4-tw; - end; - - ppos := FSliderPos; - FSliderPos := FSliderDragStart + d; - - if FSliderPos < 0 then - FSliderPos := 0; - if FSliderPos > area then - FSliderPos := area; - - if ppos <> FSliderPos then - DrawSlider(False); - - if area <> FMin then - newp := FMin + Trunc((FMax - FMin) * (FSliderPos / area)) - else - newp := FMin; - - if newp <> FPosition then - begin - Position := newp; - if Assigned(FOnChange) then - FOnChange(self, FPosition); - end; -end; - -procedure TfpgTrackBar.HandlePaint; -var - r: TfpgRect; -begin - Canvas.BeginDraw; - - DrawSlider(True); - if Focused then - begin - r.SetRect(0, 0, Width, Height); - Canvas.DrawFocusRect(r); - end; - - Canvas.EndDraw; -end; - -procedure TfpgTrackBar.DrawSlider(recalc: boolean); -var - area: TfpgCoord; - mm: TfpgCoord; - r: TfpgRect; - tw: TfpgCoord; -begin - Canvas.BeginDraw; - Canvas.Clear(FBackgroundColor); - Canvas.SetColor(FBackgroundColor); - - if Orientation = orVertical then - area := Height-4 - else - begin - tw := GetTextWidth; - area := Width-4-tw; - end; - - if recalc then - begin - if FPosition > FMax then - FPosition := FMax; - if FPosition < FMin then - FPosition := FMin; - - mm := FMax - FMin; - area := area - FSliderLength; - if mm = 0 then - FSliderPos := FMin - else - FSliderPos := Trunc(area * ((FPosition - FMin) / mm)); - if FPosition = FMin then - inc(FSliderPos, 2); - end; - - if Orientation = orVertical then - begin - Canvas.DrawButtonFace(0, Width + FSliderPos, Width, FSliderLength, [btfIsEmbedded]); - Canvas.EndDraw(0, Width, Width, Height - Width - Width); - end - else - begin - r.SetRect(1, (Height-4) div 2, Width - tw - 4, 4); - Canvas.DrawControlFrame(r); - r.SetRect(FSliderPos, (Height-20) div 2, FSliderLength, 21); - Canvas.DrawButtonFace(r, []); - if FShowPosition then - begin - Canvas.SetTextColor(TextColor); - fpgStyle.DrawString(Canvas, Width - tw, (Height - FFont.Height) div 2, IntToStr(Position), Enabled); - end; - end; - Canvas.EndDraw; -end; - -procedure TfpgTrackBar.RepaintSlider; -begin - if not HasHandle then - Exit; //==> - DrawSlider(True); -end; - -procedure TfpgTrackBar.PositionChange(d: integer); -begin - FPosition := FPosition + d; - if FPosition < FMin then - FPosition := FMin; - if FPosition > FMax then - FPosition := FMax; - - if Visible then - DrawSlider(True); - - if Assigned(FOnChange) then - FOnChange(self, FPosition); -end; - -constructor TfpgTrackBar.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - FFocusable := True; - Height := 30; - Width := 100; - FOrientation := orHorizontal; - FMin := 0; - FMax := 100; - FPosition := 0; - FSliderPos := 0; - FSliderDragging := False; - FSliderLength := 11; - FScrollStep := 1; - FShowPosition := False; - FFont := fpgGetFont('#Grid'); - FTextColor := Parent.TextColor; - FBackgroundColor := Parent.BackgroundColor; - FOnChange := nil; -end; - -destructor TfpgTrackBar.Destroy; -begin - FOnChange := nil; - FFont.Free; - inherited Destroy; -end; - -end. - diff --git a/src/gui/gui_tree.pas b/src/gui/gui_tree.pas deleted file mode 100644 index 7e76e4c4..00000000 --- a/src/gui/gui_tree.pas +++ /dev/null @@ -1,1835 +0,0 @@ -{ - fpGUI - Free Pascal GUI Toolkit - - Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this - distribution, for details of the copyright. - - See the file COPYING.modifiedLGPL, included in this distribution, - for details about redistributing fpGUI. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - - Description: - Defines a basic Treeview control and Node classes. The treeview - keeps track of the nodes in a double-linked list structure. - Each Node as .prev and .next property pointing to it's neighbours. -} - -unit gui_tree; - -{$mode objfpc}{$H+} - -{ - TODO: - * Lots!! - * Columns need to be reworked. We don't want coluns per node levels. Instead - we want a main column covering the tree. Then extra columns for user - text and data. - * Implement event handlers the user can hook into and do custom drawing. - - WARNING: This is still under heavy development. Use at own risk! -} - -{.$Define Debug} - -interface - -uses - Classes, - SysUtils, - fpg_base, - fpg_main, - fpg_widget, - fpg_imagelist, - gui_scrollbar, - gui_menu; - -type - - PfpgTreeColumnWidth = ^TfpgTreeColumnWidth; - TfpgTreeColumnWidth = record - next: PfpgTreeColumnWidth; - width: word; - end; - - // forward declaration - TfpgTreeNode = class; - - TfpgTreeNodeFindMethod = procedure(ANode: TfpgTreeNode; var AFound: boolean) of object; - - - TfpgTreeNode = class(TObject) - private - FCollapsed: boolean; - FData: Pointer; - FFirstSubNode: TfpgTreeNode; // the subnodes - for list implementation - FImageIndex: integer; - FInactSelColor: TfpgColor; - FInactSelTextColor: TfpgColor; - FLastSubNode: TfpgTreeNode; - FNext: TfpgTreeNode; - FParent: TfpgTreeNode; - FPrev: TfpgTreeNode; - FSelColor: TfpgColor; - FSelTextColor: TfpgColor; - FText: string; - FTextColor: TfpgColor; - procedure SetCollapsed(const AValue: boolean); - procedure SetInactSelColor(const AValue: TfpgColor); - procedure SetInactSelTextColor(const AValue: TfpgColor); - procedure SetParent(const AValue: TfpgTreeNode); - procedure SetSelColor(const AValue: TfpgColor); - procedure SetSelTextColor(const AValue: TfpgColor); - procedure SetText(const AValue: string); - procedure SetTextColor(const AValue: TfpgColor); - procedure DoRePaint; - public - constructor Create; - destructor Destroy; override; - // node related - function AppendText(AText: string): TfpgTreeNode; - function Count: integer; - function CountRecursive: integer; - function FindSubNode(AText: string; ARecursive: Boolean): TfpgTreeNode; overload; - function FindSubNode(ATreeNodeFindMethod: TfpgTreeNodeFindMethod): TfpgTreeNode; overload; - function GetMaxDepth: integer; - function GetMaxVisibleDepth: integer; - procedure Append(aValue: TfpgTreeNode); - procedure Clear; // remove all nodes recursively - procedure Collapse; - procedure Expand; - procedure Remove(aNode: TfpgTreeNode); - procedure UnregisterSubNode(aNode: TfpgTreeNode); - // parent color settings - function ParentInactSelColor: TfpgColor; - function ParentInactSelTextColor: TfpgColor; - function ParentSelColor: TfpgColor; - function ParentSelTextColor: TfpgColor; - function ParentTextColor: TfpgColor; - // general properties - property Collapsed: boolean read FCollapsed write SetCollapsed; - property Data: Pointer read FData write FData; - property FirstSubNode: TfpgTreeNode read FFirstSubNode; - property ImageIndex: integer read FImageIndex write FImageIndex; - property LastSubNode: TfpgTreeNode read FLastSubNode; - property Next: TfpgTreeNode read FNext write FNext; - property Parent: TfpgTreeNode read FParent write SetParent; - property Prev: TfpgTreeNode read FPrev write FPrev; - property Text: string read FText write SetText; - // color settings - property InactSelColor: TfpgColor read FInactSelColor write SetInactSelColor; - property InactSelTextColor: TfpgColor read FInactSelTextColor write SetInactSelTextColor; - property SelColor: TfpgColor read FSelColor write SetSelColor; - property SelTextColor: TfpgColor read FSelTextColor write SetSelTextColor; - property TextColor: TfpgColor read FTextColor write SetTextColor; - end; - - - TfpgTreeExpandEvent = procedure(Sender: TObject; ANode: TfpgTreeNode) of object; - - - { TfpgTreeView } - - TfpgTreeView = class(TfpgWidget) - private - FImageList: TfpgImageList; - FColumnHeight: integer; // height of the column header - FDefaultColumnWidth: word; - FIndentNodeWithNoImage: boolean; - FFirstColumn: PfpgTreeColumnWidth; // the list for column widths - FFont: TfpgFont; - FHScrollbar: TfpgScrollbar; - FMoving: boolean; - FMovingCol: integer; - FMovingPos: integer; - FNoImageIndent: integer; - FOnChange: TNotifyEvent; - FOnExpand: TfpgTreeExpandEvent; - FRootNode: TfpgTreeNode; - FScrollWheelDelta: integer; - FSelection: TfpgTreeNode; // currently selected node - FShowColumns: boolean; - FShowImages : boolean; - FTreeLineColor: TfpgColor; - FTreeLineStyle: TfpgLineStyle; - FVScrollbar: TfpgScrollbar; - FXOffset: integer; // for repaint and scrollbar-calculation - FYOffset: integer; - function GetFontDesc: string; - function GetRootNode: TfpgTreeNode; - procedure SetDefaultColumnWidth(const AValue: word); - procedure SetFontDesc(const AValue: string); - procedure SetSelection(const AValue: TfpgTreeNode); - procedure SetShowColumns(const AValue: boolean); - procedure SetShowImages(const AValue: boolean); - procedure SetTreeLineColor(const AValue: TfpgColor); - procedure SetTreeLineStyle(const AValue: TfpgLineStyle); - procedure SetIndentNodeWithNoImage(const AValue: boolean); - function VisibleWidth: integer; - function VisibleHeight: integer; - function GetNodeHeightSum: integer; - function MaxNodeWidth: integer; - function GetNodeHeight: integer; - // width of a node inclusive image - function GetNodeWidth(ANode: TfpgTreeNode): integer; - function NodeIsVisible(ANode: TfpgTreeNode): boolean; - // returns the node-top in pixels - function GetAbsoluteNodeTop(ANode: TfpgTreeNode): integer; - function GetColumnLeft(AIndex: integer): integer; - procedure PreCalcColumnLeft; - procedure VScrollbarScroll(Sender: TObject; position: integer); - procedure HScrollbarScroll(Sender: TObject; position: integer); - procedure UpdateScrollbars; - procedure ResetScrollbar; - procedure ClearColumnLeft; - procedure FreeAllTreeNodes; - protected - FColumnLeft: TList; - FPopupMenu: TfpgPopupMenu; - procedure HandleResize(awidth, aheight: TfpgCoord); override; - procedure HandleLMouseUp(x, y: integer; shiftstate: TShiftState); override; - procedure HandleLMouseDown(x, y: integer; shiftstate: TShiftState); override; - procedure HandleRMouseUp(x, y: integer; shiftstate: TShiftState); override; - procedure HandleDoubleClick(x, y: integer; button: word; shiftstate: TShiftState); override; - procedure HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override; - procedure HandleMouseScroll(x, y: integer; shiftstate: TShiftState; delta: smallint); override; - procedure HandleShow; override; - procedure HandlePaint; override; - procedure DrawHeader(ACol: integer; ARect: TfpgRect; AFlags: integer); virtual; - procedure DoChange; virtual; - procedure DoExpand(ANode: TfpgTreeNode); virtual; - function NextVisualNode(ANode: TfpgTreeNode): TfpgTreeNode; - function PrevVisualNode(ANode: TfpgTreeNode): TfpgTreeNode; - // the nodes between the given node and the direct next node - function SpaceToVisibleNext(aNode: TfpgTreeNode): integer; - function StepToRoot(aNode: TfpgTreeNode): integer; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - procedure SetColumnWidth(AIndex, AWidth: word); - // the width of a column - aIndex of the rootnode = 0 - function GetColumnWidth(AIndex: word): word; - property Font: TfpgFont read FFont; - // Invisible node that starts the tree - property RootNode: TfpgTreeNode read GetRootNode; - property Selection: TfpgTreeNode read FSelection write SetSelection; - property ImageList: TfpgImageList read FImageList write FImageList; - property PopupMenu: TfpgPopupMenu read FPopupMenu write FPopupMenu; - published - property DefaultColumnWidth: word read FDefaultColumnWidth write SetDefaultColumnWidth default 15; - property FontDesc: string read GetFontDesc write SetFontDesc; - property IndentNodeWithNoImage: boolean read FIndentNodeWithNoImage write SetIndentNodeWithNoImage default True; - property NoImageIndent: integer read FNoImageIndent write FNoImageIndent default 16; - property ParentShowHint; - property ScrollWheelDelta: integer read FScrollWheelDelta write FScrollWheelDelta default 15; - property ShowColumns: boolean read FShowColumns write SetShowColumns default False; - property ShowHint; - property ShowImages: boolean read FShowImages write SetShowImages default False; - property TabOrder; - property TreeLineColor: TfpgColor read FTreeLineColor write SetTreeLineColor default clShadow1; - property TreeLineStyle: TfpgLineStyle read FTreeLineStyle write SetTreeLineStyle default lsDot; - property OnChange: TNotifyEvent read FOnChange write FOnChange; - property OnExpand: TfpgTreeExpandEvent read FOnExpand write FOnExpand; - end; - - -implementation - -type - PColumnLeft = ^integer; - - -{ TfpgTreeNode } - -procedure TfpgTreeNode.SetInactSelColor(const AValue: TfpgColor); -begin - if AValue <> FInactSelColor then - begin - FInactSelColor := AValue; - DoRePaint; - end; -end; - -procedure TfpgTreeNode.SetCollapsed(const AValue: boolean); -begin - if aValue <> FCollapsed then - begin - FCollapsed := AValue; - DoRePaint; - end; -end; - -procedure TfpgTreeNode.SetInactSelTextColor(const AValue: TfpgColor); -begin - if AValue <> FInactSelTextColor then - begin - FInactSelTextColor := AValue; - DoRePaint; - end; -end; - -procedure TfpgTreeNode.SetParent(const AValue: TfpgTreeNode); -begin - if aValue <> FParent then - begin - if FParent <> nil then - FParent.UnRegisterSubNode(self); // unregisteres - FParent := aValue; - if FParent <> nil then - begin - DoRePaint; - end; - end; -end; - -procedure TfpgTreeNode.SetSelColor(const AValue: TfpgColor); -begin - if FSelColor <> aValue then - begin - FSelColor := aValue; - DoRePaint; - end; -end; - -procedure TfpgTreeNode.SetSelTextColor(const AValue: TfpgColor); -begin - if FTextColor <> aValue then - begin - FSelTextColor := aValue; - DoRePaint; - end; -end; - -procedure TfpgTreeNode.SetText(const AValue: string); -begin - if aValue <> FText then - begin - FText := aValue; - DoRePaint; - end; -end; - -procedure TfpgTreeNode.SetTextColor(const AValue: TfpgColor); -begin - if FTextColor <> aValue then - begin - FTextColor := aValue; - DoRePaint; - end; -end; - -procedure TfpgTreeNode.DoRePaint; -begin - // todo -end; - -constructor TfpgTreeNode.Create; -begin - FData := nil; - FFirstSubNode := nil; - FLastSubNode := nil; - FText := ''; - FImageIndex := -1; - - FParent := nil; - FNext := nil; - FPrev := nil; - - FSelColor := clUnset; - FSelTextColor := clUnset; - FTextColor := clUnset; - FInactSelColor := clUnset; - FInactSelTextColor := clUnset; -end; - -destructor TfpgTreeNode.Destroy; -begin - if FParent <> nil then - FParent.UnregisterSubNode(self); - FData := nil; - FParent := nil; - FNext := nil; - FPrev := nil; - FFirstSubNode := nil; - FLastSubNode := nil; - inherited Destroy; -end; - -procedure TfpgTreeNode.UnregisterSubNode(aNode: TfpgTreeNode); -var - h: TfpgTreeNode; -begin - h := FFirstSubNode; - while h <> nil do - begin - if h = aNode then - begin - if h = FFirstSubNode then - FFirstSubNode := FFirstSubNode.Next; - if h = FLastSubNode then - FLastSubNode := FLastSubNode.Prev; - if h.prev <> nil then - h.prev.next := h.next; - if h.next <> nil then - h.next.prev := h.prev; - exit; - end; - h := h.next; - end; -end; - -procedure TfpgTreeNode.Append(aValue: TfpgTreeNode); -begin - aValue.Parent := self; - aValue.Next := nil; - - if FFirstSubNode = nil then - FFirstSubNode := aValue; - - aValue.prev := FLastSubNode; - - if FLastSubNode <> nil then - FLastSubNode.Next := aValue; - - FLastSubNode := aValue; -end; - -function TfpgTreeNode.FindSubNode(AText: string; ARecursive: Boolean): TfpgTreeNode; -var - h: TfpgTreeNode; -begin - result := nil; - if ARecursive then - begin - h := FirstSubNode; - while h <> nil do - begin -// writeln('h.Text = ', h.Text); - if h.Text = AText then - begin - result := h; - Exit; //==> - end; - if h.count > 0 then - begin - result := h.FindSubNode(AText, ARecursive); - if result <> nil then - Exit; //==> - end; - h := h.next; - end; { while } - end - else - begin - h := FirstSubNode; - while h <> nil do - begin - if h.Text = AText then - begin - result := h; - break; - end; - h := h.next; - end; - end; { if/else } -end; - -function TfpgTreeNode.FindSubNode(ATreeNodeFindMethod: TfpgTreeNodeFindMethod): TfpgTreeNode; -var - lFound: Boolean; - h: TfpgTreeNode; -begin - result := nil; - lFound := False; - if not Assigned(ATreeNodeFindMethod) then - Exit; //==> - - h := FirstSubNode; - while h <> nil do - begin - ATreeNodeFindMethod(h, lFound); - if lFound then - begin - result := h; - Exit; //==> - end; - if h.Count > 0 then - begin - result := h.FindSubNode(ATreeNodeFindMethod); - if result <> nil then - Exit; //==> - end; - h := h.next; - end; -end; - -function TfpgTreeNode.AppendText(AText: string): TfpgTreeNode; -var - h: TfpgTreeNode; -begin - {$IFDEF DEBUG} - writeln('TfpgTreeNode.AppendText'); - {$ENDIF} - h := TfpgTreeNode.Create; - h.Text := AText; - Append(h); - result := h; -end; - -function TfpgTreeNode.GetMaxDepth: integer; -var - h: TfpgTreeNode; - a: integer; - t: integer; -begin - {$IFDEF DEBUG} - writeln('TfpgTreeNode.GetMaxDepth'); - {$ENDIF} - h := FirstSubNode; - result := 1; - a := 0; - while h <> nil do - begin - t := h.GetMaxDepth; - if t > a then - a := t; - h := h.next; - end; - result := result + a; -end; - -function TfpgTreeNode.GetMaxVisibleDepth: integer; -var - h: TfpgTreeNode; - a: integer; - t: integer; -begin - {$IFDEF DEBUG} - writeln('TfpgTreeNode.GetMaxVisibleDepth'); - {$ENDIF} - result := 1; - h := FirstSubNode; - if h.Collapsed then - exit; - a := 0; - while h <> nil do - begin - t := h.GetMaxDepth; - if t > a then - a := t; - h := h.next; - end; - result := result + a; -end; - -procedure TfpgTreeNode.Collapse; -begin - Collapsed := True; -end; - -procedure TfpgTreeNode.Expand; -begin - Collapsed := False; -end; - -function TfpgTreeNode.Count: integer; -var - h: TfpgTreeNode; - i: integer; -begin - h := FirstSubNode; - i := 0; - while h <> nil do - begin - inc(i); - h := h.next; - end; - result := i; -end; - -function TfpgTreeNode.CountRecursive: integer; -var - h: TfpgTreeNode; - i: integer; -begin - h := FFirstSubNode; - i := 0; - while h <> nil do - begin - inc(i); // current node - i := i + h.CountRecursive; // increases i by the count of the subnodes of the subnode - h := h.next; - end; - result := i; -end; - -procedure TfpgTreeNode.Remove(aNode: TfpgTreeNode); -begin - if FirstSubNode = aNode then - begin - FFirstSubNode := aNode.next; - if FFirstSubNode <> nil then - FFirstSubNode.Prev := nil; - end - else - if aNode.prev <> nil then - aNode.Prev.next := aNode.next; - if LastSubNode = aNode then - begin - FLastSubNode := aNode.prev; - if FLastSubNode <> nil then - FLastSubNode.next := nil; - end - else - if aNode.next <> nil then - aNode.next.prev := aNode.prev; - aNode.prev := nil; - aNode.next := nil; - aNode.parent := nil; -end; - -procedure TfpgTreeNode.Clear; -begin - while FirstSubNode <> nil do - begin - if FirstSubNode.Count > 0 then - FirstSubNode.Clear; - Remove(FirstSubNode); - end; -end; - -function TfpgTreeNode.ParentTextColor: TfpgColor; -begin - if TextColor <> clUnset then - result := TextColor - else - begin - if parent <> nil then - result := parent.ParentTextColor - else - result := clText1; - end; -end; - -function TfpgTreeNode.ParentSelTextColor: TfpgColor; -begin - if SelTextColor <> clUnset then - result := SelTextColor - else - begin - if parent <> nil then - result := parent.ParentSelTextColor - else - result := clSelectionText; - end; -end; - -function TfpgTreeNode.ParentSelColor: TfpgColor; -begin - if SelColor <> clUnset then - result := SelColor - else - begin - if parent <> nil then - result := parent.ParentSelColor - else - result := clSelection; - end; -end; - -function TfpgTreeNode.ParentInactSelTextColor: TfpgColor; -begin - if InactSelTextColor <> clUnset then - result := InactSelTextColor - else - begin - if Parent <> nil then - Result := Parent.ParentInactSelTextColor - else - Result := clInactiveSelText; - end; -end; - -function TfpgTreeNode.ParentInactSelColor: TfpgColor; -begin - if InactSelColor <> clUnset then - result := InactSelColor - else - begin - if Parent <> nil then - result := parent.ParentInactSelColor - else - result := clInactiveSel; - end; -end; - -{ TfpgTreeview } - -procedure TfpgTreeview.VScrollbarScroll(Sender: TObject; position: integer); -begin - {$IFDEF DEBUG} - writeln(Classname, '.VScrollbarMove'); - {$ENDIF} - FYOffset := Position; - RePaint; -end; - -function TfpgTreeview.GetFontDesc: string; -begin - Result := FFont.FontDesc; -end; - -function TfpgTreeview.GetRootNode: TfpgTreeNode; -begin - if FRootNode = nil then - FRootNode := TfpgTreeNode.Create; - FRootNode.TextColor := clText1; - FRootnode.SelTextColor := clSelectionText; - FRootnode.SelColor := clSelection; - Result := FRootNode; -end; - -procedure TfpgTreeview.SetDefaultColumnWidth(const AValue: word); -begin - if (aValue <> FDefaultColumnWidth) and (aValue > 3) then - begin - FDefaultColumnWidth := AValue; - RePaint; - end; -end; - -procedure TfpgTreeview.SetFontDesc(const AValue: string); -begin - FFont.Free; - FFont := fpgGetFont(AValue); - RePaint; -end; - -procedure TfpgTreeview.SetSelection(const AValue: TfpgTreeNode); -var - n: TfpgTreeNode; -begin - if aValue <> FSelection then - begin - FSelection := aValue; - if aValue <> nil then - begin - n := aValue.parent; - while n <> nil do - begin - n.Expand; - DoExpand(n); - n := n.parent; - end; - end; - - if GetAbsoluteNodeTop(Selection) + GetNodeHeight - FVScrollbar.Position > VisibleHeight then - begin - FVScrollbar.Position := GetAbsoluteNodeTop(Selection) + GetNodeHeight - VisibleHeight; - FYOffset := FVScrollbar.Position; - UpdateScrollBars; - end; - - if GetAbsoluteNodeTop(Selection) - FVScrollbar.Position < 0 then - begin - FVScrollbar.Position := GetAbsoluteNodeTop(Selection); - FYOffset := FVScrollbar.Position; - UpdateScrollbars; - end; - end; -end; - -procedure TfpgTreeview.SetShowColumns(const AValue: boolean); -begin - if FShowColumns <> aValue then - begin - FShowColumns := aValue; - RePaint; - end; -end; - -procedure TfpgTreeview.SetShowImages(const AValue: boolean); -begin - if AValue <> FShowImages then - begin - FShowImages := AValue; - UpdateScrollbars; - RePaint; - end; -end; - -procedure TfpgTreeview.SetTreeLineColor(const AValue: TfpgColor); -begin - if FTreeLineColor = AValue then - Exit; //==> - FTreeLineColor := AValue; - RePaint; -end; - -procedure TfpgTreeview.SetTreeLineStyle(const AValue: TfpgLineStyle); -begin - if FTreeLineStyle = AValue then - Exit; //==> - FTreeLineStyle := AValue; - RePaint; -end; - -procedure TfpgTreeView.SetIndentNodeWithNoImage(const AValue: boolean); -begin - if AValue <> FIndentNodeWithNoImage then - begin - FIndentNodeWithNoImage := AValue; - UpdateScrollbars; - RePaint; - end; -end; - -function TfpgTreeview.VisibleWidth: integer; -begin - Result := Width - 2; - if FVScrollbar.Visible then - dec(Result, FVScrollbar.Width); -end; - -function TfpgTreeview.VisibleHeight: integer; -begin - Result := Height - 2; - if FShowColumns then - dec(Result, FColumnHeight); - if FHScrollbar.Visible then - dec(Result, FHScrollbar.Height); -end; - -function TfpgTreeview.GetNodeHeightSum: integer; -var - h: TfpgTreeNode; - i: integer; -begin - h := RootNode; - i := -1; - while h <> nil do - begin - inc(i); - if (not h.Collapsed) and (h.Count > 0) then - begin - h := h.FirstSubNode; - end - else - begin - if h.next <> nil then - h := h.next - else - begin - while h.next = nil do - begin - h := h.parent; - if h = nil then - begin - result := i; - exit; - end; - end; - h := h.next; - end; - end; - end; - result := i; -end; - -function TfpgTreeview.MaxNodeWidth: integer; -var - h: TfpgTreeNode; - w: integer; - r: integer; -begin - {$IFDEF DEBUG} - writeln('TfpgTreeView.MaxNodeWidth'); - {$ENDIF} - result := 0; - h := RootNode.FirstSubNode; - r := 0; - while h <> nil do - begin - w := GetColumnLeft(StepToRoot(h)); - if r < w + GetNodeWidth(h) then - r := w + GetNodeWidth(h); - if (not h.collapsed) and (h.count > 0) then - h := h.FirstSubNode - else - begin - if h.next <> nil then - h := h.next - else - begin - while h.next = nil do - begin - h := h.parent; - if h = nil then - begin - result := r + 4; - exit; - end; - end; { while } - h := h.next; - end; - end; { if/else } - end; { while } -end; - -function TfpgTreeview.GetNodeHeight: integer; -begin - Result := FFont.Height + 2; -end; - -function TfpgTreeview.GetNodeWidth(ANode: TfpgTreeNode): integer; -var - AImage: TfpgImageItem; -begin - {$IFDEF DEBUG} - writeln('TfpgTreeView.GetNodeWidth'); - {$ENDIF} - if ANode = nil then - Result := 0 - else - begin - Result := FFont.TextWidth(ANode.Text) + 2; - if ShowImages and (ImageList <> nil) then - begin - if ANode.ImageIndex > -1 then - begin - AImage := ImageList.Item[ANode.ImageIndex]; - if AImage <> nil then - result := result + AImage.Image.Width + 2; - end - else if IndentNodeWithNoImage then - result := result + NoImageIndent + 2; - end; - end; { if/else } -end; - -function TfpgTreeview.NodeIsVisible(ANode: TfpgTreeNode): boolean; -begin - Result := True; - if ANode = nil then - begin - Result := False; - exit; - end; - ANode := ANode.Parent; - while ANode <> nil do - begin - if ANode.Collapsed and (ANode.Parent <> nil) then - Result := False; - ANode := ANode.Parent; - end; -end; - -function TfpgTreeview.GetAbsoluteNodeTop(ANode: TfpgTreeNode): integer; -var - i: integer; -begin - i := 0; - while (ANode <> nil) and (ANode <> RootNode) do - begin - ANode := PrevVisualNode(ANode); - inc(i); - end; - result := (i - 1) * GetNodeHeight; -end; - -function TfpgTreeview.GetColumnLeft(AIndex: integer): integer; -begin - if FColumnLeft = nil then - PreCalcColumnLeft; - - if AIndex < 0 then - Result := 0 - else - begin - if AIndex > FColumnLeft.Count - 1 then - result := PColumnLeft(FColumnLeft[FColumnLeft.Count - 1])^ - else - result := PColumnLeft(FColumnLeft[AIndex])^; - end; -end; - -function TfpgTreeview.GetColumnWidth(AIndex: word): word; -var - h: PfpgTreeColumnWidth; - i: integer; -begin -{$IFDEF DEBUG} - writeln('TfpgTreeView.GetColumnWidth'); -{$ENDIF} - h := FFirstColumn; - i := 0; - if h = nil then // not found - begin - result := DefaultColumnWidth; - exit; - end; - while i < aIndex do - begin - if h = nil then // not found - returns the default - begin - result := DefaultColumnWidth; - exit; - end; - h := h^.next; - inc(i); - end; - if h <> nil then - result := h^.width - else // not found -> returns the default - result := DefaultColumnWidth; -end; - -procedure TfpgTreeview.PreCalcColumnLeft; -var - Aleft: TfpgCoord; - ACounter: integer; - AColumnLeft: PColumnLeft; -begin - {$IFDEF DEBUG} - writeln('TfpgTreeView.PreCalcColumnWidth'); - {$ENDIf} - if FColumnLeft = nil then - FColumnLeft := TList.Create; - - ClearColumnLeft; // Freeing memory - - Aleft := 0; - for ACounter := 1 to RootNode.GetMaxDepth do - begin - AColumnLeft := new(PColumnLeft); - AColumnLeft^ := Aleft; - FColumnLeft.Add(AColumnLeft); - Aleft := Aleft + GetColumnWidth(ACounter); - end; -end; - -procedure TfpgTreeview.HScrollbarScroll(Sender: TObject; position: integer); -begin - FXOffset := Position; - RePaint; -end; - -procedure TfpgTreeview.UpdateScrollbars; -begin - {$IFDEF DEBUG} - writeln(Classname, '.UpdateScrollbars'); - {$ENDIF} - FVScrollbar.Visible := VisibleHeight < GetNodeHeightSum * GetNodeHeight; - FVScrollbar.Min := 0; - FVScrollbar.Max := (GetNodeHeightSum - 1) * GetNodeHeight; - FHScrollbar.Min := 0; - FHScrollbar.Max := MaxNodeWidth - VisibleWidth + FVScrollbar.Width; - FHScrollbar.Visible := MaxNodeWidth > Width - 2; - if not FVScrollbar.Visible then - begin - FVScrollbar.Position := 0; - FVScrollBar.RepaintSlider; - FYOffset := 0; - end; - if not FHScrollbar.Visible then - begin - FHScrollbar.Position := 0; - FHScrollBar.RepaintSlider; - FXOffset := 0; - end; -end; - -procedure TfpgTreeview.ResetScrollbar; -begin - {$IFDEF DEBUG} - writeln(Classname, '.ResetScrollbar'); - {$ENDIF} - UpdateScrollBars; - if FHScrollbar.Visible then - FVScrollbar.SetPosition(Width - 19, 1, 18, Height - 2 - 18) - else - FVScrollbar.SetPosition(Width - 19, 1, 18, Height - 2); - FHScrollbar.SetPosition(1, Height - 19, Width - 2, 18); -end; - -procedure TfpgTreeView.ClearColumnLeft; -var - i: integer; - AColumnLeft: PColumnLeft; -begin - for i := 0 to FColumnLeft.Count - 1 do // Freeing Memory - begin - AColumnLeft := FColumnLeft[i]; - Dispose(AColumnLeft); - end; - FColumnLeft.Clear; -end; - -procedure TfpgTreeView.FreeAllTreeNodes; -var - n: TfpgTreeNode; - list: TList; -begin - list := TList.Create; - n := RootNode.FirstSubNode; - list.Add(n); - - while n <> nil do - begin - // todo: this only frees of the first level of nodes!!!! - n := n.next; - list.Add(n); - end; - -// writeln('NodeCount = ', list.Count); - while list.Count > 0 do - begin - n := TfpgTreeNode(list.Last); - list.Remove(n); - n.Free; - end; - list.Clear; - list.Free; -end; - -procedure TfpgTreeview.HandleResize(awidth, aheight: TfpgCoord); -begin - {$IFDEF DEBUG} - writeln(Classname, '.HandleResize'); - {$ENDIF} - inherited HandleResize(awidth, aheight); - if (csLoading in ComponentState) then - exit; - ResetScrollbar; - RePaint; -end; - -procedure TfpgTreeview.HandleLMouseUp(x, y: integer; shiftstate: TShiftState); -var - col: integer; - i: integer; - w: integer; - i1: integer; - last: TfpgTreeNode; - node: TfpgTreeNode; - cancel: boolean; - OldSel: TfpgTreeNode; -begin - inherited HandleLMouseUp(x, y, shiftstate); - - node := nil; - OldSel := Selection; - if FMoving then // column resize - begin - FMoving := false; - x := x + FXOffset; - SetColumnWidth(FMovingCol, GetColumnWidth(FMovingCol) + x - FMovingPos); - FMoving := false; - end - else - begin - if ShowColumns then - col := FColumnHeight - else - col := 0; - y := y - col - 1 + FYOffset; - i := 0; - x := x + FXOffset; - cancel := False; - last := RootNode; - while not (((i - 1) * GetNodeHeight - 2 <= y) and ((i) * GetNodeHeight + 2 >= y)) do - begin - node := NextVisualNode(last); - if node = nil then - exit; //==> - if node = last then - begin - cancel := True; - break; //==> - end; - inc(i); - last := node; - end; - - if (not cancel) or (node <> nil) then - begin - // +/- or node-selection? - i1 := StepToRoot(node); - w := GetColumnLeft(i1); - if (x >= w - GetColumnWidth(i1) div 2 - 3) and (x <= w - GetColumnWidth(i1) div 2 + 6) then - // collapse or expand? - begin // yes - if node.Count > 0 then - begin - if node.Collapsed then - begin - node.expand; - DoExpand(node); - end - else - node.Collapse; - ResetScrollBar; - RePaint; - end; - end - else - begin - if x > w - GetColumnWidth(i1) div 2 + 6 then - Selection := node; - end; - end; - end; - if OldSel <> Selection then - begin - RePaint; - DoChange; - end; -end; - -procedure TfpgTreeview.HandleLMouseDown(x, y: integer; shiftstate: TShiftState); -var - xpos: integer; - i: integer; -begin - inherited HandleLMouseDown(x, y, shiftstate); - if ShowColumns then - begin - x := x + FXOffset; - xpos := 0; - i := 0; - while xpos + 2 < x do - begin - inc(i); - xpos := xpos + GetColumnWidth(i); - end; - if (x > xpos - 2) and (x < xpos + 2) then - begin - FMoving := True; - FMovingPos := xpos; - FMovingCol := i; - SetColumnWidth(i, GetColumnWidth(i)); - end; - end; - RePaint; -end; - -procedure TfpgTreeView.HandleRMouseUp(x, y: integer; shiftstate: TShiftState); -begin - inherited HandleRMouseUp(x, y, shiftstate); - if Assigned(PopupMenu) then - PopupMenu.ShowAt(self, x, y); -end; - -procedure TfpgTreeview.HandleDoubleClick(x, y: integer; button: word; - shiftstate: TShiftState); -begin - // to setup cursor co-ordinates and handle selection - HandleLMouseUp(x, y, shiftstate); - inherited HandleDoubleClick(x, y, button, shiftstate); - if Selection <> nil then - begin - if Selection.Collapsed then - begin - Selection.Expand; - DoExpand(Selection); - end - else - Selection.Collapse; - RePaint; - end; -end; - -procedure TfpgTreeview.HandleShow; -begin - if (csLoading in ComponentState) then - Exit; - ResetScrollbar; - inherited HandleShow; -end; - -procedure TfpgTreeview.HandlePaint; -var - r: TfpgRect; - h: TfpgTreeNode; - i: integer; - i1: integer; - w: integer; - YPos: integer; - col: integer; - ACenterPos: integer; - x: integer; - y: integer; - AImageItem: TfpgImageItem; - AVisibleHeight: integer; -begin - {$IFDEF DEBUG} - writeln('TfpgTreeview.HandlePaint'); - {$ENDIF} -// inherited HandlePaint; - if not HasHandle then - Exit; //==> - i1 := 0; - PreCalcColumnLeft; - UpdateScrollbars; - AVisibleHeight := VisibleHeight; - - Canvas.BeginDraw; // start double buffering - Canvas.ClearClipRect; - Canvas.Clear(FBackgroundColor); - if FFocused then - Canvas.SetColor(clWidgetFrame) - else - Canvas.SetColor(clInactiveWgFrame); - r.SetRect(0, 0, Width, Height); - Canvas.DrawRectangle(r); // border - - { TODO : Columns need to be redesigned completely } - if ShowColumns then - begin - // Drawing column headers - r.SetRect(1, 1, 0, FColumnHeight); - for col := 1 to rootnode.getMaxDepth - 1 do - begin - r.Width := GetColumnWidth(col); - DrawHeader(col, r, 0); - inc(r.Left, r.Width); - if r.Left >= VisibleWidth then - Break; // small optimization. Don't draw what we can't see - end; - // Fill remainder of the client area with one big header - r.width := VisibleWidth - r.Left + 1; - DrawHeader(col+1, r, 0); - end; - - // Calculate the client area used for nodes and lines - if ShowColumns then - begin - r.SetRect(1, 1 + FColumnHeight, VisibleWidth, VisibleHeight); - col := FColumnHeight; - end - else - begin - r.SetRect(1, 1, VisibleWidth, VisibleHeight); - col := 0; - end; - Canvas.ClearClipRect; - Canvas.SetClipRect(r); - - // draw the nodes with lines - h := RootNode.FirstSubNode; - YPos := 0; - while h <> nil do - begin - Canvas.SetTextColor(h.ParentTextColor); - // lines with + or - - w := GetColumnLeft(StepToRoot(h)); - ACenterPos := YPos - FYOffset + col + (GetNodeHeight div 2); - YPos := YPos + GetNodeHeight; - i := GetColumnLeft(StepToRoot(h)) + GetNodeWidth(h); - - // only paint the node if it is fully visible - if i > FXOffset then - begin -// writeln('painting node: ', h.Text); - if h = Selection then // draw the selection rectangle and text - begin - if Focused then - begin - Canvas.SetColor(h.ParentSelColor); - Canvas.SetTextColor(h.ParentSelTextColor); - end - else - begin - Canvas.SetColor(h.ParentInactSelColor); - Canvas.SetTextColor(h.ParentInActSelTextColor); - end; - Canvas.FillRectangle(w - FXOffset, YPos - FYOffset + col - GetNodeHeight + FFont.Ascent div 2 - 2, GetNodeWidth(h), GetNodeHeight); - if (ImageList <> nil) and ShowImages then - begin - AImageItem := ImageList.Item[h.ImageIndex]; - if AImageItem <> nil then - begin - Canvas.DrawImagePart(w - FXOffset + 1, ACenterPos - 4, AImageItem.Image, 0, 0, 16, 16); - Canvas.DrawString(w - FXOffset + 1 + AImageItem.Image.Width + 2, ACenterPos - FFont.Ascent div 2, h.text); - end - else - begin - if FIndentNodeWithNoImage then - Canvas.DrawString(w - FXOffset + 1 + FNoImageIndent + 2 {spacer}, ACenterPos - FFont.Ascent div 2, h.text) - else - Canvas.DrawString(w - FXOffset + 1, ACenterPos - FFont.Ascent div 2, h.text); - end; - end - else - Canvas.DrawString(w - FXOffset + 1, ACenterPos - FFont.Ascent div 2, h.text); - Canvas.SetTextColor(h.ParentTextColor); - end - else - begin - if (ImageList <> nil) and ShowImages then - begin - AImageItem := ImageList.Item[h.ImageIndex]; - if AImageItem <> nil then - begin - Canvas.DrawImagePart(w - FXOffset + 1, ACenterPos - 4, AImageItem.Image, 0, 0, 16, 16); - Canvas.DrawString(w - FXOffset + 1 + AImageItem.Image.Width + 2, ACenterPos - FFont.Ascent div 2, h.text); - end - else - begin - if FIndentNodeWithNoImage then - Canvas.DrawString(w - FXOffset + 1 + FNoImageIndent + 2 {spacer}, ACenterPos - FFont.Ascent div 2, h.text) - else - Canvas.DrawString(w - FXOffset + 1, ACenterPos - FFont.Ascent div 2, h.text); - end - end - else - Canvas.DrawString(w - FXOffset + 1, ACenterPos - FFont.Ascent div 2, h.text); - end; { if/else } - - Canvas.SetLineStyle(1, FTreeLineStyle); - if h.Count > 0 then // do we have subnodes? - begin - // small horizontal line above rectangle for first subnode (with children) only - if (h <> RootNode.FirstSubNode) then - begin - if (h.Parent.FirstSubNode = h) then - begin - Canvas.SetLineStyle(1, FTreeLineStyle); - Canvas.DrawLine(w - FXOffset - GetColumnWidth(i1) div 2 + 1, ACenterPos - 7, w - FXOffset - GetColumnWidth(i1) div 2 + 1, ACenterPos - 3); - end; - end; - - // subnode rectangle around the "+" or "-" - Canvas.SetColor(FTreeLineColor); - Canvas.SetLineStyle(1, lsSolid); // rectangle is always solid line style - Canvas.DrawRectangle(w - FXOffset - GetColumnWidth(i1) div 2 - 3, ACenterPos - 3, 9, 9); - - Canvas.SetColor(clText1); - - if h.Collapsed then - begin - // draw a "+" - Canvas.DrawLine(w - FXOffset - GetColumnWidth(i1) div 2 - 1, ACenterPos + 1, w - FXOffset - GetColumnWidth(i1) div 2 + 4, ACenterPos + 1); - Canvas.DrawLine(w - FXOffset - GetColumnWidth(i1) div 2 + 1, ACenterPos - 1, w - FXOffset - GetColumnWidth(i1) div 2 + 1, ACenterPos + 4); - end - else - begin - // draw a "-" - Canvas.DrawLine(w - FXOffset - GetColumnWidth(i1) div 2 - 1, ACenterPos + 1, w - FXOffset - GetColumnWidth(i1) div 2 + 4, ACenterPos + 1); - end; - - Canvas.SetLineStyle(1, FTreeLineStyle); - end - else - begin - // short horizontal line for each node - Canvas.SetColor(FTreeLineColor); - Canvas.DrawLine(w - FXOffset - GetColumnWidth(i1) div 2 + 1, ACenterPos + 1, w - FXOffset - 1, ACenterPos + 1); - end; - - Canvas.SetColor(FTreeLineColor); - if h.prev <> nil then - begin - // line up to the previous node - if h.prev.count > 0 then - begin - // take the previous subnode rectangle in account - if h.count > 0 then - // we have a subnode rectangle - Canvas.DrawLine(w - FXOffset - GetColumnWidth(i1) div 2 + 1, ACenterPos - 4, w - FXOffset - GetColumnWidth(i1) div 2 + 1, ACenterPos - (SpaceToVisibleNext(h.prev) * GetNodeHeight) + 5) - else - Canvas.DrawLine(w - FXOffset - GetColumnWidth(i1) div 2 + 1, ACenterPos, w - FXOffset - GetColumnWidth(i1) div 2 + 1, ACenterPos - (SpaceToVisibleNext(h.prev) * GetNodeHeight) + 5); - end - else - begin - // previous node has no subnodes - if h.count > 0 then - // we have a subnode rectangle - Canvas.DrawLine(w - FXOffset - GetColumnWidth(i1) div 2 + 1, ACenterPos - 3, w - FXOffset - GetColumnWidth(i1) div 2 + 1, ACenterPos - SpaceToVisibleNext(h.prev) * GetNodeHeight + 1) - else - Canvas.DrawLine(w - FXOffset - GetColumnWidth(i1) div 2 + 1, ACenterPos, w - FXOffset - GetColumnWidth(i1) div 2 + 1, ACenterPos - SpaceToVisibleNext(h.prev) * GetNodeHeight + 1); - end; - end - else - begin - if h.count > 0 then - // take the subnode rectangle in account - Canvas.DrawLine(w - FXOffset - GetColumnWidth(i1) div 2 + 1,ACenterPos - 3, w - FXOffset - GetColumnWidth(i1) div 2 + 1, ACenterPos - GetNodeHeight div 2 + 3) - else - Canvas.DrawLine(w - FXOffset - GetColumnWidth(i1) div 2 + 1, ACenterPos, w - FXOffset - GetColumnWidth(i1) div 2 + 1, ACenterPos - GetNodeHeight div 2 + 3); - end; - end; - - if ShowColumns then - i := ACenterPos - else - i := ACenterPos + GetNodeHeight; - - if AVisibleHeight > i then - begin - if (h.count > 0) and (not h.Collapsed) then - begin - h := h.FirstSubNode; - continue; - end; - - if h.next <> nil then - h := h.next // next node - else - begin - while h.next = nil do // or recurse next node per parent - begin - h := h.parent; - if (h = nil) or (h = rootnode) then - begin - break; //==> - end; - end; { while } - h := h.next; - end; { if/else } - end - else - begin - // Draw Lines up to the parent nodes - ACenterPos := ACenterPos + GetNodeHeight; - while h <> RootNode do - begin - w := GetColumnLeft(StepToRoot(h)); - if h.next <> nil then - begin - h := h.next; - if h.prev.count > 0 then - begin - x := w - FXOffset - GetColumnWidth(i1) div 2 + 1; - y := GetAbsoluteNodeTop(h.prev) - FYOffset + 5 + (GetNodeHeight div 2); - if ShowColumns then - inc(y, FColumnHeight); - Canvas.DrawLine(x, ACenterPos, x, y); - end - else - begin - x := w - FXOffset - GetColumnWidth(i1) div 2 + 1; - y := GetAbsoluteNodeTop(h.prev) - FYOffset + 1 + (GetNodeHeight div 2); - if ShowColumns then - inc(y, FColumnHeight); - Canvas.DrawLine(x, ACenterPos, x, y); - end; - end; - h := h.parent; - end; - break; //==> - end; - end; { while h <> nil } - Canvas.EndDraw; -end; - -procedure TfpgTreeview.DrawHeader(ACol: integer; ARect: TfpgRect; - AFlags: integer); -begin - // Here we can implement a head style check - Canvas.DrawButtonFace(ARect, [btfIsEmbedded]); -end; - -procedure TfpgTreeview.HandleKeyPress(var keycode: word; - var shiftstate: TShiftState; var consumed: boolean); -var - h: TfpgTreeNode; - OldSelection: TfpgTreeNode; -begin - OldSelection := Selection; - case KeyCode of - keyRight: - begin - Consumed := True; - Selection.Collapsed := false; - DoExpand(Selection); - ResetScrollbar; - RePaint; - end; - - keyLeft: - begin - Consumed := True; - Selection.Collapsed := true; - ResetScrollbar; - RePaint; - end; - - keyUp: - begin - if Selection = nil then - Selection := RootNode.FirstSubNode - else - if Selection <> RootNode then - begin - if NodeIsVisible(selection) then - begin - h := PrevVisualNode(Selection); - if (h <> RootNode) and (h <> nil) then - Selection := h; - end - else - begin - Selection := RootNode.FirstSubNode; - end; - end; - Consumed := True; - end; - - keyDown: - begin - Consumed := True; - if Selection = nil then - Selection := RootNode.FirstSubNode - else - begin - if NodeIsVisible(selection) then - begin - h := NextVisualNode(Selection); - if (h <> nil) then - Selection := h; - end - else - Selection := RootNode.FirstSubNode; - end; - end; - - else - Consumed := False; - end; - - if Selection <> OldSelection then - begin - RePaint; - DoChange; - end; - - if not Consumed then - inherited HandleKeyPress(keycode, shiftstate, consumed); -end; - -procedure TfpgTreeview.HandleMouseScroll(x, y: integer; - shiftstate: TShiftState; delta: smallint); -begin - inherited HandleMouseScroll(x, y, shiftstate, delta); - if delta > 0 then - begin - inc(FYOffset, FScrollWheelDelta); - if FYOffset > VisibleHeight then - FYOffset := VisibleHeight; - end - else - begin - dec(FYOffset, FScrollWheelDelta); - if FYOffset < 0 then - FYOffset := 0; - end; - - UpdateScrollbars; - RePaint; -end; - -procedure TfpgTreeview.DoChange; -begin - if Assigned(FOnChange) then - FOnChange(self); -end; - -procedure TfpgTreeview.DoExpand(ANode: TfpgTreeNode); -begin - if Assigned(FOnExpand) then - FOnExpand(self, ANode); -end; - -function TfpgTreeview.NextVisualNode(ANode: TfpgTreeNode): TfpgTreeNode; - //---------------- - procedure _FindNextNode; - begin - if ANode.Next <> nil then - begin - result := ANode.Next; - end - else - begin - while ANode.Next = nil do - begin - ANode := ANode.Parent; - if ANode = nil then - exit; //==> - end; - result := ANode.Next; - end; - end; - -begin - result := nil; - if ANode.Collapsed then - begin - _FindNextNode; - end - else - begin - if ANode.Count > 0 then - begin - result := ANode.FirstSubNode; - end - else - _FindNextNode; - end; -end; - -function TfpgTreeview.PrevVisualNode(ANode: TfpgTreeNode): TfpgTreeNode; -var - n: TfpgTreeNode; -begin - n := ANode; - if ANode.Prev <> nil then - begin - result := ANode.Prev; - ANode := ANode.Prev; - while (not ANode.Collapsed) and (ANode.Count > 0) do - begin - result := ANode.LastSubNode; - ANode := ANode.LastSubNode; - end; - end - else - begin - if ANode.Parent <> nil then - result := ANode.Parent - else - result := n; - end; -end; - -function TfpgTreeview.SpaceToVisibleNext(aNode: TfpgTreeNode): integer; -var - h: TfpgTreeNode; - i: integer; -begin - result := 0; - i := 0; - if aNode.next = nil then - exit; - h := aNode; - while h <> aNode.next do - begin - inc(i); - if (h.count > 0) and (not h.collapsed) then - begin - h := h.FirstSubNode; - end - else - begin - while h.next = nil do - h := h.parent; - h := h.next; - end; - end; - result := i; -end; - -function TfpgTreeview.StepToRoot(aNode: TfpgTreeNode): integer; -var - i: integer; -begin - i := -1; - while aNode <> nil do - begin - aNode := aNode.parent; - inc(i); - end; - result := i; -end; - -constructor TfpgTreeview.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - FRootNode := nil; - FSelection := nil; - FShowImages := False; - FShowColumns := False; - FDefaultColumnWidth := 15; - FFirstColumn := nil; - FFont := fpgGetFont('#Label1'); - FWidth := 150; - FHeight := 100; - - FHScrollbar := TfpgScrollbar.Create(self); - FHScrollbar.Orientation := orHorizontal; - FHScrollbar.OnScroll := @HScrollbarScroll; - FHScrollbar.Visible := False; - FHScrollbar.Position := 0; - FHScrollbar.SliderSize := 0.2; - - FVScrollbar := TfpgScrollbar.Create(self); - FVScrollbar.Orientation := orVertical; - FVScrollbar.OnScroll := @VScrollbarScroll; - FVScrollbar.Visible := False; - FVScrollbar.Position := 0; - FVScrollbar.SliderSize := 0.2; - - FBackgroundColor := clListBox; - FTreeLineColor := clShadow1; //clText1; - FTreeLineStyle := lsDot; - FFocusable := True; - FMoving := False; - FXOffset := 0; - FYOffset := 0; - FColumnHeight := FFont.Height + 2; - FScrollWheelDelta := 15; - FNoImageIndent := 16; - FIndentNodeWithNoImage := True; -end; - -destructor TfpgTreeView.Destroy; -begin - if Assigned(FColumnLeft) then - ClearColumnLeft; - FFont.Free; - FreeAllTreeNodes; - inherited Destroy; -end; - -procedure TfpgTreeview.SetColumnWidth(AIndex, AWidth: word); -var - h: PfpgTreeColumnWidth; - n: PfpgTreeColumnWidth; - i: word; -begin - {$IFDEF DEBUG} - writeln('TfpgTreeView.SetColumnWidth'); - {$ENDIF} - h := FFirstColumn; - if h = nil then - begin - new(h); - h^.width := FDefaultColumnWidth; - h^.next := nil; - FFirstColumn := h; - end; - i := 0; - while i < AIndex do - begin - if h^.next = nil then - begin - new(n); - h^.next := n; - n^.width := DefaultColumnWidth; - n^.next := nil; - end; - h := h^.next; - inc(i); - end; - if h^.width <> AWidth then - begin - h^.width := AWidth; - RePaint; - end; -end; - - -end. - diff --git a/src/gui/logo.inc b/src/gui/logo.inc index 3a99e5f4..2fdef319 100644 --- a/src/gui/logo.inc +++ b/src/gui/logo.inc @@ -1,4 +1,4 @@ -{%mainunit gui_dialogs.pas} +{%mainunit fpg_dialogs.pas} const // This is a ugly logo purely as an example. It will be replaced soon. diff --git a/uidesigner/newformdesigner.pas b/uidesigner/newformdesigner.pas index 098f3fd1..34e9c1c9 100644 --- a/uidesigner/newformdesigner.pas +++ b/uidesigner/newformdesigner.pas @@ -26,16 +26,16 @@ uses Classes, fpg_base, fpg_widget, - gui_form, - gui_label, - gui_button, - gui_edit, - gui_listbox, - gui_memo, - gui_combobox, - gui_menu, - gui_mru, - gui_hyperlink, + fpg_form, + fpg_label, + fpg_button, + fpg_edit, + fpg_listbox, + fpg_memo, + fpg_combobox, + fpg_menu, + fpg_mru, + fpg_hyperlink, vfdwidgetclass, vfdwidgets; @@ -169,8 +169,8 @@ implementation uses fpg_main, vfdmain, - gui_iniutils, - gui_dialogs; + fpg_iniutils, + fpg_dialogs; // Anchor images diff --git a/uidesigner/vfddesigner.pas b/uidesigner/vfddesigner.pas index bd10cfe1..e3b505c5 100644 --- a/uidesigner/vfddesigner.pas +++ b/uidesigner/vfddesigner.pas @@ -28,15 +28,15 @@ uses fpg_base, fpg_main, fpg_widget, - gui_form, - gui_dialogs, - gui_label, - gui_edit, - gui_button, - gui_listbox, - gui_memo, - gui_combobox, - gui_checkbox, + fpg_form, + fpg_dialogs, + fpg_label, + fpg_edit, + fpg_button, + fpg_listbox, + fpg_memo, + fpg_combobox, + fpg_checkbox, vfdresizer, vfdforms, vfdeditors, diff --git a/uidesigner/vfdeditors.pas b/uidesigner/vfdeditors.pas index 9860f907..b9e8cce9 100644 --- a/uidesigner/vfdeditors.pas +++ b/uidesigner/vfdeditors.pas @@ -25,9 +25,9 @@ uses Classes, SysUtils, fpg_widget, - gui_label, - gui_button, - gui_memo, + fpg_label, + fpg_button, + fpg_memo, vfdforms; type diff --git a/uidesigner/vfdfile.pas b/uidesigner/vfdfile.pas index 2361e215..2c63890a 100644 --- a/uidesigner/vfdfile.pas +++ b/uidesigner/vfdfile.pas @@ -352,11 +352,11 @@ begin 'interface' + LineEnding + LineEnding + 'uses' + LineEnding + ' SysUtils, Classes, fpg_base, fpg_main, fpg_widget,' + LineEnding + - ' gui_edit, gui_form, gui_label, gui_button,' + LineEnding + - ' gui_listbox, gui_memo, gui_combobox, gui_basegrid, gui_grid, ' + LineEnding + - ' gui_dialogs, gui_checkbox, gui_tree, gui_trackbar, ' + LineEnding + - ' gui_progressbar, gui_radiobutton, gui_tab, gui_menu,' + LineEnding + - ' gui_panel, gui_popupcalendar, gui_gauge;' + LineEnding + LineEnding + + ' fpg_edit, fpg_form, fpg_label, fpg_button,' + LineEnding + + ' fpg_listbox, fpg_memo, fpg_combobox, fpg_basegrid, fpg_grid, ' + LineEnding + + ' fpg_dialogs, fpg_checkbox, fpg_tree, fpg_trackbar, ' + LineEnding + + ' fpg_progressbar, fpg_radiobutton, fpg_tab, fpg_menu,' + LineEnding + + ' fpg_panel, fpg_popupcalendar, fpg_gauge;' + LineEnding + LineEnding + 'type' + LineEnding + LineEnding + '{@VFD_NEWFORM_DECL}' + LineEnding + LineEnding + 'implementation' + LineEnding + LineEnding + diff --git a/uidesigner/vfdformparser.pas b/uidesigner/vfdformparser.pas index 5e20fb92..2f41c308 100644 --- a/uidesigner/vfdformparser.pas +++ b/uidesigner/vfdformparser.pas @@ -26,7 +26,7 @@ uses SysUtils, fpg_main, fpg_widget, - gui_form, + fpg_form, vfddesigner, vfdwidgetclass, vfdwidgets; diff --git a/uidesigner/vfdforms.pas b/uidesigner/vfdforms.pas index 9b50eeea..8987c49d 100644 --- a/uidesigner/vfdforms.pas +++ b/uidesigner/vfdforms.pas @@ -26,14 +26,14 @@ uses SysUtils, fpg_base, fpg_widget, - gui_form, - gui_label, - gui_edit, - gui_button, - gui_listbox, - gui_combobox, - gui_trackbar, - gui_checkbox; + fpg_form, + fpg_label, + fpg_edit, + fpg_button, + fpg_listbox, + fpg_combobox, + fpg_trackbar, + fpg_checkbox; type @@ -131,7 +131,7 @@ implementation uses fpg_main, - gui_iniutils, + fpg_iniutils, fpg_constants, vfdprops; // used to get Object Inspector defaults diff --git a/uidesigner/vfdmain.pas b/uidesigner/vfdmain.pas index 612def1d..a310acfd 100644 --- a/uidesigner/vfdmain.pas +++ b/uidesigner/vfdmain.pas @@ -25,7 +25,7 @@ uses Classes, SysUtils, fpg_widget, - gui_dialogs, + fpg_dialogs, vfdprops, vfdforms, vfddesigner, @@ -83,7 +83,7 @@ implementation uses vfdformparser, - gui_iniutils, + fpg_iniutils, fpg_utils, fpg_main; diff --git a/uidesigner/vfdpropeditgrid.pas b/uidesigner/vfdpropeditgrid.pas index 1004a56f..2af4daad 100644 --- a/uidesigner/vfdpropeditgrid.pas +++ b/uidesigner/vfdpropeditgrid.pas @@ -26,17 +26,17 @@ uses SysUtils, fpg_base, fpg_widget, - gui_form, - gui_label, - gui_edit, - gui_button, - gui_listbox, - gui_memo, - gui_combobox, - gui_customgrid, - gui_basegrid, - gui_grid, - gui_checkbox, + fpg_form, + fpg_label, + fpg_edit, + fpg_button, + fpg_listbox, + fpg_memo, + fpg_combobox, + fpg_customgrid, + fpg_basegrid, + fpg_grid, + fpg_checkbox, vfdforms, vfdwidgetclass, vfdprops, diff --git a/uidesigner/vfdprops.pas b/uidesigner/vfdprops.pas index 13000c78..93c2dff5 100644 --- a/uidesigner/vfdprops.pas +++ b/uidesigner/vfdprops.pas @@ -27,9 +27,9 @@ uses fpg_base, fpg_widget, vfdwidgetclass, - gui_edit, - gui_button, - gui_combobox; + fpg_edit, + fpg_button, + fpg_combobox; type @@ -152,7 +152,7 @@ uses vfdformparser, vfdeditors, fpg_main, - gui_dialogs; + fpg_dialogs; procedure EditStringList(sl: TStringList); diff --git a/uidesigner/vfdutils.pas b/uidesigner/vfdutils.pas index 8a7fd4c3..a97cf432 100644 --- a/uidesigner/vfdutils.pas +++ b/uidesigner/vfdutils.pas @@ -25,12 +25,12 @@ uses Classes, SysUtils, fpg_widget, - gui_form, - gui_label, - gui_edit, - gui_button, - gui_memo, - gui_checkbox; + fpg_form, + fpg_label, + fpg_edit, + fpg_button, + fpg_memo, + fpg_checkbox; procedure SetWidgetText(wg: TfpgWidget; txt: string); diff --git a/uidesigner/vfdwidgets.pas b/uidesigner/vfdwidgets.pas index 489dee3c..6771f5f1 100644 --- a/uidesigner/vfdwidgets.pas +++ b/uidesigner/vfdwidgets.pas @@ -43,25 +43,25 @@ implementation uses fpg_main, vfddesigner, - gui_form, - gui_label, - gui_edit, - gui_button, - gui_listbox, - gui_memo, - gui_combobox, - gui_grid, - gui_checkbox, - gui_panel, - gui_tree, - gui_radiobutton, - gui_listview, - gui_trackbar, - gui_menu, - gui_progressbar, - gui_tab, - gui_popupcalendar, - gui_gauge, + fpg_form, + fpg_label, + fpg_edit, + fpg_button, + fpg_listbox, + fpg_memo, + fpg_combobox, + fpg_grid, + fpg_checkbox, + fpg_panel, + fpg_tree, + fpg_radiobutton, + fpg_listview, + fpg_trackbar, + fpg_menu, + fpg_progressbar, + fpg_tab, + fpg_popupcalendar, + fpg_gauge, vfdpropeditgrid; var -- cgit v1.2.3-70-g09d2