lbcalen.pas

天涯進銷存系統

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

procedure TLBCalen.SetFocusColor(Value: TColor);
begin
  if (FFocusColor <> Value) then
  begin
    FFocusColor := Value;
    Items[FCurrent].Update;
  end;
end;

procedure TLBCalen.SetPassiveColor(Value: TColor);
begin
  if (FPassiveColor <> Value) then
  begin
    FPassiveColor := Value;
    Items[FCurrent].Update;
  end;
end;

procedure TLBCalen.SetDate(Value: TDate);
begin
  FDate:=Value;
  UpdateCells;
end;

procedure TLBCalen.DrawCell(Wich: Integer; Contents: string);
var
  R: TRect;
begin
  GetCellRect(Wich, R);
  case FStyle of
    csLowered: Frame3D(Canvas, R, clBtnShadow, clBtnHighlight, FBorderWidth);
    csRaised: Frame3D(Canvas, R, clBtnHighlight, clBtnShadow, FBorderWidth);
    csNone:
      begin
        //Make sure the lines don't overlap
        if not (Wich in [6, 13, 20, 27, 34, 41, 48]) then
          Inc(R.Right);
        if Wich < Count - FColumns then
          Inc(R.Bottom);
        Frame3D(Canvas, R, FGridColor, FGridColor, FBorderWidth);
      end;
  end;

  with Inherited Canvas do
  begin
    if (Wich = FCurrent) then
    begin
      Font := Self.Font;
      if FHasFocus then
        Brush.Color := FFocusColor
      else
        Brush.Color := FPassiveColor;
    end
   else
    case IsDayName(Wich) of
      true:
        begin
          Font := FDaysFont;
          Brush.Color := FDaysColor;
        end;
      false:
        begin
          Font := Self.Font;
          Brush.Color := Self.Color;
        end;
    end; //Case
    Brush.Style := bsSolid;
    FillRect(R);
    DrawText(Handle, PChar(Contents), -1, R,
      DT_SINGLELINE or DT_EXPANDTABS or DT_CENTER or DT_VCENTER);
{    if (FHasFocus) and (Wich = FCurrent) then
      DrawFocusRect(R);}
  end;
end;

procedure TLBCalen.Paint;
var
  I: Integer;
begin
  with Inherited Canvas do
  begin
    Brush.Color := Color;
    Brush.Style := bsSolid;
    FillRect(ClientRect);
  end;
  for I := 0 to Pred(Count) do
    Items[I].Update;
end;

procedure TLBCalen.CalcPaintParams(DoRepaint: Boolean);
var
  NewWidth, NewHeight: Integer;
begin
  NewWidth := (Width div FColumns) * FColumns;
  NewHeight := (Height div FRows) * FRows;
  BoundsRect := Bounds(Left, Top, NewWidth, NewHeight);
  FCellXSize := Width div FColumns;
  FCellYSize := Height div FRows;
  if DoRepaint then Invalidate;
end;

procedure TLBCalen.WMSize(var Message: TWMSize);
begin
  inherited;
  CalcPaintParams(false);
end;

procedure TLBCalen.GetCellRect(Wich: Integer; var R: TRect);
var
  X, Y: Integer;
begin
  X := (Wich mod FColumns) * FCellXSize;
  Y := (Wich div FColumns) * FCellYSize;
  R := Bounds(X, Y, FCellXSize, FCellYSize);
end;

function TLBCalen.GetCellFromPos(X, Y: Integer): Integer;
var
  W, H: Integer;
begin
  W := (FCellXSize * FColumns) - 1;
  H := (FCellYSize * FRows) - 1;
  if X > W then X := W else if X < 0 then X := 0;
  if Y > H then Y := H else if Y < 0 then Y := 0;
  X := (Y div FCellYSize) * FColumns + (X div FCellXSize);
  Result := X;
end;

function TLBCalen.IsDayName(I: Integer): Boolean;
begin
  Result := (I < FColumns) and (FDaysVisible);
end;

function TLBCalen.DaysThisMonth: Integer;
begin
  Result := DaysPerMonth(FYear, FMonth);
