rxpickdate.pas

rx library V2.7.7a component use in delphi7 to delphi 2006

{*******************************************************}
{                                                       }
{         Delphi VCL Extensions (RX)                    }
{                                                       }
{         Copyright (c) 1995, 1996 AO ROSNO             }
{         Copyright (c) 1997, 1998 Master-Bank          }
{                                                       }
{ Patched by Polaris Software                           }
{*******************************************************}

unit rxPickDate;

{$I RX.INC}
{$S-}

interface

uses
  Windows, Classes, Controls, SysUtils, Graphics, rxDateUtil;

{ Calendar dialog }

function SelectDate(Sender: TWinControl; var Date: TDateTime; const DlgCaption: TCaption;
  AStartOfWeek: TDayOfWeekName; AWeekends: TDaysOfWeek;
  AWeekendColor: TColor; BtnHints: TStrings;
  MinDate: TDateTime {$IFDEF RX_D4}= 0{$ENDIF};
  MaxDate: TDateTime {$IFDEF RX_D4}= 0{$ENDIF}  // Polaris
  ): Boolean;
function SelectDateStr(Sender: TWinControl; var StrDate: string; const DlgCaption: TCaption;
  AStartOfWeek: TDayOfWeekName; AWeekends: TDaysOfWeek;
  AWeekendColor: TColor; BtnHints: TStrings;
  MinDate: TDateTime {$IFDEF RX_D4}= 0{$ENDIF};
  MaxDate: TDateTime {$IFDEF RX_D4}= 0{$ENDIF}
  ): Boolean;  // Polaris
function PopupDate(var Date: TDateTime; Edit: TWinControl;
                   MinDate: TDateTime {$IFDEF RX_D4}= 0{$ENDIF};
                   MaxDate: TDateTime {$IFDEF RX_D4}= 0{$ENDIF}
                   ): Boolean;

{ Popup calendar }

function CreatePopupCalendar(AOwner: TComponent;
  {$IFDEF RX_D4} ABiDiMode: TBiDiMode = bdLeftToRight; {$ENDIF}
  MinDate: TDateTime {$IFDEF RX_D4}= 0{$ENDIF};
  MaxDate: TDateTime {$IFDEF RX_D4}= 0{$ENDIF}
  ): TWinControl;
procedure SetupPopupCalendar(PopupCalendar: TWinControl;
  AStartOfWeek: TDayOfWeekName; AWeekends: TDaysOfWeek;
  AWeekendColor: TColor; BtnHints: TStrings; FourDigitYear: Boolean;
  MinDate: TDateTime {$IFDEF RX_D4}= 0{$ENDIF};
  MaxDate: TDateTime {$IFDEF RX_D4}= 0{$ENDIF}
  );

const
  PopupCalendarSize: TPoint = (X: 187; Y: 124);

implementation

uses
  Messages, Consts, Forms, Buttons, StdCtrls, Grids, ExtCtrls, 
  {$IFDEF RX_D6} Variants, {$ENDIF}
  RXCtrls, RXCConst, rxToolEdit, rxVCLUtils, rxMaxMin, rxStrUtils;

 {$R *.R32}

const
  SBtnGlyphs: array[0..3] of PChar = ('PREV2', 'PREV1', 'NEXT1', 'NEXT2');

procedure FontSetDefault(AFont: TFont);
var
  NonClientMetrics: TNonClientMetrics;
begin
  NonClientMetrics.cbSize := SizeOf(NonClientMetrics);
  if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @NonClientMetrics, 0) then
    AFont.Handle := CreateFontIndirect(NonClientMetrics.lfMessageFont)
  else
    with AFont do begin
      Color := clWindowText;
      Name := 'MS Sans Serif';
      Size := 8;
      Style := [];
    end;
end;

{ TRxTimerSpeedButton }

type
  TRxTimerSpeedButton = class(TRxSpeedButton)
  public
    constructor Create(AOwner: TComponent); override;
  published
    property AllowTimer default True;
    property Style default bsWin31;
  end;

constructor TRxTimerSpeedButton.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Style := bsWin31;
  AllowTimer := True;
  ControlStyle := ControlStyle + [csReplicatable];
end;

{ TRxCalendar }

{ TRxCalendar implementation copied from Borland CALENDAR.PAS sample unit
  and modified }

type
  TDayOfWeek = 0..6;

  TRxCalendar = class(TCustomGrid)
  private
