vrcalendar.pas

作工控的好控件

  SizeY := Height div FRows;
end;

procedure TVrCalendar.Click;
begin
end;

procedure TVrCalendar.CreateObjects;
var
  I, Count: Integer;
begin
  Collection.Clear;
  Count := FColumns * FRows;
  for I := 0 to Pred(Count) do
    TVrCalendarItem.Create(Collection);
  FItemIndex := -1;
  TrackLast := -1;
end;

function TVrCalendar.GetCount: Integer;
begin
  Result := Collection.Count;
end;

function TVrCalendar.GetItem(Index: Integer): TVrCalendarItem;
begin
  Result := Collection.Items[Index];
end;

procedure TVrCalendar.StyleChanged(Sender: TObject);
begin
  UpdateControlCanvas;
end;

procedure TVrCalendar.BevelChanged(Sender: TObject);
var
  R: TRect;
begin
  if not Loading then
  begin
    R := ClientRect;
    FBevel.GetVisibleArea(R);
    InflateRect(ViewPort, R.Left, R.Top);
    BoundsRect := Bounds(Left, Top, WidthOf(ViewPort),
      HeightOf(ViewPort));
  end;
  UpdateControlCanvas;
end;


procedure TVrCalendar.SetOptions(Value: TVrCalendarOptions);
begin
  FOptions := Value;
end;

procedure TVrCalendar.UpdateItem(Index: Integer);
var
  Rect: TRect;
  Item: TVrCalendarItem;
  State: Boolean;
begin
  Item := Collection.Items[Index];

  GetItemRect(Index, Rect);

  with DestCanvas do
    case FGrid.Style of
      gsLowered:
          DrawFrame3D(DestCanvas, Rect, FGrid.Shadow3D, FGrid.Highlight3D, FGrid.Width);
        gsRaised:
          DrawFrame3D(DestCanvas, Rect, FGrid.Highlight3D, FGrid.Shadow3D, FGrid.Width);
        gsSingle:
          begin
            if FOrientation = voHorizontal then
            begin
              if (Index mod FColumns <> FColumns - 1) then Inc(Rect.Right);
              if Index < Count - FColumns then Inc(Rect.Bottom);
            end
            else
            begin
              if (Index mod FRows <> FRows - 1) then Inc(Rect.Bottom);
              if Index < Count - FRows then Inc(Rect.Right);
            end;
            DrawFrame3D(DestCanvas, Rect, FGrid.Color, FGrid.Color, FGrid.Width);
          end;
    end; //case

  State := (TrackLast = Index) or Item.Active;

  if FDrawStyle = dsOwnerDraw then
  begin
    if Assigned(FOnDraw) then
      FOnDraw(Self, DestCanvas, Rect, Index, State);
    Exit;
  end;

  if Item.Visible then
    with DestCanvas do
    begin
      Font := Self.Font;

      Font.Color := FPalette.Colors[ord(State)];
      Brush.Color := Self.Color;
      DrawText(handle, PChar(Item.Caption), -1, Rect,
        DT_SINGLELINE or DT_EXPANDTABS or TextAlignments[FAlignment]);
    end;
end;

procedure TVrCalendar.UpdateItems;
var
  I: Integer;
begin
  for I := 0 to Collection.Count - 1 do
    UpdateItem(I);
end;

procedure TVrCalendar.Reset;
var
  I: Integer;
begin
  for I := 0 to Collection.Count - 1 do
    Items[I].Active := false;
end;

procedure TVrCalendar.Paint;
var
  R: TRect;
begin
  CalcPaintParams;
  ClearBitmapCanvas;

  DestCanvas := BitmapCanvas;
  try
    R := ClientRect;
    FBevel.Paint(DestCanvas, R);
    UpdateItems;
    inherited Paint;
  finally
    DestCanvas := Self.Canvas;
  end;
end;

procedure TVrCalendar.CalcPaintParams;
var
  NewWidth, NewHeight, X, Y: Integer;
begin
  ViewPort := ClientRect;
  FBevel.GetVisibleArea(ViewPort);

  X := WidthOf(ViewPort) div FColumns;
  NewWidth := (ViewPort.Left * 2) + (FColumns * X);

  Y := HeightOf(ViewPort) div FRows;
  NewHeight := (ViewPort.Top * 2) + (FRows * Y);

  if (NewWidth <> Width) or (NewHeight <> Height) then
    BoundsRect := Bounds(Left, Top, NewWidth, NewHeight);

  SizeX := WidthOf(ViewPort) div FColumns;
  SizeY := HeightOf(ViewPort) div FRows;
end;

procedure TVrCalendar.GetItemRect(Index: Integer; var R: TRect);
var
  X, Y: Integer;
begin
  if FOrientation = voHorizontal then
  begin
    X := (Index mod FColumns) * SizeX;
    Y := (Index div FColumns) * SizeY;
  end
  else
  begin
    X := (Index div FRows) * SizeX;
    Y := (Index mod FRows) * SizeY;
  end;

  R := Bounds(ViewPort.Left + X, ViewPort.Top + Y, SizeX, SizeY);