end;

function TLBCalen.GetFirstCell: Integer;
begin
  Result := -FMonthOffset + 1;
end;

function TLBCalen.GetLastCell: Integer;
begin
  Result := -FMonthOffset + DaysThisMonth;
end;

procedure TLBCalen.WMSetFocus(var Message: TWMSetFocus);
begin
  FHasFocus := True;
  Items[FCurrent].Update;
  inherited;
end;

procedure TLBCalen.WMKillFocus(var Message: TWMKillFocus);
begin
  FHasFocus := False;
  Items[FCurrent].Update;
  inherited;
end;

procedure TLBCalen.WMGetDlgCode(var Message: TWMGetDlgCode);
begin
  Message.Result := DLGC_WANTARROWS or DLGC_WANTCHARS;
end;

procedure TLBCalen.FocusCell(Wich: Integer);
var
  OldCell: Integer;
begin
  if (Wich = FCurrent) or (Wich < GetFirstCell) or
    (Wich > GetLastCell) or (FReadOnly) then Exit;
  OldCell := FCurrent;
  FCurrent := Wich;
  FDay := StrToInt(Items[FCurrent].Contents);
  Items[OldCell].Update;
  Items[FCurrent].Update;
  Change;
end;

procedure TLBCalen.Change;
begin
  if assigned(FOnChange) then
    FOnChange(self);
end;

procedure TLBCalen.UpdateCells;
var
  I: Integer;
begin
  AnalyseMonth;
  for I := 0 to Pred(Count) do
    if not IsDayName(I) then Items[I].Update;
end;

procedure TLBCalen.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  inherited MouseDown(Button, Shift, X, Y);
  FButton := Button;
  FButtonDown := true;
  if Button = mbLeft then
    FocusCell(GetCellFromPos(X, Y));
  if TabStop then SetFocus;
end;

procedure TLBCalen.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
  inherited MouseMove(Shift, X, Y);
  if (FButtonDown) and (FButton = mbLeft) then
    FocusCell(GetCellFromPos(X, Y));
end;

procedure TLBCalen.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  inherited MouseUp(Button, Shift, X, Y);
  FButtonDown := False;
end;

procedure TLBCalen.KeyDown(var Key: Word; Shift: TShiftState);
var
  NewSel: Integer;
begin
  inherited KeyDown(Key, Shift);
  NewSel := FCurrent;
  case Key of
    VK_HOME: NewSel := GetFirstCell;
    VK_END: NewSel := GetLastCell;
    VK_UP: if NewSel - FColumns >= GetFirstCell then Dec(NewSel, FColumns);
    VK_LEFT: if NewSel > GetFirstCell then Dec(NewSel);
    VK_DOWN: if (NewSel + FColumns <= GetLastCell) then Inc(NewSel, FColumns);
    VK_RIGHT: if NewSel < GetLastCell then Inc(NewSel);
  end;
  Key := 0;
  FocusCell(NewSel);
end;

function TLBCalen.ChangeDate(AYear, AMonth, ADay: Word): Boolean;
begin
  Result := IsValiddate(AYear, AMonth, ADay);
  if Result then
  begin
    FDay := ADay;
    FMonth := AMonth;
    FYear := AYear;
    UpdateCells;
    Change;
  end;
end;

function TLBCalen.GetAsDateTime: TDateTime;
begin
  Result := EncodeDate(FYear, FMonth, FDay);
end;

function TLBCalen.GetAsString(Format: String): String;
begin
  Result := FormatDateTime(Format, GetAsDateTime);
end;

procedure TLBCalen.NextYear;
begin
  if IsLeapYear(FYear) and (FMonth = 2) and (FDay = 29) then FDay := 28;
  FYear := FYear + 1;
  FDate:=EncodeDate(FYear, FMonth, FDay);;
  UpdateCells;
  Change;
end;

procedure TLBCalen.PrevYear;
begin
  if IsLeapYear(FYear) and (FMonth = 2) and (FDay = 29) then FDay := 28;
  FYear := FYear - 1;
  FDate:=EncodeDate(FYear, FMonth, FDay);;
  UpdateCells;
  Change;
