4938f826fd
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@5380 8e941d3f-bd1b-0410-a28a-d453659cc2b4
1922 lines
54 KiB
ObjectPascal
1922 lines
54 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, Forms, Controls, Graphics, Dialogs, Types,
|
||
ExtCtrls, Menus;
|
||
|
||
const
|
||
TopRow = 0;
|
||
DayRow = 1;
|
||
FirstDateRow = 2;
|
||
LastDateRow = 7;
|
||
LastCol = 7;
|
||
TodayRow = 8;
|
||
LastRow: word = 0;
|
||
DefCalHeight = 160;
|
||
DefCalWidth = 210;
|
||
DefMinHeight = 120;
|
||
DefMinWidth = 120;
|
||
DefTStyle: TTextStyle = (Alignment : taCenter; Layout : tlCenter;
|
||
SingleLine : False; Clipping : True;
|
||
ExpandTabs : False; ShowPrefix : False;
|
||
Wordbreak : True; Opaque : False;
|
||
SystemFont : False; RightToLeft: False;
|
||
EndEllipsis: False);
|
||
|
||
DefaultDisplayText = 'Today is,"mmm dd"","" yyyy",Holidays during,There are no holidays set for';
|
||
EnglishDays = 'Sun,Mon,Tue,Wed,Thu,Fri,Sat';
|
||
EnglishMonths = 'January,February,March,April,May,June,July,August,September,October,November,December';
|
||
|
||
HebrewDays = 'א,ב,ג,ד,ה,ו,ש';
|
||
HebrewMonths = ('ינואר,פברואר,מרץ,אפריל,מאי,יוני, יולי,אוגוסט,ספטמבר,אוקטובר,נובמבר,דצמבר');
|
||
HebrewTexts = 'היום הוא,yyyy-mm-dd,במהלך החגים, אין חגים מוגדרים עבור';
|
||
|
||
FrenchDays = 'dim,lun,mar,mer,jeu,ven,sam';
|
||
FrenchMonths = 'janvier,février,mars,avril,mai,juin,juillet,août,septembre,octobre,novembre,décembre';
|
||
FrenchTexts = 'Est aujourd''hui,dd/mm/yyyy,vacances pendant,Il n''y a pas de jours fériés fixés pour';
|
||
|
||
GermanMonths = 'Januar,Februar,März,April,Mai,Juni,Juli,August,September,Oktober,November,Dezember';
|
||
GermanDays = 'So,Mo,Di,Mi,Do,Fr,Sa';
|
||
GermamTexts = 'Heute ist,dd.mm.yyyy,Urlaub während,Es gibt keine Feiertage im';
|
||
|
||
SpanishDays = 'dom,lun,mar,mié,jue,vie,sáb';
|
||
SpanishMonths = 'enero,febrero,marzo,abril,mayo,junio,julio,agosto,septiembre,octubre,noviembre,diciembre';
|
||
SpanishTexts = 'Hoy es,dd/mm/yyyy,Dias de fiestas,No hay dias feriados establecidos para';
|
||
|
||
ItalianDays = 'dom,lun,mar,mer,gio,ven,sab';
|
||
ItalianMonths = 'gennaio,febbraio,marzo,aprile,maggio,giugno,luglio,agosto,settembre,ottobre,novembre,dicembre';
|
||
ItalianTexts = 'Oggi è,dd/mmm/yyyy,Vacanze durante,Non ci sono vacanze fissati per';
|
||
|
||
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';
|
||
|
||
FinnishTexts ='Tänään on,dd.mm.yyyy,Lomapäivät,Lomapäiviä ei ole asetettu';
|
||
FinnishMonths = 'Tammikuu,Helmikuu,Maaliskuu,Huhtikuu,Toukokuu,Kesäkuu,Heinäkuu,Elokuu,Syyskuu,Lokakuu,Marraskuu,Joulukuu';
|
||
FinnishDays = 'Su,Ma,Ti,ke,To,Pe,La';
|
||
|
||
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=1, dowMonday=2, dowTuesday=3, dowWednesday=4,
|
||
dowThursday=5, dowFriday=6, dowSaturday=7);
|
||
TDaysOfWeek = set of TDayOfWeek;
|
||
|
||
TDisplayText = (dtToday=0, dtTodayFormat=1, dtHolidaysDuring=2, dtNoHolidaysDuring=3);
|
||
|
||
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, coUseTopRowColors);
|
||
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);
|
||
|
||
|
||
{ 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;
|
||
FCanvas: TCanvas;
|
||
FCellSize: TSize;
|
||
FColPositions: TColArray;
|
||
FOwner: TCalendarLite;
|
||
FRowPositions: TRowArray;
|
||
FStartDate: TDateTime;
|
||
FThisDay: word;
|
||
FThisMonth: word;
|
||
FThisYear: word;
|
||
FTStyle: TTextStyle;
|
||
procedure CalcSettings;
|
||
procedure DrawArrow(ARect: TRect; AHead: TArrowhead; ADirec: TArrowDirection);
|
||
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(Shift: TShiftState);
|
||
procedure RightClick;
|
||
public
|
||
constructor Create(ACanvas: TCanvas);
|
||
procedure Draw;
|
||
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
|
||
FCalDrawer: TCalDrawer;
|
||
FColors: TCalColors;
|
||
FDate: TDateTime;
|
||
FDayNames: TStringList;
|
||
FDisplayTexts: TStringList;
|
||
FMonthNames: TStringList;
|
||
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;
|
||
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 SetDate(AValue: TDateTime);
|
||
procedure SetDayNames(const AValue: String);
|
||
procedure SetDefaultDisplayTexts;
|
||
procedure SetDisplayTexts(AValue: String);
|
||
procedure SetMonthNames(const AValue: String);
|
||
procedure SetMultiSelect(AValue: Boolean);
|
||
procedure SetOptions(AValue: TCalOptions);
|
||
procedure SetStartingDayOfWeek(AValue: TDayOfWeek);
|
||
procedure SetWeekendDays(AValue: TDaysOfWeek);
|
||
procedure SetLanguage(AValue: TLanguage);
|
||
procedure TimerExpired(Sender: TObject);
|
||
procedure YearMenuItemClicked(Sender: TObject);
|
||
|
||
protected
|
||
procedure ChangeDateTo(ADate: TDate; ASelMode: TCalSelMode);
|
||
procedure DateChange; virtual;
|
||
procedure DblClick; 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 Paint; override;
|
||
|
||
{ 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;
|
||
|
||
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 Colors: TCalColors read FColors write FColors;
|
||
property Date: TDateTime read FDate write SetDate;
|
||
property DayNames: String read GetDayNames write SetDayNames;
|
||
property DisplayTexts: String read GetDisplaytexts write SetDisplayTexts;
|
||
property MonthNames: String read GetMonthnames write SetMonthNames;
|
||
property MultiSelect: Boolean read FMultiSelect write SetMultiSelect;
|
||
property Options: TCalOptions read FOptions write SetOptions
|
||
default [coShowTodayFrame, coBoldHolidays, coShowWeekend, coShowHolidays, coShowTodayRow];
|
||
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
|
||
|
||
uses
|
||
LCLType, LazUTF8, dateutils, math;
|
||
|
||
const
|
||
DBLCLICK_INTERVAL = 300; // Interval (ms) for detection of a double-click
|
||
|
||
|
||
{ 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
|
||
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(ACanvas: TCanvas);
|
||
begin
|
||
inherited Create;
|
||
FCanvas:= ACanvas;
|
||
FTStyle:= DefTStyle;
|
||
end;
|
||
|
||
procedure TCalDrawer.CalcSettings;
|
||
var
|
||
rem: Integer = 0;
|
||
hSpc: Integer = 0;
|
||
ch: Integer = 0;
|
||
sp: Integer = 0;
|
||
cw: Integer = 0;
|
||
bit: integer=0;
|
||
i, cellWidths, totalSpace, cellHeights,
|
||
adjSpace, borderh, borderv, numRows: integer;
|
||
sz: TSize;
|
||
begin
|
||
if (FOwner.BiDiMode = bdLeftToRight) then
|
||
FTStyle.RightToLeft:= False
|
||
else
|
||
FTStyle.RightToLeft:= True;
|
||
SetLength(FRowPositions, 0);
|
||
if (coShowTodayRow in FOwner.Options) then
|
||
LastRow := TodayRow
|
||
else
|
||
LastRow := LastDateRow;
|
||
SetLength(FRowPositions, LastRow+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 LastRow of
|
||
LastDateRow : totalSpace := 12;
|
||
TodayRow : totalSpace := 14;
|
||
end;
|
||
|
||
cellHeights := sz.cy - totalSpace;
|
||
numRows := Succ(LastRow);
|
||
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;
|
||
cw := bit + borderv + rem;
|
||
FRowPositions[TopRow] := cw;
|
||
inc(cw, rem);
|
||
FRowPositions[DayRow] := cw + ch;
|
||
for i := FirstDateRow to LastDateRow do
|
||
FRowPositions[i] := cw + i*ch + (i-1)*sp;
|
||
if (LastRow = 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;
|
||
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;
|
||
d, ox, oy, half: integer;
|
||
pts: TArrowPoints;
|
||
begin
|
||
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);
|
||
d := Min(sz.cy, sz.cx) div 3;
|
||
half := d div 2;
|
||
ox := ARect.Left + (sz.cx - d) div 2;
|
||
oy := ARect.Top + (sz.cy - d) div 2;
|
||
case AHead of
|
||
ahSingle:
|
||
begin
|
||
case ADirec of
|
||
adLeft:
|
||
begin
|
||
pts[1]:= Point(ox+d, oy);
|
||
pts[2]:= Point(ox, oy+half);
|
||
pts[3]:= Point(ox+d, oy+d);
|
||
end;
|
||
adRight:
|
||
begin
|
||
pts[1]:= Point(ox, oy);
|
||
pts[2]:= Point(ox, oy+d);
|
||
pts[3]:= Point(ox+d, oy+half);
|
||
end;
|
||
end;
|
||
FCanvas.Polygon(pts);
|
||
end;
|
||
ahDouble:
|
||
case ADirec of
|
||
adLeft:
|
||
begin
|
||
pts[1]:= Point(ox+half-1, oy);
|
||
pts[2]:= Point(ox-1, oy+half);
|
||
pts[3]:= Point(ox+half-1, oy+d);
|
||
FCanvas.Polygon(pts);
|
||
pts[1]:= Point(ox+d, oy);
|
||
pts[2]:= Point(ox+half, oy+half);
|
||
pts[3]:= Point(ox+d, oy+d);
|
||
FCanvas.Polygon(pts);
|
||
end;
|
||
adRight:
|
||
begin
|
||
pts[1]:= Point(ox, oy);
|
||
pts[2]:= Point(ox+half, oy+half);
|
||
pts[3]:= Point(ox, oy+d);
|
||
FCanvas.Polygon(pts);
|
||
pts[1]:= Point(ox+half+1, oy);
|
||
pts[2]:= Point(ox+d+1, oy+half);
|
||
pts[3]:= Point(ox+half+1, oy+d);
|
||
FCanvas.Polygon(pts);
|
||
end;
|
||
end;
|
||
end;
|
||
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);
|
||
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 := [fsBold];
|
||
end else
|
||
{ Special case: override weekend }
|
||
if (coShowWeekend in FOwner.Options) and
|
||
(TDayOfWeek(DayOfWeek(dt)) in FOwner.FWeekendDays) then
|
||
begin
|
||
FCanvas.Font.Color := FOwner.Colors.WeekendColor;
|
||
if coBoldWeekend in FOwner.Options then
|
||
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);
|
||
|
||
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, FTStyle);
|
||
end;
|
||
|
||
dt:= dt + 1;
|
||
end; // for c
|
||
|
||
oldPen.Free;
|
||
oldBrush.Free;
|
||
|
||
end;
|
||
|
||
procedure TCalDrawer.DrawDayLabels;
|
||
var
|
||
c, map: integer;
|
||
rec: TRect;
|
||
lbls: TWeekNameArray;
|
||
begin
|
||
FCanvas.Font.Color:= FOwner.Colors.TextColor;
|
||
if (coBoldDayNames in FOwner.Options) then
|
||
FCanvas.Font.Style := [fsBold]
|
||
else
|
||
FCanvas.Font.Style := [];
|
||
map := Integer(FOwner.FStartingDayOfWeek);
|
||
for c:= Low(TWeekNameArray) to High(TWeekNameArray) do
|
||
begin
|
||
if (map > High(TWeekNameArray)) then map := Low(TWeekNameArray);
|
||
lbls[c] := FOwner.GetDayName(TDayOfWeek(map));
|
||
inc(map);
|
||
end;
|
||
for c:= Low(FColPositions) to High(FColPositions) do
|
||
begin
|
||
rec := GetCellAtColRow(c, DayRow);
|
||
FCanvas.TextRect(rec, 0, 0, lbls[c], FTStyle);
|
||
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;
|
||
begin
|
||
if (LastRow <> 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 := [fsBold] else
|
||
FCanvas.Font.Style := [];
|
||
|
||
s:= FOwner.GetDisplayText(dtToday);
|
||
if (coShowTodayName in FOwner.Options) then
|
||
s := Format('%s %s',[s, FOwner.GetDayName(TDayOfWeek(DayOfWeek(Date())))]);
|
||
AppendStr(s, ' ' + FormatDateTime(FOwner.GetDisplayText(dtTodayFormat), Date()));
|
||
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.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, FTStyle);
|
||
end;
|
||
|
||
procedure TCalDrawer.DrawTopRow;
|
||
var
|
||
r: TRect;
|
||
s: String;
|
||
begin
|
||
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 := [fsBold]
|
||
else
|
||
FCanvas.Font.Style := [];
|
||
|
||
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;
|
||
s := FOwner.GetMonthName(FThisMonth) + ' ' + IntToStr(FThisYear);
|
||
FCanvas.TextRect(r, 0, 0, s, FTStyle);
|
||
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);
|
||
var
|
||
d: TDate;
|
||
begin
|
||
if not TryEncodeDate(FThisYear, AMonth, FThisDay, d) then // Feb 29 in leap year!
|
||
d := EncodeDate(FThisYear, AMonth, FThisDay);
|
||
FOwner.Date := d;
|
||
end;
|
||
|
||
procedure TCalDrawer.GotoToday;
|
||
begin
|
||
FOwner.Date:= Date();
|
||
end;
|
||
|
||
procedure TCalDrawer.GotoYear(AYear: word);
|
||
var
|
||
d: TDate;
|
||
begin
|
||
if not TryEncodeDate(AYear, FThisMonth, FThisDay, d) then // Feb 29 in leap year!
|
||
d := EncodeDate(AYear, FThisMonth, FThisDay);
|
||
FOwner.Date := d;
|
||
end;
|
||
|
||
procedure TCalDrawer.LeftClick(Shift: TShiftState);
|
||
var
|
||
p, ppopup: TPoint;
|
||
cell: TSize;
|
||
Rm, Ry: TRect;
|
||
sm: TCalSelMode;
|
||
begin
|
||
sm := FOwner.SelMode(Shift);
|
||
p := FOwner.ScreenToClient(Mouse.CursorPos);
|
||
cell := GetCellAt(p);
|
||
case cell.cy of
|
||
TopRow:
|
||
case cell.cx of
|
||
1: FOwner.Date := IncYear(FOwner.Date, -1);
|
||
2: FOwner.Date := IncMonth(FOwner.Date, -1);
|
||
3..5:
|
||
begin
|
||
GetMonthYearRects(Rm{%H-}, Ry{%H-});
|
||
if PtInRect(Rm, p) then begin
|
||
FOwner.PopulateMonthPopupMenu;
|
||
ppopup := FOwner.ClientToScreen(Point(Rm.Left, Rm.Bottom));
|
||
FOwner.FPopupMenu.PopUp(ppopup.x, ppopup.y);
|
||
end;
|
||
if PtInRect(Ry, p) then begin
|
||
FOwner.PopulateYearPopupMenu;
|
||
ppopup := FOwner.ClientToScreen(Point(Ry.Left, Ry.Bottom));
|
||
FOwner.FPopupMenu.Popup(ppopup.x, ppopup.y);
|
||
end;
|
||
end;
|
||
6: FOwner.Date := IncMonth(FOwner.Date, +1);
|
||
7: 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;
|
||
|
||
|
||
{ 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.Invalidate;
|
||
end;
|
||
|
||
|
||
{ TCalendarLite }
|
||
|
||
constructor TCalendarLite.Create(anOwner: TComponent);
|
||
begin
|
||
inherited Create(anOwner);
|
||
FSelDates := TCalDateList.Create;
|
||
FColors := TCalColors.Create(self);
|
||
Color := clWhite;
|
||
FStartingDayOfWeek:= dowSunday;
|
||
with GetControlClassDefaultSize do
|
||
SetInitialBounds(0, 0, cx, cy);
|
||
Constraints.MinHeight := DefMinHeight;
|
||
Constraints.MinWidth := DefMinWidth;
|
||
Canvas.Brush.Style := bsSolid;
|
||
TabStop := true;
|
||
FDayNames := TStringList.Create;
|
||
FMonthNames := TStringList.Create;
|
||
FDisplayTexts := TStringList.Create;
|
||
FDisplayTexts.StrictDelimiter := True;
|
||
FDisplayTexts.Delimiter := ',';
|
||
SetDefaultDisplayTexts;
|
||
FPopupMenu := TPopupMenu.Create(Self);
|
||
FCalDrawer := TCalDrawer.Create(Canvas);
|
||
FCalDrawer.FOwner:= Self;
|
||
FDblClickTimer := TTimer.Create(self);
|
||
FDblClickTimer.Enabled := false;
|
||
FDblClickTimer.Interval := DBLCLICK_INTERVAL;
|
||
FDblClickTimer.OnTimer := @TimerExpired;
|
||
FWeekendDays := [dowSunday, dowSaturday];
|
||
FOptions := [coShowTodayFrame, coBoldHolidays, coShowWeekend, coShowHolidays,
|
||
coShowTodayRow];
|
||
SetLanguage(lgEnglish);
|
||
FPrevMouseDate := 0;
|
||
Date := SysUtils.Date;
|
||
end;
|
||
|
||
destructor TCalendarLite.Destroy;
|
||
begin
|
||
FreeAndNil(FSelDates);
|
||
FreeAndNil(FDayNames);
|
||
FreeAndNil(FMonthNames);
|
||
FreeAndNil(FDisplayTexts);
|
||
FreeAndNil(FColors);
|
||
SetLength(FCalDrawer.FRowPositions, 0);
|
||
FreeAndNil(FCalDrawer);
|
||
inherited Destroy;
|
||
end;
|
||
|
||
procedure TCalendarLite.ChangeDateTo(ADate: TDate; ASelMode: TCalSelMode);
|
||
var
|
||
d, d1, d2: TDate;
|
||
oldMonth: Integer;
|
||
begin
|
||
oldMonth := MonthOf(FDate);
|
||
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;
|
||
|
||
with FCalDrawer do begin
|
||
FCanvas.Brush.Color := Colors.BackgroundColor;
|
||
FCanvas.FillRect(FBoundsRect);
|
||
end;
|
||
Invalidate;
|
||
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(FClickShift + [ssDouble]);
|
||
mbRight : ;
|
||
end;
|
||
end;
|
||
|
||
class function TCalendarLite.GetControlClassDefaultSize: TSize;
|
||
begin
|
||
Result.cx := DefCalWidth;
|
||
Result.cy := DefCalHeight;
|
||
end;
|
||
|
||
function TCalendarLite.GetDayName(ADayOfWeek: TDayOfWeek): String;
|
||
begin
|
||
Result := SysToUTF8(DefaultFormatSettings.ShortDayNames[integer(ADayOfWeek)]);
|
||
if Pred(integer(ADayOfWeek)) < FDayNames.Count then
|
||
Result := FDayNames[Pred(integer(ADayOfWeek))];
|
||
end;
|
||
|
||
function TCalendarLite.GetDayNames: String;
|
||
begin
|
||
Result := FDayNames.CommaText;
|
||
end;
|
||
|
||
function TCalendarLite.GetDisplayText(aTextIndex: TDisplayText): String;
|
||
begin
|
||
Result := FDisplayTexts[Integer(aTextIndex)];
|
||
end;
|
||
|
||
function TCalendarLite.GetDisplayTexts: String;
|
||
begin
|
||
Result := FDisplayTexts.CommaText;
|
||
end;
|
||
|
||
function TCalendarLite.GetMonthName(AMonth: Integer): String;
|
||
begin
|
||
Result := SysToUTF8(DefaultFormatSettings.LongMonthNames[AMonth]);
|
||
if pred(AMonth) < FMonthnames.Count then
|
||
Result := FMonthNames[pred(AMonth)];
|
||
end;
|
||
|
||
function TCalendarLite.GetMonthNames: String;
|
||
begin
|
||
Result := FMonthNames.CommaText;
|
||
end;
|
||
|
||
procedure TCalendarLite.HolidayMenuItemClicked(Sender: TObject);
|
||
begin
|
||
FCalDrawer.GotoDay(TMenuItem(Sender).Tag);
|
||
end;
|
||
|
||
procedure TCalendarLite.InternalClick;
|
||
begin
|
||
case FClickButton of
|
||
mbLeft : FCalDrawer.LeftClick(FClickShift);
|
||
mbRight : FCalDrawer.RightClick;
|
||
end;
|
||
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 FMultiSelect and (ssCtrl in Shift) then
|
||
Date := IncYear(FDate, Delta(Key = VK_NEXT)) else
|
||
Date := IncMonth(FDate, Delta(Key = VK_NEXT));
|
||
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;
|
||
var
|
||
r: TRect;
|
||
begin
|
||
if Assigned(FCalDrawer) then
|
||
begin
|
||
if ParentColor then
|
||
Colors.BackgroundColor := Parent.Color;
|
||
|
||
if ParentFont then
|
||
begin
|
||
if (Parent.Font <> FCalDrawer.FCanvas.Font)
|
||
then FCalDrawer.FCanvas.Font := Parent.Font
|
||
else if (Canvas.Font.Color <> Colors.TextColor)
|
||
then FColors.TextColor := Canvas.Font.Color;
|
||
end;
|
||
|
||
case (BiDiMode = bdLeftToRight) of
|
||
False: if not FCalDrawer.FTStyle.RightToLeft then
|
||
FCalDrawer.FTStyle.RightToLeft := True;
|
||
True : if FCalDrawer.FTStyle.RightToLeft then
|
||
FCalDrawer.FTStyle.RightToLeft := False;
|
||
end;
|
||
|
||
Canvas.Brush.Color:= Colors.BackGroundColor;
|
||
Canvas.FillRect(ClientRect);
|
||
if (coShowBorder in FOptions) then
|
||
begin
|
||
if (Canvas.Pen.Color <> FColors.BorderColor) then
|
||
Canvas.Pen.Color := FColors.BorderColor;
|
||
Canvas.Pen.Style := psSolid;
|
||
Canvas.Frame(ClientRect);
|
||
end;
|
||
|
||
r:= ClientRect;
|
||
if (coShowBorder in FOptions) then InflateRect(r, -1, -1);
|
||
FCalDrawer.FBoundsRect:= r;
|
||
FCalDrawer.Draw;
|
||
end;
|
||
|
||
inherited Paint;
|
||
end;
|
||
|
||
procedure TCalendarLite.PopulateHolidayPopupMenu;
|
||
var
|
||
item: TMenuItem;
|
||
m, d, dayCount: Integer;
|
||
population: integer = 0;
|
||
hols: THolidays = 0;
|
||
dt: TDateTime;
|
||
begin
|
||
with FPopupMenu.Items do begin
|
||
Clear;
|
||
item:= TMenuItem.Create(Self);
|
||
item.Caption:= Format('%s %d', [GetDisplayText(dtHolidaysDuring), 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
|
||
Items[0].Caption := Format('%s %d', [GetDisplayText(dtNoHolidaysDuring), FCalDrawer.FThisYear]);
|
||
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;
|
||
if (FCalDrawer.FThisDay = 29) and (FCalDrawer.FThisMonth = 2) and not IsLeapYear(y)
|
||
then item.Enabled:= False;
|
||
Add(item);
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
function TCalendarLite.SelectedDates: TCalDateArray;
|
||
begin
|
||
Result := FSelDates.AsArray;
|
||
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.SetDate(AValue: TDateTime);
|
||
var
|
||
oldMonth: Integer;
|
||
begin
|
||
if FDate = AValue then Exit;
|
||
oldMonth := MonthOf(FDate);
|
||
FDate := AValue;
|
||
FPrevDate := AValue;
|
||
FSelDates.Clear;
|
||
DateChange;
|
||
if MonthOf(FDate) <> oldMonth then
|
||
MonthChange;
|
||
Invalidate;
|
||
end;
|
||
|
||
procedure TCalendarLite.SetDayNames(const AValue: String);
|
||
begin
|
||
FDayNames.CommaText := AValue;
|
||
Invalidate;
|
||
end;
|
||
|
||
procedure TCalendarLite.SetDefaultDisplayTexts;
|
||
begin
|
||
FDisplayTexts.CommaText := DefaultDisplayText;
|
||
end;
|
||
|
||
procedure TCalendarLite.SetDisplayTexts(AValue: String);
|
||
begin
|
||
FDisplayTexts.CommaText := AValue;
|
||
Invalidate;
|
||
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
|
||
DayNames := EnglishDays;
|
||
MonthNames := EnglishMonths;
|
||
DisplayTexts := DefaultDisplayText;
|
||
BiDiMode:= bdLeftToRight;
|
||
end;
|
||
lgFrench: begin
|
||
DayNames := FrenchDays;
|
||
MonthNames := FrenchMonths;
|
||
DisplayTexts := FrenchTexts;
|
||
BiDiMode:= bdLeftToRight;
|
||
end;
|
||
lgGerman: begin
|
||
DayNames := GermanDays;
|
||
MonthNames := GermanMonths;
|
||
DisplayTexts := GermamTexts;
|
||
BiDiMode:= bdLeftToRight;
|
||
end;
|
||
lgHebrew: begin
|
||
DayNames := HebrewDays;
|
||
MonthNames := HebrewMonths;
|
||
DisplayTexts := HebrewTexts;
|
||
BiDiMode:= bdRightToLeft;
|
||
end;
|
||
lgSpanish: begin
|
||
DayNames := SpanishDays;
|
||
MonthNames := SpanishMonths;
|
||
DisplayTexts := SpanishTexts;
|
||
BiDiMode:= bdLeftToRight;
|
||
end;
|
||
lgItalian: begin
|
||
DayNames := ItalianDays;
|
||
MonthNames := ItalianMonths;
|
||
DisplayTexts := ItalianTexts;
|
||
BiDiMode:= bdLeftToRight;
|
||
end;
|
||
lgPolish: begin
|
||
DayNames := PolishDays;
|
||
MonthNames := PolishMonths;
|
||
DisplayTexts := PolishTexts;
|
||
BiDiMode:= bdLeftToRight;
|
||
end;
|
||
lgFinnish: begin
|
||
DayNames := FinnishDays;
|
||
MonthNames := FinnishMonths;
|
||
DisplayTexts := FinnishTexts;
|
||
BiDiMode := bdLeftToRight;
|
||
end;
|
||
end;
|
||
|
||
Invalidate;
|
||
end;
|
||
|
||
procedure TCalendarLite.SetMonthNames(const AValue: String);
|
||
begin
|
||
FMonthNames.CommaText := AValue;
|
||
Invalidate;
|
||
end;
|
||
|
||
procedure TCalendarLite.SetMultiSelect(AValue: Boolean);
|
||
begin
|
||
if AValue = FMultiSelect then
|
||
exit;
|
||
FMultiSelect := AValue;
|
||
FSelDates.Clear;
|
||
FSelDates.AddDate(FDate);
|
||
FPrevDate := FDate;
|
||
end;
|
||
|
||
procedure TCalendarLite.SetStartingDayOfWeek(AValue: TDayOfWeek);
|
||
begin
|
||
if FStartingDayOfWeek = AValue then Exit;
|
||
FStartingDayOfWeek := AValue;
|
||
Invalidate;
|
||
end;
|
||
|
||
procedure TCalendarLite.SetOptions(AValue: TCalOptions);
|
||
begin
|
||
if FOptions = AValue then Exit;
|
||
FOptions := AValue;
|
||
case (coShowTodayRow in FOptions) of
|
||
False: if LastRow <> LastDateRow then LastRow := LastDateRow;
|
||
True : if LastRow <> TodayRow then LastRow := TodayRow;
|
||
end;
|
||
if Length(FCalDrawer.FRowPositions) <> LastRow+1 then
|
||
SetLength(FCalDrawer.FRowPositions, LastRow+1);
|
||
Invalidate;
|
||
end;
|
||
|
||
procedure TCalendarLite.SetWeekendDays(AValue: TDaysOfWeek);
|
||
begin
|
||
if FWeekendDays = AValue then Exit;
|
||
FWeekendDays := AValue;
|
||
Invalidate;
|
||
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.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
|
||
{$I calendarlite_icon.lrs}
|
||
RegisterComponents('Misc', [TCalendarLite]);
|
||
end;
|
||
|
||
|
||
end.
|