paweld/lazarus-ccr
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
371b77567f
lazarus-ccr/components/orpheus/ovccal.pas
wp_xxyyzz 3062cbec03 orpheus: Fix compilation with Laz 1.8/1.9 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@6123 8e941d3f-bd1b-0410-a28a-d453659cc2b4
2018-01-09 19:39:55 +00:00

1803 lines
48 KiB
ObjectPascal
Raw Blame History

{*********************************************************}
{* OVCCAL.PAS 4.06 *}
{*********************************************************}
{* ***** BEGIN LICENSE BLOCK ***** *}
{* Version: MPL 1.1 *}
{* *}
{* The contents of this file are subject to the Mozilla Public License *}
{* Version 1.1 (the "License"); you may not use this file except in *}
{* compliance with the License. You may obtain a copy of the License at *}
{* http://www.mozilla.org/MPL/ *}
{* *}
{* Software distributed under the License is distributed on an "AS IS" basis, *}
{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *}
{* for the specific language governing rights and limitations under the *}
{* License. *}
{* *}
{* The Original Code is TurboPower Orpheus *}
{* *}
{* The Initial Developer of the Original Code is TurboPower Software *}
{* *}
{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *}
{* TurboPower Software Inc. All Rights Reserved. *}
{* *}
{* Contributor(s): *}
{* *}
{* ***** END LICENSE BLOCK ***** *}
{$I OVC.INC}
{$B-} {Complete Boolean Evaluation}
{$I+} {Input/Output-Checking}
{$P+} {Open Parameters}
{$T-} {Typed @ Operator}
{.W-} {Windows Stack Frame}
{$X+} {Extended Syntax}
unit ovccal;
{-Calendar component}
interface
uses
{$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, LclType, MyMisc, FileUtil,{$ENDIF}
Buttons, Classes, Controls, Forms, Graphics, Menus,
SysUtils, OvcBase, OvcConst, OvcData, OvcIntl,
OvcMisc, OvcDate;
type
TOvcDateFormat = (dfShort, dfLong);
TOvcDayNameWidth = 1..3;
TOvcDayType = (dtSunday, dtMonday, dtTuesday, dtWednesday,
dtThursday, dtFriday, dtSaturday);
TOvcCalDisplayOption = (cdoShortNames, cdoShowYear, cdoShowInactive,
cdoShowRevert, cdoShowToday, cdoShowNavBtns,
cdoHideActive);
TOvcCalDisplayOptions = set of TOvcCalDisplayOption;
type
TOvcCalColorArray = array[0..5] of TColor;
TOvcCalColorScheme = (cscalCustom, cscalClassic, cscalWindows,
cscalGold, cscalOcean, cscalRose);
TOvcCalSchemeArray = array[TOvcCalColorScheme] of TOvcCalColorArray;
const
{ActiveDay, DayNames, Days, InactiveDays, MonthAndYear, Weekend}
CalScheme : TOvcCalSchemeArray =
((0, 0, 0, 0, 0, 0),
(clHighlight, clWindow, clWindow, clWindow, clWindow, clWindow),
(clRed, clMaroon, clBlack, clGray, clBlue, clRed),
(clBlack, clBlack, clYellow, clGray, clBlack, clTeal),
(clBlack, clBlack, clAqua, clGray, clBlack, clNavy),
(clRed, clRed, clFuchsia, clGray, clBlue, clTeal)
);
type
TOvcCalColors = class(TPersistent)
{.Z+}
protected {private}
{property variables}
FUpdating : Boolean;
FOnChange : TNotifyEvent;
{internal variables}
SettingScheme : Boolean;
{property methods}
function GetColor(Index : Integer) : TColor;
procedure SetColor(Index : Integer; Value : TColor);
procedure SetColorScheme(Value : TOvcCalColorScheme);
{internal methods}
procedure DoOnChange;
public
{public property variables}
FCalColors : TOvcCalColorArray;
FColorScheme : TOvcCalColorScheme;
procedure Assign(Source : TPersistent);
override;
procedure BeginUpdate;
procedure EndUpdate;
property OnChange : TNotifyEvent
read FOnChange write FOnChange;
{.Z-}
published
property ActiveDay : TColor index 0
read GetColor write SetColor;
property ColorScheme : TOvcCalColorScheme
read FColorScheme write SetColorScheme;
property DayNames : TColor index 1
read GetColor write SetColor;
property Days : TColor index 2
read GetColor write SetColor;
property InactiveDays : TColor index 3
read GetColor write SetColor;
property MonthAndYear : TColor index 4
read GetColor write SetColor;
property Weekend : TColor index 5
read GetColor write SetColor;
end;
type
TDateChangeEvent = procedure(Sender : TObject; Date : TDateTime)
of object;
TCalendarDateEvent =
procedure(Sender : TObject; ADate : TDateTime; const Rect : TRect)
of object;
TGetHighlightEvent =
procedure(Sender : TObject; ADate : TDateTime; var Color : TColor)
of object;
TGetDateEnabledEvent =
procedure(Sender : TObject; ADate : TDateTime; var Enabled : Boolean)
of object;
TOvcCustomCalendar = class(TOvcCustomControl)
{.Z+}
protected {private}
{property variables}
FBorderStyle : TBorderStyle;
FBrowsing : Boolean;
FColors : TOvcCalColors;
FOptions : TOvcCalDisplayOptions;
FDate : TDateTime;
FDay : Integer; {calendar day}
FDateFormat : TOvcDateFormat;
FDayNameWidth : TOvcDayNameWidth;
FDrawHeader : Boolean; {true to draw day name header}
FIntlSup : TOvcIntlSup; {international date/time support}
FMonth : Integer; {calendar month}
FReadOnly : Boolean; {true if in read only mode}
FWantDblClicks : Boolean; {true to include cs_dblclks style}
FWeekStarts : TOvcDayType; {the day that begins the week}
FYear : Integer; {calendar year}
{$IFDEF LCL}
FCtl3D : Boolean;
{$ENDIF}
{event variables}
FOnChange : TDateChangeEvent;
FOnDrawDate : TCalendarDateEvent;
FOnDrawItem : TCalendarDateEvent;
FOnGetDateEnabled: TGetDateEnabledEvent;
FOnGetHighlight : TGetHighlightEvent;
{internal variables}
clBtnLeft : TSpeedButton;
clBtnRevert : TSpeedButton;
clBtnRight : TSpeedButton;
clBtnToday : TSpeedButton;
clInPopup : Boolean;
clBtnNextYear : TSpeedButton;
clBtnPrevYear : TSpeedButton;
clCalendar : array[1..49] of Byte; {current month grid}
clDay : Word;
clFirst : Byte; {index for first day in current month}
clLast : Byte; {index for last day in current month}
clMonth : Word;
clRowCol : array[0..8, 0..6] of TRect; {cell TRect info}
cSettingScheme : Boolean;
clYear : Word;
clWidth : Integer; {client width - margins}
clMask : array[0..MaxDateLen] of AnsiChar; {default date mask}
clPopup : Boolean; {true if being created as a popup}
clRevertDate : TDateTime; {date on entry}
clRowCount : Integer; {7 if no header, otherwise 8}
clStartRow : Integer; {first row number}
{property methods}
function GetAsDateTime : TDateTime;
function GetAsStDate : TStDate;
function GetCalendarDate : TDateTime;
function GetDay : Integer;
function GetMonth : Integer;
function GetYear : Integer;
procedure SetAsDateTime(Value : TDateTime);
procedure SetAsStDate(Value : TStDate);
procedure SetBorderStyle(Value : TBorderStyle);
procedure SetDate(Value : TDateTime);
procedure SetDateFormat(Value : TOvcDateFormat);
procedure SetDayNameWidth(Value : TOvcDayNameWidth);
procedure SetDisplayOptions(Value : TOvcCalDisplayOptions);
procedure SetDrawHeader(Value : Boolean);
procedure SetIntlSupport(Value : TOvcIntlSup);
procedure SetWantDblClicks(Value : Boolean);
procedure SetWeekStarts(Value : TOvcDayType);
{internal methods}
procedure calChangeMonth(Sender : TObject);
procedure calColorChange(Sender : TObject);
function calGetCurrentRectangle : TRect;
{-get bounding rectangle for the current calendar day}
function calGetValidDate(ADate : TDateTime; Delta : Integer) : TDateTime;
procedure calRebuildCalArray;
{-recalculate the contents of the calendar array}
procedure calRecalcSize;
{-calcualte new sizes for rows and columns}
{VCL control methods}
{$IFNDEF LCL}
procedure CMCtl3DChanged(var Msg : TMessage);
message CM_CTL3DCHANGED;
{$ENDIF}
procedure CMEnter(var Msg : TMessage);
message {$IFNDEF LCL} CM_ENTER; {$ELSE} LM_SETFOCUS; {$ENDIF}
//CM_ messages not supported in LCL, so use something similar
// so clRevertDate is initialized properly.
procedure CMExit(var Msg : TMessage);
message CM_EXIT;
procedure CMFontChanged(var Msg : TMessage);
message CM_FONTCHANGED;
{windows message methods}
procedure WMEraseBkgnd(var Msg : TWMEraseBkgnd);
message WM_ERASEBKGND;
procedure WMGetDlgCode(var Msg : TWMGetDlgCode);
message WM_GETDLGCODE;
procedure WMKillFocus(var Msg : TWMKillFocus);
message WM_KILLFOCUS;
protected
procedure calBtnClick(Sender : TObject);
procedure CreateParams(var Params : TCreateParams);
override;
procedure CreateWnd;
override;
procedure DoOnChange(Value : TDateTime);
dynamic;
function DoOnGetDateEnabled(ADate : TDateTime) : Boolean;
dynamic;
procedure DoOnMouseWheel(Shift : TShiftState; Delta, XPos, YPos : SmallInt);
override;
function IsReadOnly : Boolean;
dynamic;
{-return true if the calendar is in read-only mode}
procedure KeyDown(var Key : Word; Shift : TShiftState);
override;
procedure KeyPress(var Key : Char);
override;
procedure MouseDown(Button : TMouseButton; Shift : TShiftState; X, Y : Integer);
override;
procedure MouseUp(Button : TMouseButton; Shift : TShiftState; X, Y : Integer);
override;
procedure Paint;
override;
{virtual property methods}
procedure SetCalendarDate(Value : TDateTime);
virtual;
public
constructor Create(AOwner : TComponent);
override;
constructor CreateEx(AOwner : TComponent; AsPopup : Boolean);
virtual;
destructor Destroy;
override;
procedure SetBounds(ALeft, ATop, AWidth, AHeight : Integer);
override;
{.Z-}
function DateString(const Mask : string): string;
function DayString : string;
procedure IncDay(Delta : Integer);
procedure IncMonth(Delta : Integer);
procedure IncYear(Delta : Integer);
function MonthString : string;
procedure SetToday;
property AsDateTime : TDateTime
read GetAsDateTime write SetAsDateTime;
property AsStDate : TStDate
read GetAsStDate write SetAsStDate;
property Browsing : Boolean
read FBrowsing;
property Canvas;
property Day : Integer
read GetDay;
property Month : Integer
read GetMonth;
property Year : Integer
read GetYear;
{$IFDEF LCL}
property Ctl3D : Boolean read FCtl3D write FCtl3D default True;
{$ENDIF}
{properties}
property BorderStyle : TBorderStyle
read FBorderStyle write SetBorderStyle;
property CalendarDate : TDateTime
read GetCalendarDate write SetCalendarDate;
property Colors : TOvcCalColors
read FColors write FColors;
property Date : TDateTime
read FDate write SetDate;
property DateFormat : TOvcDateFormat
read FDateFormat write SetDateFormat;
property DayNameWidth : TOvcDayNameWidth
read FDayNameWidth write SetDayNameWidth;
property DrawHeader : Boolean
read FDrawHeader write SetDrawHeader;
property IntlSupport : TOvcIntlSup
read FIntlSup write SetIntlSupport;
property Options : TOvcCalDisplayOptions
read FOptions write SetDisplayOptions;
property ReadOnly : Boolean
read FReadOnly write FReadOnly;
property WantDblClicks : Boolean
read FWantDblClicks write SetWantDblClicks;
property WeekStarts : TOvcDayType
read FWeekStarts write SetWeekStarts;
{events}
property OnChange : TDateChangeEvent
read FOnChange write FOnChange;
property OnDrawDate : TCalendarDateEvent
read FOnDrawDate write FOnDrawDate;
property OnDrawItem : TCalendarDateEvent
read FOnDrawItem write FOnDrawItem;
property OnGetDateEnabled : TGetDateEnabledEvent
read FOnGetDateEnabled write FOnGetDateEnabled;
property OnGetHighlight : TGetHighlightEvent
read FOnGetHighlight write FOnGetHighlight;
end;
TOvcCalendar = class(TOvcCustomCalendar)
published
{properties}
{$IFDEF VERSION4}
property Anchors;
property Constraints;
property DragKind;
{$ENDIF}
property About;
property Align;
property BorderStyle;
property Colors;
property Color;
property Ctl3D;
property Cursor;
property DateFormat default dfLong;
property DayNameWidth;
property DragCursor;
property DragMode;
property Enabled;
property Font;
property LabelInfo;
property Options;
{$IFNDEF LCL}
property ParentCtl3D;
{$ENDIF}
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ReadOnly default False;
property ShowHint;
property TabOrder;
property TabStop default True;
property Visible;
property WantDblClicks default True;
property WeekStarts default dtSunday;
{events}
property AfterEnter;
property AfterExit;
property OnChange;
property OnClick;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnDrawDate;
property OnDrawItem;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnGetDateEnabled;
property OnGetHighlight;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnStartDrag;
end;
implementation
{$IFDEF LCL}
uses
LazUTF8;
{$ENDIF}
const
calMargin = 4; {left, right, and top margin}
{*** TOvcCalColors ***}
procedure TOvcCalColors.Assign(Source : TPersistent);
begin
if Source is TOvcCalColors then begin
FCalColors := TOvcCalColors(Source).FCalColors;
FColorScheme := TOvcCalColors(Source).FColorScheme;
FOnChange := TOvcCalColors(Source).FOnChange;
end else
inherited Assign(Source);
end;
procedure TOvcCalColors.BeginUpdate;
begin
FUpdating := True;
end;
procedure TOvcCalColors.EndUpdate;
begin
FUpdating := False;
DoOnChange;
end;
procedure TOvcCalColors.DoOnChange;
begin
if not FUpdating and Assigned(FOnChange) then
FOnChange(Self);
if not SettingScheme then
FColorScheme := cscalCustom;
end;
function TOvcCalColors.GetColor(Index : Integer) : TColor;
begin
Result := FCalColors[Index];
end;
procedure TOvcCalColors.SetColor(Index : Integer; Value : TColor);
begin
if Value <> FCalColors[Index] then begin
FCalColors[Index] := Value;
DoOnChange;
end;
end;
procedure TOvcCalColors.SetColorScheme(Value : TOvcCalColorScheme);
begin
if Value <> FColorScheme then begin
SettingScheme := True;
try
FColorScheme := Value;
if Value <> cscalCustom then begin
FCalColors := CalScheme[Value];
DoOnChange;
end;
finally
SettingScheme := False;
end;
end;
end;
{*** TOvcCustomCalendar ***}
procedure TOvcCustomCalendar.calBtnClick(Sender : TObject);
var
Key : Word;
begin
SetFocus;
Key := 0;
if Sender = clBtnLeft then begin
Key := VK_PRIOR;
KeyDown(Key, []);
end else if Sender = clBtnRevert then begin
Key := VK_ESCAPE;
KeyDown(Key, []);
end else if Sender = clBtnRight then begin
Key := VK_NEXT;
KeyDown(Key, []);
end else if Sender = clBtnToday then begin
Key := VK_BACK;
KeyDown(Key, [ssAlt]);
end else if Sender = clBtnNextYear then begin
Key := VK_NEXT;
KeyDown(Key, [ssCtrl]);
end else if Sender = clBtnPrevYear then begin
Key := VK_PRIOR;
KeyDown(Key, [ssCtrl]);
end;
end;
procedure TOvcCustomCalendar.calChangeMonth(Sender : TObject);
var
Y, M, D : Word;
MO : Integer;
MI : TMenuItem;
begin
MI := (Sender as TMenuItem);
DecodeDate(FDate, Y, M, D);
MO := MI.Tag;
{set month and year}
if (MO > M) and (MI.HelpContext < 3) then
Dec(Y)
else if (MO < M) and (MI.HelpContext > 3) then
Inc(Y);
M := M + MO;
{set day}
if D > DaysInMonth(MO, Y, 0) then
D := DaysInMonth(MO, Y, 0);
SetDate(calGetValidDate(EncodeDate(Y, MO, D)-1, +1));
if (Assigned(FOnChange)) then
FOnChange(Self, FDate);
end;
procedure TOvcCustomCalendar.calColorChange(Sender : TObject);
begin
Invalidate;
end;
function TOvcCustomCalendar.calGetCurrentRectangle : TRect;
{-get bounding rectangle for the current date}
var
Idx : Integer;
R, C : Integer;
begin
{index into the month grid}
Idx := clFirst + Pred(clDay) + 13;
R := (Idx div 7);
C := (Idx mod 7);
Result := clRowCol[R,C];
end;
{added}
{Modified July 9, 2001}
function TOvcCustomCalendar.calGetValidDate(ADate : TDateTime;
Delta : Integer) : TDateTime;
var
I, X : Integer;
Valid: Boolean;
Fwd: Boolean;
begin
Valid := false;
Fwd := false;
X := Delta;
I := 1;
while not Valid and (I < 1000) do begin
{If the date is valid then yay!}
if (DoOnGetDateEnabled(ADate + (X * I))) then begin
Valid := true;
Fwd := True;
end
{otherwise check the other direction}
else if (DoOnGetDateEnabled(ADate - (X * I))) then begin
valid := true;
end
else Inc(I);
end;
if Valid then
if Fwd then Result := ADate + (X * I)
else Result := ADate - (X * I)
else
raise(Exception.Create(GetOrphStr(SCInvalidDate)));
end;
procedure TOvcCustomCalendar.calRebuildCalArray;
var
Day1 : TOvcDayType;
I, J : Integer;
begin
HandleNeeded;
DecodeDate(FDate, clYear, clMonth, clDay);
{get the first day of the current month and year}
Day1 := TOvcDayType(SysUtils.DayOfWeek(EncodeDate(clYear, clMonth, 1)) -1);
{find its index}
I := Byte(Day1) - Byte(WeekStarts) + 1;
if I < 1 then
Inc(I, 7);
clFirst := I;
{find the index of the last day in the month}
clLast := clFirst + DaysInMonth(clMonth, clYear, 0) - 1;
{initialize the first part of the calendar}
if clMonth = 1 then
J := DaysInMonth(12, clYear-1, 0)
else
J := DaysInMonth(clMonth-1, clYear, 0);
for I := clFirst-1 downto 1 do begin
clCalendar[I] := J;
Dec(J);
end;
{initialize the rest of the calendar}
J := 1;
for I := clFirst to 49 do begin
clCalendar[I] := J;
if I = clLast then
J := 1
else
Inc(J);
end;
end;
procedure TOvcCustomCalendar.calRecalcSize;
{-calcualte new sizes for rows and columns}
var
R : Integer;
C : Integer;
D1 : Integer;
D2 : Integer;
CH : Integer;
RH : Integer;
Row : array[0..8] of Integer;
Col : array[0..6] of Integer;
function SumOf(const A : array of Integer; First, Last : Integer) : Integer;
var
I : Integer;
begin
Result := 0;
for I := First to Last do
Result := Result + A[I];
end;
begin
if not HandleAllocated then
Exit;
{clear row/col position structure}
FillChar(clRowCol, SizeOf(clRowCol), #0);
{set the way the buttons should look}
clBtnLeft.Flat := not Ctl3D and not clPopup;
clBtnRevert.Flat := not Ctl3D and not clPopup;
clBtnRight.Flat := not Ctl3D and not clPopup;
clBtnToday.Flat := not Ctl3D and not clPopup;
clBtnNextYear.Flat := not Ctl3D and not clPopup;
clBtnPrevYear.Flat := not Ctl3D and not clPopup;
clBtnRevert.Visible := cdoShowRevert in FOptions;
clBtnToday.Visible := cdoShowToday in FOptions;
clBtnLeft.Visible := (cdoShowNavBtns in FOptions);
clBtnRight.Visible := (cdoShowNavBtns in FOptions);
clBtnNextYear.Visible := (cdoShowNavBtns in FOptions);
clBtnPrevYear.Visible := (cdoShowNavBtns in FOptions);
clWidth := ClientWidth - 2*calMargin;
{store row and column sizes}
for C := 0 to 6 do
Col[C] := clWidth div 7;
Canvas.Font := Font;
(*
Row[0] := Round(1.3 * Canvas.TextHeight('Yy')); {button and date row}
Row[1] := Round(1.5 * Canvas.TextHeight('Yy'));; {day name row}
*)
if (DrawHeader) then begin
{button and date row}
Row[0] := Round(1.4 * Canvas.TextHeight('Yy'));
{day name row}
Row[1] := Round(1.5 * Canvas.TextHeight('Yy'))
end else begin
{button and date row}
Row[0] := Round(1.3 * Canvas.TextHeight('Yy'));
{day name row}
Row[1] := 0;
end;
CH := ClientHeight - 2*calMargin - Row[0] - Row[1];
RH := CH div 7;
for R := 2 to 8 do
Row[R] := RH;
{distribute any odd horizontal space equally among the columns}
for C := 0 to clWidth mod 7 do
Inc(Col[C]);
{distribute odd vertical space to top 2 rows}
D1 := 0;
for R := 0 to 8 do
D1 := D1 + Row[R];
D1 := ClientHeight - D1 - 2*calMargin;
D2 := D1 div 2;
D1 := D1 - D2;
Row[0] := Row[0] + D1;
if (DrawHeader) then
Row[1] := Row[1] + D2;
{initialize each cells TRect structure using}
{the row heights from the Row[] array and the}
{column widths from the Col[] array}
for R := clStartRow to 7 do begin
for C := 0 to 6 do begin
clRowCol[R, C].Left := SumOf(Col, 0, C-1) + calMargin;
clRowCol[R, C].Right := SumOf(Col, 0, C) + calMargin;
clRowCol[R, C].Top := SumOf(Row, 0, R-1) + calMargin;
clRowCol[R, C].Bottom := SumOf(Row, 0, R) + calMargin;
end;
end;
{position and size the left and right month buttons}
{position and size the next and prev year buttons}
clBtnNextYear.Height := Row[0] - calMargin;
clBtnNextYear.Width := Col[1] - calMargin;
if clBtnNextYear.Width < clBtnNextYear.Glyph.Width + 3 then
clBtnNextYear.Width := clBtnNextYear.Glyph.Width + 3;
clBtnNextYear.Top := calMargin;
clBtnNextYear.Left := ClientWidth - calMargin - clBtnNextYear.Width;
clBtnPrevYear.Height := Row[0] - calMargin;
clBtnPrevYear.Width := Col[5] - calMargin;
if clBtnPrevYear.Width < clBtnPrevYear.Glyph.Width + 3 then
clBtnPrevYear.Width := clBtnPrevYear.Glyph.Width + 3;
clBtnPrevYear.Top := calMargin;
clBtnPrevYear.Left := calMargin;
clBtnLeft.Height := Row[0] - calMargin;
clBtnLeft.Width := Col[0] - calMargin;
if clBtnLeft.Width < clBtnLeft.Glyph.Width + 3 then
clBtnLeft.Width := clBtnLeft.Glyph.Width + 3;
clBtnLeft.Top := calMargin;
clBtnLeft.Left := clBtnPrevYear.Left + clBtnPrevYear.Width;
clBtnRight.Height := Row[0] - calMargin;
clBtnRight.Width := Col[6] - calMargin;
if clBtnRight.Width < clBtnRight.Glyph.Width + 3 then
clBtnRight.Width := clBtnRight.Glyph.Width + 3;
clBtnRight.Top := calMargin;
clBtnRight.Left := clBtnNextYear.Left - clBtnRight.Width;
{position and size "today" button}
clBtnToday.Height := Row[8];
clBtnToday.Width := Col[5] + Col[6] - calMargin;
clBtnToday.Top := ClientHeight - calMargin - clBtnToday.Height + 1;
clBtnToday.Left := ClientWidth - calMargin - clBtnToday.Width;
{position and size "revert" button}
clBtnRevert.Height := Row[8];
clBtnRevert.Width := Col[5] + Col[6] - calMargin;
clBtnRevert.Top := ClientHeight - calMargin - clBtnRevert.Height + 1;
clBtnRevert.Left := clBtnToday.Left - clBtnRevert.Width - calMargin;
end;
{$IFNDEF LCL}
procedure TOvcCustomCalendar.CMCtl3DChanged(var Msg : TMessage);
begin
inherited;
if (csLoading in ComponentState) or not HandleAllocated then
Exit;
if NewStyleControls and (FBorderStyle = bsSingle) then
{$IFNDEF LCL}
RecreateWnd;
{$ELSE}
MyMisc.RecreateWnd(Self);
{$ENDIF}
calReCalcSize;
Invalidate;
end;
{$ENDIF}
procedure TOvcCustomCalendar.CMEnter(var Msg : TMessage);
var
R : TRect;
begin
inherited;
clRevertDate := FDate;
{invalidate the active date to ensure that the focus rect is painted}
R := calGetCurrentRectangle;
InvalidateRect(Handle, @R, False);
end;
procedure TOvcCustomCalendar.CMExit(var Msg : TMessage);
var
R : TRect;
begin
inherited;
{invalidate the active date to ensure that the focus rect is painted}
R := calGetCurrentRectangle;
InvalidateRect(Handle, @R, False);
end;
procedure TOvcCustomCalendar.CMFontChanged(var Msg : TMessage);
begin
inherited;
if csLoading in ComponentState then
Exit;
calRecalcSize;
Invalidate;
end;
constructor TOvcCustomCalendar.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
ControlStyle := ControlStyle + [csClickEvents, csFramed] - [csCaptureMouse];
Height := 140;
TabStop := True;
Width := 200;
{$IFDEF MSWINDOWS}
Font.Name := 'MS Sans Serif';
Font.Size := 8;
{$ELSE} //Size 8 doesn't convert in LCL to Height -11 as it should.
Font.Name := 'Arial';
Font.Height := -11;
{$ENDIF}
{$IFDEF LCL}
FCtl3D := True;
{$ENDIF}
FBorderStyle := bsNone;
FDayNameWidth := 3;
FDateFormat := dfLong;
FOptions := [cdoShortNames, cdoShowYear, cdoShowInactive,
cdoShowRevert, cdoShowToday, cdoShowNavBtns];
FWantDblClicks := True;
FWeekStarts := dtSunday;
{create navigation buttons}
clBtnLeft := TSpeedButton.Create(Self);
clBtnLeft.Parent := Self;
{$IFNDEF LCL}
clBtnLeft.Glyph.Handle := LoadBaseBitmap('ORLEFTARROW');
{$ELSE}
clBtnLeft.Glyph.LoadFromLazarusResource('ORLEFTARROW');
{$ENDIF}
clBtnLeft.OnClick := calBtnClick;
clBtnRight := TSpeedButton.Create(Self);
clBtnRight.Parent := Self;
{$IFNDEF LCL}
clBtnRight.Glyph.Handle := LoadBaseBitmap('ORRIGHTARROW');
{$ELSE}
clBtnRight.Glyph.LoadFromLazarusResource('ORRIGHTARROW');
{$ENDIF}
clBtnRight.OnClick := calBtnClick;
clBtnNextYear := TSpeedButton.Create(Self);
clBtnNextYear.Parent := Self;
{$IFNDEF LCL}
clBtnNextYear.Glyph.Handle := LoadBaseBitmap('ORRIGHTARROWS');
{$ELSE}
clBtnNextYear.Glyph.LoadFromLazarusResource('ORRIGHTARROWS');
{$ENDIF}
clBtnNextYear.OnClick := calBtnClick;
clBtnPrevYear := TSpeedButton.Create(Self);
clBtnPrevYear.Parent := Self;
{$IFNDEF LCL}
clBtnPrevYear.Glyph.Handle := LoadBaseBitmap('ORLEFTARROWS');
{$ELSE}
clBtnPrevYear.Glyph.LoadFromLazarusResource('ORLEFTARROWS');
{$ENDIF}
clBtnPrevYear.OnClick := calBtnClick;
{create "revert" button}
clBtnRevert := TSpeedButton.Create(Self);
clBtnRevert.Parent := Self;
{$IFNDEF LCL}
clBtnRevert.Glyph.Handle := LoadBaseBitmap('ORREVERT');
{$ELSE}
clBtnRevert.Glyph.LoadFromLazarusResource('ORREVERT');
{$ENDIF}
clBtnRevert.OnClick := calBtnClick;
{create "today" button}
clBtnToday := TSpeedButton.Create(Self);
clBtnToday.Parent := Self;
{$IFNDEF LCL}
clBtnToday.Glyph.Handle := LoadBaseBitmap('ORTODAY');
{$ELSE}
clBtnToday.Glyph.LoadFromLazarusResource('ORTODAY');
{$ENDIF}
clBtnToday.OnClick := calBtnClick;
{assign default color scheme}
FColors := TOvcCalColors.Create;
FColors.OnChange := calColorChange;
FColors.FCalColors := CalScheme[cscalWindows];
{assign default international support object}
FIntlSup := OvcIntlSup;
FDrawHeader:= True;
clRowCount := 8;
clStartRow := 0;
end;
constructor TOvcCustomCalendar.CreateEx(AOwner : TComponent; AsPopup : Boolean);
begin
clPopup := AsPopup;
Create(AOwner);
end;
procedure TOvcCustomCalendar.CreateParams(var Params : TCreateParams);
const
BorderStyles : array[TBorderStyle] of LongInt = (0, WS_BORDER);
begin
inherited CreateParams(Params);
with Params do begin
Style := LongInt(Style) or BorderStyles[FBorderStyle];
if clPopup then begin
Style := WS_POPUP or WS_BORDER;
WindowClass.Style := WindowClass.Style or CS_SAVEBITS;
end;
end;
if NewStyleControls and (Ctl3D or clPopup) and (FBorderStyle = bsSingle) then begin
if not clPopup then
Params.Style := Params.Style and not WS_BORDER;
Params.ExStyle := Params.ExStyle or WS_EX_CLIENTEDGE;
end;
{$IFDEF LCL}
inherited SetBorderStyle(FBorderStyle);
{$ENDIF}
{set style to reflect desire for double clicks}
if FWantDblClicks then
ControlStyle := ControlStyle + [csDoubleClicks]
else
ControlStyle := ControlStyle - [csDoubleClicks];
{get windows date mask}
FIntlSup.InternationalLongDatePChar(clMask, cdoShortNames in FOptions, False);
end;
procedure TOvcCustomCalendar.CreateWnd;
begin
inherited CreateWnd;
calRecalcSize;
{if not set, get current date}
if FDate = 0 then
SetDate(calGetValidDate(SysUtils.Date-1, +1));
end;
destructor TOvcCustomCalendar.Destroy;
begin
FColors.Free;
FColors := nil;
inherited Destroy;
end;
function TOvcCustomCalendar.DateString(const Mask : string): string;
var
M : string;
begin
M := Mask;
if Length(M) = 0 then
M := StrPas(clMask);
{convert calendar month and year to a string}
Result := FIntlSup.DateToDateString(M, DateTimeToStDate(FDate), True);
end;
function TOvcCustomCalendar.DayString: string;
begin
Result := IntlSupport.DayOfWeekToString(DayOfWeek(DateTimeToStDate(FDate)));
end;
procedure TOvcCustomCalendar.DoOnChange(Value : TDateTime);
begin
if Assigned(FOnChange) then
FOnChange(Self, Value);
end;
function TOvcCustomCalendar.DoOnGetDateEnabled(ADate : TDateTime) : Boolean;
begin
Result := True;
if Assigned(FOnGetDateEnabled) then
FOnGetDateEnabled(Self, ADate, Result);
end;
procedure TOvcCustomCalendar.DoOnMouseWheel(Shift : TShiftState; Delta, XPos, YPos : SmallInt);
var
Key : Word;
begin
inherited DoOnMouseWheel(Shift, Delta, XPos, YPos);
if Abs(Delta) = WHEEL_DELTA then begin
{inc/dec month}
if Delta < 0 then
Key := VK_NEXT
else
Key := VK_PRIOR;
KeyDown(Key, []);
end else if Abs(Delta) > WHEEL_DELTA then begin
{inc/dec year}
if Delta < 0 then
Key := VK_NEXT
else
Key := VK_PRIOR;
KeyDown(Key, [ssCtrl]);
end else if Abs(Delta) < WHEEL_DELTA then begin
{inc/dec Week}
if Delta < 0 then
Key := VK_DOWN
else
Key := VK_UP;
KeyDown(Key, []);
end;
end;
function TOvcCustomCalendar.GetAsDateTime : TDateTime;
begin
Result := FDate;
end;
function TOvcCustomCalendar.GetAsStDate : TStDate;
begin
Result := DateTimeToStDate(FDate)
end;
function TOvcCustomCalendar.IsReadOnly : Boolean;
begin
Result := ReadOnly;
end;
{revised}
procedure TOvcCustomCalendar.KeyDown(var Key : Word; Shift : TShiftState);
var
Y : Word;
M : Word;
D : Word;
HD : TDateTime;
begin
inherited KeyDown(Key, Shift);
if IsReadOnly then
Exit;
HD := FDate;
case Key of
VK_LEFT : if Shift = [] then
SetDate(calGetValidDate(FDate, -1));
VK_RIGHT : if Shift = [] then
SetDate(calGetValidDate(FDate, +1));
VK_UP : if Shift = [] then
SetDate(calGetValidDate(FDate, -7));
VK_DOWN : if Shift = [] then
SetDate(calGetValidDate(FDate, +7));
VK_HOME :
begin
if ssCtrl in Shift then begin
DecodeDate(FDate, Y, M, D);
SetDate(calGetValidDate(EncodeDate(Y, 1, 1)-1, +1));
end else if Shift = [] then begin
DecodeDate(FDate, Y, M, D);
SetDate(calGetValidDate(EncodeDate(Y, M, 1)-1, +1));
end;
end;
VK_END :
begin
if ssCtrl in Shift then begin
DecodeDate(FDate, Y, M, D);
SetDate(calGetValidDate(EncodeDate(Y, 12, DaysInMonth(12, Y, 0))+1, -1));
end else if Shift = [] then begin
DecodeDate(FDate, Y, M, D);
SetDate(calGetValidDate(EncodeDate(Y, M, DaysInMonth(M, Y, 0))+1, -1));
end;
end;
VK_PRIOR :
begin
if ssCtrl in Shift then begin
IncYear(-1);
end else if Shift = [] then begin
IncMonth(-1);
end;
end;
VK_NEXT :
begin
if ssCtrl in Shift then begin
IncYear(1);
end else if Shift = [] then begin
IncMonth(1);
end;
end;
VK_BACK :
begin
if ssAlt in Shift then
SetDate(calGetValidDate(SysUtils.Date-1, +1));
end;
VK_ESCAPE:
begin
if Shift = [] then
SetDate(calGetValidDate(clRevertDate-1, +1));
end;
end;
if HD <> FDate then begin
FBrowsing := True;
try
DoOnChange(FDate);
finally
FBrowsing := False;
end;
end;
end;
procedure TOvcCustomCalendar.KeyPress(var Key : Char);
begin
inherited KeyPress(Key);
if IsReadOnly then
Exit;
case Key of
'+' : SetDate(calGetValidDate(FDate, +1));
'-' : SetDate(calGetValidDate(FDate, -1));
#13 : DoOnChange(FDate); {date selected}
#32 : DoOnChange(FDate); {date selected}
^Z : SetDate(calGetValidDate(SysUtils.Date-1, +1));
end;
end;
procedure TOvcCustomCalendar.MouseDown(Button : TMouseButton; Shift : TShiftState; X, Y : Integer);
var
Yr : Word;
M : Word;
D : Word;
Yr2 : Word;
M2 : Word;
D2 : Word;
R, C : Integer;
OldIdx : Integer;
NewIdx : Integer;
Re : TRect;
Ignore : Boolean;
begin
{exit if this click happens when the popup menu is active}
if clInPopup then
Exit;
SetFocus;
inherited MouseDown(Button, Shift, X, Y);
if IsReadOnly then
Exit;
{if we have the mouse captured, see if a button was clicked}
if GetCapture = Handle then begin
if (cdoShowNavBtns in Options) then begin
Re := clBtnLeft.ClientRect;
Re.TopLeft := ScreenToClient(clBtnLeft.ClientToScreen(Re.TopLeft));
Re.BottomRight := ScreenToClient(clBtnLeft.ClientToScreen(Re.BottomRight));
if PtInRect(Re, Point(X, Y)) then begin
clBtnLeft.Click;
Exit;
end;
Re := clBtnRight.ClientRect;
Re.TopLeft := ScreenToClient(clBtnRight.ClientToScreen(Re.TopLeft));
Re.BottomRight := ScreenToClient(clBtnRight.ClientToScreen(Re.BottomRight));
if PtInRect(Re, Point(X, Y)) then begin
clBtnRight.Click;
Exit;
end;
Re := clBtnNextYear.ClientRect;
Re.TopLeft := ScreenToClient(clBtnNextYear.ClientToScreen(Re.TopLeft));
Re.BottomRight := ScreenToClient(clBtnNextYear.ClientToScreen(Re.BottomRight));
if PtInRect(Re, Point(X, Y)) then begin
clBtnNextYear.Click;
Exit;
end;
Re := clBtnPrevYear.ClientRect;
Re.TopLeft := ScreenToClient(clBtnPrevYear.ClientToScreen(Re.TopLeft));
Re.BottomRight := ScreenToClient(clBtnPrevYear.ClientToScreen(Re.BottomRight));
if PtInRect(Re, Point(X, Y)) then begin
clBtnPrevYear.Click;
Exit;
end;
end;
if (cdoShowRevert in Options) then begin
Re := clBtnRevert.ClientRect;
Re.TopLeft := ScreenToClient(clBtnRevert.ClientToScreen(Re.TopLeft));
Re.BottomRight := ScreenToClient(clBtnRevert.ClientToScreen(Re.BottomRight));
if PtInRect(Re, Point(X, Y)) then begin
clBtnRevert.Click;
Exit;
end;
end;
if (cdoShowToday in Options) then begin
Re := clBtnToday.ClientRect;
Re.TopLeft := ScreenToClient(clBtnToday.ClientToScreen(Re.TopLeft));
Re.BottomRight := ScreenToClient(clBtnToday.ClientToScreen(Re.BottomRight));
if PtInRect(Re, Point(X, Y)) then begin
clBtnToday.Click;
Exit;
end;
end;
end;
{save current date}
DecodeDate(FDate, Yr, M, D);
M2 := M;
{calculate the row and column clicked on}
for R := 2 to 8 do begin
for C := 0 to 6 do begin
if PtInRect(clRowCol[R,C], Point(X, Y)) then begin
{convert to an index}
NewIdx := ((R-2) * 7) + Succ(C);
OldIdx := clFirst + Pred(clDay);
Ignore := False;
if NewIdx <> OldIdx then begin
{see if this date is disabled - selection not allowed}
if not DoOnGetDateEnabled(FDate+(NewIdx-OldIdx)) then
Break;
DecodeDate(FDate+(NewIdx-OldIdx), Yr2, M2, D2);
if not (cdoShowInactive in FOptions) then begin
{will this change the month?}
if M2 <> M then
Ignore := True;
end;
{convert to a date and redraw}
if not Ignore then
SetDate(FDate+(NewIdx-OldIdx));
end;
if (not Ignore) and (Button = mbLeft) then begin
if M2 <> M then begin
FBrowsing := True;
try
DoOnChange(FDate);
finally
FBrowsing := False;
end;
end else
DoOnChange(FDate);
end;
Break;
end;
end;
end;
end;
procedure TOvcCustomCalendar.MouseUp(Button : TMouseButton; Shift : TShiftState; X, Y : Integer);
var
P : TPoint;
M : TPopUpMenu;
MI : TMenuItem;
I : Integer;
J : Integer;
K : Integer;
MO : Integer;
YR : Word;
MM : Word;
DA : Word;
HC : Boolean;
begin
inherited MouseUp(Button, Shift, X, Y);
if (PopUpMenu = nil) and (Button = mbRight) and
(Y < clRowCol[1,0].Top) {above day names} and
(X > clBtnPrevYear.Left + clBtnNextYear.Width) and
(X < clBtnNextYear.Left) then begin
if not Focused and CanFocus then
SetFocus;
M := TPopupMenu.Create(Self);
try
DecodeDate(FDate, YR, MM, DA);
MO := MM; {convert to integer to avoid wrap-around errors with words}
{determine the starting month}
I := MO - 3;
if I < 1 then
I := MO - 3 + 12;
{determine the ending month + 1}
J := MO + 4;
if J > 12 then
J := MO + 4 - 12;
K := 0;
{create the menu items}
repeat
MI := TMenuItem.Create(M);
MI.Caption := LongMonthNames[I];
MI.Enabled := Enabled;
MI.OnClick := calChangeMonth;
MI.Tag := I;
MI.HelpContext := K;
M.Items.Add(MI);
Inc(I);
Inc(K);
if I > 12 then
I := 1;
until I = J;
HC := GetCapture = Handle;
P.X := X-20;
P.Y := Y - ((GetSystemMetrics(SM_CYMENU)*7) div 2);
P := ClientToScreen(P);
{move the mouse to cause the menu item to highlight}
PostMessage(Handle, WM_MOUSEMOVE, 0, MAKELONG(P.X,P.Y+1));
clInPopup := True;
try
M.PopUp(P.X, P.Y);
Application.ProcessMessages;
{capture the mouse again}
if clPopup and HC then
SetCapture(Handle);
finally
clInPopup := false;
end;
finally
M.Free;
end;
end;
end;
procedure TOvcCustomCalendar.IncDay(Delta : Integer);
{-change the day by Delta (signed) days}
begin
if Delta > 0 then
SetDate(calGetValidDate(FDate+Delta-1, +1))
else
SetDate(calGetValidDate(FDate+Delta+1, -1))
end;
procedure TOvcCustomCalendar.IncMonth(Delta : Integer);
{-change the month by Delta (signed) months}
var
Y, M, D : Word;
iY, iM, iD : Integer;
begin
DecodeDate(FDate, Y, M, D);
iY := Y; iM := M; iD := D;
Inc(iM, Delta);
if iM > 12 then begin
iM := iM - 12;
Inc(iY);
end else if iM < 1 then begin
iM := iM + 12;
Dec(iY);
end;
if iD > DaysInMonth(iM, iY, 0) then
iD := DaysInMonth(iM, iY, 0);
SetDate(calGetValidDate(EncodeDate(iY, iM, iD)-1, +1));
end;
procedure TOvcCustomCalendar.IncYear(Delta : Integer);
var
Y, M, D : Word;
iY, iM, iD : Integer;
begin
DecodeDate(FDate, Y, M, D);
iY := Y; iM := M; iD := D;
Inc(iY, Delta);
if iD > DaysInMonth(iM, iY, 0) then
iD := DaysInMonth(iM, iY, 0);
SetDate(calGetValidDate(EncodeDate(iY, iM, iD)-1, +1));
end;
function TOvcCustomCalendar.MonthString: string;
var
M, D, Y : Word;
begin
DecodeDate(FDate, Y, M, D);
Result := IntlSupport.MonthToString(M);
end;
procedure TOvcCustomCalendar.Paint;
var
R, C : Integer;
I : Integer;
{CurIndex : Integer;}
SatCol : Integer;
SunCol : Integer;
DOW : TOvcDayType;
procedure DrawDate;
var
R : TRect;
S : string;
begin
if FDateFormat = dfLong then
if cdoShowYear in FOptions then
S := FormatDateTime('mmmm yyyy', FDate)
else
S := FormatDateTime('mmmm', FDate)
else
if cdoShowYear in FOptions then
S := FormatDateTime('mmm yyyy', FDate)
else
S := FormatDateTime('mmm', FDate);
R := clRowCol[0,1];
R.Right := clRowCol[0,6].Left;
{switch to short date format if string won't fit}
if FDateFormat = dfLong then
if Canvas.TextWidth(S) > R.Right-R.Left then
S := FormatDateTime('mmm yyyy', FDate);
{$IFDEF LCL}
S := SysToUTF8(S); //DrawText expects UTF8 with most widgetsets
{$ENDIF}
Canvas.Font.Color := FColors.MonthAndYear;
if Assigned(FOnDrawDate) then
FOnDrawDate(Self, FDate, R)
else
DrawText(Canvas.Handle, @S[1], Length(S), R, DT_SINGLELINE or DT_CENTER or DT_VCENTER);
end;
procedure DrawDayNames;
var
I : Integer;
S : string[3];
begin
{draw the day name column labels}
Canvas.Font.Color := FColors.DayNames;
I := 0;
DOW := FWeekStarts;
repeat
{record columns for weekends}
if DOW = dtSaturday then
SatCol := I;
if DOW = dtSunday then
SunCol := I;
{get the day name}
S := Copy(ShortDayNames[Ord(DOW)+1], 1, FDayNameWidth);
{$IFDEF LCL}
S := SysToUTF8(S);
{$ENDIF}
{draw the day name above each column}
DrawText(Canvas.Handle, @S[1], Length(S), clRowCol[1,I],
DT_SINGLELINE or DT_CENTER or DT_VCENTER);
Inc(I);
if DOW < High(DOW) then
Inc(DOW)
else
DOW := Low(DOW);
until DOW = WeekStarts;
end;
procedure DrawLine;
begin
if Ctl3D then begin
Canvas.Pen.Color := clBtnHighlight;
Canvas.MoveTo(0, clRowCol[1,0].Bottom-3);
Canvas.LineTo(ClientWidth, clRowCol[1,0].Bottom-3);
Canvas.Pen.Color := clBtnShadow;
Canvas.MoveTo(0, clRowCol[1,0].Bottom-2);
Canvas.LineTo(ClientWidth, clRowCol[1,0].Bottom-2);
end else if BorderStyle = bsSingle then begin
Canvas.Pen.Color := Font.Color;
Canvas.MoveTo(0, clRowCol[1,0].Bottom-3);
Canvas.LineTo(ClientWidth, clRowCol[1,0].Bottom-3);
end;
end;
procedure DrawDay(R, C, I : Integer; Grayed{, Current} : Boolean);
var
Cl : TColor;
OldIdx : Integer;
NewIdx : Integer;
S : string[10];
begin
{avoid painting day number under buttons}
if cdoShowRevert in FOptions then
if (R = 8) {bottom} and (C >= 3) then
Exit;
if cdoShowToday in FOptions then
if (R = 8) {bottom} and (C >= 5) then
Exit;
{convert to a string and draw it centered in its rectangle}
S := IntToStr(clCalendar[I]);
if Grayed then
Canvas.Font.Color := FColors.InactiveDays;
if not Grayed or (cdoShowInactive in FOptions) then begin
NewIdx := ((R-2) * 7) + Succ(C);
OldIdx := clFirst + Pred(clDay);
if Assigned(FOnGetHighlight) then begin
Cl := Canvas.Font.Color;
FOnGetHighlight(Self, FDate+(NewIdx-OldIdx), Cl);
Canvas.Font.Color := Cl;
end;
{$IFDEF LCL}
S := SysToUTF8(S);
{$ENDIF}
if Assigned(FOnDrawItem) then
FOnDrawItem(Self, FDate+(NewIdx-OldIdx), clRowCol[R,C])
else
DrawText(Canvas.Handle, @S[1], Length(S), clRowCol[R,C], DT_SINGLELINE or DT_CENTER or DT_VCENTER);
end;
end;
procedure DrawFocusBox;
var
R : TRect;
S : string[10];
BS : TButtonStyle;
begin
S := IntToStr(clDay);
if Ctl3D then
BS := bsNew
else
BS := bsWin31;
if Focused then
R := DrawButtonFace(Canvas, calGetCurrentRectangle, 1, BS, True, True, False)
else
R := DrawButtonFace(Canvas, calGetCurrentRectangle, 1, BS, True, False, False);
{$IFDEF LCL}
S := SysToUTF8(S);
{$ENDIF}
DrawText(Canvas.Handle, @S[1], Length(S), R, DT_CENTER or DT_VCENTER or DT_SINGLELINE);
end;
begin
Canvas.Font := Font;
Canvas.Brush.Color := Color;{clBtnFace;}
Canvas.FillRect(ClientRect);
{draw the month and year at the top of the calendar}
DrawDate;
{draw the days of the week}
DrawDayNames;
{draw line under day names}
DrawLine;
{draw each day}
{CurIndex := clFirst + Pred(clDay);}
I := 1;
for R := 2 to 8 do
for C := 0 to 6 do begin
if (C = SatCol) or (C = SunCol) then
Canvas.Font.Color := FColors.WeekEnd
else
Canvas.Font.Color := FColors.Days;
DrawDay(R, C, I, (I < clFirst) or (I > clLast){, I = CurIndex});
Inc(I);
end;
Canvas.Font.Color := FColors.ActiveDay;
if not Assigned(FOnDrawItem) then
if not (cdoHideActive in FOptions) then
DrawFocusBox;
end;
function TOvcCustomCalendar.GetCalendarDate : TDateTime;
begin
Result := FDate;
end;
function TOvcCustomCalendar.GetDay : Integer;
begin
Result := clDay;
end;
function TOvcCustomCalendar.GetMonth : Integer;
begin
Result := clMonth;
end;
function TOvcCustomCalendar.GetYear : Integer;
begin
Result := clYear;
end;
procedure TOvcCustomCalendar.SetAsDateTime(Value : TDateTime);
begin
SetDate(calGetValidDate(Value-1, +1));
end;
procedure TOvcCustomCalendar.SetAsStDate(Value : TStDate);
begin
SetDate(calGetValidDate(StDateToDateTime(Value)-1, +1));
end;
procedure TOvcCustomCalendar.SetBorderStyle(Value : TBorderStyle);
begin
if Value <> FBorderStyle then begin
FBorderStyle := Value;
{$IFNDEF LCL}
RecreateWnd;
{$ELSE}
MyMisc.RecreateWnd(Self);
{$ENDIF}
end;
end;
procedure TOvcCustomCalendar.SetBounds(ALeft, ATop, AWidth, AHeight : Integer);
begin
inherited Setbounds(ALeft, ATop, AWidth, AHeight);
if csLoading in ComponentState then
Exit;
calRecalcSize;
end;
procedure TOvcCustomCalendar.SetCalendarDate(Value : TDateTime);
var
NewDate : TStDate;
begin
NewDate := DateTimeToStDate(Value);
if (NewDate = BadDate) or (NewDate = CalendarDate) or
(IncDateTrunc(NewDate, 1, 0) = BadDate) or
(IncDateTrunc(NewDate, -1, 0) = BadDate) then begin
Exit;
end;
SetDate(calGetValidDate(Value-1, +1));
end;
procedure TOvcCustomCalendar.SetDate(Value : TDateTime);
var
R : TRect;
Y : Word;
M : Word;
D : Word;
begin
if Value <> FDate then begin
{determine if the new date is in the same month}
DecodeDate(Value, Y, M, D);
if (clYear = Y) and (clMonth = M) then begin
{invalidate the old date}
R := calGetCurrentRectangle;
InvalidateRect(Handle, @R, False);
end else
Invalidate;
DecodeDate(Value, clYear, clMonth, clDay);
FDate := Value;
calRebuildCalArray;
{invalidate the new date}
R := calGetCurrentRectangle;
InvalidateRect(Handle, @R, False);
end;
end;
procedure TOvcCustomCalendar.SetDateFormat(Value : TOvcDateFormat);
begin
if Value <> FDateFormat then begin
FDateFormat := Value;
Invalidate;
end;
end;
procedure TOvcCustomCalendar.SetDayNameWidth(Value : TOvcDayNameWidth);
begin
if Value <> FDayNameWidth then begin
FDayNameWidth := Value;
Invalidate;
end;
end;
procedure TOvcCustomCalendar.SetDisplayOptions(Value : TOvcCalDisplayOptions);
begin
if Value <> FOptions then begin
FOptions := Value;
calRecalcSize;
Invalidate;
end;
end;
procedure TOvcCustomCalendar.SetDrawHeader(Value : Boolean);
{-set the DrawHeader property value}
begin
if Value <> FDrawHeader then begin
FDrawHeader := Value;
if FDrawHeader then begin
clStartRow := 0;
clRowCount := 8;
end else begin
clStartRow := 2;
clRowCount := 7;
end;
calRecalcSize;
Refresh;
end;
end;
procedure TOvcCustomCalendar.SetIntlSupport(Value : TOvcIntlSup);
{-set the international support object this field will use}
begin
if Assigned(Value) then
FIntlSup := Value
else
FIntlSup := OvcIntlSup;
end;
procedure TOvcCustomCalendar.SetToday;
{-set the calendar to todays date}
begin
SetDate(calGetValidDate(SysUtils.Date-1, +1));
end;
procedure TOvcCustomCalendar.SetWantDblClicks(Value : Boolean);
begin
if Value <> FWantDblClicks then begin
FWantDblClicks := Value;
{$IFNDEF LCL}
RecreateWnd;
{$ELSE}
MyMisc.RecreateWnd(Self);
{$ENDIF}
end;
end;
procedure TOvcCustomCalendar.SetWeekStarts(Value : TOvcDayType);
begin
if Value <> FWeekStarts then begin
FWeekStarts := Value;
if csLoading in ComponentState then
Exit;
calRebuildCalArray;
Invalidate;
end;
end;
procedure TOvcCustomCalendar.WMEraseBkgnd(var Msg : TWMEraseBkgnd);
begin
Msg.Result := 1; {don't erase background, just say we did}
end;
procedure TOvcCustomCalendar.WMGetDlgCode(var Msg : TWMGetDlgCode);
begin
Msg.Result := DLGC_WANTARROWS;
end;
procedure TOvcCustomCalendar.WMKillFocus(var Msg : TWMKillFocus);
begin
inherited;
Invalidate;
end;
end.
Reference in New Issue View Git Blame Copy Permalink