You've already forked lazarus-ccr
7940c5f9df
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@8838 8e941d3f-bd1b-0410-a28a-d453659cc2b4
2354 lines
68 KiB
ObjectPascal
2354 lines
68 KiB
ObjectPascal
{ TCalendarLite is a lightweight calendar component, a TGraphiccontrol
|
|
descendant, which is consequently not dependent on any widgetset.
|
|
It is not a fixed-size component, as are most calendars, but will align
|
|
and resize as needed
|
|
|
|
Originator : H Page-Clark, 2013/2016
|
|
Contributions : Ariel Rodriguez, 2013
|
|
Werner Pamler, 2013/2016
|
|
John Greetham, 2016
|
|
|
|
This library is free software; you can redistribute it and/or modify it
|
|
under the terms of the GNU Library General Public License as published by
|
|
the Free Software Foundation; either version 2 of the License, or (at your
|
|
option) any later version with the following modification:
|
|
|
|
As a special exception, the copyright holders of this library give you
|
|
permission to link this library with independent modules to produce an
|
|
executable, regardless of the license terms of these independent modules,and
|
|
to copy and distribute the resulting executable under terms of your choice,
|
|
provided that you also meet, for each linked independent module, the terms
|
|
and conditions of the license of that module. An independent module is a
|
|
module which is not derived from or based on this library. If you modify
|
|
this library, you may extend this exception to your version of the library,
|
|
but you are not obligated to do so. If you do not wish to do so, delete this
|
|
exception statement from your version.
|
|
|
|
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. See the GNU Library General Public License
|
|
for more details.
|
|
|
|
You should have received a copy of the GNU Library General Public License
|
|
along with this library; if not, write to the Free Software Foundation,
|
|
Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
|
}
|
|
|
|
unit CalendarLite;
|
|
|
|
{$mode objfpc}{$H+}
|
|
|
|
interface
|
|
|
|
uses
|
|
Classes, SysUtils, LResources, LCLVersion,
|
|
Forms, Controls, Graphics, Dialogs, Types, ExtCtrls, Menus;
|
|
|
|
{$if lcl_fullversion >= 1080000}
|
|
{$define lcl_scaling}
|
|
{$ifend}
|
|
|
|
const
|
|
LastCol = 7;
|
|
|
|
type
|
|
TCalendarLite = class;
|
|
|
|
TColArray = array[1..LastCol] of word;
|
|
TRowArray = array of word;
|
|
|
|
TArrowDirection = (adLeft, adRight);
|
|
TArrowhead = (ahSingle, ahDouble);
|
|
TArrowPoints = array[1..3] of TPoint;
|
|
|
|
TDayOfWeek = (dowSunday, dowMonday, dowTuesday, dowWednesday,
|
|
dowThursday, dowFriday, dowSaturday);
|
|
TDaysOfWeek = set of TDayOfWeek;
|
|
|
|
TDisplayText = (dtToday, dtTodayFormat, dtHolidaysDuring,
|
|
dtNoHolidaysDuring, dtTodayFormatLong, dtCaptionFormat);
|
|
|
|
THolidays = DWord;
|
|
TGetHolidaysEvent = procedure (Sender: TObject; AMonth, AYear: Integer;
|
|
var Holidays: THolidays) of object;
|
|
|
|
TCalCellState = (csSelectedDay, csToday, csOtherMonth);
|
|
TCalCellStates = set of TCalCellState;
|
|
|
|
TCalPrepareCanvasEvent = procedure (Sender: TObject; ACanvas: TCanvas;
|
|
AYear, AMonth, ADay: Word; AState: TCalCellStates) of object;
|
|
|
|
TCalDrawCellEvent = procedure (Sender: TObject; ACanvas: TCanvas;
|
|
AYear, AMonth, ADay: Word; AState: TCalCellStates; var ARect: TRect;
|
|
var AContinueDrawing: Boolean) of object;
|
|
|
|
TCalGetDayTextEvent = procedure (Sender: TObject; AYear, AMonth, ADay: Word;
|
|
var AText: String) of object;
|
|
|
|
TCalOption = (coBoldDayNames, coBoldHolidays, coBoldToday, coBoldTopRow,
|
|
coBoldWeekend, coDayLine, coShowBorder, coShowHolidays,
|
|
coShowTodayFrame, coShowTodayName, coShowTodayRow,
|
|
coShowWeekend, coShowDayNames, coShowTopRow, coUseTopRowColors,
|
|
coNoMonthChange, coNoOtherMonthDays
|
|
);
|
|
TCalOptions = set of TCalOption;
|
|
|
|
TCalDateArray = array of TDate;
|
|
|
|
TCalSelMode = (smFirstSingle, smNextSingle, smFirstRange, smNextRange,
|
|
smFirstWeek, smNextWeek, smNextWeekRange);
|
|
|
|
TLanguage = (lgEnglish, lgFrench, lgGerman, lgHebrew, lgSpanish, lgItalian,
|
|
lgPolish, lgFinnish, lgGreek, lgRussian, lgCustom);
|
|
|
|
|
|
{ TCalDateList }
|
|
|
|
TCalDateList = class
|
|
private
|
|
FList: TFPList;
|
|
function GetCount: Integer;
|
|
function GetDate(AIndex: Integer): TDate;
|
|
procedure SetDate(AIndex: Integer; AValue: TDate);
|
|
protected
|
|
procedure Sort;
|
|
public
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
procedure AddDate(ADate: TDate);
|
|
function AsArray: TCalDateArray;
|
|
procedure Clear;
|
|
procedure DeleteDate(ADate: TDate);
|
|
function IndexOfDate(ADate: TDate): Integer;
|
|
procedure Insert(AIndex: Integer; ADate: TDate);
|
|
property Count: Integer read GetCount;
|
|
property Values[AIndex: Integer]: TDate read GetDate write SetDate; default;
|
|
end;
|
|
|
|
|
|
{ TCalDrawer }
|
|
|
|
TCalDrawer = class
|
|
private
|
|
FBoundsRect: TRect;
|
|
FBuffer: TBitmap;
|
|
FCanvas: TCanvas;
|
|
FCellSize: TSize;
|
|
FColPositions: TColArray;
|
|
FOwner: TCalendarLite;
|
|
FRowPositions: TRowArray;
|
|
FLastRow: Integer;
|
|
FStartDate: TDateTime;
|
|
FThisDay: word;
|
|
FThisMonth: word;
|
|
FThisYear: word;
|
|
FTextStyle: TTextStyle;
|
|
procedure CalcSettings;
|
|
procedure DrawArrow(ARect: TRect; AHead: TArrowhead; ADirec: TArrowDirection);
|
|
procedure DrawBackground;
|
|
procedure DrawDayCells;
|
|
procedure DrawDayLabels;
|
|
procedure DrawTodayRow;
|
|
procedure DrawTopRow;
|
|
function GetCellAt(aPoint: TPoint): TSize;
|
|
function GetCellAtColRow(aCol, aRow: integer): TRect;
|
|
function GetColRowPosition(aCol, aRow: integer): TSize;
|
|
function GetDateOfCell(ACell: TSize): TDate;
|
|
function GetLeftColIndex: Integer;
|
|
procedure GetMonthYearRects(var AMonthRect, AYearRect: TRect);
|
|
function GetRightColIndex: Integer;
|
|
procedure GotoDay(ADate: word);
|
|
procedure GotoMonth(AMonth: word);
|
|
procedure GotoToday;
|
|
procedure GotoYear(AYear: word);
|
|
procedure LeftClick(APoint: TPoint; Shift: TShiftState);
|
|
procedure RightClick;
|
|
procedure SetBoundsRect(ARect: TRect);
|
|
public
|
|
constructor Create(AOwner: TCalendarLite);
|
|
destructor Destroy; override;
|
|
procedure Draw;
|
|
property BoundsRect: TRect read FBoundsRect write SetBoundsRect;
|
|
property Buffer: TBitmap read FBuffer;
|
|
end;
|
|
|
|
|
|
{ TCalColors }
|
|
|
|
TCalColors = class(TPersistent)
|
|
private
|
|
FOwner: TCalendarLite;
|
|
FColors: Array[0..12] of TColor;
|
|
function GetColor(AIndex: Integer): TColor;
|
|
procedure SetColor(AIndex: Integer; AValue: TColor);
|
|
public
|
|
constructor Create(AOwner: TCalendarLite);
|
|
published
|
|
property ArrowBorderColor: TColor index 0 read GetColor write SetColor default clSilver;
|
|
property ArrowColor: TColor index 1 read GetColor write SetColor default clSilver;
|
|
property BackgroundColor: TColor index 2 read GetColor write SetColor default clWhite;
|
|
property BorderColor: TColor index 3 read GetColor write SetColor default clSilver;
|
|
property DaylineColor: TColor index 4 read GetColor write SetColor default clSilver;
|
|
property HolidayColor: TColor index 5 read GetColor write SetColor default clRed;
|
|
property PastMonthColor: TColor index 6 read GetColor write SetColor default clSilver;
|
|
property SelectedDateColor: TColor index 7 read GetColor write SetColor default clMoneyGreen;
|
|
property TextColor: TColor index 8 read GetColor write SetColor default clBlack;
|
|
property TodayFrameColor: TColor index 9 read GetColor write SetColor default clLime;
|
|
property TopRowColor: TColor index 10 read GetColor write SetColor default clHighlight;
|
|
property TopRowTextColor: TColor index 11 read GetColor write SetColor default clHighlightText;
|
|
property WeekendColor: TColor index 12 read GetColor write SetColor default clRed;
|
|
end;
|
|
|
|
|
|
{ TCalendarLite }
|
|
|
|
TCalendarLite = class(TCustomControl)
|
|
private
|
|
FBufferValid: Boolean;
|
|
FCalDrawer: TCalDrawer;
|
|
FColors: TCalColors;
|
|
FDate: TDateTime;
|
|
FCustomDayNames: string;
|
|
FCustomDisplayTexts: String;
|
|
FCustomMonthNames: string;
|
|
FDisplayTexts: array[TDisplayText] of string;
|
|
FOnDateChange: TNotifyEvent;
|
|
FOnMonthChange: TNotifyEvent;
|
|
FOnGetDayText: TCalGetDayTextEvent;
|
|
FOnDrawCell: TCalDrawCellEvent;
|
|
FOnGetHolidays: TGetHolidaysEvent;
|
|
FOnHint: TCalGetDayTextEvent;
|
|
FOnPrepareCanvas: TCalPrepareCanvasEvent;
|
|
FOptions: TCalOptions;
|
|
FPopupMenu: TPopupMenu;
|
|
FStartingDayOfWeek: TDayOfWeek;
|
|
FWeekendDays: TDaysOfWeek;
|
|
FPrevMouseDate: TDate;
|
|
FPrevDate: TDate;
|
|
FSavedHint: String;
|
|
FMultiSelect: Boolean;
|
|
FSelDates: TCalDateList;
|
|
FClickShift: TShiftState;
|
|
FClickPoint: TPoint;
|
|
FClickButton: TMouseButton;
|
|
FLanguage: TLanguage;
|
|
FDblClickTimer: TTimer;
|
|
FFormatSettings: TFormatSettings;
|
|
FButtonHeight: Integer;
|
|
FButtonWidth: Integer;
|
|
function GetDayNames: String;
|
|
function GetDisplayText(aTextIndex: TDisplayText): String;
|
|
function GetDisplayTexts: String;
|
|
function GetMonthNames: String;
|
|
procedure HolidayMenuItemClicked(Sender: TObject);
|
|
procedure MonthMenuItemClicked(Sender: TObject);
|
|
procedure PopulateHolidayPopupMenu;
|
|
procedure PopulateMonthPopupMenu;
|
|
procedure PopulateYearPopupMenu;
|
|
procedure SetButtonHeight(const AValue: Integer);
|
|
procedure SetButtonWidth(const AValue: Integer);
|
|
procedure SetCustomDayNames(const AValue: String);
|
|
procedure SetCustomDisplayTexts(const AValue: String);
|
|
procedure SetCustomMonthNames(const AValue: String);
|
|
procedure SetDate(AValue: TDateTime);
|
|
procedure SetDefaultDayNames;
|
|
procedure SetDefaultDisplayTexts;
|
|
procedure SetDefaultMonthNames;
|
|
procedure SetDisplayTexts(AValue: String);
|
|
procedure SetLanguage(AValue: TLanguage);
|
|
procedure SetMultiSelect(AValue: Boolean);
|
|
procedure SetOptions(AValue: TCalOptions);
|
|
procedure SetStartingDayOfWeek(AValue: TDayOfWeek);
|
|
procedure SetWeekendDays(AValue: TDaysOfWeek);
|
|
procedure TimerExpired(Sender: TObject);
|
|
procedure YearMenuItemClicked(Sender: TObject);
|
|
|
|
protected
|
|
procedure ChangeDateTo(ADate: TDate; ASelMode: TCalSelMode);
|
|
procedure DateChange; virtual;
|
|
{$ifdef lcl_scaling}
|
|
procedure DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy;
|
|
const AXProportion, AYProportion: Double); override;
|
|
{$endif}
|
|
procedure DblClick; override;
|
|
procedure FontChanged(Sender: TObject); override;
|
|
class function GetControlClassDefaultSize: TSize; override;
|
|
procedure InternalClick;
|
|
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
|
|
procedure MonthChange; virtual;
|
|
procedure MouseDown(Button: TMouseButton; Shift:TShiftState; X,Y:Integer); override;
|
|
procedure MouseEnter; override;
|
|
procedure MouseLeave; override;
|
|
procedure MouseMove(Shift: TShiftState; X,Y: Integer); override;
|
|
function SelMode(Shift: TShiftState): TCalSelMode;
|
|
procedure SetBiDiMode(AValue: TBiDiMode); override;
|
|
procedure SetParentBiDiMode(AValue: Boolean); override;
|
|
|
|
procedure Paint; override;
|
|
procedure Resize; override;
|
|
procedure UpdateBiDiMode;
|
|
procedure UseDayName(ADayOfWeek: TDayOfWeek; const AValue: String);
|
|
procedure UseDayNames(const AValue: String);
|
|
procedure UseDisplayTexts(const AValue: String);
|
|
procedure UseMonthName(AMonth: Integer; const AValue: String);
|
|
procedure UseMonthNames(const AValue: String);
|
|
|
|
{ Hints }
|
|
procedure ShowHintWindow(APoint: TPoint; ADate: TDate);
|
|
procedure HideHintWindow;
|
|
public
|
|
constructor Create(anOwner: TComponent); override;
|
|
destructor Destroy; override;
|
|
|
|
function GetDayName(ADayOfWeek: TDayOfWeek): String;
|
|
function GetMonthName(AMonth: Integer): String;
|
|
|
|
procedure AddSelectedDate(ADate: TDate);
|
|
procedure ClearSelectedDates;
|
|
procedure Draw; // Use instead of Invalidate to recreate the buffer
|
|
function IsSelected(ADate: TDate): Boolean;
|
|
function SelectedDates: TCalDateArray;
|
|
|
|
published
|
|
property Align;
|
|
property Anchors;
|
|
property BiDiMode;
|
|
property BorderSpacing;
|
|
property Constraints;
|
|
property Cursor;
|
|
property Font;
|
|
property Height;
|
|
property HelpContext;
|
|
property HelpKeyword;
|
|
property HelpType;
|
|
property Hint;
|
|
property Left;
|
|
property Name;
|
|
property ParentBiDiMode;
|
|
property ParentColor;
|
|
property ParentFont;
|
|
property PopupMenu;
|
|
property ParentShowHint;
|
|
property ShowHint;
|
|
property TabOrder;
|
|
property TabStop;
|
|
property Tag;
|
|
property Top;
|
|
property Visible;
|
|
property Width;
|
|
property OnChangeBounds;
|
|
property OnClick;
|
|
property OnContextPopup;
|
|
property OnDblClick;
|
|
property OnEnter;
|
|
property OnExit;
|
|
property OnKeyDown;
|
|
property OnKeyPress;
|
|
property OnKeyUp;
|
|
property OnMouseDown;
|
|
property OnMouseEnter;
|
|
property OnMouseLeave;
|
|
property OnMouseMove;
|
|
property OnMouseUp;
|
|
property OnMouseWheel;
|
|
property OnMouseWheelDown;
|
|
property OnMouseWheelUp;
|
|
|
|
// new properties
|
|
property ButtonWidth: Integer read FButtonWidth write SetButtonWidth default 0;
|
|
property ButtonHeight: Integer read FButtonHeight write SetButtonHeight default 0;
|
|
property Colors: TCalColors read FColors write FColors;
|
|
property Date: TDateTime read FDate write SetDate;
|
|
property DayNames: String read FCustomDayNames write SetCustomDayNames;
|
|
property DisplayTexts: String read GetDisplayTexts write SetCustomDisplayTexts;
|
|
property MonthNames: String read FCustomMonthNames write SetCustomMonthNames;
|
|
property MultiSelect: Boolean read FMultiSelect write SetMultiSelect default false;
|
|
property Options: TCalOptions read FOptions write SetOptions
|
|
default [coShowTodayFrame, coBoldHolidays, coShowWeekend, coShowHolidays,
|
|
coShowTodayRow, coShowDayNames, coShowTopRow];
|
|
property StartingDayOfWeek: TDayOfWeek read FStartingDayOfWeek
|
|
write SetStartingDayOfWeek default dowSunday;
|
|
property WeekendDays: TDaysOfWeek read FWeekendDays
|
|
write SetWeekendDays default [dowSunday];
|
|
property Languages: TLanguage read FLanguage
|
|
write SetLanguage default lgEnglish;
|
|
|
|
// new event properties
|
|
property OnDateChange: TNotifyEvent read FOnDateChange write FOnDateChange;
|
|
property OnDrawCell: TCalDrawCellEvent read FOnDrawCell write FOnDrawCell;
|
|
property OnGetDayText: TCalGetDayTextEvent read FOnGetDayText write FOnGetDayText;
|
|
property OnGetHolidays: TGetHolidaysEvent read FOnGetHolidays write FOnGetHolidays;
|
|
property OnHint: TCalGetDayTextEvent read FOnHint write FOnHint;
|
|
property OnMonthChange: TNotifyEvent read FOnMonthChange write FOnMonthChange;
|
|
property OnPrepareCanvas: TCalPrepareCanvasEvent read FOnPrepareCanvas write FOnPrepareCanvas;
|
|
end;
|
|
|
|
procedure ClearHolidays(var AHolidays: THolidays);
|
|
procedure AddHoliday(ADay: Integer; var AHolidays: THolidays);
|
|
function IsHoliday(ADay: Integer; AHolidays: THolidays): Boolean;
|
|
|
|
procedure Register;
|
|
|
|
|
|
implementation
|
|
|
|
{$R calendarlite_icon.res}
|
|
|
|
uses
|
|
LCLType, LazUTF8, dateutils, math;
|
|
|
|
resourcestring
|
|
rsCalTodayIs = 'Today is %s';
|
|
rsCalTodayFormat = 'mmm dd, yyyy';
|
|
rsCalTodayFormatLong = 'dddd, mmm dd, yyyy';
|
|
rsCalCaptionFormat = 'mmmm yyyy';
|
|
rsCalHolidaysIn = 'Holidays in %d';
|
|
rsCalNoHolidaysIn = 'There are no holidays set for %d';
|
|
|
|
rsCalJanuary = 'January|Jan';
|
|
rsCalFebruary = 'February|Feb';
|
|
rsCalMarch = 'March|Mar';
|
|
rsCalApril = 'April|Apr';
|
|
rsCalMay = 'May|May';
|
|
rsCalJune = 'June|Jun';
|
|
rsCalJuly = 'July|Jul';
|
|
rsCalAugust = 'August|Aug';
|
|
rsCalSeptember = 'September|Sp';
|
|
rsCalOctober = 'October|Oct';
|
|
rsCalNovember = 'November|Nov';
|
|
rsCalDecember = 'December|Dec';
|
|
|
|
rsCalSunday = 'Sunday|Sun';
|
|
rsCalMonday = 'Monday|Mon';
|
|
rsCalTuesday = 'Tuesday|Tue';
|
|
rsCalWednesday = 'Wesnesday|Wed';
|
|
rsCalThursday = 'Thursday|Thu';
|
|
rsCalFriday = 'Friday|Fri';
|
|
rsCalSaturday = 'Saturday|Sat';
|
|
|
|
|
|
const
|
|
TopRow = 0;
|
|
DayRow = 1;
|
|
FirstDateRow = 2;
|
|
LastDateRow = 7;
|
|
TodayRow = 8;
|
|
DefCalHeight = 160;
|
|
DefCalWidth = 210;
|
|
DefMinHeight = 120;
|
|
DefMinWidth = 120;
|
|
DefTextStyle: TTextStyle = (
|
|
Alignment : taCenter; Layout : tlCenter;
|
|
SingleLine : False; Clipping : True;
|
|
ExpandTabs : False; ShowPrefix : False;
|
|
Wordbreak : True; Opaque : False;
|
|
SystemFont : False; RightToLeft: False;
|
|
EndEllipsis: False
|
|
);
|
|
|
|
// IMPORTANT NOTE: NO SPACES IN FRONT OF QUOTES !!!
|
|
|
|
EnglishDays = 'Sunday|Sun,Monday|Mon,Tuesday|Tue,Wednesday|Wed,Thursday|Thu,Friday|Fri,Saturday|Sat';
|
|
EnglishMonths = 'January|Jan,February|Feb,March|Mar,April|Apr,May|May,June|Jun,'+
|
|
'July|Jul,August|Aug,September|Sep,October|Oct,November|Nov,December|Dec';
|
|
EnglishTexts = 'Today is %s,"mmm dd"", ""yyyy",Holidays in %d,'+
|
|
'There are no holidays set for %d,"dddd"", "" mmm dd"", ""yyyy",mmmm yyyy';
|
|
|
|
HebrewDays = 'א,ב,ג,ד,ה,ו,ש';
|
|
HebrewMonths = ('ינואר,פברואר,מרץ,אפריל,מאי,יוני, יולי,אוגוסט,ספטמבר,אוקטובר,נובמבר,דצמבר');
|
|
HebrewTexts = 'היום הוא,yyyy-mm-dd,במהלך החגים, אין חגים מוגדרים עבור';
|
|
|
|
FrenchDays = 'dimanche|dim,lundi|lun,mardi|mar,mercredi|mer,jeudi|jeu,vendredi|ven,samedi|sam';
|
|
FrenchMonths = 'janvier|janv.,février|févr.,mars|mars,avril|avr.,mai|mai,juin|juin,'+
|
|
'juillet|juill.,août|août,septembre|sept.,octobre|oct.,novembre|nov.,décembre|déc.';
|
|
FrenchTexts = 'Est aujourd''hui %s, dd/mm/yyyy, vacances pendant %d, '+
|
|
'Il n''y a pas de jours fériés fixés pour %d, dddd dd/mm/yyyy, mmmm yyyy';
|
|
|
|
GermanDays = 'Sonntag|So,Montag|Mo,Dienstag|Di,Mittwoch|Mi,Donnerstag|Do,Freitag|Fr,Samstag|Sa';
|
|
GermanMonths = 'Januar|Jan.,Februar|Febr.,März|März,April|Apr.,Mai|Mai,Juni|Jun,'+
|
|
'Juli|Jul,August|Aug.,September|Sept.,Oktober|Okt.,November|Nov.,Dezember|Dez.';
|
|
GermamTexts = 'Heute ist %s, dd.mm.yyyy, Feiertage in %d, '+
|
|
'Keine Feiertage vorbereitet für %d, dddd dd.mm.yyyy, mmmm yyyy';
|
|
|
|
SpanishDays = 'dom,lun,mar,mié,jue,vie,sáb';
|
|
SpanishMonths = 'enero|ene,febrero|feb,marzo|mar,abril|abr,mayo|may,junio|jun,'+
|
|
'julio|jul,agosto|ago,septiembre|sep,octubre|oct,noviembre|nov,diciembre|dic';
|
|
SpanishTexts = 'Hoy es %s, dd/mm/yyyy, Dias de fiestas %d, '+
|
|
'No hay dias feriados establecidos para %d, dddd dd/mm/yyyy, mmmm yyyy';
|
|
|
|
ItalianDays = 'domenica|dom,lunedi|lun,martedi|mar,mercoledì|mer,giovedì|gio,venerdì|ven,sabato|sab';
|
|
ItalianMonths = 'gennaio|gen,febbraio|feb,marzo|mar,aprile|apr,maggio|mag,giugno|giu,'+
|
|
'luglio|lug,agosto|ago,settembre|set,ottobre|ott,novembre|nov,dicembre|dic';
|
|
ItalianTexts = 'Oggi è %s, dd/mmm/yyyy, Vacanze durante %d, '+
|
|
'Non ci sono vacanze fissati per %d,"dddd, dd/mmm/yyyy",mmmm yyyy';
|
|
|
|
PolishDays = 'nie,pon,wto,Śro,czw,pią,sob';
|
|
PolishMonths = 'Styczeń,Luty,Marzec,Kwiecień,Maj,Czerwiec,Lipiec,Sierpień,Wrzesień,Październik,Listopad,Grudzień';
|
|
PolishTexts = 'Dziś jest,dd/mmm/yyyy,urlop w czasie,Brak święta określone dla';
|
|
|
|
FinnishDays = 'Su,Ma,Ti,ke,To,Pe,La';
|
|
FinnishMonths = 'Tammikuu,Helmikuu,Maaliskuu,Huhtikuu,Toukokuu,Kesäkuu,Heinäkuu,Elokuu,Syyskuu,Lokakuu,Marraskuu,Joulukuu';
|
|
FinnishTexts ='Tänään on %s, dd.mm.yyyy, Lomapäivät %d, Lomapäiviä ei ole asetettu %d';
|
|
|
|
GreekDays = 'Κυρ,Δευ,Τρί,Τετ,Πεμ,Παρ,Σαβ';
|
|
GreekMonths = 'Ιανουάριος,Φεβρουάριος,Μάρτιος,Απρίλος,Μάιος,Ιούνιος,Ιούλιος,Αύγουστος,Σεπτέμβριος,Οκτώβριος,Νοέμβριος,Δεκέμβριος';
|
|
GreekTexts = 'Σήμερα είναι,"mmm dd"","" yyyy",Καμία γιορτή,Δεν έχει καμία αργία';
|
|
|
|
RussianDays = 'Воскресенье|Вс,Понедельник|Пн,Вторник|Вт,Среда|Ср,Четверг|Чт,Пятница|Пт,Суббота|Сб';
|
|
RussianMonths = 'Январь|Янв,Февраль|Фев,Март|Мар,Апрель|Апр,Май|Май,Июнь|Июн,'+
|
|
'Июль|Июл,Август|Авг,Сентябрь|Сен,Октябрь|Окт,Ноябрь|Ноя,Декабрь|Дек';
|
|
RussianTexts = 'Сегодня %s,"dd mmm"", "" yyyy", праздничные дни для %d,'+
|
|
'Праздники и выходные для %d не установлены,"dddd"", ""dd mmm"", ""yyyy",mmmm yyyy';
|
|
|
|
DBLCLICK_INTERVAL = 300; // Interval (ms) for detection of a double-click
|
|
|
|
|
|
function SameRect(const R1, R2: TRect): Boolean;
|
|
begin
|
|
Result := (R1.Left = R2.Left) and (R1.Top = R2.Top) and
|
|
(R1.Right = R2.Right) and (R1.Bottom = R2.Bottom);
|
|
end;
|
|
|
|
{ Holiday helpers }
|
|
|
|
{ Clears the per month holiday buffer }
|
|
procedure ClearHolidays(var AHolidays: DWord);
|
|
begin
|
|
AHolidays := 0;
|
|
end;
|
|
|
|
{ Set bit for given day to mark the day as a holiday }
|
|
procedure AddHoliday(ADay: Integer; var AHolidays: DWord);
|
|
begin
|
|
AHolidays := DWord(1 shl ADay) or AHolidays;
|
|
end;
|
|
|
|
{ Check if the bit for the given day is set in AHolidays }
|
|
function IsHoliday(ADay: Integer; AHolidays: THolidays): Boolean;
|
|
begin
|
|
Result := (AHolidays and DWord(1 shl ADay)) <> 0;
|
|
end;
|
|
|
|
|
|
{ TCalSortedDateList }
|
|
|
|
type
|
|
TDateItem = TDate;
|
|
PDateItem = ^TDateItem;
|
|
|
|
function CompareDates(P1, P2: Pointer): Integer;
|
|
begin
|
|
Result := CompareDate(PDateItem(P1)^, PDateItem(P2)^);
|
|
end;
|
|
|
|
constructor TCalDateList.Create;
|
|
begin
|
|
inherited;
|
|
FList := TFPList.Create;
|
|
end;
|
|
|
|
destructor TCalDateList.Destroy;
|
|
begin
|
|
Clear;
|
|
FList.Free;
|
|
inherited;
|
|
end;
|
|
|
|
procedure TCalDateList.AddDate(ADate: TDate);
|
|
var
|
|
i: Integer;
|
|
P: PDateItem;
|
|
begin
|
|
i := IndexOfDate(ADate);
|
|
if i > -1 then begin
|
|
P := PDateItem(FList.Items[i]);
|
|
Dispose(P);
|
|
FList.Delete(i);
|
|
exit;
|
|
end;
|
|
|
|
// Assume that the list is sorted
|
|
for i:= FList.Count-1 downto 0 do begin
|
|
P := PDateItem(FList.Items[i]);
|
|
// Add new date
|
|
if P^ < ADate then begin
|
|
Insert(i+1, ADate); // meaning: "insert BEFORE index i"
|
|
exit;
|
|
end;
|
|
end;
|
|
Insert(0, ADate);
|
|
end;
|
|
|
|
function TCalDateList.AsArray: TCalDateArray;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
Result := nil;
|
|
SetLength(Result, Count);
|
|
for i:=0 to High(Result) do
|
|
Result[i] := Values[i];
|
|
end;
|
|
|
|
procedure TCalDateList.Clear;
|
|
var
|
|
i: Integer;
|
|
P: PDateItem;
|
|
begin
|
|
for i := FList.Count-1 downto 0 do begin
|
|
P := PDateItem(FList.Items[i]);
|
|
Dispose(P);
|
|
FList.Delete(i);
|
|
end;
|
|
FList.Clear;
|
|
end;
|
|
|
|
procedure TCalDateList.DeleteDate(ADate: TDate);
|
|
var
|
|
i: Integer;
|
|
P: PDateItem;
|
|
begin
|
|
i := IndexOfDate(ADate);
|
|
if i > -1 then begin
|
|
P := PDateItem(FList.Items[i]);
|
|
Dispose(P);
|
|
FList.Delete(i);
|
|
end;
|
|
end;
|
|
|
|
function TCalDateList.GetCount: Integer;
|
|
begin
|
|
Result := FList.Count;
|
|
end;
|
|
|
|
function TCalDateList.GetDate(AIndex: Integer): TDate;
|
|
var
|
|
P: PDateItem;
|
|
begin
|
|
P := PDateItem(FList.Items[AIndex]);
|
|
Result := P^;
|
|
end;
|
|
|
|
function TCalDateList.IndexOfDate(ADate: TDate): Integer;
|
|
var
|
|
lower, higher, mid, truncADate, truncMidDate: integer;
|
|
|
|
function Compare: integer;
|
|
begin
|
|
if (truncMidDate < truncADate) then
|
|
Exit(-1)
|
|
else if (truncMidDate > truncADate) then
|
|
Exit(+1)
|
|
else
|
|
Exit(0);
|
|
end;
|
|
|
|
begin
|
|
lower := 0;
|
|
higher := Pred(FList.Count);
|
|
truncADate := trunc(ADate);
|
|
while (lower <= higher) do begin
|
|
mid := (lower + higher) shr 1;
|
|
truncMidDate:=trunc(GetDate(mid));
|
|
case Compare of
|
|
-1: lower := Succ(mid);
|
|
+1: higher := Pred(mid);
|
|
0: Exit(mid);
|
|
end;
|
|
end;
|
|
Exit(-1);
|
|
end;
|
|
|
|
procedure TCalDateList.Insert(AIndex: Integer; ADate: TDate);
|
|
var
|
|
P: PDateItem;
|
|
begin
|
|
New(P);
|
|
P^ := ADate;
|
|
if AIndex >= FList.Count then
|
|
FList.Add(P)
|
|
else
|
|
FList.Insert(AIndex, P);
|
|
end;
|
|
|
|
procedure TCalDateList.SetDate(AIndex: Integer; AValue: TDate);
|
|
var
|
|
P: PDateItem;
|
|
begin
|
|
P := PDateItem(FList.Items[AIndex]);
|
|
P^ := AValue;
|
|
Sort;
|
|
end;
|
|
|
|
procedure TCalDateList.Sort;
|
|
begin
|
|
FList.Sort(@CompareDates);
|
|
end;
|
|
|
|
|
|
{ TCalDrawer }
|
|
|
|
constructor TCalDrawer.Create(AOwner: TCalendarLite);
|
|
begin
|
|
inherited Create;
|
|
FBuffer := TBitmap.Create;
|
|
FOwner := AOwner;
|
|
FCanvas := FBuffer.Canvas;
|
|
FTextStyle:= DefTextStyle;
|
|
end;
|
|
|
|
destructor TCalDrawer.Destroy;
|
|
begin
|
|
FBuffer.Free;
|
|
inherited;
|
|
end;
|
|
|
|
procedure TCalDrawer.CalcSettings;
|
|
var
|
|
rem: Integer = 0;
|
|
hSpc: Integer = 0;
|
|
ch: Integer = 0;
|
|
sp: Integer = 0;
|
|
cw: Integer = 0;
|
|
cy: Integer = 0;
|
|
bit: integer = 0;
|
|
i, cellWidths, totalSpace, cellHeights,
|
|
adjSpace, borderh, borderv, numRows: integer;
|
|
sz: TSize;
|
|
begin
|
|
if (FOwner.BiDiMode = bdLeftToRight) then
|
|
FTextStyle.RightToLeft:= False
|
|
else
|
|
FTextStyle.RightToLeft:= True;
|
|
SetLength(FRowPositions, 0);
|
|
if (coShowTodayRow in FOwner.Options) then
|
|
FLastRow := TodayRow
|
|
else
|
|
FLastRow := LastDateRow;
|
|
SetLength(FRowPositions, FLastRow+1);
|
|
|
|
totalspace := Succ(LastCol)*3;
|
|
sz := Size(FBoundsRect);
|
|
cellWidths := sz.cx - totalSpace;
|
|
DivMod(cellWidths, LastCol, cw, rem);
|
|
FCellSize.cx := cw;
|
|
adjSpace := sz.cx - LastCol*cw;
|
|
DivMod(adjSpace, LastCol+1, hSpc, rem);
|
|
borderh := (rem div 2) + 1;
|
|
for i := Low(FColPositions) to High(FColPositions) do
|
|
case FOwner.BiDiMode = bdLeftToRight of
|
|
False : FColPositions[8-i]:= borderh + Pred(i)*cw + hSpc*i;
|
|
True : FColPositions[i]:= borderh + Pred(i)*cw + hSpc*i;
|
|
end;
|
|
|
|
case FLastRow of
|
|
LastDateRow : totalSpace := 12;
|
|
TodayRow : totalSpace := 14;
|
|
end;
|
|
cellHeights := sz.cy - totalSpace;
|
|
numRows := Succ(FLastRow);
|
|
if not (coShowDayNames in FOwner.Options) then dec(numRows);
|
|
if not (coShowTopRow in FOwner.Options) then dec(numRows);
|
|
DivMod(cellHeights, numRows, ch, rem);
|
|
FCellSize.cy := ch;
|
|
adjSpace := sz.cy - numRows*ch;
|
|
DivMod(adjSpace, totalSpace, sp, rem);
|
|
rem := sz.cy - ch*numRows - totalSpace*sp;
|
|
borderv := rem div 3;
|
|
if (borderv = 0) then
|
|
bit := rem + 1;
|
|
rem := sp shl 1;
|
|
cy := bit + borderv + rem;
|
|
FRowPositions[TopRow] := cy;
|
|
if coShowTopRow in FOwner.Options then inc(cy, rem + ch);
|
|
FRowPositions[DayRow] := cy;
|
|
if coShowDayNames in FOwner.Options then inc(cy, ch);
|
|
for i := FirstDateRow to LastDateRow do begin
|
|
FRowPositions[i] := cy;
|
|
inc(cy, ch + sp);
|
|
end;
|
|
if (FLastRow = TodayRow) then
|
|
FRowPositions[TodayRow] := FRowPositions[LastDateRow] + borderv + ch + rem;
|
|
end;
|
|
|
|
procedure TCalDrawer.Draw;
|
|
begin
|
|
if not Assigned(FCanvas) then Exit;
|
|
DecodeDate(FOwner.FDate, FThisYear, FThisMonth, FThisDay);
|
|
CalcSettings;
|
|
FCanvas.Font.Assign(FOwner.Font);
|
|
DrawBackground;
|
|
DrawTopRow;
|
|
DrawDayLabels;
|
|
DrawTodayRow;
|
|
DrawDayCells; // must be last to avoid resetting the canvas
|
|
end;
|
|
|
|
procedure TCalDrawer.DrawArrow(ARect: TRect; AHead: TArrowhead;
|
|
ADirec: TArrowDirection);
|
|
var
|
|
sz: TSize;
|
|
dx, dy, ox, oy, halfx, halfy: integer;
|
|
pts: TArrowPoints;
|
|
begin
|
|
if (coNoMonthChange in FOwner.Options) then
|
|
exit;
|
|
|
|
FCanvas.Pen.Style := psSolid;
|
|
if (FCanvas.Brush.Color <> FOwner.Colors.ArrowColor) then
|
|
FCanvas.Brush.Color:= FOwner.Colors.ArrowColor;
|
|
if (FCanvas.Pen.Color <> FOwner.Colors.ArrowBorderColor) then
|
|
FCanvas.Pen.Color := FOwner.Colors.ArrowBorderColor;
|
|
sz := Size(aRect);
|
|
if FOwner.ButtonWidth = 0 then
|
|
dx := Min(sz.cy, sz.cx) div 3
|
|
else
|
|
dx := FOwner.ButtonWidth;
|
|
if FOwner.ButtonHeight = 0 then
|
|
dy := Min(sz.cy, sz.cx) div 3
|
|
else
|
|
dy := FOwner.ButtonHeight;
|
|
halfx := dx div 2;
|
|
halfy := dy div 2;
|
|
ox := ARect.Left + (sz.cx - dx) div 2;
|
|
oy := ARect.Top + (sz.cy - dy) div 2;
|
|
case AHead of
|
|
ahSingle:
|
|
begin
|
|
case ADirec of
|
|
adLeft:
|
|
begin
|
|
pts[1]:= Point(ox+dx, oy);
|
|
pts[2]:= Point(ox, oy+halfy);
|
|
pts[3]:= Point(ox+dx, oy+dy);
|
|
end;
|
|
adRight:
|
|
begin
|
|
pts[1]:= Point(ox, oy);
|
|
pts[2]:= Point(ox, oy+dy);
|
|
pts[3]:= Point(ox+dx, oy+halfy);
|
|
end;
|
|
end;
|
|
FCanvas.Polygon(pts);
|
|
end;
|
|
ahDouble:
|
|
case ADirec of
|
|
adLeft:
|
|
begin
|
|
pts[1]:= Point(ox+halfx-1, oy);
|
|
pts[2]:= Point(ox-1, oy+halfy);
|
|
pts[3]:= Point(ox+halfx-1, oy+dy);
|
|
FCanvas.Polygon(pts);
|
|
pts[1]:= Point(ox+dx, oy);
|
|
pts[2]:= Point(ox+halfx, oy+halfy);
|
|
pts[3]:= Point(ox+dx, oy+dy);
|
|
FCanvas.Polygon(pts);
|
|
end;
|
|
adRight:
|
|
begin
|
|
pts[1]:= Point(ox, oy);
|
|
pts[2]:= Point(ox+halfx, oy+halfy);
|
|
pts[3]:= Point(ox, oy+dy);
|
|
FCanvas.Polygon(pts);
|
|
pts[1]:= Point(ox+halfx+1, oy);
|
|
pts[2]:= Point(ox+dx+1, oy+halfy);
|
|
pts[3]:= Point(ox+halfx+1, oy+dy);
|
|
FCanvas.Polygon(pts);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TCalDrawer.DrawBackground;
|
|
begin
|
|
FBuffer.Canvas.Brush.Color := FOwner.Colors.BackgroundColor;
|
|
if (coShowBorder in FOwner.Options) then
|
|
begin
|
|
FCanvas.Pen.Color := FOwner.FColors.BorderColor;
|
|
FCanvas.Pen.Style := psSolid;
|
|
FCanvas.Rectangle(0, 0, FBuffer.Width, FBuffer.Height);
|
|
end else
|
|
FBuffer.Canvas.FillRect(0, 0, FBuffer.Width, FBuffer.Height);
|
|
end;
|
|
|
|
procedure TCalDrawer.DrawDayCells;
|
|
var
|
|
remDays: integer = 0;
|
|
startRow: Integer = 0;
|
|
holidays: THolidays = 0;
|
|
r, c, startCol, startSpan: integer;
|
|
rec: TRect;
|
|
s: string;
|
|
dow, y, m, d: word;
|
|
partWeeks: Integer;
|
|
dt, todayDate: TDateTime;
|
|
oldBrush: TBrush;
|
|
oldPen: TPen;
|
|
state: TCalCellStates;
|
|
continueDrawing: Boolean;
|
|
begin
|
|
todayDate := Date;
|
|
dow := DayOfWeek(FOwner.FDate) - 1; // DayOfWeek is 1-based, dow is 0-based !
|
|
c := dow - integer(FOwner.FStartingDayOfWeek);
|
|
if (c < 0) then Inc(c, 7);
|
|
startCol := Succ(c);
|
|
partweeks := FThisDay - startCol;
|
|
DivMod(partWeeks, 7, startRow, remDays);
|
|
if (remDays > 0) then Inc(startRow, 1);
|
|
startspan := startRow*7 + startCol - 1;
|
|
FStartDate := FOwner.FDate - startSpan;
|
|
dt := FStartDate;
|
|
|
|
oldBrush := TBrush.Create;
|
|
oldPen := TPen.Create;
|
|
|
|
{ Get holidays in current month }
|
|
ClearHolidays(holidays);
|
|
if Assigned(FOwner.FOnGetHolidays) then
|
|
FOwner.FOnGetHolidays(FOwner, FThisMonth, FThisYear, holidays);
|
|
|
|
for r:= FirstDateRow to LastDateRow do
|
|
for c:= Low(FColPositions) to High(FColPositions) do
|
|
begin
|
|
rec := GetCellAtColRow(c, r);
|
|
DecodeDate(dt, y, m, d);
|
|
|
|
{ Default canvas }
|
|
FCanvas.Brush.Style := bsSolid;
|
|
FCanvas.Brush.Color := FOwner.Colors.BackgroundColor;
|
|
FCanvas.Pen.Style := psClear;
|
|
FCanvas.Pen.Width := 1;
|
|
FCanvas.Font.Assign(FOwner.Font);
|
|
state := [];
|
|
|
|
{ Set font of day cells }
|
|
if m = FThisMonth then
|
|
begin
|
|
{ Default text color of day numbers }
|
|
FCanvas.Font.Color:= FOwner.Colors.TextColor;
|
|
{ Special case: override holidays }
|
|
if (coShowHolidays in FOwner.Options) and IsHoliday(d, holidays) then
|
|
begin
|
|
FCanvas.Font.Color := FOwner.Colors.HolidayColor;
|
|
if coBoldHolidays in FOwner.Options then
|
|
FCanvas.Font.Style := FCanvas.Font.Style + [fsBold];
|
|
end else
|
|
{ Special case: override weekend }
|
|
if (coShowWeekend in FOwner.Options) and
|
|
(TDayOfWeek(DayOfWeek(dt) - 1) in FOwner.FWeekendDays) then
|
|
begin
|
|
FCanvas.Font.Color := FOwner.Colors.WeekendColor;
|
|
if coBoldWeekend in FOwner.Options then
|
|
FCanvas.Font.Style := FCanvas.Font.Style + [fsBold];
|
|
end;
|
|
end else
|
|
begin
|
|
{ color of days from previous and next months }
|
|
FCanvas.Font.Color := FOwner.Colors.PastMonthColor;
|
|
Include(state, csOtherMonth);
|
|
end;
|
|
|
|
{ Set default background color }
|
|
if FOwner.IsSelected(dt) then begin
|
|
FCanvas.Brush.Color := FOwner.FColors.SelectedDateColor;
|
|
Include(state, csSelectedDay);
|
|
end else
|
|
FCanvas.Brush.Color := FOwner.Colors.BackgroundColor;
|
|
|
|
{ Set border pen of "today" cell }
|
|
if (dt = todayDate) and (coShowTodayFrame in FOwner.Options) then
|
|
begin
|
|
FCanvas.Pen.Color := FOwner.Colors.TodayFrameColor;
|
|
FCanvas.Pen.Width := 2;
|
|
FCanvas.Pen.Style := psSolid;
|
|
Include(state, csToday);
|
|
end else
|
|
FCanvas.Pen.Style := psClear;
|
|
|
|
{ Override canvas properties }
|
|
oldPen.Assign(FCanvas.Pen);
|
|
oldBrush.Assign(FCanvas.Brush);
|
|
if Assigned(FOwner.FOnPrepareCanvas) then
|
|
FOwner.FOnPrepareCanvas(FOwner, FCanvas, y, m, d, state);
|
|
|
|
if (coNoOtherMonthDays in FOwner.Options) and (csOtherMonth in state) then
|
|
begin
|
|
dt := dt + 1;
|
|
continue;
|
|
end;
|
|
|
|
continueDrawing := true;
|
|
if Assigned(FOwner.FOnDrawCell) then
|
|
{ Custom-draw the cell }
|
|
FOwner.FOnDrawCell(FOwner, FCanvas, y, m, d, state, rec, continueDrawing);
|
|
|
|
if continueDrawing then
|
|
begin
|
|
{ Paint the background of the selected date }
|
|
if FOwner.IsSelected(dt) or
|
|
(oldBrush.Color <> FCanvas.Brush.Color) or
|
|
(oldBrush.Style <> FCanvas.brush.Style) or
|
|
(oldPen.Color <> FCanvas.Pen.Color) or
|
|
(oldPen.Style <> FCanvas.Pen.Style) or
|
|
(oldPen.Width <> FCanvas.Pen.Width)
|
|
then
|
|
FCanvas.Rectangle(rec);
|
|
|
|
{ Paint the frame around the "today" cell }
|
|
if (dt = todayDate) and (coShowTodayFrame in FOwner.Options) then
|
|
begin
|
|
Inc(rec.Top);
|
|
Inc(rec.Bottom);
|
|
FCanvas.Rectangle(rec);
|
|
end;
|
|
|
|
{ Paint the day number }
|
|
s := IntToStr(d);
|
|
if Assigned(FOwner.FOnGetDayText) then
|
|
FOwner.FOnGetDayText(FOwner, y, m, d, s);
|
|
FCanvas.TextRect(rec, 0, 0, s, FTextStyle);
|
|
end;
|
|
|
|
dt:= dt + 1;
|
|
end; // for c
|
|
|
|
oldPen.Free;
|
|
oldBrush.Free;
|
|
|
|
end;
|
|
|
|
procedure TCalDrawer.DrawDayLabels;
|
|
var
|
|
c, map: integer;
|
|
rec: TRect;
|
|
lbls: TWeekNameArray;
|
|
begin
|
|
if not (coShowDayNames in FOwner.Options) then
|
|
exit;
|
|
|
|
FCanvas.Font.Color:= FOwner.Colors.TextColor;
|
|
if (coBoldDayNames in FOwner.Options) then
|
|
FCanvas.Font.Style := FCanvas.Font.Style + [fsBold]
|
|
else
|
|
FCanvas.Font.Style := FCanvas.Font.Style - [fsBold];
|
|
map := Integer(FOwner.FStartingDayOfWeek) + 1;
|
|
for c:= Low(TWeekNameArray) to High(TWeekNameArray) do
|
|
begin
|
|
if (map > High(TWeekNameArray)) then map := Low(TWeekNameArray);
|
|
lbls[c] := FOwner.GetDayName(TDayOfWeek(map - 1));
|
|
inc(map);
|
|
end;
|
|
for c:= Low(FColPositions) to High(FColPositions) do
|
|
begin
|
|
rec := GetCellAtColRow(c, DayRow);
|
|
FCanvas.TextRect(rec, 0, 0, lbls[c], FTextStyle);
|
|
end;
|
|
if (coDayLine in FOwner.Options) then begin
|
|
rec := GetCellAtColRow(GetLeftColIndex, DayRow);
|
|
rec.Right := GetCellAtColRow(GetRightColIndex, DayRow).Right;
|
|
rec.Bottom := rec.Top;
|
|
FCanvas.Pen.Color := FOwner.Colors.DayLineColor;
|
|
FCanvas.Line(rec);
|
|
end;
|
|
end;
|
|
|
|
procedure TCalDrawer.DrawTodayRow;
|
|
var
|
|
r1, r2: TRect;
|
|
w1, w2, w3, rem, halfRem: integer;
|
|
s: String;
|
|
ds: String;
|
|
begin
|
|
if (FLastRow <> TodayRow) then
|
|
exit;
|
|
|
|
r1 := GetCellAtColRow(2, TodayRow);
|
|
if coUseTopRowColors in FOwner.Options then begin
|
|
if (FCanvas.Font.Color <> FOwner.Colors.TopRowTextColor)
|
|
then FCanvas.Font.Color:= FOwner.Colors.TopRowTextColor;
|
|
FCanvas.Brush.Color := FOwner.Colors.TopRowColor;
|
|
FCanvas.FillRect(r1);
|
|
end else
|
|
if (FCanvas.Font.Color <> FOwner.Colors.TextColor) then
|
|
FCanvas.Font.Color:= FOwner.Colors.TextColor;
|
|
|
|
if coBoldToday in FOwner.Options then
|
|
FCanvas.Font.Style := FCanvas.Font.Style + [fsBold] else
|
|
FCanvas.Font.Style := FCanvas.Font.Style - [fsBold];
|
|
|
|
s:= FOwner.GetDisplayText(dtToday);
|
|
if pos('%s', s) = 0 then begin
|
|
if (coShowTodayName in FOwner.Options) then
|
|
s := Format('%s %s',[s, FOwner.GetDayName(TDayOfWeek(DayOfWeek(Date())-1))]);
|
|
AppendStr(s, ' ' + FormatDateTime(FOwner.GetDisplayText(dtTodayFormat), Date(), FOwner.FFormatSettings));
|
|
end else begin
|
|
if coShowTodayName in FOwner.Options then
|
|
ds := FormatDateTime(FOwner.GetDisplayText(dtTodayFormatLong), Date(), FOwner.FFormatSettings)
|
|
else
|
|
ds := FormatDateTime(FOwner.GetDisplayText(dtTodayFormat), Date(), FOwner.FFormatSettings);
|
|
s := Format(s, [ds]);
|
|
end;
|
|
w1 := FCanvas.TextWidth('aaa');
|
|
w2 := FCanvas.TextWidth(' ');
|
|
w3 := FCanvas.TextWidth(s);
|
|
rem := Size(r1).cx - w1 - w2 - w3;
|
|
halfRem := rem div 2;
|
|
if (rem < 0) then
|
|
begin
|
|
Inc(r1.Left, halfRem);
|
|
Dec(r1.Right, halfRem);
|
|
rem := 0;
|
|
end;
|
|
r2 := r1;
|
|
|
|
r1.Left := r1.Left + halfRem;
|
|
r1.Right := r1.Left + w1;
|
|
InflateRect(r1, 0, -FCellSize.cy div 5);
|
|
if (FCanvas.Pen.Color <> FOwner.Colors.TodayFrameColor) then
|
|
FCanvas.Pen.Color := FOwner.Colors.TodayFrameColor;
|
|
FCanvas.Pen.Style := psSolid;
|
|
FCanvas.Pen.Width := 2;
|
|
FCanvas.Frame(r1);
|
|
FCanvas.Pen.Width := 1;
|
|
|
|
r2.Left := r1.Right + w2;
|
|
r2.Right := r2.Left + w3 + 2;
|
|
if (coBoldToday in FOwner.Options) then
|
|
FCanvas.Font.Style := [fsBold]
|
|
else
|
|
FCanvas.Font.Style := [];
|
|
FCanvas.TextRect(r2, 0, 0, s, FTextStyle);
|
|
end;
|
|
|
|
procedure TCalDrawer.DrawTopRow;
|
|
var
|
|
r: TRect;
|
|
s: String;
|
|
dt: TDateTime;
|
|
begin
|
|
if not (coShowTopRow in FOwner.Options) then
|
|
exit;
|
|
|
|
if coUseTopRowColors in FOwner.Options then begin
|
|
FCanvas.Font.Color := FOwner.Colors.TopRowTextColor;
|
|
FCanvas.Brush.Color := FOwner.Colors.TopRowColor;
|
|
r := GetCellAtColRow(GetLeftColIndex, TopRow);
|
|
r.Right := GetCellAtColRow(GetRightColIndex, TopRow).Right;
|
|
FCanvas.FillRect(r);
|
|
end else
|
|
if (FCanvas.Font.Color <> FOwner.Colors.TextColor) then
|
|
FCanvas.Font.Color := FOwner.Colors.TextColor;
|
|
if (coBoldTopRow in FOwner.Options) then
|
|
FCanvas.Font.Style := FCanvas.Font.Style + [fsBold]
|
|
else
|
|
FCanvas.Font.Style := FCanvas.Font.Style - [fsBold];
|
|
|
|
case (FOwner.BiDiMode = bdLeftToRight) of
|
|
False: begin
|
|
r:= GetCellAtColRow(7, TopRow); DrawArrow(r, ahDouble, adLeft);
|
|
r:= GetCellAtColRow(6, TopRow); DrawArrow(r, ahSingle, adLeft);
|
|
r:= GetCellAtColRow(1, TopRow); DrawArrow(r, ahDouble, adRight);
|
|
r:= GetCellAtColRow(2, TopRow); DrawArrow(r, ahSingle, adRight);
|
|
r:= GetCellAtColRow(3, TopRow);
|
|
end;
|
|
True: begin
|
|
r:= GetCellAtColRow(1, TopRow); DrawArrow(r, ahDouble, adLeft);
|
|
r:= GetCellAtColRow(2, TopRow); DrawArrow(r, ahSingle, adLeft);
|
|
r:= GetCellAtColRow(7, TopRow); DrawArrow(r, ahDouble, adRight);
|
|
r:= GetCellAtColRow(6, TopRow); DrawArrow(r, ahSingle, adRight);
|
|
r:= GetCellAtColRow(3, TopRow);
|
|
end;
|
|
end;
|
|
dt := EncodeDate(FThisYear, FThisMonth, 1);
|
|
s := FormatDateTime(FOwner.GetDisplayText(dtCaptionFormat), dt, FOwner.FFormatSettings);
|
|
// s := FOwner.GetMonthName(FThisMonth) + ' ' + IntToStr(FThisYear);
|
|
FCanvas.TextRect(r, 0, 0, s, FTextStyle);
|
|
end;
|
|
|
|
function TCalDrawer.GetCellAt(aPoint: TPoint): TSize;
|
|
var
|
|
x: integer;
|
|
begin
|
|
case FOwner.BiDiMode <> bdLeftToRight of
|
|
False:
|
|
for x := Low(FColPositions) to High(FColPositions) do
|
|
if FColPositions[x] >= aPoint.x then
|
|
begin
|
|
Result.cx := x-1;
|
|
Break;
|
|
end else
|
|
Result.cx := LastCol;
|
|
True:
|
|
for x:= High(FColPositions) downto Low(FColPositions) do
|
|
if FColPositions[x] >= aPoint.x then
|
|
begin
|
|
Result.cx := x+1;
|
|
Break;
|
|
end else
|
|
Result.cx := 1;
|
|
end;
|
|
for x := 1 to High(FRowPositions) do
|
|
if FRowPositions[x] >= aPoint.y then
|
|
begin
|
|
Result.cy := x-1;
|
|
Break;
|
|
end
|
|
else
|
|
Result.cy := High(FRowPositions);
|
|
end;
|
|
|
|
function TCalDrawer.GetCellAtColRow(aCol, aRow: integer): TRect;
|
|
var
|
|
sz: TSize;
|
|
mid, midmid, midhi, midmidhi, half, fraction: integer;
|
|
begin
|
|
sz := GetColRowPosition(aCol, aRow);
|
|
Result.Top := sz.cy;
|
|
Result.Bottom := Result.Top + FCellSize.cy;
|
|
half := FCellSize.cx div 2;
|
|
case aRow of
|
|
TopRow:
|
|
begin
|
|
case (FOwner.BiDiMode = bdLeftToRight) of
|
|
True:
|
|
begin // LeftToRight
|
|
mid := FColPositions[2] + half;
|
|
fraction := (mid - FColPositions[1]) div 2;
|
|
midmid := FColPositions[1] + fraction;
|
|
midhi := FColPositions[6] + half;
|
|
midmidhi := midhi + fraction;
|
|
end;
|
|
False:
|
|
begin // RightToLeft
|
|
mid := FColPositions[6] + half;
|
|
fraction := (mid - FColPositions[7]) div 2;
|
|
midmid := FColPositions[7] + fraction;
|
|
midhi := FColPositions[2] + half;
|
|
midmidhi := midhi + fraction;
|
|
aCol := 8 - aCol;
|
|
end;
|
|
end;
|
|
case aCol of
|
|
1:
|
|
begin
|
|
Result.Left := sz.cx;
|
|
Result.Right := midmid;
|
|
end;
|
|
2:
|
|
begin
|
|
Result.Left := midmid;
|
|
Result.Right := mid;
|
|
end;
|
|
3..5:
|
|
begin
|
|
Result.Left := mid;
|
|
Result.Right := midhi;
|
|
end;
|
|
6:
|
|
begin
|
|
Result.Right := midmidhi;
|
|
Result.Left := midhi;
|
|
end;
|
|
7:
|
|
begin
|
|
Result.Left := midmidhi;
|
|
Result.Right := midmidhi + fraction;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
TodayRow:
|
|
begin
|
|
Result.Left := GetColRowPosition(GetLeftColIndex, TodayRow).cx;
|
|
Result.Right := GetColRowPosition(GetRightColIndex, TodayRow).cx + FCellSize.cx;
|
|
end;
|
|
|
|
else
|
|
Result.Left := sz.cx;
|
|
Result.Right := Result.Left + FCellSize.cx;
|
|
end;
|
|
end;
|
|
|
|
function TCalDrawer.GetColRowPosition(aCol, aRow: integer): TSize;
|
|
begin
|
|
Result.cy := FRowPositions[aRow];
|
|
Result.cx := FColPositions[aCol];
|
|
end;
|
|
|
|
function TCalDrawer.GetDateOfCell(ACell: TSize): TDate;
|
|
var
|
|
diff: Integer;
|
|
begin
|
|
if (ACell.cy > 1) and (ACell.cy < 8) then
|
|
begin
|
|
diff := ACell.cx + LastCol * (ACell.cy - 2);
|
|
Result := FStartDate + diff - 1;
|
|
end else
|
|
Result := 0;
|
|
end;
|
|
|
|
function TCalDrawer.GetLeftColIndex: Integer;
|
|
begin
|
|
if FOwner.BiDiMode = bdLeftToRight then
|
|
Result := 1
|
|
else
|
|
Result := 7;
|
|
end;
|
|
|
|
procedure TCalDrawer.GetMonthYearRects(var AMonthRect, AYearRect: TRect);
|
|
var
|
|
sm, sy: string;
|
|
w: Integer;
|
|
r: TRect;
|
|
begin
|
|
AMonthRect := GetCellAtColRow(3, TopRow);
|
|
AYearRect := AMonthRect;
|
|
if (coBoldTopRow in FOwner.Options) then
|
|
FCanvas.Font.Style := [fsBold]
|
|
else
|
|
FCanvas.Font.Style := [];
|
|
sm := FOwner.GetMonthName(FThisMonth);
|
|
sy := IntToStr(FThisYear);
|
|
w := FCanvas.TextWidth(sm + ' ' + sy);
|
|
AMonthRect.Left := (FOwner.Width - w) div 2;
|
|
AMonthRect.Right := AMonthRect.Left + FCanvas.TextWidth(sm);
|
|
AYearRect.Right := (FOwner.Width + w) div 2;
|
|
AYearRect.Left := AYearRect.Right - FCanvas.TextWidth(sy);
|
|
if (FOwner.BiDiMode <> bdLeftToRight) then
|
|
begin
|
|
r := AMonthRect;
|
|
AMonthRect := AYearRect;
|
|
AYearRect := r;
|
|
end;
|
|
end;
|
|
|
|
function TCalDrawer.GetRightColIndex: Integer;
|
|
begin
|
|
if FOwner.BiDiMode = bdLeftToRight then
|
|
Result := 7
|
|
else
|
|
Result := 1;
|
|
end;
|
|
|
|
procedure TCalDrawer.GotoDay(ADate: word);
|
|
begin
|
|
FOwner.Date := ADate;
|
|
end;
|
|
|
|
procedure TCalDrawer.GotoMonth(AMonth: word);
|
|
begin
|
|
if (AMonth < 1) or (AMonth > 12) or (coNoMonthChange in FOwner.FOptions) then
|
|
exit;
|
|
FThisDay := EnsureRange(FThisDay, 1, DaysInAMonth(FThisYear, AMonth));
|
|
FOwner.Date := EncodeDate(FThisYear, AMonth, FThisDay);
|
|
end;
|
|
|
|
procedure TCalDrawer.GotoToday;
|
|
begin
|
|
if (coNoMonthChange in FOwner.FOptions) then
|
|
exit;
|
|
FOwner.Date:= Date();
|
|
end;
|
|
|
|
procedure TCalDrawer.GotoYear(AYear: word);
|
|
begin
|
|
if (FThisMonth < 1) or (FThisMonth > 12) or (coNoMonthChange in FOwner.Options) then
|
|
exit;
|
|
FThisDay := EnsureRange(FThisday, 1, DaysInAMonth(AYear, FThisMonth));
|
|
FOwner.Date := EncodeDate(AYear, FThisMonth, FThisDay);
|
|
end;
|
|
|
|
procedure TCalDrawer.LeftClick(APoint: TPoint; Shift: TShiftState);
|
|
var
|
|
ppopup: TPoint;
|
|
cell: TSize;
|
|
Rm, Ry: TRect;
|
|
sm: TCalSelMode;
|
|
begin
|
|
sm := FOwner.SelMode(Shift);
|
|
cell := GetCellAt(APoint);
|
|
case cell.cy of
|
|
TopRow:
|
|
case cell.cx of
|
|
1: if not (coNoMonthChange in FOwner.Options) then
|
|
FOwner.Date := IncYear(FOwner.Date, -1);
|
|
2: if not (coNoMonthChange in FOwner.Options) then
|
|
FOwner.Date := IncMonth(FOwner.Date, -1);
|
|
3..5:
|
|
if not (coNoMonthChange in FOwner.Options) then
|
|
begin
|
|
GetMonthYearRects(Rm{%H-}, Ry{%H-});
|
|
if PtInRect(Rm, APoint) then begin
|
|
FOwner.PopulateMonthPopupMenu;
|
|
ppopup := FOwner.ClientToScreen(Point(Rm.Left, Rm.Bottom));
|
|
FOwner.FPopupMenu.PopUp(ppopup.x, ppopup.y);
|
|
end;
|
|
if PtInRect(Ry, APoint) then begin
|
|
FOwner.PopulateYearPopupMenu;
|
|
ppopup := FOwner.ClientToScreen(Point(Ry.Left, Ry.Bottom));
|
|
FOwner.FPopupMenu.Popup(ppopup.x, ppopup.y);
|
|
end;
|
|
end;
|
|
6: if not (coNoMonthChange in FOwner.Options) then
|
|
FOwner.Date := IncMonth(FOwner.Date, +1);
|
|
7: if not (coNoMonthChange in FOwner.Options) then
|
|
FOwner.Date := IncYear(FOwner.Date, +1);
|
|
end;
|
|
|
|
DayRow: ;
|
|
|
|
FirstDateRow..LastDateRow :
|
|
FOwner.ChangeDateTo(GetDateOfCell(cell), sm);
|
|
|
|
else
|
|
GotoToday;
|
|
end;
|
|
end;
|
|
|
|
procedure TCalDrawer.RightClick;
|
|
begin
|
|
if (FOwner.PopupMenu = nil) and Assigned(FOwner.FOnGetHolidays) then
|
|
begin
|
|
FOwner.PopulateHolidayPopupMenu;
|
|
FOwner.FPopupMenu.PopUp(Mouse.CursorPos.x, Mouse.CursorPos.y);
|
|
end;
|
|
end;
|
|
|
|
procedure TCalDrawer.SetBoundsRect(ARect: TRect);
|
|
begin
|
|
if SameRect(FBoundsRect, ARect) then exit;
|
|
FBoundsRect := ARect;
|
|
FBuffer.SetSize(FBoundsRect.Right-BoundsRect.Left, FBoundsRect.Bottom-BoundsRect.Top);
|
|
Draw;
|
|
end;
|
|
|
|
|
|
{ TCalColors }
|
|
|
|
constructor TCalColors.Create(AOwner: TCalendarLite);
|
|
begin
|
|
inherited Create;
|
|
FOwner := AOwner;
|
|
FColors[0] := clSilver; // ArrowBorderColor
|
|
FColors[1] := clSilver; // ArrowColor
|
|
FColors[2] := clWhite; // BackgroundColor
|
|
FColors[3] := clSilver; // BorderColor
|
|
FColors[4] := clSilver; // DaylineColor
|
|
FColors[5] := clRed; // HolidayColor
|
|
FColors[6] := clSilver; // PastMonthColor
|
|
FColors[7] := clMoneyGreen; // SelectedDateColor
|
|
FColors[8] := clBlack; // TextColor
|
|
FColors[9] := clGray; // TodayFrameColor
|
|
FColors[10] := clHighlight; // TopRowColor
|
|
FColors[11] := clHighlightText; // TopRowTextColor
|
|
FColors[12] := clRed; // WeekendColor
|
|
end;
|
|
|
|
function TCalColors.GetColor(AIndex: Integer): TColor;
|
|
begin
|
|
Result := FColors[AIndex];
|
|
end;
|
|
|
|
procedure TCalColors.SetColor(AIndex: Integer; AValue: TColor);
|
|
begin
|
|
if FColors[AIndex] = AValue then exit;
|
|
FColors[AIndex] := AValue;
|
|
FOwner.Draw;
|
|
end;
|
|
|
|
|
|
{ TCalendarLite }
|
|
|
|
constructor TCalendarLite.Create(anOwner: TComponent);
|
|
begin
|
|
inherited Create(anOwner);
|
|
FFormatSettings := DefaultFormatSettings;
|
|
FCalDrawer := TCalDrawer.Create(Self);
|
|
FSelDates := TCalDateList.Create;
|
|
FColors := TCalColors.Create(self);
|
|
//Color := clWhite;
|
|
FStartingDayOfWeek:= dowSunday;
|
|
with GetControlClassDefaultSize do
|
|
SetInitialBounds(0, 0, cx, cy);
|
|
{$ifdef lcl_scaling}
|
|
Constraints.MinHeight := DefMinHeight;
|
|
Constraints.MinWidth := DefMinWidth;
|
|
{$else}
|
|
Constraints.MinHeight := ScaleX(DefMinHeight, DESIGNTIME_PPI);
|
|
Constraints.MinWidth := ScaleY(DefMinWidth, DESIGNTIME_PPI);
|
|
{$endif}
|
|
//Canvas.Brush.Style := bsSolid;
|
|
TabStop := true;
|
|
SetDefaultDayNames;
|
|
// FCustomDayNames := GetDayNames;
|
|
SetDefaultMonthNames;
|
|
// FCustomMonthNames := GetMonthNames;
|
|
SetDefaultDisplayTexts;
|
|
FCustomDisplayTexts := GetDisplayTexts;
|
|
FPopupMenu := TPopupMenu.Create(Self);
|
|
FDblClickTimer := TTimer.Create(self);
|
|
FDblClickTimer.Enabled := false;
|
|
FDblClickTimer.Interval := DBLCLICK_INTERVAL;
|
|
FDblClickTimer.OnTimer := @TimerExpired;
|
|
FWeekendDays := [dowSunday, dowSaturday];
|
|
FOptions := [coShowTodayFrame, coBoldHolidays, coShowWeekend, coShowHolidays,
|
|
coShowTodayRow, coShowDayNames, coShowTopRow];
|
|
SetLanguage(lgEnglish);
|
|
FPrevMouseDate := 0;
|
|
Date := SysUtils.Date;
|
|
end;
|
|
|
|
destructor TCalendarLite.Destroy;
|
|
begin
|
|
FreeAndNil(FSelDates);
|
|
FreeAndNil(FColors);
|
|
SetLength(FCalDrawer.FRowPositions, 0);
|
|
FreeAndNil(FCalDrawer);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TCalendarLite.AddSelectedDate(ADate: TDate);
|
|
begin
|
|
FSelDates.AddDate(ADate);
|
|
Draw;
|
|
end;
|
|
|
|
procedure TCalendarLite.ChangeDateTo(ADate: TDate; ASelMode: TCalSelMode);
|
|
var
|
|
d, d1, d2: TDate;
|
|
oldMonth: Integer;
|
|
begin
|
|
oldMonth := MonthOf(FDate);
|
|
if (coNoMonthChange in FOptions) and (oldMonth <> MonthOf(ADate)) then
|
|
exit;
|
|
|
|
FDate := ADate;
|
|
|
|
case ASelMode of
|
|
smFirstSingle:
|
|
begin
|
|
FSelDates.Clear;
|
|
FSelDates.AddDate(ADate);
|
|
FPrevDate := ADate;
|
|
end;
|
|
|
|
smNextSingle:
|
|
begin
|
|
FSelDates.AddDate(ADate);
|
|
FPrevDate := ADate;
|
|
end;
|
|
|
|
smFirstWeek, smNextWeek, smNextWeekRange:
|
|
begin
|
|
if (DayOfWeek(ADate) in [ord(dowSunday), ord(dowSaturday)]) then
|
|
exit;
|
|
if ASelMode = smFirstWeek then
|
|
FSelDates.Clear;
|
|
// Collect all weekdays
|
|
if ASelMode = smNextWeekRange then begin
|
|
if FPRevDate < ADate then begin
|
|
d1 := FPrevDate + 7;
|
|
d2 := ADate;
|
|
end else begin
|
|
d1 := ADate;
|
|
d2 := FPrevDate + 7;
|
|
end;
|
|
end else begin
|
|
d1 := ADate;
|
|
d2 := ADate;
|
|
end;
|
|
while DayOfWeek(d1) <> ord(dowMonday) do d1 := d1 - 1;
|
|
while DayOfWeek(d2) <> ord(dowFriday) do d2 := d2 + 1;
|
|
d := d1;
|
|
while d <= d2 do begin
|
|
if not (DayOfWeek(d) in [ord(dowSunday), ord(dowSaturday)]) then
|
|
FSelDates.AddDate(d);
|
|
d := d + 1;
|
|
end;
|
|
FPrevDate := ADate;
|
|
end;
|
|
|
|
smFirstRange, smNextRange:
|
|
begin
|
|
if (ASelMode = smFirstRange) then
|
|
FSelDates.Clear;
|
|
if FPrevDate < ADate then begin
|
|
d1 := FPrevDate + ord(ASelMode = smNextRange);
|
|
d2 := ADate;
|
|
end else begin
|
|
d1 := ADate;
|
|
d2 := FPrevDate - ord(ASelMode = smNextRange);
|
|
end;
|
|
d := d1;
|
|
while (d <= d2) do begin
|
|
FSelDates.AddDate(d);
|
|
d := d + 1;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
DateChange;
|
|
if MonthOf(FDate) <> oldMonth then
|
|
MonthChange;
|
|
|
|
Draw;
|
|
end;
|
|
|
|
procedure TCalendarLite.ClearSelectedDates;
|
|
begin
|
|
FSelDates.Clear;
|
|
Draw;
|
|
end;
|
|
|
|
procedure TCalendarLite.DateChange;
|
|
begin
|
|
if Assigned(FOnDateChange) then
|
|
FOnDateChange(Self);
|
|
end;
|
|
|
|
procedure TCalendarLite.DblClick;
|
|
begin
|
|
FDblClickTimer.Enabled := false;
|
|
inherited;
|
|
case FClickButton of
|
|
mbLeft : FCalDrawer.LeftClick(FClickPoint, FClickShift + [ssDouble]);
|
|
mbRight : ;
|
|
end;
|
|
end;
|
|
|
|
{$ifdef lcl_scaling}
|
|
procedure TCalendarLite.DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy;
|
|
const AXProportion, AYProportion: Double);
|
|
begin
|
|
inherited;
|
|
if AMode in [lapAutoAdjustWithoutHorizontalScrolling, lapAutoAdjustForDPI] then
|
|
begin
|
|
FButtonWidth := round(FButtonWidth * AXProportion);
|
|
FButtonHeight := round(FButtonHeight * AYProportion);
|
|
end;
|
|
end;
|
|
{$endif}
|
|
|
|
{ Use this method to enforce a repaint of the calendar (instead of the standard
|
|
"Invalidate". This is because it marks the drawing buffer to be invalid
|
|
and enforces repainting of the buffer. }
|
|
procedure TCalendarLite.Draw;
|
|
begin
|
|
FBufferValid := false;
|
|
Invalidate;
|
|
end;
|
|
|
|
procedure TCalendarLite.FontChanged(Sender: TObject);
|
|
begin
|
|
inherited;
|
|
Draw;
|
|
end;
|
|
|
|
class function TCalendarLite.GetControlClassDefaultSize: TSize;
|
|
begin
|
|
{$ifdef lcl_scaling}
|
|
Result.cx := DefCalWidth;
|
|
Result.cy := DefCalHeight;
|
|
{$else}
|
|
Result.cx := ScaleX(DefCalWidth, DESIGNTIME_PPI);
|
|
Result.cy := ScaleY(DefCalHeight, DESIGNTIME_PPI);
|
|
{$endif}
|
|
end;
|
|
|
|
function TCalendarLite.GetDayName(ADayOfWeek: TDayOfWeek): String;
|
|
begin
|
|
Result := FFormatSettings.ShortDayNames[integer(ADayOfWeek) + 1];
|
|
end;
|
|
|
|
function TCalendarLite.GetDayNames: String;
|
|
var
|
|
L: TStrings;
|
|
i: Integer;
|
|
begin
|
|
L := TStringList.Create;
|
|
try
|
|
for i:= 1 to 7 do
|
|
L.Add(FFormatSettings.LongDayNames[i] + '|' + FFormatSettings.ShortDayNames[i]);
|
|
Result := L.CommaText;
|
|
finally
|
|
L.Free;
|
|
end;
|
|
end;
|
|
|
|
function TCalendarLite.GetDisplayText(aTextIndex: TDisplayText): String;
|
|
begin
|
|
Result := FDisplayTexts[aTextIndex];
|
|
end;
|
|
|
|
function TCalendarLite.GetDisplayTexts: String;
|
|
var
|
|
L: TStrings;
|
|
dt: TDisplayText;
|
|
begin
|
|
L := TStringList.Create;
|
|
try
|
|
L.StrictDelimiter := true;
|
|
for dt in TDisplayText do L.Add(FDisplayTexts[dt]);
|
|
Result := L.CommaText;
|
|
finally
|
|
L.Free;
|
|
end;
|
|
end;
|
|
|
|
function TCalendarLite.GetMonthName(AMonth: Integer): String;
|
|
begin
|
|
Result := FFormatSettings.LongMonthNames[AMonth];
|
|
end;
|
|
|
|
function TCalendarLite.GetMonthNames: String;
|
|
var
|
|
L: TStrings;
|
|
i: Integer;
|
|
begin
|
|
L := TStringList.Create;
|
|
try
|
|
for i:=1 to 12 do
|
|
L.Add(FFormatSettings.LongMonthNames[i] + '|' + FFormatSettings.ShortMonthNames[i]);
|
|
Result := L.CommaText;
|
|
finally
|
|
L.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TCalendarLite.HolidayMenuItemClicked(Sender: TObject);
|
|
begin
|
|
FCalDrawer.GotoDay(TMenuItem(Sender).Tag);
|
|
end;
|
|
|
|
procedure TCalendarLite.InternalClick;
|
|
begin
|
|
case FClickButton of
|
|
mbLeft : FCalDrawer.LeftClick(FClickPoint, FClickShift);
|
|
mbRight : FCalDrawer.RightClick;
|
|
end;
|
|
Draw;
|
|
end;
|
|
|
|
function TCalendarLite.IsSelected(ADate: TDate): Boolean;
|
|
begin
|
|
if FMultiSelect then
|
|
Result := FSelDates.IndexOfDate(ADate) > -1
|
|
else
|
|
Result := (ADate = FDate);
|
|
end;
|
|
|
|
procedure TCalendarLite.KeyDown(var Key: Word; Shift: TShiftState);
|
|
|
|
function Delta(Increase: Boolean): Integer;
|
|
begin
|
|
if Increase then Result := +1 else Result := -1;
|
|
end;
|
|
|
|
var
|
|
sm: TCalSelMode;
|
|
begin
|
|
sm := SelMode(Shift);
|
|
|
|
case Key of
|
|
VK_UP,
|
|
VK_DOWN : ChangeDateTo(IncWeek(FDate, Delta(Key = VK_DOWN)), sm);
|
|
VK_LEFT,
|
|
VK_RIGHT : ChangeDateTo(IncDay(FDate, Delta(Key = VK_RIGHT)), sm);
|
|
VK_HOME : ChangeDateTo(StartOfTheMonth(FDate), sm);
|
|
VK_END : ChangeDateTo(EndOfTheMonth(FDate), sm);
|
|
VK_PRIOR,
|
|
VK_NEXT : if not (coNoMonthChange in FOptions) then
|
|
begin
|
|
if not FMultiSelect and (ssCtrl in Shift) then
|
|
Date := IncYear(FDate, Delta(Key = VK_NEXT))
|
|
else
|
|
Date := IncMonth(FDate, Delta(Key = VK_NEXT));
|
|
end;
|
|
else inherited;
|
|
exit;
|
|
end;
|
|
|
|
Key := 0;
|
|
inherited;
|
|
end;
|
|
|
|
procedure TCalendarLite.MonthChange;
|
|
begin
|
|
if Assigned(FOnMonthChange) then
|
|
FOnMonthChange(Self);
|
|
end;
|
|
|
|
procedure TCalendarLite.MouseDown(Button: TMouseButton; Shift: TShiftState;
|
|
X, Y: Integer);
|
|
begin
|
|
inherited MouseDown(Button, Shift, X, Y);
|
|
|
|
if not Focused and not(csNoFocus in ControlStyle) then
|
|
SetFocus;
|
|
|
|
FClickPoint := Point(X, Y);
|
|
FClickShift := Shift;
|
|
FClickButton := Button;
|
|
if FMultiSelect then
|
|
FDblClickTimer.Enabled := true
|
|
else
|
|
InternalClick;
|
|
end;
|
|
|
|
procedure TCalendarLite.MouseEnter;
|
|
begin
|
|
FSavedHint := Hint;
|
|
end;
|
|
|
|
procedure TCalendarLite.MouseLeave;
|
|
begin
|
|
HideHintWindow;
|
|
FPrevMouseDate := 0;
|
|
end;
|
|
|
|
procedure TCalendarLite.MouseMove(Shift: TShiftState; X, Y: Integer);
|
|
var
|
|
c: TSize;
|
|
dt: TDate;
|
|
begin
|
|
inherited MouseMove(Shift, X, Y);
|
|
|
|
if ShowHint and Assigned(FCalDrawer) then
|
|
begin
|
|
c := FCalDrawer.GetCellAt(Point(X,Y));
|
|
dt := FCalDrawer.GetDateOfCell(c);
|
|
if (dt > 0) and (dt <> FPrevMouseDate) then begin
|
|
HideHintWindow;
|
|
ShowHintWindow(Point(X, Y), dt);
|
|
end else
|
|
if (dt = 0) then
|
|
HideHintWindow;
|
|
FPrevMouseDate := dt;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure TCalendarLite.MonthMenuItemClicked(Sender: TObject);
|
|
begin
|
|
FCalDrawer.GotoMonth(TMenuItem(Sender).Tag);
|
|
end;
|
|
|
|
procedure TCalendarLite.Paint;
|
|
begin
|
|
if Assigned(FCalDrawer) then
|
|
begin
|
|
if not FBufferValid then begin
|
|
FCalDrawer.Draw; // Re-draws the buffer
|
|
FBufferValid := true;
|
|
end;
|
|
Canvas.Draw(0, 0, FCalDrawer.Buffer);
|
|
end;
|
|
|
|
inherited Paint;
|
|
end;
|
|
|
|
procedure TCalendarLite.Resize;
|
|
begin
|
|
FBufferValid := false;
|
|
FCalDrawer.BoundsRect := ClientRect;
|
|
inherited;
|
|
end;
|
|
|
|
procedure TCalendarLite.PopulateHolidayPopupMenu;
|
|
var
|
|
item: TMenuItem;
|
|
m, d, dayCount: Integer;
|
|
population: integer = 0;
|
|
hols: THolidays = 0;
|
|
dt: TDateTime;
|
|
s: String;
|
|
begin
|
|
with FPopupMenu.Items do begin
|
|
Clear;
|
|
item:= TMenuItem.Create(Self);
|
|
s := GetDisplayText(dtHolidaysDuring);
|
|
if pos('%d', s) = 0 then
|
|
item.Caption:= s + ' ' + IntToStr(FCalDrawer.FThisYear)
|
|
else
|
|
item.Caption := Format(s, [FCalDrawer.FThisYear]);
|
|
Add(item);
|
|
item:= TMenuItem.Create(Self);
|
|
item.Caption:= '-';
|
|
Add(item);
|
|
for m:= 1 to 12 do
|
|
begin
|
|
ClearHolidays(hols);
|
|
FOnGetHolidays(Self, m, FCalDrawer.FThisYear, hols);
|
|
dayCount:= DaysInAMonth(FCalDrawer.FThisYear, m);
|
|
d := 1;
|
|
repeat
|
|
if IsHoliday(d, hols) then
|
|
begin
|
|
item := TMenuItem.Create(Self);
|
|
inc(population);
|
|
item.Caption:= IntToStr(d) + ' ' + GetMonthName(m);
|
|
if (m = FCalDrawer.FThisMonth) then
|
|
item.Checked := True;
|
|
dt := EncodeDate(FCalDrawer.FThisYear, m, d);
|
|
item.Tag := trunc(dt);
|
|
item.OnClick := @HolidayMenuItemClicked;
|
|
Add(item);
|
|
end;
|
|
inc(d)
|
|
until d > dayCount;
|
|
end;
|
|
Items[0].Enabled := (population <> 0);
|
|
if not Items[0].Enabled then begin
|
|
s := GetDisplayText(dtNoHolidaysDuring);
|
|
if pos('%d', s) = 0 then
|
|
Items[0].Caption := s + ' ' + IntToStr(FCalDrawer.FThisYear)
|
|
else
|
|
Items[0].Caption := Format(s, [FCalDrawer.FThisYear]);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TCalendarLite.PopulateMonthPopupMenu;
|
|
var
|
|
m: Integer;
|
|
item: TMenuItem;
|
|
begin
|
|
with FPopupMenu.Items do begin
|
|
Clear;
|
|
for m := 1 to 12 do
|
|
begin
|
|
item := TMenuItem.Create(self);
|
|
item.Caption := GetMonthName(m);
|
|
item.OnClick := @MonthMenuItemClicked;
|
|
item.Tag := m;
|
|
if m = FCalDrawer.FThisMonth then
|
|
item.Checked := true;
|
|
Add(item);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TCalendarLite.PopulateYearPopupMenu;
|
|
var
|
|
y: Integer;
|
|
item: TMenuItem;
|
|
begin
|
|
with FPopupMenu.Items do begin
|
|
Clear;
|
|
for y := FCalDrawer.FThisYear - 10 to FCalDrawer.FThisYear + 10 do
|
|
begin
|
|
item := TMenuItem.Create(self);
|
|
item.Caption := IntToStr(y);
|
|
item.OnClick := @YearMenuItemClicked;
|
|
item.Tag := y;
|
|
if y = FCalDrawer.FThisYear then
|
|
item.Checked := true;
|
|
Add(item);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TCalendarLite.SelectedDates: TCalDateArray;
|
|
begin
|
|
Result := FSelDates.AsArray;
|
|
end;
|
|
|
|
procedure TCalendarLite.SetButtonHeight(const AValue: Integer);
|
|
begin
|
|
if FButtonHeight = AValue then exit;
|
|
FButtonHeight := AValue;
|
|
Draw;
|
|
end;
|
|
|
|
procedure TCalendarLite.SetButtonWidth(const AValue: Integer);
|
|
begin
|
|
if FButtonWidth = AValue then exit;
|
|
FButtonWidth := AValue;
|
|
Draw;
|
|
end;
|
|
|
|
procedure TCalendarLite.SetCustomDayNames(const AValue: String);
|
|
begin
|
|
FCustomDayNames := AValue;
|
|
if FLanguage = lgCustom then
|
|
SetLanguage(lgCustom);
|
|
end;
|
|
|
|
procedure TCalendarLite.SetCustomDisplayTexts(const AValue: String);
|
|
begin
|
|
FCustomDisplayTexts := AValue;
|
|
if FLanguage = lgCustom then
|
|
SetLanguage(lgCustom);
|
|
end;
|
|
|
|
procedure TCalendarLite.SetCustomMonthNames(const AValue: String);
|
|
begin
|
|
FCustomMonthNames := AValue;
|
|
if FLanguage = lgCustom then
|
|
SetLanguage(lgCustom);
|
|
end;
|
|
|
|
procedure TCalendarLite.SetDate(AValue: TDateTime);
|
|
var
|
|
oldMonth: Integer;
|
|
dateValue: Integer;
|
|
begin
|
|
dateValue := trunc(AValue);
|
|
if FDate = dateValue then Exit;
|
|
oldMonth := MonthOf(FDate);
|
|
FDate := dateValue;
|
|
FPrevDate := dateValue;
|
|
FSelDates.Clear;
|
|
DateChange;
|
|
if MonthOf(FDate) <> oldMonth then
|
|
MonthChange;
|
|
Draw;
|
|
end;
|
|
|
|
procedure TCalendarLite.SetDefaultDayNames;
|
|
begin
|
|
UseDayName(dowSunday, rsCalSunday);
|
|
UseDayName(dowMonday, rsCalMonday);
|
|
UseDayName(dowTuesday, rsCalTuesday);
|
|
UseDayName(dowWednesday, rsCalWednesday);
|
|
UseDayName(dowThursday, rsCalThursday);
|
|
UseDayName(dowFriday, rsCalFriday);
|
|
UseDayName(dowSaturday, rsCalSaturday);
|
|
end;
|
|
|
|
procedure TCalendarLite.SetDefaultDisplayTexts;
|
|
begin
|
|
FDisplayTexts[dtToday] := rsCalTodayIs;
|
|
FDisplayTexts[dtHolidaysDuring] := rsCalHolidaysIn;
|
|
FDisplayTexts[dtNoHolidaysDuring] := rsCalNoHolidaysIn;
|
|
|
|
FDisplayTexts[dtTodayFormat] := rsCalTodayFormat;
|
|
FDisplayTexts[dtTodayFormatLong] := rsCalTodayFormatLong;
|
|
FDisplayTexts[dtCaptionFormat] := rsCalCaptionFormat;
|
|
|
|
FCustomDisplayTexts := GetDisplayTexts;
|
|
end;
|
|
|
|
procedure TCalendarLite.SetDefaultMonthNames;
|
|
begin
|
|
UseMonthName(1, rsCalJanuary);
|
|
UseMonthname(2, rsCalFebruary);
|
|
UseMonthName( 3, rsCalMarch);
|
|
UseMonthName( 4, rsCalApril);
|
|
UseMonthname( 5, rsCalMay);
|
|
UseMonthname( 6, rsCalJune);
|
|
UseMonthname( 7, rsCalJuly);
|
|
UseMonthName( 8, rsCalAugust);
|
|
UseMonthname( 9, rsCalSeptember);
|
|
UseMonthName(10, rsCalOctober);
|
|
UseMonthName(11, rsCalNovember);
|
|
UseMonthName(12, rsCalDecember);
|
|
end;
|
|
|
|
procedure TCalendarLite.SetDisplayTexts(AValue: String);
|
|
var
|
|
L: TStrings;
|
|
i: Integer;
|
|
begin
|
|
L := TStringList.Create;
|
|
try
|
|
L.StrictDelimiter := True;
|
|
L.CommaText := AValue;
|
|
for i:=0 to L.Count - 1 do begin
|
|
if i >= ord(High(TDisplayText)) then
|
|
exit;
|
|
FDisplayTexts[TDisplayText(i)] := trim(L[i]);
|
|
end;
|
|
finally
|
|
L.Free;
|
|
end;
|
|
Draw;
|
|
end;
|
|
|
|
procedure TCalendarLite.SetLanguage(AValue : TLanguage);
|
|
begin
|
|
// Don't check for "FLanguage = AValue" because otherwise the code would not
|
|
// execute after being called from the constructor.
|
|
FLanguage := AValue;
|
|
|
|
case FLanguage of
|
|
lgEnglish: begin
|
|
UseDayNames(EnglishDays);
|
|
UseMonthNames(EnglishMonths);
|
|
UseDisplayTexts(EnglishTexts);
|
|
BiDiMode:= bdLeftToRight;
|
|
end;
|
|
lgFrench: begin
|
|
UseDayNames(FrenchDays);
|
|
UseMonthNames(FrenchMonths);
|
|
UseDisplayTexts(FrenchTexts);
|
|
BiDiMode:= bdLeftToRight;
|
|
end;
|
|
lgGerman: begin
|
|
UseDayNames(GermanDays);
|
|
UseMonthNames(GermanMonths);
|
|
UseDisplayTexts(GermamTexts);
|
|
BiDiMode:= bdLeftToRight;
|
|
end;
|
|
lgHebrew: begin
|
|
UseDayNames(HebrewDays);
|
|
UseMonthNames(HebrewMonths);
|
|
UseDisplayTexts(HebrewTexts);
|
|
BiDiMode:= bdRightToLeft;
|
|
end;
|
|
lgSpanish: begin
|
|
UseDayNames(SpanishDays);
|
|
UseMonthNames(SpanishMonths);
|
|
UseDisplayTexts(SpanishTexts);
|
|
BiDiMode:= bdLeftToRight;
|
|
end;
|
|
lgItalian: begin
|
|
UseDayNames(ItalianDays);
|
|
UseMonthNames(ItalianMonths);
|
|
UseDisplayTexts(ItalianTexts);
|
|
BiDiMode:= bdLeftToRight;
|
|
end;
|
|
lgPolish: begin
|
|
UseDayNames(PolishDays);
|
|
UseMonthNames(PolishMonths);
|
|
UseDisplayTexts(PolishTexts);
|
|
BiDiMode:= bdLeftToRight;
|
|
end;
|
|
lgFinnish: begin
|
|
UseDayNames(FinnishDays);
|
|
UseMonthNames(FinnishMonths);
|
|
UseDisplayTexts(FinnishTexts);
|
|
BiDiMode := bdLeftToRight;
|
|
end;
|
|
lgGreek: begin
|
|
UseDayNames(GreekDays);
|
|
UseMonthNames(GreekMonths);
|
|
UseDisplayTexts(GreekTexts);
|
|
BiDiMode := bdLeftToRight;
|
|
end;
|
|
lgRussian: begin
|
|
UseDayNames(RussianDays);
|
|
UseMonthNames(RussianMonths);
|
|
UseDisplayTexts(RussianTexts);
|
|
BiDiMode := bdLeftToRight;
|
|
end;
|
|
lgCustom: begin
|
|
UseDayNames(FCustomDayNames);
|
|
UseMonthNames(FCustomMonthNames);
|
|
UseDisplayTexts(FCustomDisplayTexts);
|
|
end;
|
|
end;
|
|
|
|
Draw;
|
|
end;
|
|
|
|
function TCalendarLite.SelMode(Shift: TShiftState): TCalSelMode;
|
|
begin
|
|
Result := smFirstSingle;
|
|
if not FMultiSelect then
|
|
exit;
|
|
|
|
if (ssDouble in Shift) then begin
|
|
Result := smFirstWeek;
|
|
if (ssCtrl in Shift) and (FPrevDate > 0) then
|
|
Result := smNextWeek
|
|
else if (ssShift in Shift) and (FPrevDate > 0) then
|
|
Result := smNextWeekRange
|
|
end else
|
|
if (ssShift in Shift) then begin
|
|
Result := smFirstRange;
|
|
if (ssCtrl in Shift) and (FPrevDate > 0) then
|
|
Result := smNextRange;
|
|
end else
|
|
if (ssCtrl in Shift) and (FPrevDate > 0) then
|
|
Result := smNextSingle;
|
|
end;
|
|
|
|
procedure TCalendarLite.SetBiDiMode(AValue: TBiDiMode);
|
|
begin
|
|
inherited;
|
|
UpdateBiDiMode;
|
|
end;
|
|
|
|
procedure TCalendarLite.SetMultiSelect(AValue: Boolean);
|
|
begin
|
|
if AValue = FMultiSelect then
|
|
exit;
|
|
FMultiSelect := AValue;
|
|
FSelDates.Clear;
|
|
FSelDates.AddDate(FDate);
|
|
FPrevDate := FDate;
|
|
end;
|
|
|
|
procedure TCalendarLite.SetParentBiDiMode(AValue: Boolean);
|
|
begin
|
|
inherited;
|
|
UpdateBiDiMode;
|
|
end;
|
|
|
|
procedure TCalendarLite.SetStartingDayOfWeek(AValue: TDayOfWeek);
|
|
begin
|
|
if FStartingDayOfWeek = AValue then Exit;
|
|
FStartingDayOfWeek := AValue;
|
|
Draw;
|
|
end;
|
|
|
|
procedure TCalendarLite.SetOptions(AValue: TCalOptions);
|
|
begin
|
|
//if FOptions = AValue then Exit;
|
|
FOptions := AValue;
|
|
case (coShowTodayRow in FOptions) of
|
|
False: if FCalDrawer.FLastRow <> LastDateRow then FCalDrawer.FLastRow := LastDateRow;
|
|
True : if FCalDrawer.FLastRow <> TodayRow then FCalDrawer.FLastRow := TodayRow;
|
|
end;
|
|
if High(FCalDrawer.FRowPositions) <> FCalDrawer.FLastRow then
|
|
SetLength(FCalDrawer.FRowPositions, FCalDrawer.FLastRow+1);
|
|
if (coNoMonthChange in FOptions) then;
|
|
Draw;
|
|
end;
|
|
|
|
procedure TCalendarLite.SetWeekendDays(AValue: TDaysOfWeek);
|
|
begin
|
|
if FWeekendDays = AValue then Exit;
|
|
FWeekendDays := AValue;
|
|
Draw;
|
|
end;
|
|
|
|
{ The DblClickTimer was triggered by a mouse-down event; its purpose is to
|
|
prevent the Click method in addition to the DblClick method. In case of
|
|
a single click the TimerExpired event is reached. In case of a double-click
|
|
the click handled directly by the DblClick }
|
|
procedure TCalendarLite.TimerExpired(Sender: TObject);
|
|
begin
|
|
FDblClickTimer.Enabled := false;
|
|
InternalClick;
|
|
end;
|
|
|
|
procedure TCalendarLite.UpdateBiDiMode;
|
|
begin
|
|
case (BiDiMode = bdLeftToRight) of
|
|
False: if not FCalDrawer.FTextStyle.RightToLeft then
|
|
FCalDrawer.FTextStyle.RightToLeft := True;
|
|
True : if FCalDrawer.FTextStyle.RightToLeft then
|
|
FCalDrawer.FTextStyle.RightToLeft := False;
|
|
end;
|
|
end;
|
|
|
|
procedure TCalendarlite.UseDayName(ADayOfWeek: TDayOfWeek; const AValue: String);
|
|
var
|
|
p: Integer;
|
|
d: Integer;
|
|
begin
|
|
if AValue = '' then exit;
|
|
d := ord(ADayOfWeek) + 1; // TDayOfWeek is 0-based, FormatSettings.DayNames are 1-based.
|
|
p := pos('|', AValue);
|
|
if p > 0 then begin
|
|
FFormatSettings.LongDayNames[d] := Trim(Copy(AValue, 1, p-1));
|
|
FFormatSettings.ShortDayNames[d] := Trim(Copy(AValue, p+1, MaxInt));
|
|
end else begin
|
|
FFormatSettings.LongDayNames[d] := Trim(AValue);
|
|
FFormatSettings.ShortDayNames[d] := FFormatSettings.LongDayNames[d];
|
|
end;
|
|
end;
|
|
|
|
procedure TCalendarLite.UseDayNames(const AValue: String);
|
|
var
|
|
L: TStrings;
|
|
i, dow: Integer;
|
|
begin
|
|
L := TStringList.Create;
|
|
try
|
|
L.CommaText := AValue;
|
|
for i:=0 to L.Count-1 do begin
|
|
dow := i;
|
|
if dow < 7 then
|
|
UseDayName(TDayOfWeek(dow), L[i]);
|
|
end;
|
|
finally
|
|
L.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TCalendarLite.UseDisplayTexts(const AValue: String);
|
|
begin
|
|
SetDisplayTexts(AValue);
|
|
end;
|
|
|
|
procedure TCalendarLite.UseMonthName(AMonth: Integer; const AValue: String);
|
|
var
|
|
p: Integer;
|
|
begin
|
|
if AValue = '' then
|
|
exit;
|
|
p := pos('|', AValue);
|
|
if p <> 0 then begin
|
|
FFormatSettings.LongMonthNames[AMonth] := Trim(Copy(AValue, 1, p-1));
|
|
FFormatSettings.ShortMonthNames[AMonth] := Trim(Copy(AValue, p+1, MaxInt));
|
|
end else begin
|
|
FFormatSettings.LongMonthNames[AMonth] := Trim(AValue);
|
|
FFormatSettings.ShortMonthNames[AMonth] := FFormatSettings.LongMonthNames[AMonth];
|
|
end;
|
|
end;
|
|
|
|
procedure TCalendarLite.UseMonthNames(const AValue: String);
|
|
var
|
|
L: TStrings;
|
|
i, m: Integer;
|
|
begin
|
|
L := TStringList.Create;
|
|
try
|
|
L.CommaText := AValue;
|
|
for i:=0 to L.Count - 1 do begin
|
|
m := succ(i);
|
|
if m <= 12 then
|
|
UseMonthName(m, L[i]);
|
|
end;
|
|
finally
|
|
L.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TCalendarLite.YearMenuItemClicked(Sender: TObject);
|
|
begin
|
|
FCalDrawer.GotoYear(TMenuItem(Sender).Tag);
|
|
end;
|
|
|
|
{ Hints }
|
|
|
|
procedure TCalendarLite.ShowHintWindow(APoint: TPoint; ADate: TDate);
|
|
var
|
|
txt: String = '';
|
|
y, m, d: Word;
|
|
begin
|
|
if Assigned(FOnHint) then begin
|
|
DecodeDate(ADate, y, m, d);
|
|
FOnHint(Self, y, m, d, txt);
|
|
if Hint <> '' then begin
|
|
if txt = '' then txt := Hint else txt := Hint + LineEnding + txt;
|
|
end;
|
|
end else
|
|
txt := Hint;
|
|
|
|
if txt = '' then
|
|
exit;
|
|
|
|
APoint := ClientToScreen(APoint);
|
|
Hint := txt;
|
|
Application.Hint := txt;
|
|
Application.ActivateHint(APoint);
|
|
end;
|
|
|
|
procedure TCalendarLite.HideHintWindow;
|
|
begin
|
|
Hint := FSavedHint;
|
|
Application.CancelHint;
|
|
end;
|
|
|
|
|
|
procedure Register;
|
|
begin
|
|
RegisterComponents('Misc', [TCalendarLite]);
|
|
end;
|
|
|
|
|
|
end.
|