//>Polaris
    FMinDate,
    FMaxDate: TDateTime;
//<Polaris
    FDate: TDateTime;
    FMonthOffset: Integer;
    FOnChange: TNotifyEvent;
    FReadOnly: Boolean;
    FStartOfWeek: TDayOfWeekName;
    FUpdating: Boolean;
    FUseCurrentDate: Boolean;
    FWeekends: TDaysOfWeek;
    FWeekendColor: TColor;
    function GetCellText(ACol, ARow: Integer): string;
    function GetDateElement(Index: Integer): Integer;
    procedure SetCalendarDate(Value: TDateTime);
    procedure SetDateElement(Index: Integer; Value: Integer);
    procedure SetStartOfWeek(Value: TDayOfWeekName);
    procedure SetUseCurrentDate(Value: Boolean);
    procedure SetWeekendColor(Value: TColor);
    procedure SetWeekends(Value: TDaysOfWeek);
    function IsWeekend(ACol, ARow: Integer): Boolean;
    procedure CalendarUpdate(DayOnly: Boolean);
    function StoreCalendarDate: Boolean;

//>Polaris
    procedure SetMinDate(Value: TDateTime);
    procedure SetMaxDate(Value: TDateTime);
//<Polaris
  protected
//>Polaris
    function GetCellDate(ACol, ARow: Integer): TDateTime;
    function CellInRange(ACol, ARow: Integer): Boolean;
    function DateInRange(ADate: TDateTime): Boolean;
//<Polaris
    procedure CreateParams(var Params: TCreateParams); override;
    procedure Change; dynamic;
    procedure ChangeMonth(Delta: Integer);
    procedure Click; override;
    function DaysThisMonth: Integer;
    procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure KeyPress(var Key: Char); override;
    function SelectCell(ACol, ARow: Longint): Boolean; override;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
  public
    constructor Create(AOwner: TComponent); override;
    procedure NextMonth;
    procedure NextYear;
    procedure PrevMonth;
    procedure PrevYear;
    procedure UpdateCalendar; virtual;
    property CellText[ACol, ARow: Integer]: string read GetCellText;
  published
    property CalendarDate: TDateTime read FDate write SetCalendarDate
      stored StoreCalendarDate;
    property Day: Integer index 3  read GetDateElement write SetDateElement stored False;
    property Month: Integer index 2  read GetDateElement write SetDateElement stored False;
    property ReadOnly: Boolean read FReadOnly write FReadOnly default False;
    property StartOfWeek: TDayOfWeekName read FStartOfWeek write SetStartOfWeek default Mon;
    property UseCurrentDate: Boolean read FUseCurrentDate write SetUseCurrentDate default True;
    property WeekendColor: TColor read FWeekendColor write SetWeekendColor default clRed;
    property Weekends: TDaysOfWeek read FWeekends write SetWeekends default [Sun];
    property Year: Integer index 1  read GetDateElement write SetDateElement stored False;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;

    property MinDate: TDateTime read FMinDate write SetMinDate stored False;
    property MaxDate: TDateTime read FMaxDate write SetMaxDate stored False;
  end;

constructor TRxCalendar.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
//>Polaris
  FMinDate := NullDate;
  FMaxDate := NullDate;
//<Polaris
  FUseCurrentDate := True;
  FStartOfWeek := Mon;
  FWeekends := [Sun];
  FWeekendColor := clRed;
  FixedCols := 0;
  FixedRows := 1;
  ColCount := 7;
  RowCount := 7;
  ScrollBars := ssNone;
  Options := Options - [goRangeSelect] + [goDrawFocusSelected];
  ControlStyle := ControlStyle + [csFramed];
  FDate := Date;
  UpdateCalendar;
end;

procedure TRxCalendar.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  Params.Style := Params.Style or WS_BORDER;
  Params.ExStyle := Params.ExStyle and not WS_EX_CLIENTEDGE;
{$IFDEF RX_D4}
  AddBiDiModeExStyle(Params.ExStyle);
{$ENDIF}
end;

procedure TRxCalendar.Change;
begin
  if Assigned(FOnChange) then FOnChange(Self);
end;

procedure TRxCalendar.Click;
var
  TheCellText: string;
begin
  inherited Click;
  TheCellText := CellText[Col, Row];
  if (TheCellText <> '') then Day := StrToInt(TheCellText);
end;