end;

procedure TLBCalen.NextMonth;
begin
  if (FMonth < 12) then Inc(FMonth)
 else
  begin
    FMonth := 1;
    FYear := FYear + 1;
  end;
  if FDay > DaysThisMonth then FDay := DaysThisMonth;
  FDate:=EncodeDate(FYear, FMonth, FDay);;
  UpdateCells;
  Change;
end;

procedure TLBCalen.PrevMonth;
begin
  if (FMonth > 1) then Dec(FMonth)
 else
  begin
    FMonth := 12;
    FYear := FYear - 1;
  end;
  if FDay > DaysThisMonth then FDay := DaysThisMonth;
  FDate:=EncodeDate(FYear, FMonth, FDay);;
  UpdateCells;
  Change;
end;

function TLBCalen.DayOfTheYear: Integer;
var
  yy, mm, dd, Tmp: Integer;
begin
  yy := FYear;
  mm := FMonth;
  dd := FDay;
  Tmp := (mm + 10) div 13;
  Result :=  3055 * (mm + 2) div 100 - Tmp * 2 - 91 +
             (1 - (yy - yy div 4 * 4 + 3) div 4 +
             (yy - yy div 100 * 100 + 99) div 100 -
             (yy - yy div 400 * 400 + 399) div 400) * Tmp + dd;
end;

function TLBCalen.WeekOfTheYear: Integer;
begin
  Result := WeekOfYear(FYear, FMonth, FDay);
  if Result = 0 then
    Result := WeekOfYear(FYear - 1, 12, 31); {belongs to previous year}
end;

//TLBDBCalen
constructor TLBDBCalen.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FDataLink := TFieldDataLink.Create;
  FDataLink.OnDataChange := DataChange;
  FDataLink.OnUpdateData := UpdateData;
end;

destructor TLBDBCalen.Destroy;
begin
  FDataLink.Free;
  inherited Destroy;
end;

procedure TLBDBCalen.DataChange(Sender: TObject);
var
  Y, M, D: Word;
begin
  if assigned(FDataLink.Field) then
  begin
    DecodeDate(FDataLink.Field.AsDateTime, Y, M, D);
    ChangeDate(Y, M, D);
  end;
end;

function TLBDBCalen.GetDataField: string;
begin
  Result := FDataLink.FieldName;
end;

function TLBDBCalen.GetDataSource: TDataSource;
begin
  Result := FDataLink.DataSource;
end;

procedure TLBDBCalen.SetDataField(const Value: string);
begin
  FDataLink.FieldName := Value;
end;

procedure TLBDBCalen.SetDataSource(Value: TDataSource);
begin
  FDataLink.DataSource := Value;
end;

procedure TLBDBCalen.UpdateData(Sender: TObject);
begin
  FDataLink.Field.AsDateTime := GetAsDateTime;
end;

procedure TLBDBCalen.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
var
  MyMouseDown: TMouseEvent;
begin
  if not ReadOnly and FDataLink.Edit then
    inherited MouseDown(Button, Shift, X, Y)
  else
  begin
    MyMouseDown := OnMouseDown;
    if Assigned(MyMouseDown) then MyMouseDown(Self, Button, Shift, X, Y);
  end;
end;

procedure TLBDBCalen.KeyDown(var Key: Word; Shift: TShiftState);
var
  MyKeyDown: TKeyEvent;
begin
  if (not ReadOnly) and (FDataLink.Edit) then
    inherited KeyDown(Key, Shift)
  else
  begin
    MyKeyDown := OnKeyDown;
    if Assigned(MyKeyDown) then MyKeyDown(Self, Key, Shift);
  end;
end;

procedure TLBDBCalen.Change;
begin
  FDataLink.Modified;
  inherited Change;
end;

procedure TLBDBCalen.CMExit(var Message: TCMExit);
begin
  try
    FDataLink.UpdateRecord;
  except
    SetFocus;
    raise;
  end;
  inherited;
end;

end.