end;

function TVrCalendar.GetItemIndex(X, Y: Integer): Integer;
begin
  if X > ViewPort.Right then X := ViewPort.Right
  else if X < ViewPort.Left then X := ViewPort.Left;
  if Y > ViewPort.Bottom then Y := ViewPort.Bottom
  else if Y < ViewPort.Top then Y := ViewPort.Top;

  if Orientation = voHorizontal then
  begin
    X := ((Y - ViewPort.Top) div SizeY) * FColumns +
         ((X - ViewPort.Left) div SizeX);
    Result := X;
  end
  else
  begin
    Y := ((X - ViewPort.Left) div SizeX) * FRows +
         ((Y - ViewPort.Top) div SizeY);
    Result := Y;
  end;
end;

procedure TVrCalendar.SetRows(Value: TVrRowInt);
begin
  if FRows <> Value then
  begin
    FRows := Value;
    CreateObjects;
    UpdateControlCanvas;
  end;
end;

procedure TVrCalendar.SetColumns(Value: TVrColInt);
begin
  if FColumns <> Value then
  begin
    FColumns := Value;
    CreateObjects;
    UpdateControlCanvas;
  end;
end;

procedure TVrCalendar.SetOrientation(Value: TVrOrientation);
begin
  if FOrientation <> Value then
  begin
    FOrientation := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrCalendar.SetDrawStyle(Value: TVrDrawStyle);
begin
  if FDrawStyle <> Value then
  begin
    FDrawStyle := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrCalendar.SetFirstIndex(Value: Integer);
begin
  if FFirstIndex <> Value then
  begin
    FFirstIndex := Value;
    CreateObjects;
    UpdateControlCanvas;
  end;
end;

procedure TVrCalendar.SetDigits(Value: Integer);
begin
  if FDigits <> Value then
  begin
    FDigits := Value;
    CreateObjects;
    UpdateControlCanvas;
  end;
end;

procedure TVrCalendar.SetAlignment(Value: TVrGridAlignment);
begin
  if FAlignment <> Value then
  begin
    FAlignment := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrCalendar.SetNextStep(Value: Integer);
begin
  if FNextStep <> Value then
  begin
    FNextStep := Value;
    CreateObjects;
    UpdateControlCanvas;
  end;
end;

procedure TVrCalendar.SetPalette(Value: TVrPalette);
begin
  FPalette.Assign(Value);
end;

procedure TVrCalendar.SetBevel(Value: TVrBevel);
begin
  FBevel.Assign(Value);
end;

procedure TVrCalendar.SetGrid(Value: TVrCalendarGrid);
begin
  FGrid.Assign(Value);
end;

procedure TVrCalendar.MouseMove(Shift: TShiftState; X, Y: Integer);
var
  Index, P: Integer;
begin
  inherited;
  if not PtInRect(ViewPort, Point(X, Y)) then
    if (coTrackMouse in Options) and Enabled then
    begin
      if TrackLast <> -1 then
      begin
        P := TrackLast;
        TrackLast := -1;
        UpdateItem(P);
      end;
      Exit;
    end;

  if (coTrackMouse in Options) and Enabled then
  begin
    Index := GetItemIndex(X, Y);
    if (TrackLast <> Index) then
    begin
      if TrackLast <> -1 then
      begin
        P := TrackLast;
        TrackLast := -1;
        UpdateItem(P);
      end;
      TrackLast := Index;
      UpdateItem(TrackLast);
    end;
  end;
end;

procedure TVrCalendar.MouseDown(Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  R: TRect;
begin
  if PtInRect(ViewPort, Point(X, Y)) then
    if (Button = mbLeft) and Enabled then
    begin
      IsPressed := True;
      CurrIndex := GetItemIndex(X, Y);
      FItemIndex := -1;
      if (coMouseClip in Options) then
      begin
        R := Bounds(ClientOrigin.X, ClientOrigin.Y,
          ClientWidth, ClientHeight);
        ClipCursor(@R);
      end;
    end;
  inherited;
end;

procedure TVrCalendar.MouseUp(Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if IsPressed then
  begin
    IsPressed := false;
    if (coMouseClip in Options) then ClipCursor(nil);

    FItemIndex := GetItemIndex(X, Y);
    if CurrIndex <> FItemIndex then FItemIndex := -1
    else
    begin
      if (coActiveClick in Options) then
        Items[FItemIndex].Active := True;
      inherited Click;
    end;
  end;
  inherited;
end;

procedure TVrCalendar.CMMouseLeave(var Message: TMessage);
var
  P: Integer;
begin
  inherited;
  if (coTrackMouse in Options) and Enabled then
  begin
    if TrackLast <> -1 then
    begin
      P := TrackLast;
      TrackLast := -1;
      UpdateItem(P);
    end;
  end;
end;


end.