unit DateEdit;

{ ---------------------------------------------------------------------------- }
{ Component Name:  TDateEdit                                                   }
{ Description:     This DateEdit component has been designed for speedy data   }
{                  entry - unlike the hopeless Windows datetimepicker control. }
{ Version:         1.1                                                         }
{ Date:            31-MAY-2003                                                 }
{ Compiler:        Delphi 3 - Delphi 7                                         }
{ Author:          Angus Johnson, angusj-AT-myrealbox-DOT-com                  }
{ Copyright        © 2001-2003 Angus Johnson                                   }
{                                                                              }
{ Notes:                                                                       }
{ 1. This component will display dates in either dd/mm/yyyy, mm/dd/yyyy or     }
{ yyyy/mm/dd format (assuming the OS's DateSeparator char = '/').              }
{ The specific format will be derived from the target user's OS dateformat     }
{ unless the UseOSDateFormat property = false.                                 }
{ 2. Assuming the dd/mm/yyyy date format, entering the following text would    }
{ be functionally equivalent to entering 01/01/2003 -                          }
{   010103, 01012003, 1/1/3, 1/1/03 and 1/1/2003.                              }
{ 3. While entering text, invalid dates will be displayed in red.              }
{ 4. [Esc] undoes date editing changes.                                        }
{ 5. The [+] and [-] keys will increment and decrement dates respectively.     }
{ 6. When the century is omitted during date entry, the Epoch property will be }
{ used to derive it (eg if Epoch = 1920 then 1/1/19 -> 01/01/2019). Epoch      }
{ defaults to 80yrs prior to the current year (rounded to the nearest 10yrs).  }
{ ---------------------------------------------------------------------------- }

{ ---------------------------------------------------------------------------- }
{ History:                                                                     }
{ 31 May 03: Added OnCheckDate event- optional event which allows the date to  }
{            be restricted to a specific date range (or ranges).               }
{            Also minor improvements in KeyPress() method.                     }
{ 26 May 03: Bugfix- Parent font was not being assigned when ParentFont = true }
{ 19 May 03: Moved Epoch property from Published to Public. This means that    }
{            unless Epoch is assigned in code it will maintain its default     }
{            behaviour (see above) beyond the compile date.                    }
{ ---------------------------------------------------------------------------- }

interface

uses
  Windows, SysUtils, Messages, Classes, Controls, Forms, StdCtrls, Graphics;

type
  TCheckDateEvent =
    function(Sender: TObject; Date: TDateTime): boolean of object;

  TDateEdit = class(TCustomEdit)
  private
    FLastValidDate: TDateTime;
    FUseOSDateFormat: boolean;
    FDateFormat: string;
    fEpoch: integer;
    FBlankDate: string;
    FColorOK, FColorInvalid: TColor;
    fZeroDateIsValid: boolean;
    fChangingColorOnly: boolean;
    FDoCheckDate: TCheckDateEvent;
    FDoInvalidDate: TNotifyEvent;
    procedure SetUseOSDateFormat(value: boolean);
    function GetDisplayedDate(out dt: TDateTime): boolean;
    function GetText: string;
    procedure AdjustWidth;
    procedure ReformatText;
    function GetDateFormat: string;
    procedure SetDateFormat(const value: string);
    function GetDate: TDateTime;
    procedure SetDate(NewDate: TDateTime);
    procedure SetEpoch(value: integer);
    procedure CMExit(var Message: TCMExit); message CM_EXIT;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  protected
    function DoCheckDate(Date: TDatetime): boolean; virtual;
    procedure CreateWnd; override;
    procedure KeyPress(var Key: Char); override;
    procedure Change; override;
  public
    function IsValidDate: boolean;
    constructor Create(AOwner: TComponent); override;
    property Date: TDateTime read GetDate write SetDate;
    procedure Clear; override;
    property Epoch: integer read fEpoch write SetEpoch; //see history 190503
  published
    property AutoSelect;
    property AutoSize;
    property BorderStyle;
    property Color;
    property ColorTextErr: TColor read fColorInvalid write fColorInvalid;
    property ColorTextOK: TColor read fColorOK write fColorOK;
    property Ctl3D;
    //DateFormat: can only be assigned when UseOSDateFormat property = false
    property DateFormat: string read GetDateFormat write SetDateFormat;
    property Enabled;
    property Font;
    property HideSelection;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ReadOnly;
    property ShowHint;
    property TabOrder;
    property Text: string read GetText;
    property UseOSDateFormat: boolean
      read FUseOSDateFormat write SetUseOSDateFormat;
    property Visible;
    property ZeroDateIsValid: boolean
      read fZeroDateIsValid write fZeroDateIsValid;
    //OnCheckDate: optional event to facilitate restricting the date range(s)
    property OnCheckDate: TCheckDateEvent
      read FDoCheckDate write FDoCheckDate; //see history 310503
      
    //OnInvalidDate: optional event to customize invalid date notification
    property OnInvalidDate: TNotifyEvent
      read FDoInvalidDate write FDoInvalidDate;
    property OnChange;
    property OnClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
  end;

procedure Register;

implementation

resourcestring
  s_invalid_date = 'Invalid Date: ';
  s_invalid_integer = 'Invalid Integer';

//------------------------------------------------------------------------------
// Miscellaneous functions ...
//------------------------------------------------------------------------------

procedure Register;
begin
  RegisterComponents('Samples', [TDateEdit]);
end;
//------------------------------------------------------------------------------

function strToWord(const str: string; startPos, len: integer): word;
var
  i: integer;
begin
  if (length(str) < startPos + len -1) or (len < 1) or (startPos < 1) then
    raise Exception.Create(s_invalid_integer);
  result := 0;
  for i := 1 to len do
  begin
    if not (str[startPos] in ['0'..'9']) then
      raise Exception.Create(s_invalid_integer);
    result := (result*10) + ord(str[startPos]) - ord('0');
    inc(startPos);
  end;
end;
//------------------------------------------------------------------------------

{$IFDEF VER100}
//Unfortunatley, in Delphi3, the DoEncodeDate() function only has unit scope.
function TryEncodeDate(Year, Month, Day: Word; out Date: TDateTime): Boolean;
var
  I: Integer;
  DayTable: PDayTable;
begin
  Result := False;
  DayTable := @MonthDays[IsLeapYear(Year)];
  if (Year >= 1) and (Year <= 9999) and (Month >= 1) and (Month <= 12) and
    (Day >= 1) and (Day <= DayTable^[Month]) then
  begin
    for I := 1 to Month - 1 do Inc(Day, DayTable^[I]);
    I := Year - 1;
    Date := I * 365 + I div 4 - I div 100 + I div 400 + Day - DateDelta;
    Result := True;
  end;
end;
{$ENDIF}

//------------------------------------------------------------------------------
// TDateEdit methods ...
//------------------------------------------------------------------------------

constructor TDateEdit.Create(AOwner: TComponent);
var
  yy,mm,dd: word;
begin
  inherited Create(AOwner);
  fZeroDateIsValid := true;
  FColorInvalid := clRed;
  FColorOK := clBlack;
  DecodeDate(sysUtils.Date,yy,mm,dd);
  //Epoch is only read when dates are entered without a specified century.
  //eg if Epoch = 1920 then entering the date 1/1/20 will be rendered to
  //01/01/1920 and the date 1/1/19 will be rendered to 01/01/2019.
  fEpoch := round(yy /10)*10 - 80;
  SetDateFormat(ShortDateFormat);
  FUseOSDateFormat := true;
  SetDate(sysUtils.date);
end;
//------------------------------------------------------------------------------

procedure TDateEdit.SetEpoch(value: integer);
begin
  if (value < 1900) or (value > 2100) then exit;
  fEpoch := value;
end;
//------------------------------------------------------------------------------

function TDateEdit.GetText: string;
begin
  result := inherited Text;
end;
//------------------------------------------------------------------------------

procedure TDateEdit.Clear;
begin
  //simply restore the last valid date
  ReformatText;
end;
//------------------------------------------------------------------------------

function TDateEdit.GetDateFormat: string;
begin
  if FUseOSDateFormat then
    result := '' else
    result := FDateFormat;
end;
//------------------------------------------------------------------------------

procedure TDateEdit.SetDateFormat(const value: string);
var
  ch: char;
begin
  //if UseOSDateFormat = true then don't allow resetting of fDateFormat ...
  if not (csLoading in ComponentState) and FUseOSDateFormat then exit;
  if value = '' then ch := 'Y'
  else ch := upcase(value[1]);
  case ch of
    'D': FDateFormat := 'dd/mm/yyyy';
    'M': FDateFormat := 'mm/dd/yyyy';
    else FDateFormat := 'yyyy/mm/dd';
  end;
  if FDateFormat[1] = 'y' then
    FBlankDate := format('0000%s00%0:s00',[dateSeparator]) else
    FBlankDate := format('00%s00%0:s0000',[dateSeparator]);
  ReformatText;
  AdjustWidth;
end;
//------------------------------------------------------------------------------

procedure TDateEdit.ReformatText;
var
  dd,mm,yy: word;
begin
  if (FLastValidDate = 0) then
  begin
    if (Owner is TCustomForm) and (TCustomForm(Owner).ActiveControl = self) then
      inherited text := FBlankDate else
      inherited text := '';
  end else
  begin
    DecodeDate(FLastValidDate,yy,mm,dd);
    case FDateFormat[1] of
      'd': inherited Text :=
        Format('%2.2d%s%2.2d%1:s%3:4.4d',[dd,DateSeparator,mm,yy]);
      'm': inherited Text :=
        Format('%2.2d%s%2.2d%1:s%3:4.4d',[mm,DateSeparator,dd,yy]);
      else inherited Text :=
        Format('%4.4d%s%2.2d%1:s%3:2.2d',[yy,DateSeparator,mm,dd]);
    end;
  end;
end;
//------------------------------------------------------------------------------

function TDateEdit.GetDisplayedDate(out dt: TDateTime): boolean;
var
  dd,mm,yy: word;
  i, len: integer;
  hasCentury: boolean;
  tmpSep1, tmpSep2: integer;
begin
  result := false;
  len := length(text);
  if (len = 0) then
  begin
    result := fZeroDateIsValid;
    dt := 0;
    exit;
  end;
  if len > 10 then exit;
  tmpSep1 := 0; tmpSep2 := 0;
  //validate the position of the date separators, if any, and
  //make sure only date separators and numerics are entered ...
  for i := 1 to len do
    if text[i] = dateSeparator then
    begin
      if i = 1 then exit
      else if tmpSep1 = 0 then tmpSep1 := i
      else if (i = tmpSep1+1) or (tmpSep2 > 0) then exit
      else tmpSep2 := i;
    end else
      if not (text[i] in ['0'..'9']) then exit;

  //check for other error conditions ...
  if ((tmpSep1 = 0) and not (len in [6,8])) or
    ((tmpSep1 > 0) and (tmpSep2 = 0)) or
    ((tmpSep1 > 0) and (tmpSep2 - tmpSep1 > 3)) or (tmpSep2 = len) then exit;

  hasCentury :=
    ((tmpSep1 = 0) and (len = 8)) or //ddmmyyyy
    ((tmpSep1 = 5) and (FDateFormat[1] = 'y')) or //yyyy/mm/dd
    ((FDateFormat[1] <> 'y') and (tmpSep2 = len-4)); //dd/mm/yyyy

  try
    case FDateFormat[1] of
      'y': if (tmpSep1 > 0) then
           begin
             if tmpSep1 = 4 then exit; //must be either y, yy or yyyy
             yy := strToWord(text,1,tmpSep1-1);
             mm := strToWord(text,tmpSep1+1,tmpSep2-tmpSep1-1);
             dd := strToWord(text,tmpSep2+1,len-tmpSep2);
           end else
           begin
             if hasCentury then i := 3 else i := 5;
             yy := strToWord(text,1,i-1);
             mm := strToWord(text,i,2);
             dd := strToWord(text,i+2,2);
           end;
      'd': if (tmpSep1 > 0) then
           begin
             if tmpSep2 = len - 3 then exit; //must be either y, yy or yyyy
             dd := strToWord(text,1,tmpSep1-1);
             mm := strToWord(text,tmpSep1+1,tmpSep2-tmpSep1-1);
             yy := strToWord(text,tmpSep2+1,len-tmpSep2);
           end else
           begin
             dd := strToWord(text,1,2);
             mm := strToWord(text,3,2);
             yy := strToWord(text,5,len-4);
           end;
      else if (tmpSep1 > 0) then
           begin
             if tmpSep2 = len - 3 then exit; //must be either y, yy or yyyy
             mm := strToWord(text,1,tmpSep1-1);
             dd := strToWord(text,tmpSep1+1,tmpSep2-tmpSep1-1);
             yy := strToWord(text,tmpSep2+1,len-tmpSep2);
           end else
           begin
             mm := strToWord(text,1,2);
             dd := strToWord(text,3,2);
             yy := strToWord(text,5,len-4);
           end;
    end;
    if yy + mm + dd = 0 then
    begin
      result := fZeroDateIsValid;
      dt := 0;
      exit;
    end;
    if not hasCentury then
    begin
      if yy >= fEpoch mod 100 then
        inc(yy, (fEpoch div 100)*100) else
        inc(yy, (fEpoch div 100)*100 +100);
    end;
    result := TryEncodeDate(yy,mm,dd,dt) and DoCheckDate(dt);
  except
    result := false;
  end;
end;
//------------------------------------------------------------------------------

function TDateEdit.IsValidDate: boolean;
var
  tmpDt: TDateTime;
begin
  Result := GetDisplayedDate(tmpDt);
end;
//------------------------------------------------------------------------------

procedure TDateEdit.SetUseOSDateFormat(value: boolean);
begin
  if value = fUseOSDateFormat then exit;
  if value or (csDesigning in ComponentState) then
  begin
    fUseOSDateFormat := false; //otherwise SetDateFormat() wont do its stuff
    SetDateFormat(ShortDateFormat);
  end;
  fUseOSDateFormat := value;
end;
//------------------------------------------------------------------------------

function TDateEdit.GetDate: TDateTime;
begin
  //nb: No error will be raised when reading the Date property if the displayed
  //date is invalid as the the date prior to editing will be returned. (Invalid
  //displayed dates are only possible while editing - ie while focused.)
  //The IsValidDate public method can be used to evaluate the 'displayed' date.
  if not GetDisplayedDate(result) then
    result := FLastValidDate;
end;
//------------------------------------------------------------------------------

procedure TDateEdit.SetDate(NewDate: TDateTime);
begin
  if (NewDate = 0) and not fZeroDateIsValid then
    raise Exception.Create(s_invalid_date + FBlankDate)
  else if not DoCheckDate(NewDate) then
    raise Exception.Create(s_invalid_date + FormatDatetime(FDateFormat,NewDate));
  FLastValidDate := NewDate;
  ReformatText;
end;
//------------------------------------------------------------------------------

procedure TDateEdit.CMExit(var Message: TCMExit);
var
  dudStr: string;
  tmpDt: TDateTime;
begin
  if GetDisplayedDate(tmpDt) then
  begin
    FLastValidDate := tmpDt;
    ReformatText;
    inherited;
  end
  else if assigned(FDoInvalidDate) then
    //either perform the custom error handling if it's assigned
    FDoInvalidDate(self)
  else
  begin
    //otherwise refocus the control and show the default error message
    dudStr := text;
    SetFocus;  //redisplays the last valid date via CMEnter() method
    Font.Color := FColorOK;
    raise Exception.create(format('%s"%s"',[s_invalid_date,dudStr]));
  end;
end;
//------------------------------------------------------------------------------

procedure TDateEdit.CreateWnd;
begin
  inherited CreateWnd;
  AdjustWidth;
end;
//------------------------------------------------------------------------------

procedure TDateEdit.CMFontChanged(var Message: TMessage);
begin
  if not fChangingColorOnly then
    AdjustWidth;
  inherited;
end;
//------------------------------------------------------------------------------

procedure TDateEdit.AdjustWidth;
var
  DC: HDC;
  SaveFont: HFont;
  Size: TSize;
begin
  if not handleAllocated then exit;
  //adjust dateEdit width...
  DC := GetDC(handle);
  try
    SaveFont := SelectObject(DC, Font.Handle);
    if gettextextentpoint32(DC,pchar(FBlankDate+'0'),
      length(FBlankDate)+1,Size) then
        clientwidth := Size.cx;
    SelectObject(DC, SaveFont);
  finally
    ReleaseDC(handle, DC);
  end;
end;
//------------------------------------------------------------------------------

procedure TDateEdit.KeyPress(var Key: Char);
var
  tmpSelstart: integer;
begin
  inherited KeyPress(Key);
  if key = #27 then
  begin
    //[ESC] reverts date to last valid date
    ReformatText;
    SelectAll;
    key := #0;
  end;
  if key < #32 then exit; //don't block these (eg ^C, ^V, ^X)
  if (key in ['+','-']) and not (FLastValidDate = 0) and IsValidDate then
  begin
    //allow + and - to increment and decrement the date respectively ...
    if (key = '+') and DoCheckDate(FLastValidDate +1) then
      Date := FLastValidDate +1
    else if (key = '-') and DoCheckDate(FLastValidDate -1) then
      Date := FLastValidDate -1;
    Key := #0;
    SelectAll;
  end
  else if not (Key in [dateSeparator, '0'..'9']) then
  begin
    //reject invalid keys ...
    Key := #0;
    beep;
  end
  else if (sellength = 0) and (length(text) > 9) then
  begin
    //if the date string is too long the trash trailing chars ...
    tmpSelstart := selstart;
    inherited text := copy(text,1,selstart);
    selstart := tmpSelstart; //repositions caret for char entry
  end;
end;
//------------------------------------------------------------------------------

procedure TDateEdit.Change;
begin
  inherited;
  if not handleallocated then exit; //see history 260503
  fChangingColorOnly := true;
  try
    if not IsValidDate then
      Font.Color := FColorInvalid else
      Font.Color := FColorOK;
  finally
    fChangingColorOnly := false;
  end;
end;
//------------------------------------------------------------------------------

function TDateEdit.DoCheckDate(Date: TDatetime): boolean;
begin
  if assigned(FDoCheckDate) then
    Result := FDoCheckDate(self, Date) else
    Result := true;
end;
//------------------------------------------------------------------------------


end.