{ 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 Contributions : Ariel Rodriguez, 2013 Werner Pamler, 2013/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, 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; DefaultDisplayText = 'Today is,dd/mm/yyyy,Holidays during,There are no holidays set for'; DefTStyle: TTextStyle = (Alignment : taCenter; Layout : tlCenter; SingleLine : True; Clipping : True; ExpandTabs : False; ShowPrefix : False; Wordbreak : False; Opaque : False; SystemFont : False; RightToLeft: False; EndEllipsis: False); //Ariel Rodriguez 12/09/2013 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,sm'; FrenchMonths = 'janvier,février,mars,avril,mai,juin,juillet,août,septembre,octobre,novembre,décembre'; FrenchTexts = 'Est aujourd''hui,yyyy/mm/dd,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 = 'Son,Mon,Die,Mit,Don,Fre,Sam'; GermamTexts = 'Heute ist,yyyy/mm/dd,Urlaub während,Es gibt keine Feiertage eingestellt für'; SpanishDays = 'Dom,Lun,Mar,Mie,Jue,Vie,Sab'; 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'; //Ariel Rodriguez 12/09/2013 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; TCalOption = (coBoldDayNames, coBoldHolidays, coBoldToday, coBoldTopRow, coBoldWeekend, coDayLine, coShowBorder, coShowHolidays, coShowTodayFrame, coShowTodayName, coShowTodayRow, coShowWeekend, coUseTopRowColors); TCalOptions = set of TCalOption; TLanguage = (lgEnglish, lgFrench, lgGerman, lgHebrew, lgSpanish); //Ariel Rodriguez 12/09/2013 { 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 ChangeDateTo(aCell: TSize); procedure DrawArrow(aRect: TRect; aHead: TArrowhead; aDirn: 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 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; procedure NextMonth; procedure NextYear; procedure PrevMonth; procedure PrevYear; 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(TGraphicControl) private FCalDrawer: TCalDrawer; FColors: TCalColors; FDate: TDateTime; FDayNames: TStringList; FDisplayTexts: TStringList; FMonthNames: TStringList; FOnDateChange: TNotifyEvent; FOnGetHolidays: TGetHolidaysEvent; FOptions: TCalOptions; FPopupMenu: TPopupMenu; FStartingDayOfWeek: TDayOfWeek; FWeekendDays: TDaysOfWeek; FLanguage: TLanguage; //Ariel Rodriguez 12/09/2013 procedure DateChange; function GetDayNames: 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 SetOptions(AValue: TCalOptions); procedure SetStartingDayOfWeek(AValue: TDayOfWeek); procedure SetWeekendDays(AValue: TDaysOfWeek); procedure YearMenuItemClicked(Sender: TObject); procedure SetLanguage(AValue: TLanguage); //Ariel Rodriguez 12/09/2013 protected // procedure CreateHandle; override; class function GetControlClassDefaultSize: TSize; override; function GetDayName(ADayOfWeek: TDayOfWeek): String; function GetDisplayText(aTextIndex: TDisplayText): String; function GetMonthName(AMonth: Integer): String; procedure MouseDown(Button: TMouseButton; Shift:TShiftState; X,Y:Integer); override; procedure Paint; override; public constructor Create(anOwner: TComponent); override; destructor Destroy; override; published property Anchors; property Align; property BiDiMode; property BorderSpacing; property Constraints; property Font; property Hint; property ParentColor; property ParentFont; property ParentShowHint; property ShowHint; property Visible; // new properties property Colors: TCalColors read 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 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; //Ariel Rodriguez 12/09/2013 // new event properties property OnDateChange: TNotifyEvent read FOnDateChange write FOnDateChange; property OnGetHolidays: TGetHolidaysEvent read FOnGetHolidays write FOnGetHolidays; end; procedure ClearHolidays(var AHolidays: THolidays); procedure AddHoliday(ADay: Integer; var AHolidays: THolidays); function IsHoliday(ADay: Integer; AHolidays: THolidays): Boolean; procedure Register; //Ariel Rodriguez 12/09/2013 implementation uses LazUTF8, dateutils, math; { 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; { 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.ChangeDateTo(aCell: TSize); var diff: integer; newDate: TDateTime; d, m, y: word; begin diff := aCell.cx + LastCol * (aCell.cy - 2); newDate:= FStartDate + diff - 1; FOwner.FDate := newDate; FOwner.DateChange; FCanvas.Brush.Color := FOwner.Colors.BackgroundColor; FCanvas.FillRect(FBoundsRect); Self.Draw; DecodeDate(newDate, y, m, d); end; procedure TCalDrawer.Draw; begin if not Assigned(FCanvas) then Exit; DecodeDate(FOwner.FDate, FThisYear, FThisMonth, FThisDay); CalcSettings; DrawTopRow; DrawDayLabels; DrawDayCells; DrawTodayRow; end; procedure TCalDrawer.DrawArrow(aRect: TRect; aHead: TArrowhead; aDirn: TArrowDirection); var sz: TSize; d, ox, oy, half: integer; pts: TArrowPoints; begin 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 aDirn 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 aDirn 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; 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; 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); case (m = FThisMonth) of False: begin FCanvas.Font.Color:= FOwner.Colors.PastMonthColor; FCanvas.Font.Style := []; end; True: begin FCanvas.Font.Color:= FOwner.Colors.TextColor; FCanvas.Font.Style := []; 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 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; end; s := IntToStr(d); if (dt = FOwner.FDate) then begin FCanvas.Brush.Color:= FOwner.FColors.SelectedDateColor; FCanvas.FillRect(rec); end else FCanvas.Brush.Color:= FOwner.Colors.BackgroundColor; FCanvas.TextRect(rec, 0, 0, s, FTStyle); if (dt = todayDate) and (coShowTodayFrame in FOwner.Options) then begin FCanvas.Pen.Color:= FOwner.Colors.TodayFrameColor; FCanvas.Pen.Width:= 2; Inc(rec.Top); Inc(rec.Bottom); FCanvas.Frame(rec); FCanvas.Pen.Width:= 1; end; dt:= dt + 1; end; // for c 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; 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.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.FDate := aDate; FOwner.DateChange; FOwner.Invalidate; 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.FDate := d; FOwner.DateChange; FOwner.Invalidate; end; procedure TCalDrawer.GotoToday; begin FOwner.FDate:= Date(); FOwner.DateChange; FOwner.Invalidate; 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.FDate := d; FOwner.DateChange; FOwner.Invalidate; end; procedure TCalDrawer.LeftClick; var p, ppopup: TPoint; cell: TSize; Rm, Ry: TRect; begin p := FOwner.ScreenToClient(Mouse.CursorPos); cell := GetCellAt(p); case cell.cy of TopRow: case cell.cx of 1: PrevYear; 2: PrevMonth; 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: NextMonth; 7: NextYear; end; DayRow: ; FirstDateRow..LastDateRow : ChangeDateTo(cell); else GotoToday; end; end; procedure TCalDrawer.NextMonth; begin FOwner.FDate := IncMonth(FOwner.FDate, 1); FOwner.DateChange; FOwner.Invalidate; end; procedure TCalDrawer.NextYear; begin FOwner.FDate := IncYear(FOwner.FDate, 1); FOwner.DateChange; FOwner.Invalidate; end; procedure TCalDrawer.PrevMonth; begin FOwner.FDate := IncMonth(FOwner.FDate, -1); FOwner.DateChange; FOwner.Invalidate; end; procedure TCalDrawer.PrevYear; begin FOwner.FDate := IncYear(FOwner.FDate, -1); FOwner.DateChange; FOwner.Invalidate; end; procedure TCalDrawer.RightClick; begin if 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: clSilver; FColors[1] := clSilver; // ArrowColor: clSilver; FColors[2] := clWhite; // BackgroundColor: clWhite; FColors[3] := clSilver; // BorderColor: clSilver; FColors[4] := clSilver; // DaylineColor: clSilver; FColors[5] := clRed; // HolidayColor: clRed; FColors[6] := clSilver; // PastMonthColor: clSilver; FColors[7] := clMoneyGreen; // SelectedDateColor: clMoneyGreen; FColors[8] := clBlack; // TextColor: clBlack; FColors[9] := clGray; // TodayFrameColor: clGray; FColors[10] := clHighlight; // TopRowColor: clHighlight; FColors[11] := clHighlightText; // TopRowTextColor: clHighlightText; FColors[12] := clRed; // WeekendColor: clRed; 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); FColors := TCalColors.Create(self); FDate:= SysUtils.Date; Color:= clWhite; FStartingDayOfWeek:= dowSunday; with GetControlClassDefaultSize do SetInitialBounds(0, 0, cx, cy); Constraints.MinHeight := DefMinHeight; Constraints.MinWidth := DefMinWidth; Canvas.Brush.Style:= bsSolid; 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; FWeekendDays := [dowSunday, dowSaturday]; FOptions := [coShowTodayFrame, coBoldHolidays, coShowWeekend, coShowHolidays, coShowTodayRow]; FLanguage := lgEnglish; //Ariel Rodriguez 12/09/2013 end; destructor TCalendarLite.Destroy; begin FreeAndNil(FDayNames); FreeAndNil(FMonthNames); FreeAndNil(FDisplayTexts); FreeAndNil(FColors); SetLength(FCalDrawer.FRowPositions, 0); FreeAndNil(FCalDrawer); inherited Destroy; end; procedure TCalendarLite.DateChange; begin if Assigned(FOnDateChange) then FOnDateChange(Self); 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.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin inherited MouseDown(Button, Shift, X, Y); case Button of mbLeft : FCalDrawer.LeftClick; mbRight : FCalDrawer.RightClick; 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.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; procedure TCalendarLite.SetDate(AValue: TDateTime); begin if FDate = AValue then Exit; FDate := AValue; DateChange; 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; //Ariel Rodriguez 12/09/2013 procedure TCalendarLite.SetLanguage(AValue : TLanguage); begin if FLanguage = AValue then Exit; 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; end; Invalidate; end; //Ariel Rodriguez 12/09/2013 procedure TCalendarLite.SetMonthNames(const AValue: String); begin FMonthNames.CommaText := AValue; Invalidate; 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; procedure TCalendarLite.YearMenuItemClicked(Sender: TObject); begin FCalDrawer.GotoYear(TMenuItem(Sender).Tag); end; //Ariel Rodriguez 12/09/2013 procedure Register; begin {$I calendarlite_icon.lrs} RegisterComponents('Misc', [TCalendarLite]); end; //Ariel Rodriguez 12/09/2013 end.