lbcalen.pas

天涯進銷存系統

unit LBCalen;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, DB, DBCtrls;

type
  TLBCalenStyle = (csRaised, csLowered, csNone);

  TLBCalen = class;

  TLBCalenItem = class(TObject)
  private
    FOwner: TLBCalen;
    FId: Integer;
    FContents: string;
  public
    constructor Create(Owner: TLBCalen; Id: Integer);
    destructor Destroy; override;
    procedure Update;
    property Contents: String read FContents write FContents;
  end;

  TLBCalen = class(TCustomControl)
  private
    FItems: TList;
    FColumns: Integer;
    FRows: Integer;
    FCellXSize: Integer;
    FCellYSize: Integer;
    FStyle: TLBCalenStyle;
    FGridColor: TColor;
    FBorderWidth: Integer;
    FYear, FMonth, FDay: Word;
    FCurrent: Integer;
    FMonthOffset: Integer;
    FDaysVisible: Boolean;
    FDaysFont: TFont;
    FDaysColor: TColor;
    FFocusColor: TColor;
    FPassiveColor: TColor;
    FReadOnly: Boolean;
    FButton: TMouseButton;
    FButtonDown: Boolean;
    FHasFocus: Boolean;
    FOnChange: TNotifyEvent;
    FDate: TDate;
    function GetCount: Integer;
    function GetItem(Index: Integer): TLBCalenItem;
    function GetCellFromPos(X, Y: Integer): Integer;
    function GetFirstCell: Integer;
    function GetLastCell: Integer;
    procedure GetCellRect(Wich: Integer; var R: TRect);
    procedure SetStyle(Value: TLBCalenStyle);
    procedure SetGridColor(Value: TColor);
    procedure SetBorderWidth(Value: Integer);
    procedure SetDaysVisible(Value: Boolean);
    procedure SetDaysFont(Value: TFont);
    procedure SetDaysColor(Value: TColor);
    procedure SetFocusColor(Value: TColor);
    procedure SetPassiveColor(Value: TColor);
    procedure SetDate(Value: TDate);
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
    procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
    procedure WMKillFocus(var Message: TWMKillFocus); message WM_KILLFOCUS;
    procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
  protected
    procedure Clear;
    procedure BuildStruct;
    procedure AnalyseMonth;
    procedure CalcPaintParams(DoRepaint: Boolean);
    procedure DrawCell(Wich: Integer; Contents: string);
    function IsDayName(I: Integer): Boolean;
    procedure FocusCell(Wich: Integer);
    procedure UpdateCells;
    procedure Change; dynamic;
    procedure Paint; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    property Count: Integer read GetCount;
    property Items[Index: Integer]: TLBCalenItem read GetItem;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function DaysThisMonth: Integer;
    function DayofTheYear: Integer;
    function WeekOfTheYear: Integer;
    function ChangeDate(AYear, AMonth, ADay: Word): Boolean;
    function GetAsDateTime: TDateTime;
    function GetAsString(Format: String): String;
    procedure NextYear;
    procedure PrevYear;
    procedure NextMonth;
    procedure PrevMonth;
    property Day: Word read FDay;
    property Month: Word read FMonth;
    property Year: Word read FYear;
  published
    property Style: TLBCalenStyle read FStyle write SetStyle;
    property GridColor: TColor read FGridColor write SetGridColor;
    property BorderWidth: Integer read FBorderWidth write SetBorderWidth;
    property Date: TDate read FDate write SetDate;
    property DaysVisible: boolean read FDaysVisible write SetDaysVisible;
    property DaysFont: TFont read FDaysFont write SetDaysFont;
    property DaysColor: TColor read FDaysColor write SetDaysColor;
    property FocusColor: TColor read FFocusColor write SetFocusColor;
    property PassiveColor: TColor read FPassiveColor write SetPassiveColor;
    property ReadOnly: Boolean read FReadOnly write FReadOnly;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property Align;
    property Color;
    property DragCursor;
    property DragMode;
    property Enabled;
    property Font;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopUpMenu;
    property ShowHint;
    property TabOrder;
    property TabStop default true;
    property Visible;
    property OnDBlClick;
    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;

  TLBDBCalen = class(TLBCalen)
    FDataLink: TFieldDataLink;
  private
    procedure DataChange(Sender: TObject);
    procedure UpdateData(Sender: TObject);
    function GetDataField: string;
    function GetDataSource: TDataSource;
    procedure SetDataField(const Value: string);
    procedure SetDataSource(Value: TDataSource);
    procedure CMExit(var Message: TCMExit); message CM_EXIT;
  protected
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure Change; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property DataField: string  read GetDataField write SetDataField;
    property DataSource: TDataSource  read GetDataSource write SetDataSource;
  end;