function TRxCalendar.DaysThisMonth: Integer;
begin
  Result := DaysPerMonth(Year, Month);
end;

procedure TRxCalendar.DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState);
var
  TheText: string;
//>Polaris
  procedure DefaultDraw;
  begin
    if TheText <> EmptySTr
    then with ARect, Canvas do begin
      Brush.Style := bsClear;
      TextRect(ARect, Left + (Right - Left - TextWidth(TheText)) div 2,
        Top + (Bottom - Top - TextHeight(TheText)) div 2, TheText);
    end;
  end;

  procedure PoleDraw;
  begin
    with ARect, Canvas do begin
      if (ARow > 0) and ((FMinDate <> NulLDate) or (FMaxDate <> NulLDate))
      then begin
        if not CellInRange(ACol, ARow)
        then begin
          if TheText <> EmptyStr then begin
            Font.Color := clBtnFace;
            if Color = clBtnFace then begin
            Font.Color := clBtnHighlight;
              TextRect(ARect, Left + (Right - Left - TextWidth(TheText)) div 2+1,
                Top + (Bottom - Top - TextHeight(TheText)) div 2+1, TheText);
              Font.Color := clBtnShadow;
            end;
          end;
        end;
      end;
      DefaultDraw;
    end;
  end;
//<Polaris
begin
  TheText := CellText[ACol, ARow];
  with ARect, Canvas do begin
    if IsWeekend(ACol, ARow) and not (gdSelected in AState) then
      Font.Color := WeekendColor;

      PoleDraw;
{
      TextRect(ARect, Left + (Right - Left - TextWidth(TheText)) div 2,
        Top + (Bottom - Top - TextHeight(TheText)) div 2, TheText);

}
  end;
end;

function TRxCalendar.GetCellText(ACol, ARow: Integer): string;
var
  DayNum: Integer;
begin
  if ARow = 0 then  { day names at tops of columns }
    Result := ShortDayNames[(Ord(StartOfWeek) + ACol) mod 7 + 1]
  else begin
    DayNum := FMonthOffset + ACol + (ARow - 1) * 7;
    if (DayNum < 1) or (DayNum > DaysThisMonth) then Result := ''
    else Result := IntToStr(DayNum);
  end;
end;

//>Polaris

procedure TRxCalendar.SetMinDate(Value: TDateTime);
begin
  if FMinDate <> Value then begin
    FMinDate := Value;
    if (FDate < FMinDate) then SetCalendarDate(FMinDate)
    ;
//    else
    UpdateCalendar;
  end;
end;

procedure TRxCalendar.SetMaxDate(Value: TDateTime);
begin
  if FMaxDate <> Value then begin
    FMaxDate := Value;
    if (FDate > FMaxDate) then SetCalendarDate(FMaxDate)
    ;
//    else
    UpdateCalendar;
  end;
end;

function TRxCalendar.GetCellDate(ACol, ARow: Integer): TDateTime;
var
  DayNum: Integer;
begin
  Result := NullDate;
  if (ARow > 0) and (GetCellText(ACol, ARow) <> EmptyStr) then begin
    DayNum := FMonthOffset + ACol + (ARow - 1) * 7;
    if (DayNum < 1) or (DayNum > DaysThisMonth) then Result := NullDate
    else Result := EncodeDate(GetDateElement(1), GetDateElement(2), DayNum);
  end;
end;

function TRxCalendar.CellInRange(ACol, ARow: Integer): Boolean;
begin
  if (Row < 1) {or ((FMinDate = NullDate) and (FMaxDate = NullDate))} then Result := True
  else Result := DateInRange(GetCellDate(ACol, ARow));
end;

function TRxCalendar.DateInRange(ADate: TDateTime): Boolean;
begin
  if ((FMinDate = NullDate) and (FMaxDate = NullDate)) or (ADate = NullDate)
  then Result := True
  else begin
    Result := False;
    if (ADate = NullDate)
    then Result := True
    else if (FMinDate <> NullDate) and (FMaxDate <> NullDate)
      then Result := (ADate>=FMinDate) and (ADate<=FMaxDate)
      else if FMinDate <> NullDate
        then Result := ADate >= FMinDate
        else if FMaxDate <> NullDate
          then Result := ADate <= FMaxDate
  end;
end;
//<Polaris

procedure TRxCalendar.KeyDown(var Key: Word; Shift: TShiftState);
//>Polaris
var
  OldDay: Integer;
//<Polaris
begin
  OldDay := Day;
  if Shift = [] then
    case Key of
      VK_LEFT, VK_SUBTRACT:
        begin
          if (Day > 1) then Day := Day - 1
          else CalendarDate := CalendarDate - 1;
          if not DateInRange(FDate) then Day := OldDay;
          Exit;
        end;
      VK_RIGHT, VK_ADD:
        begin
          if (Day < DaysThisMonth) then Day := Day + 1
          else CalendarDate := CalendarDate + 1;
          if not DateInRange(FDate) then Day := OldDay;
          Exit;
        end
    end;
  inherited KeyDown(Key, Shift);
end;

procedure TRxCalendar.KeyPress(var Key: Char);
begin
  if Key in ['T', 't'] then begin
    CalendarDate := Trunc(Now);
    Key := #0;
  end;
  inherited KeyPress(Key);
end;

function TRxCalendar.SelectCell(ACol, ARow: Longint): Boolean;
begin
  if ((not FUpdating) and FReadOnly) or (CellText[ACol, ARow] = '')
//>Polaris
  or not CellInRange(ACol, ARow)
//<Polaris
  then
    Result := False
  else Result := inherited SelectCell(ACol, ARow);
end;

procedure TRxCalendar.SetCalendarDate(Value: TDateTime);
begin
//  if FDate <> Value then begin
    if (FMinDate <> NullDate) and (Value < FMinDate) then Value := FMinDate
    else if (FMaxDate <> NullDate) and (Value > FMaxDate) then Value := FMaxDate;
    FDate := Value;
    UpdateCalendar;
    Change;
//  end;
end;

function TRxCalendar.StoreCalendarDate: Boolean;
begin
  Result := not FUseCurrentDate;
end;

function TRxCalendar.GetDateElement(Index: Integer): Integer;
var
  AYear, AMonth, ADay: Word;
begin
  DecodeDate(FDate, AYear, AMonth, ADay);
  case Index of
    1: Result := AYear;
    2: Result := AMonth;
    3: Result := ADay;
    else Result := -1;
  end;
end;

procedure TRxCalendar.SetDateElement(Index: Integer; Value: Integer);
var
  iValue: Word;
  TYear, TMonth, TDay: Word;
  AYear, AMonth, ADay: Word;
//>Polaris
  TmpDate: TDateTime;
//<Polaris
begin
  if Value > 0 then begin
    DecodeDate(FDate, AYear, AMonth, ADay);
    iValue := Value;
    case Index of
      1: begin
//>Polaris
           if FMinDate <> NullDate then begin
             DecodeDate(FMinDate, TYear, TMonth, TDay);
             if Value < TYear then Value := TYear;
             if (Value = TYear) and (AMonth < TMonth) then AMonth := TMonth;
             if (Value = TYear) and (AMonth = TMonth) and (ADay<TDay) then ADay := TDay;
           end;
           if FMaxDate <> NullDate then begin
             DecodeDate(FMaxDate, TYear, TMonth, TDay);
             if Value > TYear then Value := TYear;
             if (Value = TYear) and (AMonth > TMonth) then AMonth := TMonth;
             if (Value = TYear) and (AMonth = TMonth) and (ADay>TDay) then ADay := TDay;
           end;
//<Polaris
           if AYear <> Value then AYear := Value else Exit;
         end;
      2: if (Value <= 12) and (Value <> AMonth) then begin
//>Polaris
           if FMinDate <> NullDate then begin
             DecodeDate(FMinDate, TYear, TMonth, TDay);
             if (AYear = TYear) and (Value < TMonth) then Value := TMonth;
             if (Value = TYear) and (AMonth = TMonth) and (ADay<TDay) then ADay := TDay;
           end;
           if FMaxDate <> NullDate then begin
             DecodeDate(FMaxDate, TYear, TMonth, TDay);
             if (AYear = TYear) and (Value > TMonth) then Value := TMonth;
             if (Value = TYear) and (AMonth = TMonth) and (ADay>TDay) then ADay := TDay;
           end;
//<Polaris

           AMonth := Value;
           if ADay > DaysPerMonth(Year, Value) then
             ADay := DaysPerMonth(Year, Value);
//>Polaris
{
          TmpDate := EncodeDate(AYear, AMonth, ADay);
          if (FMinDate <> NullDate) and (TmpDate < FMinDate) then DecodeDate(FMinDate, TYear, TMonth, ADay);