implementation

const
  CalendarRows: array[boolean] of integer = (6, 7);

function ShortDayName(i: integer): string;
begin
  case i of
  1:Result:='日';
  2:Result:='一';
  3:Result:='二';
  4:Result:='三';
  5:Result:='四';
  6:Result:='五';
  7:Result:='六';
  end;
end;

function GetDayOfWeek(Year, Month, Day: Integer): Integer;
var
  Century, yr, dw: Integer;
begin
  if Month < 3 then
  begin
    Inc(Month, 10);
    Dec(Year);
  end else Dec(Month, 2);
  Century := Year div 100;
  yr := year mod 100;
  dw := (((26 * month - 2) div 10) + day + yr + (yr div 4) +
        (Century div 4) - (2 * Century)) mod 7;
  if dw < 0 then Result := dw + 7
  else Result := dw;
end;

function JulianDay(AYear, AMonth, ADay: Integer): Integer;
var
  Tmp1, Tmp2, Tmp3, Tmp4: Integer;
begin
  if AMonth > 2 then
  begin
    Tmp1 := AMonth - 3;
    Tmp2 := AYear;
  end
 else
  begin
    Tmp1 := AMonth + 9;
    Tmp2 := AYear - 1;
  end;
  Tmp1 := (Tmp1 * 153) + 2;
  Tmp3 := (Tmp2 div 100) * 146097;
  Tmp4 := (Tmp2 mod 100) * 1461;
  Result := (Tmp1 div 5) + (Tmp3 div 4) + (Tmp4 div 4) + ADay + 1721119;
end;

procedure JulianDayToDate(JDay: Integer; var AYear, AMonth, ADay: Integer);
var
  Tmp1, Tmp2, Tmp3: Integer;
begin
  Tmp1 := JDay - 1721119;
  Tmp3 := (4 * Tmp1 - 1) div 146097;
  Tmp1 := (4 * Tmp1 - 1) mod 146097;
  Tmp2 := Tmp1 div 4;
  Tmp1 := (4 * Tmp2 + 3) div 1461;
  Tmp2 := (4 * Tmp2 + 3) mod 1461;
  Tmp2 := (Tmp2 + 4) div 4;
  Amonth := (5 * Tmp2 - 3) div 153;
  Tmp2 := (5 * Tmp2 - 3) mod 153;
  ADay := ((Tmp2 + 5) div 5);
  AYear := (100 * Tmp3 + Tmp1);
  if AMonth < 10 then AMonth := AMonth + 3
 else
  begin
    AMonth := AMonth - 9;
    AYear := AYear + 1;
  end;
end;

function IsValidDate(AYear, AMonth, ADay: Integer): Boolean;
var
  JulDay: Integer;
  ycal, mcal, dcal : Integer;
begin
  JulDay := JulianDay(AYear, AMonth, ADay);
  JulianDayToDate(JulDay, ycal, mcal, dcal);
  Result := (AYear = ycal) and (AMonth = mcal) and (ADay = dcal)
end;

function WeekOfYear(Y, M, D: Integer): Integer;
var
  FirstJulian, JulDay: Integer;
  FirstDay: Integer;
begin
  JulDay := JulianDay(Y, M, D);
  FirstJulian := JulianDay(Y, 1, 1);
  FirstDay := GetDayOfWeek(Y, 1, 1);
  if FirstDay <> 0 then Inc(FirstJulian, 7-Ord(FirstDay));
  if JulDay < FirstJulian then Result := 0
 else Result := (JulDay - FirstJulian + 7) div 7;
end;

function IsLeapYear(AYear: Integer): Boolean;
begin
  Result := (AYear mod 4 = 0) and ((AYear mod 100 <> 0) or (AYear mod 400 = 0));
end;


function DaysPerMonth(AYear, AMonth: Integer): Integer;
const
  DaysInMonth: array[1..12] of Integer = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
begin
  Result := DaysInMonth[AMonth];
  if (AMonth = 2) and IsLeapYear(AYear) then Inc(Result);
end;

//TLBCalenItem

constructor TLBCalenItem.Create(Owner: TLBCalen; Id: Integer);
begin
  if (Owner <> nil) then
  begin
    Owner.FItems.add(self);
    FOwner := Owner;
  end;
  FId := Id;
  FContents := '';
end;

destructor TLBCalenItem.Destroy;
begin
  if FOwner <> nil then
    FOwner.FItems.Remove(self);
  Inherited Destroy;
end;

procedure TLBCalenItem.Update;
begin
  if FOwner <> nil then
    FOwner.DrawCell(FId, FContents);
end;


//TLBCalen

constructor TLBCalen.Create(AOwner: TComponent);
begin
  Inherited Create(AOwner);
  ControlStyle := ControlStyle + [csOpaque];
  Width := 150;
  Height := 100;
  ParentColor := false;
  Color := clBtnFace;
  TabStop := true;
  FGridColor := clBlack;
  FStyle := csLowered;
  FBorderWidth := 1;
  FColumns := 7;
  FRows := 7;
  FDaysVisible := true;
  FDaysFont := TFont.Create;
  FDaysColor := Color;
  FFocusColor := clHighlight;
  FPassiveColor := FFocusColor;
  FReadOnly := false;
  FItems := TList.Create;
  BuildStruct;
  AnalyseMonth;
end;

destructor TLBCalen.Destroy;
begin
  if FItems <> nil then Clear;
  FItems.Free;
  FDaysFont.Free;
  Inherited Destroy;
end;

procedure TLBCalen.BuildStruct;
var
  I, N: Integer;
begin
  Clear;
  N := FColumns * FRows;
  for I := 0 to Pred(N) do
    TLBCalenItem.Create(self, I);
end;

procedure TLBCalen.AnalyseMonth;
var
  I: Integer;
  DayNum: Integer;
begin
  DecodeDate(FDate, FYear, FMonth, FDay);
  FMonthOffset := 1 - GetDayOfWeek(FYear, FMonth, 1);
  if FDaysVisible then Dec(FMonthOffset, FColumns);
  FCurrent := -FMonthOffset + FDay;
  for I := 0 to Pred(Count) do
  begin
    DayNum := FMonthOffset + I;
    if (I < FColumns) and (FDaysVisible) then
      Items[I].Contents := ShortDayName(i+1)
    else
    if (DayNum < 1) or (DayNum > DaysThisMonth) then
      Items[I].Contents := ''
    else
      Items[I].Contents := IntToStr(DayNum);
  end;
end;

procedure TLBCalen.Clear;
begin
  while FItems.Count > 0 do TLBCalenItem(FItems.Last).Free;
end;

function TLBCalen.GetCount: Integer;
begin
  Result := FItems.Count;
end;

function TLBCalen.GetItem(Index: Integer): TLBCalenItem;
begin
  Result := FItems[Index];
end;

procedure TLBCalen.SetStyle(Value: TLBCalenStyle);
begin
  if (FStyle <> Value) then
  begin
    FStyle := Value;
    Invalidate;
  end;
end;

procedure TLBCalen.SetGridColor(Value: TColor);
begin
  if (FGridColor <> Value) then
  begin
    FGridColor := Value;
    Invalidate;
  end;
end;

procedure TLBCalen.SetBorderWidth(Value: Integer);
begin
  if (FBorderWidth <> Value) and (Value in [0..5]) then
  begin
    FBorderWidth := Value;
    Invalidate;
  end;
end;

procedure TLBCalen.SetDaysVisible(Value: Boolean);
begin
  if (FDaysVisible <> Value) then
  begin
    FDaysVisible := Value;
    FRows := CalendarRows[Value];
    BuildStruct;
    AnalyseMonth;
    CalcPaintParams(true);
  end;
end;

procedure TLBCalen.SetDaysFont(Value: TFont);
begin
  FDaysFont.Assign(Value);
  Invalidate;
end;